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