Permalink
Browse files

First commit of Text::Bowdlerise.

  • Loading branch information...
0 parents commit e087336f7d9904070d035f55af3232b22be32689 @jamesronan jamesronan committed Oct 12, 2011
Showing with 533 additions and 0 deletions.
  1. +5 −0 Changes
  2. +9 −0 MANIFEST
  3. +19 −0 Makefile.PL
  4. +54 −0 README
  5. +12 −0 ignore.txt
  6. +279 −0 lib/Text/Bowdlerise.pm
  7. +10 −0 t/00-load.t
  8. +47 −0 t/01-bowdlerise.t
  9. +55 −0 t/boilerplate.t
  10. +13 −0 t/manifest.t
  11. +18 −0 t/pod-coverage.t
  12. +12 −0 t/pod.t
5 Changes
@@ -0,0 +1,5 @@
+Revision history for Text-Bowdlerise
+
+0.01 Date/time
+ First version, released on an unsuspecting world.
+
9 MANIFEST
@@ -0,0 +1,9 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/Text/Bowdlerise.pm
+t/00-load.t
+t/manifest.t
+t/pod-coverage.t
+t/pod.t
19 Makefile.PL
@@ -0,0 +1,19 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Text::Bowdlerise',
+ AUTHOR => q{James Ronan <james@ronanweb.co.uk>},
+ VERSION_FROM => 'lib/Text/Bowdlerise.pm',
+ ABSTRACT_FROM => 'lib/Text/Bowdlerise.pm',
+ ($ExtUtils::MakeMaker::VERSION >= 6.3002
+ ? ('LICENSE'=> 'gpl')
+ : ()),
+ PL_FILES => {},
+ PREREQ_PM => {
+ 'Test::More' => 0,
+ },
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ clean => { FILES => 'Text-Bowdlerise-*' },
+);
54 README
@@ -0,0 +1,54 @@
+Text-Bowdlerise
+
+Module to Bowdlerise text, removing primarily profanity (but also specified
+patterns/strings) with more socially acceptable (or mapped) alternatives.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the
+perldoc command.
+
+ perldoc Text::Bowdlerise
+
+You can also look for information at:
+
+ RT, CPAN's request tracker
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=Text-Bowdlerise
+
+ AnnoCPAN, Annotated CPAN documentation
+ http://annocpan.org/dist/Text-Bowdlerise
+
+ CPAN Ratings
+ http://cpanratings.perl.org/d/Text-Bowdlerise
+
+ Search CPAN
+ http://search.cpan.org/dist/Text-Bowdlerise/
+
+
+LICENSE AND COPYRIGHT
+
+Copyright (C) 2011 James Ronan
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; version 2 dated June, 1991 or at your option
+any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+A copy of the GNU General Public License is available in the source tree;
+if not, write to the Free Software Foundation, Inc.,
+59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
12 ignore.txt
@@ -0,0 +1,12 @@
+blib*
+Makefile
+Makefile.old
+Build
+Build.bat
+_build*
+pm_to_blib*
+*.tar.gz
+.lwpcookies
+cover_db
+pod2htm*.tmp
+Text-Bowdlerise-*
279 lib/Text/Bowdlerise.pm
@@ -0,0 +1,279 @@
+package Text::Bowdlerise;
+
+use strict;
+no warnings;
+
+use Scalar::Util;
+
+our $VERSION = '0.01';
+
+=head1 NAME
+
+Text::Bowdlerise - Bowdlerise text. Simples.
+
+=head1 SYNOPSIS
+
+Bowdlerises a (or a list of) text string(s). Primarily replaces common
+profanity with socially acceptable alternative. This can of course be extended
+or even overriden by way of configuration.
+
+In it's simplest form, a straight forward use to replace the built in common
+elements, looks like this:
+
+ use Text::Bowdlerise;
+ my $acceptable_language = Text::Bowdlerise::bowdlerise($profanity);
+
+However, for more control over what is replaced:
+
+ use Text::Bowdlerise;
+
+ my $bowdler = Text::Bowdlerise->new( ignore_defaults => 1 );
+ $bowdler->add_rules(
+ 'cpan.org' => 'metacpan.org',
+ ...
+ );
+ my $fixed_links = $bowdler->bowdlerise($old_listings);
+
+=cut
+
+
+my $default_list = {
+ arse => 'bottom',
+ arsefuck => 'bottomlove',
+ ass => 'donkey',
+ assfuck => 'donkeylove',
+ cunt => 'ladypart',
+ motherfucker => 'mater-lover',
+ fucktard => 'a complete Dave',
+ defuck => 'make better',
+ fuck => 'ruin',
+ piss => 'unrine',
+ shit => 'faeces',
+ tit => 'breast',
+ twat => 'ladypart',
+ unfuck => 'make nicer',
+};
+
+
+=head1 CONSTRUCTOR
+
+Constructs a new Text::Bowdler object which can be configured how you see fit.
+
+=head2 DWIMery
+
+Can be passed either a string which is operated on using built-in rules,
+
+OR
+
+a hashref of configuration parameters (one or many of):
+
+=over
+
+=item ignore_default_list
+
+Tells the Bowdler not to use its built in list. If this is specified,
+alternate rules should be given.
+
+=item allow_part_replacement
+
+Tells the Bowdler whether to replace matches that are part of other words.
+Defaults to 1 (allow). Setting a value of 0 will disable this behaviour,
+
+=item user_rule_list
+
+Used to specify a specific set of replacements. Supplied as a hashref
+of 'thing to match' => 'replacement text'.
+
+Note that this does not override the default list; This appends to it. To
+remove the built in ruleset specify ignore_default_list => 1
+
+=item user_rule_file
+
+Use to tell the module to read a rule list file. Supplied as a string file
+name; The file must contain a perl hashref in the same format as
+rule_list
+
+=back
+
+=cut
+
+sub new {
+ my ($self, $params) = @_;
+
+ if ( $params
+ && ref $params ne 'HASH'
+ && !Scalar::Util::blessed($params) )
+ {
+ return Text::Bowdlerise->new->bowdlerise($params);
+ }
+
+ return bless {
+ _prefs => {
+ ignore_default_list => $params->{ignore_default_list} // 0,
+ allow_part_replacement => $params->{allow_part_replacement} // 1,
+ user_rule_list => $params->{user_rule_list} // {},
+ user_rule_file => $params->{user_rule_file} // '',
+ },
+ _rules => buildrules($params),
+ } => $self || __PACKAGE__;
+}
+
+=head1 METHODS
+
+=head2 bowdlerise
+
+Action method. Actually does the replacements. Accepts a single string or an
+arrayref of strings to perform the replacement upon.
+
+=cut
+
+sub bowdlerise {
+ my ($self, $text) = @_;
+
+ if ( !$text
+ || ref $text eq 'HASH'
+ || Scalar::Util::blessed($text) )
+ {
+ return;
+ }
+
+ # If it's not an arrayref then we'll assume it's a single string, so make
+ # it an arrayref.
+ $text = [ $text ] if (ref $text ne 'ARRAY');
+
+ # For the list of text, flick through each one, and apply each rule,
+ for my $chunk (@$text) {
+ while ( my ( $search, $replacement ) = each %{ $self->{_rules} } ) {
+
+ # Do the replacement first with whole words,
+ $chunk =~ s{\b\Q$search\E\b}{$replacement}gi;
+
+ # Then with part-word is that is permissable.
+ $chunk =~ s{\Q$search\E}{$replacement}gi
+ if $self->{_prefs}{allow_part_replacement};
+ }
+ }
+
+ return (scalar @$text > 1)? $text : shift @$text;
+}
+
+=head2 add_rules
+
+ In: \%rules (Hash ref of rules to add).
+
+Adds the supplied rules to the rule list.
+
+=cut
+
+sub add_rules {
+ my ($self, $newrules) = @_;
+
+ my %rules = %{ $self->{_prefs}{user_rule_list} };
+
+ %rules = ( %rules, %$newrules );
+
+ $self->{_prefs}{user_rule_list} = \%rules;
+ return $self->{_rules} = buildrules({ user_rule_list => \%rules });
+}
+
+
+
+# Build up the rules list based on what prefs are passed in.
+
+sub buildrules {
+ my ($prefs) = @_;
+
+ return if !$prefs;
+
+ my %rules;
+
+ # If we aren't ignoring the built-in list add those.
+ if (!$prefs->{ignore_default_list}) {
+ %rules = ( %rules, %$default_list );
+ }
+
+ # If we've been supplied a user list, add that:
+ if ( $prefs->{user_rule_list}
+ && ref $prefs->{user_rule_list} eq 'HASH')
+ {
+ %rules = ( %rules, %{ $prefs->{user_rule_list} } );
+ }
+
+ # Lastly, add the rules in the user_list_file, if one was specified
+ if ( $prefs->{user_list_file}
+ && -f $prefs->{user_list_file})
+ {
+ my $user_rules = do $prefs->{user_list_file};
+ if (ref $user_rules eq 'HASH') {
+ %rules = ( %rules, %$user_rules );
+ }
+ }
+
+ return \%rules;
+}
+
+=head1 AUTHOR
+
+James Ronan, C<< <james at ronanweb.co.uk> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-text-bowdlerise at rt.cpan.org>, or through
+the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Text-Bowdlerise>. I will be notified, and then you'll
+automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Text::Bowdlerise
+
+
+You can also look for information at:
+
+=over 4
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Text-Bowdlerise>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Text-Bowdlerise>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Text-Bowdlerise>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Text-Bowdlerise/>
+
+=back
+
+
+=head1 ACKNOWLEDGEMENTS
+
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright 2011 James Ronan.
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; version 2 dated June, 1991 or at your option
+any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+A copy of the GNU General Public License is available in the source tree;
+if not, write to the Free Software Foundation, Inc.,
+59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+
+=cut
+
+1; # End of Text::Bowdlerise
10 t/00-load.t
@@ -0,0 +1,10 @@
+#!perl -T
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'Text::Bowdlerise' ) || print "Bail out!
+";
+}
+
+diag( "Testing Text::Bowdlerise $Text::Bowdlerise::VERSION, Perl $], $^X" );
47 t/01-bowdlerise.t
@@ -0,0 +1,47 @@
+#!perl -T
+
+use lib '../lib';
+use Test::More;
+
+BEGIN {
+ use_ok( 'Text::Bowdlerise' );
+}
+
+my @tests = (
+ {
+ name => 'Fuck',
+ text => "Don't be silly and fuck up the config!",
+ expect => "Don't be silly and ruin up the config!",
+ },
+ {
+ name => 'Fuck-up',
+ text => 'Complete fuck-up that was!',
+ expect => 'Complete ruin-up that was!',
+ },
+ {
+ name => 'Twat',
+ text => 'Because $otherdev is a Twat...',
+ expect => 'Because $otherdev is a ladypart...',
+ },
+ {
+ name => 'Shit',
+ text => '... do it in a less shit way ...',
+ expect => '... do it in a less faeces way ...',
+ },
+ {
+ name => 'Motherfucker',
+ text => 'As Samual L Jackson said: "stupid motherfucker"',
+ expect => 'As Samual L Jackson said: "stupid mater-lover"',
+ },
+ {
+ name => 'Boobs',
+ text => 'I like tits',
+ expect => 'I like breasts',
+ },
+);
+plan tests => scalar @tests;
+
+for my $test (@tests) {
+ is(Text::Bowdlerise->new($test->{text}), $test->{expect}, $test->{name});
+}
+
55 t/boilerplate.t
@@ -0,0 +1,55 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+sub not_in_file_ok {
+ my ($filename, %regex) = @_;
+ open( my $fh, '<', $filename )
+ or die "couldn't open $filename for reading: $!";
+
+ my %violated;
+
+ while (my $line = <$fh>) {
+ while (my ($desc, $regex) = each %regex) {
+ if ($line =~ $regex) {
+ push @{$violated{$desc}||=[]}, $.;
+ }
+ }
+ }
+
+ if (%violated) {
+ fail("$filename contains boilerplate text");
+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+ } else {
+ pass("$filename contains no boilerplate text");
+ }
+}
+
+sub module_boilerplate_ok {
+ my ($module) = @_;
+ not_in_file_ok($module =>
+ 'the great new $MODULENAME' => qr/ - The great new /,
+ 'boilerplate description' => qr/Quick summary of what the module/,
+ 'stub function definition' => qr/function[12]/,
+ );
+}
+
+TODO: {
+ local $TODO = "Need to replace the boilerplate text";
+
+ not_in_file_ok(README =>
+ "The README is used..." => qr/The README is used/,
+ "'version information here'" => qr/to provide version information/,
+ );
+
+ not_in_file_ok(Changes =>
+ "placeholder date/time" => qr(Date/time)
+ );
+
+ module_boilerplate_ok('lib/Text/Bowdlerise.pm');
+
+
+}
+
13 t/manifest.t
@@ -0,0 +1,13 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+unless ( $ENV{RELEASE_TESTING} ) {
+ plan( skip_all => "Author tests not required for installation" );
+}
+
+eval "use Test::CheckManifest 0.9";
+plan skip_all => "Test::CheckManifest 0.9 required" if $@;
+ok_manifest();
18 t/pod-coverage.t
@@ -0,0 +1,18 @@
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
+ if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
+ if $@;
+
+all_pod_coverage_ok();
12 t/pod.t
@@ -0,0 +1,12 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();

0 comments on commit e087336

Please sign in to comment.