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