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