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