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 DXHash;
  16 use DXDebug;
  17
  18 use IO::File;
  19
  20 use vars qw($badword $regexcode);
  21
  22 our $regex;
  23
  24 # load the badwords file
  25 sub load
  26 {
  27         my $bwfn = localdata("badword");
  28         filecopy("$main::data.issue", $bwfn) unless -e $bwfn;
  29
  30         my @out;
  31
  32         $badword = new DXHash "badword";
  33
  34         push @out, create_regex();
  35         return @out;
  36 }
  37
  38 sub create_regex
  39 {
  40         $regex = localdata("badw_regex");
  41         filecopy("$regex.gb.issue", $regex) unless -e $regex;
  42
  43         my @out;
  44         my $fh = new IO::File $regex;
  45
  46         if ($fh) {
  47                 my $s = "sub { my \$str = shift; my \@out; \n";
  48                 while (<$fh>) {
  49                         chomp;
  50                         next if /^\s*\#/;
  51                         my @list = split " ";
  52                         for (@list) {
  53                                 # create a closure for each word so that it matches stuff with spaces/punctuation
  54                                 # and repeated characters in it
  55                                 my $w = uc $_;
  56                                 my @l = split //, $w;
  57                                 my $e = join '+[\s\W]*', @l;
  58                                 $s .= qq{push \@out, \$1 if \$str =~ m|\\b($e+)|;\n};
  59                         }
  60                 }
  61                 $s .= "return \@out;\n}";
  62                 $regexcode = eval $s;
  63                 dbg($s) if isdbg('badword');
  64                 if ($@) {
  65                         @out = ($@);
  66                         dbg($@);
  67                         return @out;
  68                 }
  69                 $fh->close;
  70         } else {
  71                 my $l = "can't open $regex $!";
  72                 dbg($l);
  73                 push @out, $l;
  74         }
  75
  76         return @out;
  77 }
  78
  79 # check the text against the badwords list
  80 sub check
  81 {
  82         my $s = uc shift;
  83         my @out;
  84
  85         push @out, &$regexcode($s) if $regexcode;
  86
  87         return @out if @out;
  88
  89         for (split(/\b/, $s)) {
  90                 push @out, $_ if $badword->in($_);
  91         }
  92
  93         return @out;
  94 }
  95
  96 1;