src/Factoids/Statement.pl

   1 ###
   2 ### Statement.pl: Kevin Lenzo  (c) 1997
   3 ###
   4
   5 ##
   6 ##  doStatement --
   7 ##
   8 ##      decide if $in is a statement, and if so,
   9 ##              - update the db
  10 ##              - return feedback statement
  11 ##
  12 ##      otherwise return
  13 ##              - null for confused.
  14 ##
  15
  16 # use strict;   # TODO
  17
  18 use Encode qw(decode_utf8);
  19
  20 sub doStatement {
  21     my ($in) = @_;
  22
  23     $in =~ s/\\(\S+)/\#$1\#/g;    # fix the backslash.
  24     $in =~ s/^no([, ]+)//i;       # 'no, '.
  25
  26     # check if we need to be addressed and if we are
  27     return unless ($learnok);
  28
  29     my ($urlType) = '';
  30
  31     # prefix www with http:// and ftp with ftp://
  32     $in =~ s/ www\./ http:\/\/www\./ig;
  33     $in =~ s/ ftp\./ ftp:\/\/ftp\./ig;
  34
  35     $urlType = 'about'   if ( $in =~ /\babout:/i );
  36     $urlType = 'afp'     if ( $in =~ /\bafp:/ );
  37     $urlType = 'file'    if ( $in =~ /\bfile:/ );
  38     $urlType = 'palace'  if ( $in =~ /\bpalace:/ );
  39     $urlType = 'phoneto' if ( $in =~ /\bphone(to)?:/ );
  40     if ( $in =~ /\b(news|http|ftp|gopher|telnet):\s*\/\/[\-\w]+(\.[\-\w]+)+/ ) {
  41         $urlType = $1;
  42     }
  43
  44     # acceptUrl.
  45     if ( &IsParam('acceptUrl') ) {
  46         if ( $param{'acceptUrl'} eq 'REQUIRE' ) {    # require url type.
  47             return if ( $urlType eq '' );
  48         }
  49         elsif ( $param{'acceptUrl'} eq 'REJECT' ) {
  50             &status("REJECTED URL entry") if ( &IsParam('VERBOSITY') );
  51             return unless ( $urlType eq '' );
  52         }
  53         else {
  54
  55             # OPTIONAL
  56         }
  57     }
  58
  59     # learn statement. '$lhs is|are $rhs'
  60     if ( $in =~ /(^|\s)(is|are)(\s|$)/i ) {
  61         my ( $lhs, $mhs, $rhs ) = ( $`, $&, $' );
  62
  63         # Quit if they are over the limits. Check done here since Core.pl calls
  64         # this mid sub and Question.pl needs its own check as well. NOTE: $in is
  65         # used in this place since lhs and rhs are really undefined for unwanted
  66         # teaching. Mainly, the "is" could be anywhere within a 510 byte or so
  67         # block of text, so the total size was choosen since the sole purpose of
  68         # this logic is to not hammer the db with pointless factoids that were
  69         # only meant to be general conversation.
  70         return ''
  71           if (
  72             length $in <
  73             &::getChanConfDefault( 'minVolunteerLength', 2, $chan ) or
  74             $param{'addressing'} =~ m/require/i ) and not $addressed;
  75         return ''
  76           if (
  77             length $in >
  78             &::getChanConfDefault( 'maxVolunteerLength', 512, $chan ) or
  79             $param{'addressing'} =~ m/require/i ) and not $addressed;
  80
  81         # allows factoid arguments to be updated. -lear.
  82         $lhs =~ s/^(cmd: )?(.*)/$1||'' . lc $2/e;
  83
  84         # discard article.
  85         $lhs =~ s/^(the|da|an?)\s+//i;
  86
  87         # remove excessive initial and final whitespaces.
  88         $lhs =~ s/^\s+|\s+$//g;
  89         $mhs =~ s/^\s+|\s+$//g;
  90         $rhs =~ s/^\s+|\s+$//g;
  91
  92         # break if either lhs or rhs is NULL.
  93         if ( $lhs eq '' or $rhs eq '' ) {
  94             return "NOT-A-STATEMENT";
  95         }
  96
  97         # lets check if it failed.
  98         if ( &validFactoid( $lhs, $rhs ) == 0 ) {
  99             if ($addressed) {
 100                 &status("IGNORE statement: <$who> $message");
 101                 &performReply( &getRandom( keys %{ $lang{'confused'} } ) );
 102             }
 103             return;
 104         }
 105
 106         # uncomment to prevent HUNGRY learning of rhs with whitespace
 107         #return if (!$addressed and $lhs =~ /\s+/);
 108         &::DEBUG("doStatement: $in:$lhs:$mhs:$rhs");
 109
 110         &status("statement: <$who> $message");
 111
 112         # change "#*#" back to '*' because of '\' sar to '#blah#'.
 113         $lhs =~ s/\#(\S+)\#/$1/g;
 114         $rhs =~ s/\#(\S+)\#/$1/g;
 115
 116         $lhs =~ s/\?+\s*$//;    # strip off '?'.
 117
 118         # verify the update statement whether there are any weird
 119         # characters.
 120         ### this can be simplified.
 121         for my $temp ($lhs,$rhs ) {
 122             my $temp2 = decode_utf8($temp);
 123             if ($temp2 =~ /([^[:print:]])/ or $temp2 =~ /\N{U+FFFD}/) {
 124                 &status("statement: illegal character '$1' ".ord($1).".");
 125                 &performAddressedReply(
 126                     "i'm not going to learn illegal characters");
 127                 return;
 128             }
 129         }
 130         # success.
 131         return if ( &update( $lhs, $mhs, $rhs ) );
 132     }
 133
 134     return 'CONTINUE';
 135 }
 136
 137 1;
 138
 139 # vim:ts=4:sw=4:expandtab:tw=80