perl/BadWords.pm

   1 #
   2 # Search for bad words in strings
   3 #
   4 # Copyright (c) 2000 Dirk Koopman
   5 #
   6 #
   7 #
   8
   9 package BadWords;
  10
  11 use strict;
  12
  13 use DXUtil;
  14 use DXVars;
  15 use DXDebug;
  16
  17 use IO::File;
  18
  19 our $regex;                                     # the big bad regex generated from @relist
  20 our @relist; # the list of regexes to try, record = [canonical word, regex]
  21 my %in; # the collection of words we are building up and their regexes
  22
  23
  24 # load the badwords file(s)
  25 sub load
  26 {
  27         %in = ();
  28         @relist = ();
  29         $regex = '';
  30
  31         my @inw;
  32         my @out;
  33         my $wasold;
  34
  35
  36         my $newfn = localdata("badword.new");
  37         filecopy("$main::data/badword.new.issue", $newfn) unless -e $newfn;
  38         if (-e $newfn) {
  39                 # new style
  40                 dbg("BadWords: Found new style badword.new file");
  41                 my $fh = new IO::File $newfn;
  42                 if ($fh) {
  43                         while (<$fh>) {
  44                                 chomp;
  45                                 next if /^\s*\#/;
  46                                 add_regex(uc $_);
  47                         }
  48                         $fh->close;
  49                         @relist = sort {$a->[0] cmp $b->[0]} @relist; # just in case...
  50                         dbg("BadWords: " . scalar @relist . " new style badwords read");
  51                 }
  52                 else {
  53                         my $l = "BadWords: can't open $newfn $!";
  54                         dbg($l);
  55                         push @out, $l;
  56                         return @out;
  57                 }
  58         }
  59         else {
  60
  61                 # using old style files
  62                 my $bwfn = localdata("badword");
  63                 filecopy("$main::data/badword.issue", $bwfn) unless -e $bwfn;
  64
  65                 # parse the existing static file
  66                 dbg("BadWords: Using old style badword file");
  67
  68                 my $fh = new IO::File $bwfn;
  69                 if ($fh) {
  70                         my $line = 0;
  71                         while (<$fh>) {
  72                                 chomp;
  73                                 ++$line;
  74                                 next if /^\s*\#/;
  75                                 unless (/\w+\s+=>\s+\d+,/) {
  76                                         dbg("BadWords: syntax error in $bwfn:$line '$_'");
  77                                         next;
  78                                 }
  79                                 my @line =  split /\s+/, uc $_;
  80                                 shift @line unless $line[0];
  81                                 push @inw, $line[0];
  82                         }
  83                         $fh->close;
  84                 }
  85                 else {
  86                         my $l = "BadWords: can't open $bwfn $!";
  87                         dbg($l);
  88                         push @out, $l;
  89                         return @out;
  90                 }
  91
  92                 # do the same for badw_regex
  93                 my $regexfn = localdata("badw_regex");
  94                 filecopy("$main::data/badw_regex.gb.issue", $regexfn) unless -e $regexfn;
  95                 dbg("BadWords: Using old style badw_regex file");
  96                 $fh = new IO::File $regexfn;
  97
  98                 if ($fh) {
  99                         while (<$fh>) {
 100                                 chomp;
 101                                 next if /^\s*\#/;
 102                                 next if /^\s*$/;
 103                                 push @inw, split /\s+/, uc $_;
 104                         }
 105                         $fh->close;
 106                 }
 107                 else {
 108                         my $l = "BadWords: can't open $regexfn $!";
 109                         dbg($l);
 110                         push @out, $l;
 111                         return @out;
 112                 }
 113
 114                 ++$wasold;
 115         }
 116
 117         # catch most of the potential duplicates
 118         @inw = sort @inw;
 119         for (@inw) {
 120                 add_regex($_);
 121         }
 122
 123         # create the master regex
 124         generate_regex();
 125
 126         # use new style from now on
 127         put() if $wasold;
 128
 129
 130         return @out;
 131 }
 132
 133 sub generate_regex
 134 {
 135         my $res;
 136         @relist = sort {$a->[0] cmp $b->[0]} @relist;
 137         for (@relist) {
 138                 $res .= qq{(?:$_->[1]) |\n};
 139         }
 140         $res =~ s/\s*\|\s*$//;
 141         $regex = qr/\b($res)/x;
 142 }
 143
 144
 145 sub _cleanword
 146 {
 147         my $w = uc shift;
 148         $w =~ tr/01/OI/;                        # de-leet any incoming words
 149         my $last = '';  # remove duplicate letters (eg BOLLOCKS > BOLOCKS)
 150         my @w;
 151         for (split //, $w) {
 152                 next if $last eq $_;
 153                 $last = $_;
 154                 push @w, $_;
 155         }
 156         return @w ? join('', @w) : '';
 157 }
 158
 159 sub add_regex
 160 {
 161         my @list = split /\s+/, shift;
 162         my @out;
 163
 164         for (@list) {
 165                 my $w = uc $_;
 166                 $w = _cleanword($w);
 167
 168                 next unless $w && $w =~ /^\w+$/; # has to be a word
 169                 next if $in{$w};           # ignore any we have already dealt with
 170                 next if _slowcheck($w); # check whether this will already be detected
 171
 172                 # re-leet word (in regex speak)if required
 173                 my @l = map { s/O/[O0]/g; s/I/[I1]/g; $_ } split //, $w;
 174                 my $e = join '+[\s\W]*',  @l;
 175                 my $q = $e;
 176                 push @relist, [$w, $q];
 177                 $in{$w} = $q;
 178                 dbg("$w = $q") if isdbg('badword');
 179                 push @out, $w;
 180         }
 181         return @out;
 182 }
 183
 184 sub del_regex
 185 {
 186         my @list = split /\s+/, shift;
 187         my @out;
 188
 189         for (@list) {
 190                 my $w = uc $_;
 191                 $w = _cleanword($w);
 192                 next unless $in{$w};
 193                 delete $in{$w};
 194                 @relist = grep {$_->[0] ne $w} @relist;
 195                 push @out, $w
 196         }
 197         return @out;
 198 }
 199
 200 sub list_regex
 201 {
 202         my $full = shift;
 203         return map { $full ? "$_->[0] = $_->[1]" : $_->[0] } @relist;
 204 }
 205
 206 # check the text against the badwords list
 207 sub check
 208 {
 209         my $s = uc shift;
 210         my @out;
 211
 212         if ($regex) {
 213                 my %uniq;
 214                 @out = grep {++$uniq{$_}; $uniq{$_} == 1 ? $_ : undef }($s =~ /\b($regex)/g);
 215                 dbg("BadWords: check '$s' = '" . join(', ', @out) . "'") if isdbg('badword');
 216                 return @out;
 217         }
 218         return _slowcheck($s) if @relist;
 219         return;
 220 }
 221
 222
 223 sub _slowcheck
 224 {
 225         my $w = shift;
 226         my @out;
 227
 228         for (@relist) {
 229                 push @out, $w =~ /\b($_->[1])/;
 230         }
 231         return @out;
 232 }
 233
 234 # write out the new bad words list
 235 sub put
 236 {
 237         my @out;
 238         my $newfn = localdata("badword.new");
 239         my $fh = new IO::File ">$newfn";
 240         if ($fh) {
 241                 dbg("BadWords: put new badword.new file");
 242                 @relist = sort {$a->[0] cmp $b->[0]} @relist;
 243                 for (@relist) {
 244                         print $fh "$_->[0]\n";
 245                 }
 246                 $fh->close;
 247         }
 248         else {
 249                 my $l = "BadWords: can't open $newfn $!";
 250                 dbg($l);
 251                 push @out, $l;
 252                 return @out;
 253         }
 254 }
 255 1;