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