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