src/UserExtra.pl

   1 #
   2 # UserExtra.pl: User Commands, Public.
   3 #       Author: dms
   4 #      Version: v0.2b (20000707)
   5 #      Created: 20000107
   6 #
   7
   8 if (&IsParam("useStrict")) { use strict; }
   9
  10 use vars qw($message $arg $qWord $verb $lobotomized);
  11 use vars qw(%channels %chanstats %cmdstats);
  12
  13 ###
  14 ### Start of command hooks for UserExtra.
  15 ###
  16
  17 &addCmdHook("main", 'chan(stats|info)', ('CODEREF' => 'chaninfo', ) );
  18 &addCmdHook("main", 'cmd(stats|info)', ('CODEREF' => 'cmdstats', ) );
  19 &addCmdHook("main", 'factinfo', ('CODEREF' => 'factinfo',
  20         'Cmdstats' => 'Factoid Info', Module => 'factoids', ) );
  21 &addCmdHook("main", 'factstats?', ('CODEREF' => 'factstats',
  22         'Cmdstats' => 'Factoid Statistics', Help => "factstats",
  23         Forker => 1, 'Identifier' => 'factoids', ) );
  24 &addCmdHook("main", 'help', ('CODEREF' => 'help',
  25         'Cmdstats' => 'Help', ) );
  26 &addCmdHook("main", 'karma', ('CODEREF' => 'karma', ) );
  27 &addCmdHook("main", 'i?spell', ('CODEREF' => 'ispell',
  28         Help => 'spell', Identifier => 'spell', ) );
  29 &addCmdHook("main", 'd?nslookup', ('CODEREF' => 'DNS',
  30         Help => 'nslookup', Identifier => 'allowDNS',
  31         Forker => "NULL", ) );
  32 &addCmdHook("main", 'tell|explain', ('CODEREF' => 'tell',
  33         Help => 'tell', Identifier => 'allowTelling', ) );
  34
  35
  36 &status("CMD: loaded ".scalar(keys %hooks_main)." MAIN command hooks.");
  37
  38 ###
  39 ### Start of commands for hooks.
  40 ###
  41
  42 sub chaninfo {
  43     my $chan = lc shift(@_);
  44     my $mode;
  45
  46     if ($chan eq "") {          # all channels.
  47         my $i           = keys %channels;
  48         my $reply       = "i am on \002$i\002 ".&fixPlural("channel",$i);
  49         my $tucount     = 0;    # total user count.
  50         my $uucount     = 0;    # unique user count.
  51         my @array;
  52
  53         ### line 1.
  54         foreach (sort keys %channels) {
  55             if (/^\s*$/ or / /) {
  56                 &status("chanstats: fe channels: chan == NULL.");
  57                 &ircCheck();
  58                 next;
  59             }
  60             push(@array, "$_ (".scalar(keys %{$channels{$_}{''}}).")");
  61         }
  62         &pSReply($reply.": ".join(' ', @array));
  63
  64         ### total user count.
  65         foreach $chan (keys %channels) {
  66             $tucount += scalar(keys %{$channels{$chan}{''}});
  67         }
  68
  69         ### unique user count.
  70         my @nicks;
  71         foreach $chan (keys %channels) {
  72             foreach (keys %{ $channels{$chan}{''} }) {
  73                 next if (grep /^\Q$_\E$/, @nicks);
  74                 $uucount++;
  75                 push(@nicks, $_);
  76             }
  77         }
  78
  79         my $chans = scalar(keys %channels);
  80         &pSReply(
  81             "i've cached \002$tucount\002 ". &fixPlural("user",$tucount).
  82             ", \002$uucount\002 unique ". &fixPlural("user",$uucount).
  83             ", distributed over \002$chans\002 ".
  84             &fixPlural("channel", $chans)."."
  85         );
  86
  87         return;
  88     }
  89
  90     # channel specific.
  91
  92     if (&validChan($chan) == 0) {
  93         &msg($who,"error: invalid channel \002$chan\002");
  94         return;
  95     }
  96
  97     # Step 1:
  98     my @array;
  99     foreach (sort keys %{$chanstats{$chan}}) {
 100         my $int = $chanstats{$chan}{$_};
 101         next unless ($int);
 102
 103         push(@array, "\002$int\002 ". &fixPlural($_,$int));
 104     }
 105     my $reply = "On \002$chan\002, there ".
 106                 &fixPlural("has",scalar(@array)). " been ".
 107                 &IJoin(@array);
 108
 109     # Step 1b: check channel inconstencies.
 110     $chanstats{$chan}{'Join'}           ||= 0;
 111     $chanstats{$chan}{'SignOff'}        ||= 0;
 112     $chanstats{$chan}{'Part'}           ||= 0;
 113
 114     my $delta_stats = $chanstats{$chan}{'Join'}
 115                 - $chanstats{$chan}{'SignOff'}
 116                 - $chanstats{$chan}{'Part'};
 117
 118     if ($delta_stats) {
 119         my $total = scalar(keys %{$channels{$chan}{''}});
 120         &status("chaninfo: join ~= signoff + part (drift of $delta_stats < $total).");
 121
 122         if ($delta_stats > $total) {
 123             &ERROR("chaninfo: delta_stats exceeds total users.");
 124         }
 125     }
 126
 127     # Step 2:
 128     undef @array;
 129     my $type;
 130     foreach ("v","o","") {
 131         my $int = scalar(keys %{$channels{$chan}{$_}});
 132         next unless ($int);
 133
 134         $type = "Voice" if ($_ eq "v");
 135         $type = "Opped" if ($_ eq "o");
 136         $type = "Total" if ($_ eq "");
 137
 138         push(@array,"\002$int\002 $type");
 139     }
 140     $reply .= ".  At the moment, ". &IJoin(@array);
 141
 142     # Step 3:
 143     ### TODO: what's wrong with the following?
 144     my %new = map { $userstats{$_}{'Count'} => $_ } keys %userstats;
 145     my($count) = (sort { $b <=> $a } keys %new)[0];
 146     if ($count) {
 147         $reply .= ".  \002$new{$count}\002 has said the most with a total of \002$count\002 messages";
 148     }
 149     &pSReply("$reply.");
 150 }
 151
 152 # Command statistics.
 153 sub cmdstats {
 154     my @array;
 155
 156     if (!scalar(keys %cmdstats)) {
 157         &performReply("no-one has run any commands yet");
 158         return;
 159     }
 160
 161     my %countstats;
 162     foreach (keys %cmdstats) {
 163         $countstats{$cmdstats{$_}}{$_} = 1;
 164     }
 165
 166     foreach (sort {$b <=> $a} keys %countstats) {
 167         my $int = $_;
 168         next unless ($int);
 169
 170         foreach (keys %{$countstats{$int}}) {
 171             push(@array, "\002$int\002 of $_");
 172         }
 173     }
 174     &pSReply("command usage include ". &IJoin(@array).".");
 175 }
 176
 177 # Factoid extension info. xk++
 178 sub factinfo {
 179     my $faqtoid = lc shift(@_);
 180     my $query   = "";
 181
 182     if ($faqtoid =~ /^\-(\S+)(\s+(.*))$/) {
 183         &msg($who,"error: individual factoid info queries not supported as yet.");
 184         &msg($who,"it's possible that the factoid mistakenly begins with '-'.");
 185         return;
 186
 187         $query   = lc $1;
 188         $faqtoid = lc $3;
 189     }
 190
 191     &CmdFactInfo($faqtoid, $query);
 192 }
 193
 194 sub factstats {
 195     my $type = shift(@_);
 196
 197     &Forker("factoids", sub {
 198         &pSReply( &CmdFactStats($type) );
 199     } );
 200 }
 201
 202 sub karma {
 203     my $target  = lc( shift || $who );
 204     my $karma   = &dbGet("karma", "nick",$target,"karma") || 0;
 205
 206     if ($karma != 0) {
 207         &pSReply("$target has karma of $karma");
 208     } else {
 209         &pSReply("$target has neutral karma");
 210     }
 211 }
 212
 213 sub ispell {
 214     my $query = shift;
 215
 216     if (! -x "/usr/bin/spell") {
 217         &msg($who, "no binary found.");
 218         return;
 219     }
 220
 221     if (!&validExec($query)) {
 222         &msg($who,"argument appears to be fuzzy.");
 223         return;
 224     }
 225
 226     my $reply = "I can't find alternate spellings for '$query'";
 227
 228     foreach (`/bin/echo '$query' | /usr/bin/ispell -a -S`) {
 229         chop;
 230         last if !length;                # end of query.
 231
 232         if (/^\@/) {            # intro line.
 233             next;
 234         } elsif (/^\*/) {               # possibly correct.
 235             $reply = "'$query' may be spelled correctly";
 236             last;
 237         } elsif (/^\&/) {               # possible correction(s).
 238             s/^\& (\S+) \d+ \d+: //;
 239             my @array = split(/,? /);
 240
 241             $reply = "possible spellings for $query: @array";
 242             last;
 243         } elsif (/^\+/) {
 244             &DEBUG("spell: '+' found => '$_'.");
 245             last;
 246         } else {
 247             &DEBUG("spell: unknown: '$_'.");
 248         }
 249     }
 250
 251     &pSReply($reply);
 252 }
 253
 254 sub nslookup {
 255     my $query = shift;
 256     &status("DNS Lookup: $query");
 257     &DNS($query);
 258 }
 259
 260 sub tell {
 261     my $args = shift;
 262     my ($target, $tell_obj) = ('','');
 263     my $dont_tell_me    = 0;
 264     my $reply;
 265
 266     ### is this fixed elsewhere?
 267     $args =~ s/\s+/ /g;         # fix up spaces.
 268     $args =~ s/^\s+|\s+$//g;    # again.
 269
 270     # this one catches most of them
 271     if ($args =~ /^(\S+) (-?)about (.*)$/i) {
 272         $target         = lc $1;
 273         $tell_obj       = $3;
 274         $dont_tell_me   = ($2) ? 1 : 0;
 275
 276         $tell_obj       = $who  if ($tell_obj =~ /^(me|myself)$/i);
 277         $query          = $tell_obj;
 278     } elsif ($args =~ /^(\S+) where (\S+) can (\S+) (.*)$/i) {
 279         # i'm sure this could all be nicely collapsed
 280         $target         = lc $1;
 281         $tell_obj       = $4;
 282         $query          = $tell_obj;
 283
 284     } elsif ($args =~ /^(\S+) (what|where) (.*?) (is|are)[.?!]*$/i) {
 285         $target         = lc $1;
 286         $qWord          = $2;
 287         $tell_obj       = $3;
 288         $verb           = $4;
 289         $query          = "$qWord $verb $tell_obj";
 290
 291     } elsif ($args =~ /^(.*?) to (\S+)$/i) {
 292         $target         = lc $3;
 293         $tell_obj       = $2;
 294         $query          = $tell_obj;
 295     }
 296
 297     # check target type. Deny channel targets.
 298     if ($target !~ /^$mask{nick}$/ or $target =~ /^$mask{chan}$/) {
 299         &msg($who,"No, $who, I won't. (target invalid?)");
 300         return;
 301     }
 302
 303     $target     = $talkchannel  if ($target =~ /^us$/i);
 304     $target     = $who          if ($target =~ /^(me|myself)$/i);
 305
 306     &status("tell: target = $target, query = $query");
 307
 308     # "intrusive".
 309     if ($target !~ /^$mask{chan}$/ and !&IsNickInAnyChan($target)) {
 310         &msg($who, "No, $target is not in any of my chans.");
 311         return;
 312     }
 313
 314     ### TODO: don't "tell" if sender is not in target's channel.
 315
 316     # self.
 317     if ($target eq $ident) {    # lc?
 318         &msg($who, "Isn't that a bit silly?");
 319         return;
 320     }
 321
 322     my $oldwho          = $who;
 323     my $oldmtype        = $msgType;
 324     $who                = $target;
 325     my $result = &doQuestion($tell_obj);
 326         # ^ returns '0' if nothing was found.
 327     $who                = $oldwho;
 328
 329     # no such factoid.
 330     if ($result =~ /^0?$/) {
 331         $who            = $target;
 332         $msgType        = "private";
 333
 334         # support command redirection.
 335         # recursive cmdHooks aswell :)
 336         my $done = 0;
 337         $done++ if &parseCmdHook("main", $tell_obj);
 338         $done++ if &parseCmdHook("extra", $tell_obj);
 339         $message        = $tell_obj;
 340         $done++ unless (&Modules());
 341
 342         &DEBUG("setting old values of who and msgType.");
 343         $who            = $oldwho;
 344         $msgType        = $oldmtype;
 345
 346         if ($done) {
 347             &msg($who, "told $target about CMD '$tell_obj'");
 348         } else {
 349             &msg($who, "i dunno what is '$tell_obj'.");
 350         }
 351
 352         return;
 353     }
 354
 355     # success.
 356     &status("tell: <$who> telling $target about $tell_obj.");
 357     if ($who ne $target) {
 358         if ($dont_tell_me) {
 359             &msg($who, "told $target about $tell_obj.");
 360         } else {
 361             &msg($who, "told $target about $tell_obj ($result)");
 362         }
 363
 364         $reply = "$who wants you to know: $result";
 365     } else {
 366         $reply = "telling yourself: $result";
 367     }
 368
 369     &msg($target, $reply);
 370 }
 371
 372 sub DNS {
 373     my $dns = shift;
 374     my($match, $x, $y, $result);
 375     my $pid;
 376
 377     if ($dns =~ /(\d+\.\d+\.\d+\.\d+)/) {
 378         &status("DNS query by IP address: $in");
 379         $match = $1;
 380         $y = pack('C4', split(/\./, $match));
 381         $x = (gethostbyaddr($y, &AF_INET));
 382
 383         if ($x !~ /^\s*$/) {
 384             $result = $match." is ".$x unless ($x =~ /^\s*$/);
 385         } else {
 386             $result = "I can't seem to find that address in DNS";
 387         }
 388     } else {
 389         &status("DNS query by name: $in");
 390         $x = join('.',unpack('C4',(gethostbyname($in))[4]));
 391
 392         if ($x !~ /^\s*$/) {
 393             $result = $in." is ".$x;
 394         } else {
 395             $result = "I can\'t find that machine name";
 396         }
 397     }
 398
 399     &performReply($result);
 400 }
 401
 402
 403 ###
 404 ### amalgamated commands.
 405 ###
 406
 407 sub userCommands {
 408     # conversion: ascii.
 409     if ($message =~ /^(asci*|chr) (\d+)$/) {
 410         return unless (&IsParam("allowConv"));
 411
 412         $arg    = $2;
 413         $result = chr($arg);
 414         $result = "NULL"        if ($arg == 0);
 415
 416         &performReply( sprintf("ascii %s is '%s'", $arg, $result) );
 417
 418         return;
 419     }
 420
 421     # conversion: ord.
 422     if ($message =~ /^ord (.)$/) {
 423         return unless (&IsParam("allowConv"));
 424
 425         $arg = $1;
 426         if (ord($arg) < 32) {
 427             $arg = chr(ord($arg) + 64);
 428             if ($arg eq chr(64)) {
 429                 $arg = 'NULL';
 430             } else {
 431                 $arg = '^'.$arg;
 432             }
 433         }
 434
 435         &performReply( sprintf("'%s' is ascii %s", $arg, ord $1) );
 436         return;
 437     }
 438
 439     # hex.
 440     if ($message =~ /^hex(\s+(.*))?$/i) {
 441         return unless (&IsParam("allowConv"));
 442         my $arg = $2;
 443
 444         if (!defined $arg) {
 445             &help("hex");
 446             return;
 447         }
 448
 449         if (length $arg > 80) {
 450             &msg($who, "Too long.");
 451             return;
 452         }
 453
 454         my $retval;
 455         foreach (split //, $arg) {
 456             $retval .= sprintf(" %X", ord($_));
 457         }
 458
 459         &pSReply("$arg is$retval");
 460
 461         return;
 462     }
 463
 464     # crypt.
 465     if ($message =~ /^crypt\s+(\S+)\s*(?:,| )\s*(\S+)/) {
 466         # word salt.
 467         &pSReply(crypt($1, $2));
 468         return;
 469     }
 470
 471
 472
 473     # cycle.
 474     if ($message =~ /^(cycle)(\s+(\S+))?$/i) {
 475         return unless (&hasFlag("o"));
 476         my $chan = lc $3;
 477
 478         if ($chan eq "") {
 479             if ($msgType =~ /public/) {
 480                 $chan = $talkchannel;
 481                 &DEBUG("cycle: setting chan to '$chan'.");
 482             } else {
 483                 &help("cycle");
 484                 return;
 485             }
 486         }
 487
 488         if (&validChan($chan) == 0) {
 489             &msg($who,"error: invalid channel \002$chan\002");
 490             return;
 491         }
 492
 493         &msg($chan, "I'm coming back. (courtesy of $who)");
 494         &part($chan);
 495 ###     &ScheduleThis(5, "getNickInUse") if (@_);
 496         &status("Schedule rejoin in 5secs to $chan by $who.");
 497         $conn->schedule(5, sub { &joinchan($chan); });
 498
 499         return;
 500     }
 501
 502     # redir.
 503     if ($message =~ /^redir(\s+(.*))?/i) {
 504         return unless (&hasFlag("o"));
 505         my $factoid = $2;
 506
 507         if (!defined $factoid) {
 508             &help("redir");
 509             return;
 510         }
 511
 512         my $val  = &getFactInfo($factoid, "factoid_value");
 513         if (!defined $val or $val eq "") {
 514             &msg($who, "error: '$factoid' does not exist.");
 515             return;
 516         }
 517         &DEBUG("val => '$val'.");
 518         my @list = &searchTable("factoids", "factoid_key",
 519                                         "factoid_value", "^$val\$");
 520
 521         if (scalar @list == 1) {
 522             &msg($who, "hrm... '$factoid' is unique.");
 523             return;
 524         }
 525         if (scalar @list > 5) {
 526             &msg($who, "A bit too many factoids to be redirected, hey?");
 527             return;
 528         }
 529
 530         my @redir;
 531         &status("Redirect '$factoid' (". ($#list) .")...");
 532         for (@list) {
 533             my $x = $_;
 534             next if (/^\Q$factoid\E$/i);
 535
 536             &status("  Redirecting '$_'.");
 537             my $was = &getFactoid($_);
 538             if ($was =~ /<REPLY> see/i) {
 539                 &status("warn: not redirecting a redirection.");
 540                 next;
 541             }
 542
 543             &DEBUG("  was '$was'.");
 544             push(@redir,$x);
 545             &setFactInfo($x, "factoid_value", "<REPLY> see $factoid");
 546         }
 547         &status("Done.");
 548
 549         &msg($who, &formListReply(0, "'$factoid' is redirected to by '", @redir));
 550
 551         return;
 552     }
 553
 554     # rot13 it.
 555     if ($message =~ /^rot13(\s+(.*))?/i) {
 556         my $reply = $2;
 557
 558         if (!defined $reply) {
 559             &help("rot13");
 560             return;
 561         }
 562
 563         $reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
 564         &pSReply($reply);
 565
 566         return;
 567     }
 568
 569     # cpustats.
 570     if ($message =~ /^cpustats$/i) {
 571         if ($^O !~ /linux/) {
 572             &ERROR("cpustats: your OS is not supported yet.");
 573             return;
 574         }
 575
 576         ### poor method to get info out of file, please fix.
 577         open(STAT,"/proc/$$/stat");
 578         my $line = <STAT>;
 579         chop $line;
 580         my @data = split(/ /, $line);
 581         close STAT;
 582
 583         # utime(13) + stime(14).
 584         my $cpu_usage   = sprintf("%.01f", ($data[13]+$data[14]) / 100 );
 585         my $time        = time() - $^T;
 586         my $raw_perc    = $cpu_usage*100/$time;
 587         my $perc;
 588
 589         if ($raw_perc > 1) {
 590             $perc       = sprintf("%.01f", $raw_perc);
 591         } elsif ($raw_perc > 0.1) {
 592             $perc       = sprintf("%.02f", $raw_perc);
 593         } else {                        # <=0.1
 594             $perc       = sprintf("%.03f", $raw_perc);
 595         }
 596
 597         &pSReply("Total CPU usage: $cpu_usage s ... Percentage CPU used: $perc %");
 598         &DEBUG("15 => $data[15] (cutime)");
 599         &DEBUG("16 => $data[16] (cstime)");
 600
 601         return;
 602     }
 603
 604     # ircstats.
 605     if ($message =~ /^ircstats$/i) {
 606         my $count       = $ircstats{'ConnectCount'};
 607         my $format_time = &Time2String(time() - $ircstats{'ConnectTime'});
 608         my $total_time  = time() - $ircstats{'ConnectTime'} + $ircstats{'TotalTime'};
 609         my $reply;
 610
 611         &DEBUG("ircstats: total_time => $total_time.");
 612         &DEBUG("ircstats: offtime => $ircstats{'OffTime'}");
 613
 614         foreach (keys %ircstats) {
 615             &DEBUG("ircstats: $_ => '$ircstats{$_}'.");
 616         }
 617
 618         ### RECONNECT COUNT.
 619         if ($count == 1) {      # good.
 620             $reply = "I'm connected to $ircstats{'Server'} and have been so".
 621                 " for $format_time";
 622         } else {
 623             $reply = "Currently I'm hooked up to $ircstats{'Server'} but only".
 624                 " for $format_time.  ".
 625                 "I had to reconnect \002$count\002 times.";
 626         }
 627
 628         ### REASON.
 629         my $reason = $ircstats{'DisconnectReason'};
 630         if (defined $reason) {
 631             $reply .= "  I was last disconnected for '$reason'.";
 632         }
 633
 634         &pSReply($reply);
 635
 636         return;
 637     }
 638
 639     # status.
 640     if ($message =~ /^statu?s$/i) {
 641         my $startString = scalar(localtime $^T);
 642         my $upString    = &Time2String(time() - $^T);
 643         my $count       = &countKeys("factoids");
 644
 645         &pSReply(
 646         "Since $startString, there have been".
 647           " \002$count{'Update'}\002 ".
 648                 &fixPlural("modification", $count{'Update'}).
 649           " and \002$count{'Question'}\002 ".
 650                 &fixPlural("question",$count{'Question'}).
 651           " and \002$count{'Dunno'}\002 ".
 652                 &fixPlural("dunno",$count{'Dunno'}).
 653           " and \002$count{'Moron'}\002 ".
 654                 &fixPlural("moron",$count{'Moron'}).
 655           ".  I have been awake for $upString this session, and ".
 656           "currently reference \002$count\002 factoids.  ".
 657           "I'm using about \002$memusage\002 ".
 658           "kB of memory."
 659         );
 660
 661         return;
 662     }
 663
 664     # wantNick. xk++
 665     if ($message =~ /^wantNick$/i) {
 666         if ($param{'ircNick'} eq $ident) {
 667             &msg($who, "I hope you're right. I'll try anyway.");
 668         }
 669
 670         if (! &IsNickInAnyChan( $param{ircNick} ) ) {
 671             my $str = "attempting to change nick to $param{'ircNick'}";
 672             &status($str);
 673             &msg($who, $str);
 674             &nick($param{'ircNick'});
 675         } else {
 676             &msg($who, "hrm... can't do it");
 677             &DEBUG("wN: nick is somewhere... should try later.");
 678         }
 679
 680         return;
 681     }
 682
 683     return "CONTINUE";
 684 }
 685
 686 1;