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 '' if (&IsParam("minVolunteerLength") == 0);
  37         return '' if (length $query < $param{'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     # what's whats => what is; who'?s => who is, etc
  86     $query =~ s/ ($qregex)\'?s / $1 is /i;
  87     if ($query =~ s/\s+($qregex)\s+//i) { # check for question word
  88         $questionWord = lc($1);
  89     }
  90
  91     if ($questionWord eq "" and $finalQMark and $addressed) {
  92         $questionWord = "where";
  93     }
  94
  95     if (&IsChanConf("factoidArguments")) {
  96         $result = &factoidArgs($query[0]);
  97
  98         return $result if (defined $result);
  99     }
 100
 101     my @link;
 102     for (my$i=0; $i<scalar @query; $i++) {
 103         $query  = $query[$i];
 104         $result = &getReply($query);
 105         next if (!defined $result or $result eq "");
 106
 107         # 'see also' factoid redirection support.
 108
 109         while ($result =~ /^see( also)? (.*?)\.?$/) {
 110             my $link    = $2;
 111
 112             # #debian@OPN was having problems with libstdc++ factoid
 113             # redirection :) 20021116. -xk.
 114             # hrm... allow recursive loops... next if statement handles
 115             # that.
 116             if (grep /^\Q$link\E$/i, @link) {
 117                 &status("recursive link found; bailing out.");
 118                 last;
 119             }
 120
 121             if (scalar @link >= 5) {
 122                 &status("recursive link limit (5) reached.");
 123                 last;
 124             }
 125
 126             push(@link, $link);
 127             my $newr = &getReply($link);
 128             last if (!defined $newr or $newr eq "");
 129             $result  = $newr;
 130         }
 131
 132         if (@link) {
 133             &status("'$query' linked to: ".join(" => ", @link) );
 134         }
 135
 136         if ($i != 0) {
 137             &VERB("Question.pl: '$query[0]' did not exist; '$query[$i]' ($i) did",2);
 138         }
 139
 140         return $result;
 141     }
 142
 143     ### TODO: Use &Forker(); move function to Freshmeat.pl.
 144     if (&IsChanConf("freshmeatForFactoid")) {
 145         &loadMyModule($myModules{'freshmeat'});
 146         $result = &Freshmeat::showPackage($query);
 147         return $result if (defined $result);
 148     }
 149
 150     ### TODO: Use &Forker(); move function to Debian.pl
 151     if (&IsChanConf("debianForFactoid")) {
 152         &loadMyModule($myModules{'debian'});
 153         $result = &Debian::DebianFind($query);  # ???
 154         ### TODO: debian module should tell, through shm, that it went
 155         ###       ok or not.
 156 ###     return $result if (defined $result);
 157     }
 158
 159     if ($questionWord ne "" or $finalQMark) {
 160         # if it has not been explicitly marked as a question
 161         if ($addressed and $reply eq "") {
 162             &status("notfound: <$who> ".join(' :: ', @query))
 163                                                 if ($finalQMark);
 164
 165             return '' unless (&IsParam("friendlyBots"));
 166
 167             foreach (split /\s+/, $param{'friendlyBots'}) {
 168                 &msg($_, ":INFOBOT:QUERY <$who> $query");
 169             }
 170         }
 171     }
 172
 173     return $reply;
 174 }
 175
 176 sub factoidArgs {
 177     my($str)    = @_;
 178     my $result;
 179
 180     # to make it eleeter, split each arg and use "blah OR blah or BLAH"
 181     # which will make it less than linear => quicker!
 182     # todo: cache this, update cache when altered. !!! !!! !!!
 183 #    my $t = &timeget();
 184     my @list = &searchTable("factoids", "factoid_key", "factoid_key", "^CMD: ");
 185 #    my $delta_time = &timedelta($t);
 186 #    &DEBUG("factArgs: delta_time = $delta_time s");
 187 #    &DEBUG("factArgs: list => ".scalar(@list) );
 188
 189     # from a design perspective, it's better to have the regex in
 190     # the factoid key to reduce repetitive processing.
 191
 192     # it does not matter if it's not alphabetically sorted.
 193     foreach (sort { length($b) <=> length($a) } @list) {
 194         next if (/#DEL#/);      # deleted.
 195
 196         s/^CMD: //i;
 197 #       &DEBUG("factarg: '$str' =~ /^$_\$/");
 198         my $arg = $_;
 199
 200         # todo: <greycat> ~punish apt for (Eating) (Parentheses)
 201         # how the hell do I fix the above? -dms.
 202
 203         # eval (evil!) code. cleaned up courtesy of lear.
 204         my @vals;
 205         eval {
 206             @vals = ($str =~ /^$arg$/i);
 207         };
 208
 209         if ($@) {
 210             &WARN("factargs: regex failed! '$str' =~ /^$_\$/");
 211             next;
 212         }
 213
 214         next unless (@vals);
 215
 216         if (defined $result) {
 217             &WARN("factargs: '$_' matches aswell.");
 218             next;
 219         }
 220
 221 #       &DEBUG("vals => @vals");
 222
 223         &status("Question: factoid Arguments for '$str'");
 224         # todo: use getReply() - need to modify it :(
 225         my $i   = 0;
 226         my $q   = "CMD: $_";
 227         my $r   = &getFactoid($q);
 228         if (!defined $r) {
 229             &DEBUG("question: !result... should this happen?");
 230             return;
 231         }
 232
 233         # update stats.
 234         if (0) {        # old.
 235             my $count = &getFactInfo($q, "requested_count") || 0;
 236             $count++;
 237             &setFactInfo($q, "requested_by", $nuh);
 238             &setFactInfo($q, "requested_time", time());
 239             &setFactInfo($q, "requested_count", $count);
 240         } else {
 241             &sqlUpdate("factoids", { factoid_key => $q }, {
 242                 requested_by            => $nuh,
 243                 requested_time          => time(),
 244                 -requested_count        => "requested_count+1",
 245             } );
 246         }
 247
 248         # end of update stats.
 249
 250         $result = $r;
 251         $result =~ s/^\((.*?)\): //;
 252
 253         foreach ( split(',', $1) ) {
 254             my $val = $vals[$i];
 255 #           &DEBUG("val => $val");
 256
 257             if (!defined $val) {
 258                 &status("factArgs: vals[$i] == undef; not SARing '$_' for '$str'");
 259                 next;
 260             }
 261
 262             my $done = 0;
 263             my $old = $result;
 264             while (1) {
 265 #               &DEBUG("Q: result => $result (1before)");
 266                 $result = &substVars($result);
 267 #               &DEBUG("Q: result => $result (1after)");
 268
 269                 last if ($old eq $result);
 270                 $old = $result;
 271                 $done++;
 272             }
 273
 274             # hack.
 275             $vals[$i] =~ s/^me$/$who/gi;
 276
 277             if (!$done) {
 278                 &status("factArgs: SARing '$_' to '$vals[$i]'.");
 279                 $result =~ s/\Q$_\E/$vals[$i]/g;
 280             }
 281             $i++;
 282         }
 283
 284         # nasty hack to get partial &getReply() functionality.
 285         $result =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i;
 286         $result =~ s/^\s*<reply>\s*//i;
 287         $result = &SARit($result);
 288
 289 # well... lets go through all of them. not advisable if we have like
 290 # 1000 commands, heh.
 291 #       return $result;
 292         $cmdstats{'Factoid Commands'}++;
 293     }
 294
 295     return $result;
 296 }
 297
 298 1;