src/Factoids/Question.pl

   1 ###
   2 ### Question.pl: Kevin Lenzo  (c) 1997
   3 ###
   4
   5 ##  doQuestion --
   6 ##      if ($query == query) {
   7 ##              return $value;
   8 ##      } else {
   9 ##              return NULL;
  10 ##      }
  11 ##
  12 ##
  13
  14 # use strict;   # TODO
  15
  16 use vars qw($query $reply $finalQMark $nuh $result $talkok $who $nuh);
  17 use vars qw(%bots %forked);
  18
  19 sub doQuestion {
  20
  21     # my doesn't allow variables to be inherinted, local does.
  22     # following is used in math()...
  23     local ($query) = @_;
  24     local ($reply) = '';
  25     local $finalQMark = $query =~ s/\?+\s*$//;
  26     $query =~ s/^\s+|\s+$//g;
  27
  28     if ( !defined $query or $query =~ /^\s*$/ ) {
  29         return '';
  30     }
  31
  32     my $questionWord = '';
  33
  34     if ( !$addressed ) {
  35         return '' unless ($finalQMark);
  36         return ''
  37           if (
  38             length $query <
  39             &::getChanConfDefault( 'minVolunteerLength', 2, $chan ) or
  40             $param{'addressing'} =~ m/require/i );
  41         return ''
  42           if (
  43             length $query >
  44             &::getChanConfDefault( 'maxVolunteerLength', 512, $chan ) or
  45             $param{'addressing'} =~ m/require/i );
  46     }
  47     else {
  48         ### TODO: this should be caught in Process.pl?
  49         return '' unless ($talkok);
  50
  51         # there is no flag to disable/enable asking factoids...
  52         # so it was added... thanks zyxep! :)
  53         if ( &IsFlag('a') ne 'a' && &IsFlag('o') ne 'o' ) {
  54             &status("$who tried to ask us when not allowed.");
  55             return;
  56         }
  57     }
  58
  59     # dangerous; common preambles should be stripped before here
  60     if ( $query =~ /^forget /i or $query =~ /^no, / ) {
  61         return if ( exists $bots{$nuh} );
  62     }
  63
  64     if ( $query =~ s/^literal\s+//i ) {
  65         &status("literal ask of '$query'.");
  66         $literal = 1;
  67     }
  68
  69     # convert to canonical reference form
  70     my $x;
  71     my @query;
  72
  73     push( @query, $query );    # 1: push original.
  74
  75     # valid factoid.
  76     if ( $query =~ s/[!.]$// ) {
  77         push( @query, $query );
  78     }
  79
  80     $x = &normquery($query);
  81     push( @query, $x ) if ( $x ne $query );
  82     $query = $x;
  83
  84     $x = &switchPerson($query);
  85     push( @query, $x ) if ( $x ne $query );
  86     $query = $x;
  87
  88     $query =~ s/\s+at\s*(\?*)$/$1/;       # where is x at?
  89     $query =~ s/^explain\s*(\?*)/$1/i;    # explain x
  90     $query = " $query ";                  # side whitespaces.
  91
  92     my $qregex = join '|', keys %{ $lang{'qWord'} };
  93
  94     # purge prefix question string.
  95     if ( $query =~ s/^ ($qregex)//i ) {
  96         $questionWord = lc($1);
  97     }
  98
  99     if ( $questionWord eq '' and $finalQMark and $addressed ) {
 100         $questionWord = 'where';
 101     }
 102     $query =~ s/^\s+|\s+$//g;             # bleh. hacked.
 103     push( @query, $query ) if ( $query ne $x );
 104
 105     if ( &IsChanConf('factoidArguments') > 0 ) {
 106         $result = &factoidArgs( $query[0] );
 107
 108         return $result if ( defined $result );
 109     }
 110
 111     my @link;
 112     for ( my $i = 0 ; $i < scalar @query ; $i++ ) {
 113         $query  = $query[$i];
 114         $result = &getReply($query);
 115         next if ( !defined $result or $result eq '' );
 116
 117         # 'see also' factoid redirection support.
 118
 119         while ( $result =~ /^see( also)? (.*?)\.?$/ ) {
 120             my $link = $2;
 121
 122             # #debian@OPN was having problems with libstdc++ factoid
 123             # redirection :) 20021116. -xk.
 124             # hrm... allow recursive loops... next if statement handles
 125             # that.
 126             if ( grep /^\Q$link\E$/i, @link ) {
 127                 &status("recursive link found; bailing out.");
 128                 last;
 129             }
 130
 131             if ( scalar @link >= 5 ) {
 132                 &status("recursive link limit (5) reached.");
 133                 last;
 134             }
 135
 136             push( @link, $link );
 137             my $newr = &getReply($link);
 138
 139             # no such factoid. try commands
 140             if ( !defined $newr || $newr =~ /^0?$/ ) {
 141
 142                 # support command redirection.
 143                 # recursive cmdHooks aswell :)
 144                 my $done = 0;
 145                 $done++ if &parseCmdHook($link);
 146                 $message = $link;
 147                 $done++ unless ( &Modules() );
 148
 149                 return;
 150             }
 151             last if ( !defined $newr or $newr eq '' );
 152             $result = $newr;
 153         }
 154
 155         if (@link) {
 156             &status( "'$query' linked to: " . join( " => ", @link ) );
 157         }
 158
 159         if ( $i != 0 ) {
 160             &VERB(
 161                 "Question.pl: '$query[0]' did not exist; '$query[$i]' ($i) did",
 162                 2
 163             );
 164         }
 165
 166         return $result;
 167     }
 168
 169     ### TODO: Use &Forker(); move function to Debian.pl
 170     if ( &IsChanConf('debianForFactoid') > 0 ) {
 171         &loadMyModule('Debian');
 172         $result = &Debian::DebianFind($query);    # ???
 173         ### TODO: debian module should tell, through shm, that it went
 174         ###       ok or not.
 175 ###     return $result if (defined $result);
 176     }
 177
 178     if ( $questionWord ne '' or $finalQMark ) {
 179
 180         # if it has not been explicitly marked as a question
 181         if ( $addressed and $reply eq '' ) {
 182             &status( "notfound: <$who> " . join( ' :: ', @query ) )
 183               if ($finalQMark);
 184
 185             return '' unless ( &IsParam('friendlyBots') );
 186
 187             foreach ( split /\s+/, $param{'friendlyBots'} ) {
 188                 &msg( $_, ":INFOBOT:QUERY <$who> $query" );
 189             }
 190         }
 191     }
 192
 193     return $reply;
 194 }
 195
 196 sub factoidArgs {
 197     my ($str) = @_;
 198     my $result;
 199
 200     # to make it eleeter, split each arg and use "blah OR blah or BLAH"
 201     # which will make it less than linear => quicker!
 202     # TODO: cache this, update cache when altered. !!! !!! !!!
 203     #    my $t = &timeget();
 204     my ($first) = split( /\s+/, $str );
 205
 206     # ignore split to commands [dumb commands vs. factoids] (editing commands?)
 207     return undef if $str =~ /\s+\=\~\s+s[\#\/\:]/;
 208     my @list =
 209       &searchTable( 'factoids', 'factoid_key', 'factoid_key', "^cmd: $first " );
 210
 211     #    my $delta_time = &timedelta($t);
 212     #    &DEBUG("factArgs: delta_time = $delta_time s");
 213     #    &DEBUG("factArgs: list => ".scalar(@list) );
 214
 215     # from a design perspective, it's better to have the regex in
 216     # the factoid key to reduce repetitive processing.
 217
 218     # it does not matter if it's not alphabetically sorted.
 219     foreach ( sort { length($b) <=> length($a) } @list ) {
 220         next if (/#DEL#/);    # deleted.
 221
 222         s/^cmd: //i;
 223
 224         #       &DEBUG("factarg: '$str' =~ /^$_\$/");
 225         my $arg = $_;
 226
 227         # eval (evil!) code. cleaned up courtesy of lear.
 228         my @vals;
 229         eval { @vals = ( $str =~ /^$arg$/i ); };
 230
 231         if ($@) {
 232             &WARN("factargs: regex failed! '$str' =~ /^$_\$/");
 233             next;
 234         }
 235
 236         next unless (@vals);
 237
 238         if ( defined $result ) {
 239             &WARN("factargs: '$_' matches aswell.");
 240             next;
 241         }
 242
 243         #       &DEBUG("vals => @vals");
 244
 245         &status("Question: factoid Arguments for '$str'");
 246
 247         # TODO: use getReply() - need to modify it :(
 248         my $i = 0;
 249         my $q = "cmd: $_";
 250         my $r = &getFactoid($q);
 251         if ( !defined $r ) {
 252             &DEBUG("question: !result... should this happen?");
 253             return;
 254         }
 255
 256         # update stats. old mysql/sqlite don't do +1
 257         my ($count) =
 258           &sqlSelect( 'factoids', 'requested_count', { factoid_key => $q } );
 259         $count++;
 260         &sqlSet(
 261             'factoids',
 262             { 'factoid_key' => $q },
 263             {
 264                 requested_by    => $nuh,
 265                 requested_time  => time(),
 266                 requested_count => $count
 267             }
 268         );
 269
 270         # end of update stats.
 271
 272         $result = $r;
 273
 274         $result =~ s/^\((.*?)\): //;
 275         my $vars = $1;
 276
 277         # start nasty hack to get partial &getReply() functionality.
 278         $result = &SARit($result);
 279
 280         foreach ( split( ',', $vars ) ) {
 281             my $val = $vals[$i];
 282
 283             #       &DEBUG("val => $val");
 284
 285             if ( !defined $val ) {
 286                 &status(
 287                     "factArgs: vals[$i] == undef; not SARing '$_' for '$str'");
 288                 next;
 289             }
 290
 291             my $done = 0;
 292             my $old  = $result;
 293             while (1) {
 294
 295                 #               &DEBUG("Q: result => $result (1before)");
 296                 $result = &substVars( $result, 1 );
 297
 298                 #               &DEBUG("Q: result => $result (1after)");
 299
 300                 last if ( $old eq $result );
 301                 $old = $result;
 302                 $done++;
 303             }
 304
 305             # hack.
 306             $vals[$i] =~ s/^me$/$who/gi;
 307
 308             #       if (!$done) {
 309             &status("factArgs: SARing '$_' to '$vals[$i]'.");
 310             $result =~ s/\Q$_\E/$vals[$i]/g;
 311
 312             #       }
 313             $i++;
 314         }
 315
 316         # rest of nasty hack to get partial &getReply() functionality.
 317         $result =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i;
 318         $result =~ s/^\s*<reply>\s*//i;
 319
 320         # well... lets go through all of them. not advisable if we have like
 321         # 1000 commands, heh.
 322         #       return $result;
 323         $cmdstats{'Factoid Commands'}++;
 324     }
 325
 326     return $result;
 327 }
 328
 329 1;
 330
 331 # vim:ts=4:sw=4:expandtab:tw=80