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