src/Factoids/Reply.pl

   1 ###
   2 ### Reply.pl: Kevin Lenzo   (c) 1997
   3 ###
   4
   5 ##
   6 # x is y === $lhs $mhs $rhs
   7 #
   8 #   lhs - factoid.
   9 #   mhs - verb.
  10 #   rhs - factoid message.
  11 ##
  12
  13 if (&IsParam("useStrict")) { use strict; }
  14
  15 use vars qw($msgType $uh $lastWho $ident);
  16 use vars qw(%lang %lastWho);
  17
  18 sub getReply {
  19     my($message) = @_;
  20     my($lhs,$mhs,$rhs);
  21     my($result,$reply);
  22     $orig{message} = $message;
  23
  24     if (!defined $message or $message =~ /^\s*$/) {
  25         &WARN("getR: message == NULL.");
  26         return '';
  27     }
  28
  29     $message =~ tr/A-Z/a-z/;
  30
  31     if ($result = &getFactoid($message)) {
  32         $lhs = $message;
  33         $mhs = "is";
  34         $rhs = $result;
  35
  36         return "$lhs $mhs $rhs" if ($literal);
  37     } else {
  38         return '';
  39     }
  40
  41     # if there was a head...
  42     my(@poss) = split '\|\|', $result;
  43     $poss[0] =~ s/^\s//;
  44     $poss[$#poss] =~ s/\s$//;
  45
  46     if (@poss > 1) {
  47         $result = &getRandom(@poss);
  48         $result =~ s/^\s*//;
  49     }
  50
  51     my $fauthor = &dbGet("factoids", "created_by", "factoid_key=".&dbQuote($message) );
  52     $result     = &SARit($result);
  53
  54     $reply      = $result;
  55     if ($result ne "") {
  56         ### AT LAST, REPEAT PREVENTION CODE REMOVED IN FAVOUR OF GLOBAL
  57         ### FLOOD REPETION AND PROTECTION. -20000124
  58
  59         # stats code.
  60         ### FIXME: old mysql doesn't support
  61         ### "requested_count=requested_count+1".
  62         my $count = &getFactInfo($lhs,"requested_count") || 0;
  63         $count++;
  64         ### BROKEN!!!
  65         if (1) {        # old code.
  66             &setFactInfo($lhs,"requested_by", $nuh);
  67             &setFactInfo($lhs,"requested_time", time());
  68             &setFactInfo($lhs,"requested_count", $count);
  69         } else {
  70             &dbReplace("factoids", "factoid_key", (
  71                 factoid_key     => $lhs,
  72                 requested_by    => $nuh,
  73                 requested_time  => time(),
  74                 requested_count => $count
  75             ) );
  76         }
  77
  78         # todo: rename $real to something else!
  79         my $real   = 0;
  80 #       my $author = &getFactInfo($lhs,"created_by") || '';
  81 #       $real++ if ($author =~ /^\Q$who\E\!/);
  82 #       $real++ if (&IsFlag("n"));
  83         $real = 0 if ($msgType =~ /public/);
  84
  85         ### fix up the reply.
  86         # only remove '<reply>'
  87         if (!$real and $reply =~ s/^\s*<reply>\s*//i) {
  88             # 'are' fix.
  89             if ($reply =~ s/^are /$lhs are /i) {
  90                 &VERB("Reply.pl: el-cheapo 'are' fix executed.",2);
  91             }
  92
  93         } elsif (!$real and $reply =~ s/^\s*<action>\s*(.*)/\cAACTION $1\cA/i) {
  94             # only remove '<action>' and make it an action.
  95         } else {                # not a short reply
  96
  97             ### bot->bot reply.
  98             if (exists $bots{$nuh} and $rhs !~ /^\s*$/) {
  99                 return "$lhs $mhs $rhs";
 100             }
 101
 102             ### bot->person reply.
 103             # result is random if separated by '||'.
 104             # rhs is full factoid with '||'.
 105             if ($mhs eq "is") {
 106                 $reply = &getRandom(keys %{ $lang{'factoid'} });
 107                 $reply =~ s/##KEY/$lhs/;
 108                 $reply =~ s/##VALUE/$result/;
 109             } else {
 110                 $reply = "$lhs $mhs $result";
 111             }
 112
 113             if ($reply =~ s/^\Q$who\E is/you are/i) {
 114                 # fix the person.
 115             } else {
 116                 if ($reply =~ /^you are / or $reply =~ / you are /) {
 117                     return if ($addressed);
 118                 }
 119             }
 120         }
 121     }
 122
 123     return $reply if ($literal);
 124
 125     # remove excessive beginning and end whitespaces.
 126     $reply      =~ s/^\s+|\s+$//g;
 127
 128     if ($reply =~ /^\s+$/) {
 129         &DEBUG("Reply: Null factoid ($message)");
 130         return '';
 131     }
 132
 133     return $reply unless ($reply =~ /\$/);
 134
 135     ###
 136     ### $ SUBSTITUTION.
 137     ###
 138
 139 #    &DEBUG("Reply: reply => $reply");
 140     $reply = &substVars($reply,1);
 141 #    &DEBUG("Reply: reply => $reply");
 142
 143     $reply;
 144 }
 145
 146 sub smart_replace {
 147     my ($string) = @_;
 148     my ($l,$r)  = (0,0);        # l = left,  r = right.
 149     my ($s,$t)  = (0,0);        # s = start, t = marker.
 150     my $i       = 0;
 151     my $old     = $string;
 152     my @rand;
 153
 154     foreach (split //, $string) {
 155
 156         if ($_ eq "(") {
 157 ###         print "( l=>$l, r=>$r\n";
 158
 159             if (!$l and !$r) {
 160 #               print "STARTING at $i\n";
 161                 $s = $i;
 162                 $t = $i;
 163             }
 164
 165             $l++;
 166             $r--;
 167         }
 168
 169         if ($_ eq ")") {
 170 ###         print ") l=>$l, r=>$r\n";
 171
 172             $r++;
 173             $l--;
 174
 175             if (!$l and !$r) {
 176                 my $substr = substr($old,$s,$i-$s+1);
 177 #               print "STOP at $i $substr\n";
 178                 push(@rand, substr($old,$t+1,$i-$t-1) );
 179
 180                 my $rand = $rand[rand @rand];
 181                 &status("SARing '$substr' to '$rand'.");
 182                 $string =~ s/\Q$substr\E/$rand/;
 183                 undef @rand;
 184             }
 185         }
 186
 187         if ($_ eq "|" and $l+$r== 0 and $l==1) {
 188 #           print "| at $i (l=>$l,r=>$r)\n";
 189             push(@rand, substr($old,$t+1,$i-$t-1) );
 190             $t = $i;
 191         }
 192
 193         $i++;
 194     }
 195
 196     if ($old eq $string) {
 197         &WARN("smart_replace: no subst made. (string => $string)");
 198     }
 199
 200     return $string;
 201 }
 202
 203 sub SARit {
 204     my($txt) = @_;
 205     my $done = 0;
 206
 207     # (blah1|blah2)?
 208     while ($txt =~ /\((.*?)\)\?/) {
 209         my $str = $1;
 210         if (rand() > 0.5) {             # fix.
 211             &status("Factoid transform: keeping '$str'.");
 212             $txt =~ s/\(\Q$str\E\)\?/$str/;
 213         } else {                        # remove
 214             &status("Factoid transform: removing '$str'.");
 215             $txt =~ s/\(\Q$str\E\)\?\s?//;
 216         }
 217         $done++;
 218         last if ($done >= 10);  # just in case.
 219     }
 220     $done = 0;
 221
 222     # EG: (0-32768) => 6325
 223     ### TODO: (1-10,20-30,40) => 24
 224     while ($txt =~ /\((\d+)-(\d+)\)/) {
 225         my ($lower,$upper) = ($1,$2);
 226         my $new = int(rand $upper-$lower) + $lower;
 227
 228         &status("SARing '$&' to '$new' (2).");
 229         $txt =~ s/$&/$new/;
 230         $done++;
 231         last if ($done >= 10);  # just in case.
 232     }
 233     $done = 0;
 234
 235     # EG: (blah1|blah2|blah3|) => blah1
 236     while ($txt =~ /.*\((.*\|.*?)\).*/) {
 237         $txt = &smart_replace($txt);
 238
 239         $done++;
 240         last if ($done >= 10);  # just in case.
 241     }
 242     &status("Reply.pl: $done SARs done.") if ($done);
 243
 244     return $txt;
 245 }
 246
 247 sub substVars {
 248     my($reply,$flag) = @_;
 249
 250     # $date, $time.
 251     my $date    =  scalar(localtime());
 252     $date       =~ s/\:\d+(\s+\w+)\s+\d+$/$1/;
 253     $reply      =~ s/\$date/$date/gi;
 254     $date       =~ s/\w+\s+\w+\s+\d+\s+//;
 255     # todo: support UTC.
 256     $reply      =~ s/\$time/$date/gi;
 257
 258     # dollar variables.
 259     if ($flag) {
 260         $reply  =~ s/\$nick/$who/g;
 261         $reply  =~ s/\$who/$who/g;      # backward compat.
 262     }
 263
 264     if ($reply =~ /\$(user(name)?|host)/) {
 265         my ($username, $hostname) = split /\@/, $uh;
 266         $reply  =~ s/\$user(name)?/$username/g;
 267         $reply  =~ s/\$host(name)?/$hostname/g;
 268     }
 269     $reply      =~ s/\$chan(nel)?/$talkchannel/g;
 270     if ($msgType =~ /public/) {
 271         $reply  =~ s/\$lastspeaker/$lastWho{$talkchannel}/g;
 272     } else {
 273         $reply  =~ s/\$lastspeaker/$lastWho/g;
 274     }
 275
 276     if ($reply =~ /\$rand/) {
 277         my $rand  = rand();
 278
 279         # $randnick.
 280         if ($reply =~ /\$randnick/) {
 281             my @nicks = keys %{ $channels{$chan}{''} };
 282             my $randnick = $nicks[ int($rand*$#nicks) ];
 283             $reply =~ s/\$randnick/$randnick/g;
 284         }
 285
 286         # eg: $rand100.3
 287         ### TODO: number of digits. 'x.y'
 288         # too hard.
 289         if ($reply =~ /\$rand(\d+)(\.(\d+))?/) {
 290             my $max = $1;
 291             my $dot = $3 || 0;
 292             &status("dot => $dot, max => $max, rand=>$rand");
 293             $rand = sprintf("%.*f", $dot, $rand*$max);
 294             my $orig = $&;
 295
 296             &status("swapping $orig to $rand");
 297             &status("reply => $reply");
 298             $reply =~ s/$orig/$rand/eg;
 299             &status("reply => $reply");
 300         }
 301
 302         $reply =~ s/\$rand/$rand/g;
 303     }
 304
 305     $reply      =~ s/\$ident/$ident/g;
 306
 307     if ($reply =~ /\$startTime/) {
 308         my $time = scalar(localtime $^T);
 309         $reply =~ s/\$startTime/$time/;
 310     }
 311
 312     if ($reply =~ /\$uptime/) {
 313         my $uptime = &Time2String(time() - $^T);
 314         $reply =~ s/\$uptime/$uptime/;
 315     }
 316
 317     if ($reply =~ /\$factoids/) {
 318         my $count = &countKeys("factoids");
 319         $reply =~ s/\$factoids/$factoids/;
 320     }
 321
 322     if ($reply =~ /\$Fupdate/) {
 323         my $x = "\002$count{'Update'}\002 ".
 324                 &fixPlural("modification", $count{'Update'});
 325         $reply =~ s/\$Fupdate/$x/;
 326     }
 327
 328     if ($reply =~ /\$Fquestion/) {
 329         my $x = "\002$count{'Question'}\002 ".
 330                 &fixPlural("question", $count{'Question'});
 331         $reply =~ s/\$Fquestion/$x/;
 332     }
 333
 334     if ($reply =~ /\$Fdunno/) {
 335         my $x = "\002$count{'Dunno'}\002 ".
 336                 &fixPlural("dunno", $count{'Dunno'});
 337         $reply =~ s/\$Fdunno/$x/;
 338     }
 339
 340     $reply      =~ s/\$memusage/$memusage/;
 341
 342     return $reply;
 343 }
 344
 345 1;