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] , $chan);
 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,$chan) = @_;
 198     my $result;
 199
 200     $chan //= '';
 201
 202     # to make it eleeter, split each arg and use "blah OR blah or BLAH"
 203     # which will make it less than linear => quicker!
 204     # TODO: cache this, update cache when altered. !!! !!! !!!
 205     #    my $t = &timeget();
 206     my ($first) = split( /\s+/, $str );
 207
 208     # ignore split to commands [dumb commands vs. factoids] (editing commands?)
 209     return undef if $str =~ /\s+\=\~\s+s[\#\/\:]/;
 210     my @list =
 211       &searchTable( 'factoids', 'factoid_key', 'factoid_key', "^$chan cmd: $first " );
 212       &searchTable( 'factoids', 'factoid_key', 'factoid_key', "^cmd: $first " );
 213
 214     &DEBUG("chan is $chan, first is $first; searching for '^$chan cmd: $first' ");
 215
 216     #    my $delta_time = &timedelta($t);
 217     #    &DEBUG("factArgs: delta_time = $delta_time s");
 218     &DEBUG("factArgs: list => ".scalar(@list) );
 219
 220     # from a design perspective, it's better to have the regex in
 221     # the factoid key to reduce repetitive processing.
 222
 223     # it does not matter if it's not alphabetically sorted.
 224     foreach ( sort { length($b) <=> length($a) } @list ) {
 225         next if (/#DEL#/);    # deleted.
 226
 227         s/^\Q$chan \E//i;
 228         s/^cmd: //i;
 229
 230         #       &DEBUG("factarg: '$str' =~ /^$_\$/");
 231         my $arg = $_;
 232
 233         # eval (evil!) code. cleaned up courtesy of lear.
 234         my @vals;
 235         eval { @vals = ( $str =~ /^$arg$/i ); };
 236
 237         if ($@) {
 238             &WARN("factargs: regex failed! '$str' =~ /^$_\$/");
 239             next;
 240         }
 241
 242         next unless (@vals);
 243
 244         if ( defined $result ) {
 245             &WARN("factargs: '$_' matches aswell.");
 246             next;
 247         }
 248
 249         #       &DEBUG("vals => @vals");
 250
 251         &status("Question: factoid Arguments for '$str'");
 252
 253         # TODO: use getReply() - need to modify it :(
 254         my $i = 0;
 255         my $q = "cmd: $_";
 256         my $r = &getFactoid($q);
 257         if ( !defined $r ) {
 258             &DEBUG("question: !result... should this happen?");
 259             return;
 260         }
 261
 262         # update stats. old mysql/sqlite don't do +1
 263         my ($count) =
 264           &sqlSelect( 'factoids', 'requested_count', { factoid_key => $q } );
 265         $count++;
 266         &sqlSet(
 267             'factoids',
 268             { 'factoid_key' => $q },
 269             {
 270                 requested_by    => $nuh,
 271                 requested_time  => time(),
 272                 requested_count => $count
 273             }
 274         );
 275
 276         # end of update stats.
 277
 278         $result = $r;
 279
 280         $result =~ s/^\((.*?)\): //;
 281         my $vars = $1;
 282
 283         # start nasty hack to get partial &getReply() functionality.
 284         $result = &SARit($result);
 285
 286         foreach ( split( ',', $vars ) ) {
 287             my $val = $vals[$i];
 288
 289             #       &DEBUG("val => $val");
 290
 291             if ( !defined $val ) {
 292                 &status(
 293                     "factArgs: vals[$i] == undef; not SARing '$_' for '$str'");
 294                 next;
 295             }
 296
 297             my $done = 0;
 298             my $old  = $result;
 299             while (1) {
 300
 301                 #               &DEBUG("Q: result => $result (1before)");
 302                 $result = &substVars( $result, 1 );
 303
 304                 #               &DEBUG("Q: result => $result (1after)");
 305
 306                 last if ( $old eq $result );
 307                 $old = $result;
 308                 $done++;
 309             }
 310
 311             # hack.
 312             $vals[$i] =~ s/^me$/$who/gi;
 313
 314             #       if (!$done) {
 315             &status("factArgs: SARing '$_' to '$vals[$i]'.");
 316             $result =~ s/\Q$_\E/$vals[$i]/g;
 317
 318             #       }
 319             $i++;
 320         }
 321
 322         # rest of nasty hack to get partial &getReply() functionality.
 323         $result =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i;
 324         $result =~ s/^\s*<reply>\s*//i;
 325
 326         # well... lets go through all of them. not advisable if we have like
 327         # 1000 commands, heh.
 328         #       return $result;
 329         $cmdstats{'Factoid Commands'}++;
 330     }
 331
 332     return $result;
 333 }
 334
 335 1;
 336
 337 # vim:ts=4:sw=4:expandtab:tw=80