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