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