home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / profane.pl < prev    next >
Text File  |  2009-11-06  |  8KB  |  266 lines
  1. # FILE: profane.pl
  2. # DESCRIPTION: Profanity filtering of various kinds
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $PARAMS $DCONF);
  17.  
  18. ###
  19. ### profanity_filter
  20. ###
  21. ### Controls checking of input for profane words
  22. ###
  23.  
  24. sub profanity_filter {
  25.     my ($text_in, $argument) = @_;
  26.     my $args = {};
  27.     $args->{force_check} = $argument->{force_check} == 0 ? 0 : 1;
  28.     return $text_in if $GLOBAL_OPTIONS->{profanity} == 0 && ! $args->{force_check};
  29.     return $text_in if $text_in !~ /\S/;
  30.     $args->{force_read} = $argument->{force_read} eq "0" ? 0 : 1;
  31.     $args->{error_report} = defined $argument->{error_report} ? $argument->{error_report} : 2;
  32.     $args->{error_report} = 2 if ($GLOBAL_OPTIONS->{profanity_detected} == 2 && $argument->{error_report} == 1);
  33.     $args->{alternate_handler} = $argument->{alternate_handler} if defined $argument->{alternate_handler};
  34.     my $result = profanity_filter_internal($text_in, $args, $argument);
  35.     return $result if $args->{error_report} != 2;
  36.     if (keys(%{ $result->{cuss_found} })) {
  37.         if (! defined $args->{alternate_handler}) {
  38.             my $error_message = read_language()->{PROFANITY_DETECTED_MESSAGE};
  39.             my $l = join("<li>", sort keys(%{ $result->{cuss_found} })); $l = "<li>$l";
  40.             $error_message =~ s/\%wordlist/$l/g;
  41.             error_message(read_language()->{GENERAL_PROFANITY_ERROR}, $error_message, 0, 1);
  42.         } else {
  43.             &{ $args->{alternate_handler} }($text_in, $argument, $result->{cuss_found});
  44.         }
  45.     }
  46.     return $text_in;
  47. }
  48.  
  49. ###
  50. ### create_regular_expression
  51. ###
  52. ### Creates a regular expression for a word based on a character map
  53. ###
  54.  
  55. sub create_regular_expression {
  56.     my ($word, $charmap) = @_;
  57.     my $regexp = "";
  58.     my @letters = split(//, $word);
  59.     my $i = -1;
  60.     foreach my $letter (@letters) {
  61.         next if $letter eq chr(92);
  62.         $i++;
  63.         if ($letter =~ /\s/) {
  64.             $regexp .= $letter;
  65.             next;
  66.         }
  67.         my $L = defined $charmap->{$letter} ? $charmap->{$letter} : quotemeta($letter);
  68.         next if $L eq "";
  69.         $L = join($L, "[", "]") if length($charmap->{$letter}) > 1;
  70.         if ($GLOBAL_OPTIONS->{profanity_middle} && $i < $#letters && $i != 0) {
  71.             $L = join($L, "(?:", "|[^\\w\\s]+)");
  72.         }
  73.         if ($GLOBAL_OPTIONS->{profanity_repeated}) {
  74.             $L .= "+";
  75.         }
  76.         if ($GLOBAL_OPTIONS->{profanity_spaces} && $i < $#letters) {
  77.             $L .= "[_\\W]*";
  78.         }
  79.         $regexp .= $L;
  80.     }
  81.     return $regexp;
  82. }
  83.  
  84. ###
  85. ### profanity_filter_internal
  86. ###
  87. ### Checks a given input for profanity.  Replaces naughty words with dots,
  88. ### generates an error, or returns a list of the bad words, as requested.
  89. ###
  90.  
  91. sub profanity_filter_internal {
  92.     my ($message_in, $arg, $argument) = @_;
  93.     my $result = {};
  94.     if ($GLOBAL_OPTIONS->{'profanity'} + $arg->{force_check} == 0) {
  95.         return $message_in;
  96.     }
  97.     if ($arg->{force_read} || ! defined $PARAMS->{cuss_expressions}) {
  98.         my $cuss = defined $arg->{cuss_in} ? $arg->{cuss_in} : read_cuss_file($arg->{force_read});
  99.         my @cuss = ();
  100.         my $charmap = {};
  101.         foreach my $letter ("a" .. "z") {
  102.             $charmap->{$letter} = $letter;
  103.         }
  104.         if ($GLOBAL_OPTIONS->{profanity_chars}) {
  105.             $charmap->{a} =~ s/a/a└┴┬├─┼αßΓπΣσ/gi;
  106.             $charmap->{b} =~ s/b/b■▀▐/gi;
  107.             $charmap->{c} =~ s/c/c╟τ/gi;
  108.             $charmap->{d} =~ s/d/d╨/gi;
  109.             $charmap->{e} =~ s/e/e╚╔╩╦ΦΘΩδ/gi;
  110.             $charmap->{i} =~ s/i/i╠═╬╧∞φε∩1!/gi;
  111.             $charmap->{o} =~ s/o/o╥╙╘╒╓╪≡≥≤⌠⌡÷°/gi;
  112.             $charmap->{u} =~ s/u/u┘┌█▄∙·√ⁿ/gi;
  113.             $charmap->{y} =~ s/y/y▌² /gi;
  114.         }
  115.         if ($GLOBAL_OPTIONS->{profanity_symbols}) {
  116.             $charmap->{a} =~ s/a/a\@/gi;
  117.             $charmap->{i} =~ s/i/i1\!/gi;
  118.             $charmap->{l} =~ s/l/l1\!/gi;
  119.             $charmap->{o} =~ s/o/o0/gi;
  120.             $charmap->{s} =~ s/s/s\\\$5/gi;
  121.         }
  122.         foreach my $word (@{ $cuss }) {
  123.             my $wordsave = $word;
  124.             $wordsave =~ s/\(\\S\*\)/\r/g;
  125.             $wordsave = create_regular_expression($wordsave, $charmap);
  126.             $wordsave =~ s/\r/\\S\*/g;
  127.             $wordsave =~ s/\\\\\\(\W)/\\$1/g;
  128.             push @cuss, { word => $word, wordrexp => $wordsave };
  129.         }
  130.         $PARAMS->{cuss_expressions} = \@cuss;
  131.     }
  132.     my $star_flag = ($GLOBAL_OPTIONS->{profanity_star} eq "" ? '\red{\char{149}}' : $GLOBAL_OPTIONS->{profanity_star});
  133.     my $within_html_star_flag = "*";
  134.     my @cuss = @{$PARAMS->{cuss_expressions}};
  135.  
  136.     # Prevent tricks like w\b{or}d getting around filtering for 'word'
  137.  
  138.     my $mtemp = $message_in;
  139.     $mtemp =~ s/\\char\{(\d+)\}/quotemeta(chr($1))/gie;
  140.     $mtemp =~ s/\\(\w+)\{(.*?)\}/$2/g;
  141.     $mtemp =~ s/<img[^>]*alt="(.*?)">/\[ $1 \]/gi;
  142.     my $cusscount = 0;
  143.     my $cusswords = {};
  144.     foreach my $word (@cuss) {
  145.         my $wordsave = $word->{wordrexp};
  146.         if ($arg->{error_report} == 1 || $arg->{globalcheck} == 1) {
  147.             while ($mtemp =~ /(^|\W)($wordsave)(\W|$)/ig) {
  148.                 $cusswords->{$2} = 1; $cusscount++;
  149.             }
  150.         } else {
  151.             if ($mtemp =~ /(^|\W)($wordsave)(\W|$)/i) {
  152.                 $cusswords->{$2} = 1; $cusscount++;
  153.             }
  154.         }
  155.     }
  156.  
  157.     # Scan the actual message as it was entered
  158.  
  159.     $message_in =~ s/\r\n/\n/g;
  160.     $message_in =~ s/\r/\n/g;
  161.     my @u = split(/<.*?>/, $message_in);
  162.     my @v = (); while ($message_in =~ /<.*?>/g) { push @v, $&; }
  163.     my $cusscount_cmp = 0;
  164.     my $W = $GLOBAL_OPTIONS->{profanity_international} == 1 ? "[\0-/:-\?\[-`\{-\┐]" : '\W';
  165.     foreach my $u (@u) {
  166.         study $u;
  167.         foreach my $word (@cuss) {
  168.             my $wordsave = $word->{wordrexp};
  169. W:            while ($u =~ /(^|$W)($wordsave)($W|$)/i) {
  170.                 $cusscount_cmp++;
  171.                 last W if $cusscount_cmp > 100;
  172.                 if ($arg->{error_report} == 1) {
  173.                     $u = join("", $`, $1, "\r" x length($2), $3, $');
  174.                 } elsif ($arg->{error_report} == 2) {
  175.                     $result->{cuss_found}->{$2} = 1;
  176.                     last W;
  177.                 } elsif ($arg->{error_report} == 3) {
  178.                     return $word->{word};
  179.                 } else {
  180.                     last W;
  181.                 }
  182.             }
  183.         }
  184.         $u =~ s/\r/$star_flag/g;
  185.     }
  186.     foreach my $v (@v) {
  187.         next if $v !~ m|<img([^>]+)alt="([^">]+)">|i;
  188.         my ($vbef, $vbtwn, $v2, $vaft) = ($`, $1, $2, $');
  189.         foreach my $word (@cuss) {
  190.             my $wordsave = $word->{wordrexp};
  191. W:            while ($v2 =~ /(^|$W)($wordsave)($W|$)/i) {
  192.                 $cusscount_cmp++;
  193.                 if ($arg->{error_report} == 1) {
  194.                     $v2 = join("", $`, $1, "\r" x length($2), $3, $');
  195.                 } elsif ($arg->{error_report} == 2) {
  196.                     $result->{cuss_found}->{$2} = 1;
  197.                     last W;
  198.                 } elsif ($arg->{error_report} == 3) {
  199.                     return $word->{word};
  200.                 } else {
  201.                     last W;
  202.                 }
  203.             }
  204.             $v2 =~ s/\r/$within_html_star_flag/g;
  205.         }
  206.         $v = join("", $vbef, "<img", $vbtwn, 'alt="', $v2, '">', $vaft);
  207.     }
  208.  
  209.     # Compare tricks vs. actual scan
  210.  
  211.     if ($arg->{error_report} == 1) {
  212.         if ($cusscount > $cusscount_cmp) {
  213.             if (! defined $arg->{alternate_handler}) {
  214.                 my $error_message = read_language()->{PROFANITY_DETECTED_MESSAGE};
  215.                 my $l = join("<li>", sort keys(%{ $cusswords })); $l = "<li>$l";
  216.                 $error_message =~ s/\%wordlist/$l/g;
  217.                 error_message(read_language()->{GENERAL_PROFANITY_ERROR}, $error_message, 0, 1);
  218.             } else {
  219.                 &{ $arg->{alternate_handler} }($message_in, $argument, $cusswords);
  220.             }
  221.         }
  222.         my $screened = "";
  223.         while (scalar(@u) + scalar(@v)) {
  224.             $screened .= shift @u;
  225.             $screened .= shift @v;
  226.         }
  227.         return $screened;
  228.     } elsif ($arg->{error_report} == 2) {
  229.         $result->{cuss_found} = $cusswords;
  230.         $result->{screened_message} = $message_in;
  231.     } elsif ($arg->{error_report} == 3) {
  232.         return undef;
  233.     }
  234.     return $result;
  235. }
  236.  
  237. ###
  238. ### read_cuss_file
  239. ###
  240. ### Reads in the list of cuss words
  241. ###
  242.  
  243. sub read_cuss_file {
  244.     my ($force) = @_;
  245.     return $PARAMS->{'naughty_words'} if defined $PARAMS->{'naughty_words'} && ! $force;
  246.     my $y = readfile("$DCONF->{admin_dir}/cuss.txt", "naughty_words", { zero_ok => 1, no_lock => 1, no_unlock => 1 });
  247.     my @z = ();
  248.     foreach my $line (@{ $y }) {
  249.         chomp $line;
  250.         if ($line =~ m|^\!|) {
  251.             $line = $';
  252.             $line =~ tr/a-zA-Z/b-zaB-ZA/;
  253.             push @z, $line;
  254.         } else {
  255.             push @z, $line if $line =~ /\S/ && $line !~ /^#/;
  256.         }
  257.     }
  258.     $PARAMS->{'naughty_words'} = \@z;
  259.     return \@z;
  260. }
  261.  
  262. 1;
  263.  
  264.  
  265.  
  266.