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