2 # UserExtra.pl: User Commands, Public.
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);
12 ### hooks get added in CommandHooks.pl.
15 ### Start of commands for hooks.
19 my $chan = lc shift(@_);
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.
31 foreach (keys %channels) {
32 if ( /^\s*$/ or / / ) {
33 &status("chanstats: fe channels: chan == NULL.");
37 next if (/^_default$/);
39 $chans{$_} = scalar(keys %{ $channels{$_}{''} });
41 foreach $chan (sort {$chans{$b} <=> $chans{$a}} keys %chans) {
42 push(@array, "$chan/" . $chans{$chan});
44 &performStrictReply($reply.": ".join(', ', @array));
47 foreach $chan (keys %channels) {
48 $tucount += scalar(keys %{ $channels{$chan}{''} });
51 ### unique user count.
53 foreach $chan (keys %channels) {
55 foreach $nick (keys %{ $channels{$chan}{''} }) {
59 $uucount = scalar(keys %nicks);
61 my $chans = scalar(keys %channels);
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)."."
75 if (&validChan($chan) == 0) {
76 &msg($who,"error: invalid channel \002$chan\002");
82 foreach (sort keys %{ $chanstats{$chan} }) {
83 my $int = $chanstats{$chan}{$_};
86 push(@array, "\002$int\002 ". &fixPlural($_,$int));
88 my $reply = "On \002$chan\002, there ".
89 &fixPlural('has',scalar(@array)). " been ".
92 # Step 1b: check channel inconstencies.
93 $chanstats{$chan}{'Join'} ||= 0;
94 $chanstats{$chan}{'SignOff'} ||= 0;
95 $chanstats{$chan}{'Part'} ||= 0;
97 my $delta_stats = $chanstats{$chan}{'Join'}
98 - $chanstats{$chan}{'SignOff'}
99 - $chanstats{$chan}{'Part'};
102 my $total = scalar(keys %{ $channels{$chan}{''} });
103 &status("chaninfo: join ~= signoff + part (drift of $delta_stats < $total).");
105 if ($delta_stats > $total) {
106 &ERROR("chaninfo: delta_stats exceeds total users.");
113 foreach ('v','o','') {
114 my $int = scalar(keys %{ $channels{$chan}{$_} });
117 $type = 'Voice' if ($_ eq 'v');
118 $type = 'Opped' if ($_ eq 'o');
119 $type = 'Total' if ($_ eq '');
121 push(@array,"\002$int\002 $type");
123 $reply .= ". At the moment, ". &IJoin(@array);
127 foreach (keys %userstats) {
128 next unless (exists $userstats{$_}{'Count'});
129 if ($userstats{$_}{'Count'} =~ /^\D+$/) {
130 &WARN("userstats{$_}{Count} is non-digit.");
134 $new{$_} = $userstats{$_}{'Count'};
137 # TODO: show top 3 with percentages?
138 my($count) = (sort { $new{$b} <=> $new{$a} } keys %new)[0];
140 $reply .= ". \002$count\002 has said the most with a total of \002$new{$count}\002 messages";
142 &performStrictReply("$reply.");
145 # Command statistics.
149 if (!scalar(keys %cmdstats)) {
150 &performReply("no-one has run any commands yet");
155 foreach (keys %cmdstats) {
156 $countstats{ $cmdstats{$_} }{$_} = 1;
159 foreach (sort {$b <=> $a} keys %countstats) {
163 foreach (keys %{ $countstats{$int} }) {
164 push(@array, "\002$int\002 of $_");
167 &performStrictReply("command usage include ". &IJoin(@array).".");
170 # Factoid extension info. xk++
172 my $faqtoid = lc shift(@_);
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 '-'.");
184 &CmdFactInfo($faqtoid, $query);
188 my $type = shift(@_);
190 &Forker('Factoids', sub {
191 &performStrictReply( &CmdFactStats($type) );
196 my $target = lc( shift || $who );
197 my $karma = &sqlSelect('stats', 'counter',
198 { nick => $target, type => 'karma'}) || 0;
201 &performStrictReply("$target has karma of $karma");
203 &performStrictReply("$target has neutral karma");
209 my ($target, $tell_obj) = ('','');
210 my $dont_tell_me = 0;
213 ### is this fixed elsewhere?
214 $args =~ s/\s+/ /g; # fix up spaces.
215 $args =~ s/^\s+|\s+$//g; # again.
217 # this one catches most of them
218 if ($args =~ /^(\S+) (-?)about (.*)$/i) {
221 $dont_tell_me = ($2) ? 1 : 0;
223 $tell_obj = $who if ($tell_obj =~ /^(me|myself)$/i);
225 } elsif ($args =~ /^(\S+) where (\S+) can (\S+) (.*)$/i) {
226 # i'm sure this could all be nicely collapsed
231 } elsif ($args =~ /^(\S+) (what|where) (.*?) (is|are)[.?!]*$/i) {
236 $query = "$qWord $verb $tell_obj";
238 } elsif ($args =~ /^(.*?) to (\S+)$/i) {
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?)");
250 $target = $talkchannel if ($target =~ /^us$/i);
251 $target = $who if ($target =~ /^(me|myself)$/i);
253 &status("tell: target = $target, query = $query");
256 # if ($target !~ /^$mask{chan}$/ and !&IsNickInAnyChan($target)) {
257 # &msg($who, "No, $target is not in any of my chans.");
262 if ($target =~ /^\Q$ident\E$/i) {
263 &msg($who, "Isn't that a bit silly?");
268 my $oldmtype = $msgType;
270 my $result = &doQuestion($tell_obj);
271 # ^ returns '0' if nothing was found.
275 if (!defined $result || $result =~ /^0?$/) {
277 $msgType = 'private';
279 # support command redirection.
280 # recursive cmdHooks aswell :)
282 $done++ if &parseCmdHook($tell_obj);
283 $message = $tell_obj;
284 $done++ unless (&Modules());
286 &VERB("tell: setting old values of who and msgType.",2);
288 $msgType = $oldmtype;
291 &msg($who, "told $target about CMD '$tell_obj'");
293 &msg($who, "i dunno what is '$tell_obj'.");
300 &status("tell: <$who> telling $target about $tell_obj.");
301 if ($who ne $target) {
303 &msg($who, "told $target about $tell_obj.");
305 &msg($who, "told $target about $tell_obj ($result)");
308 $reply = "$who wants you to know: $result";
310 $reply = "telling yourself: $result";
313 &msg($target, $reply);
317 if (exists $cache{countryStats}) {
318 &msg($who,"countrystats is already running!");
327 &help('countrystats');
332 $cache{countryStats}{chan} = $chan;
333 $cache{countryStats}{mtype} = $msgType;
334 $cache{countryStats}{who} = $who;
335 $cache{on_who_Hack} = 1;
338 sub do_countrystats {
339 $chan = $cache{countryStats}{chan};
340 $msgType = $cache{countryStats}{mtype};
341 $who = $cache{countryStats}{who};
345 foreach (keys %{ $cache{nuhInfo} }) {
346 my $h = $cache{nuhInfo}{$_}{Host};
348 if ($h =~ /^.*\.(\D+)$/) { # host
351 $cstats{unresolve}++;
356 foreach (keys %cstats) {
357 $count{ $cstats{$_} }{$_} = 1;
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);
366 push(@list, "$str ($_, $perc %)");
369 # TODO: move this into a scheduler
370 $msgType = 'private';
371 &performStrictReply( &formListReply(0, "Country Stats ", @list) );
373 delete $cache{countryStats};
374 delete $cache{on_who_Hack};
378 ### amalgamated commands.
383 if ($message =~ /^(asci*|chr) (\d+)$/) {
384 &DEBUG("ascii/chr called ...");
385 return unless (&IsChanConfOrWarn('allowConv'));
387 &DEBUG("ascii/chr called");
391 $result = 'NULL' if ($arg == 0);
393 &performReply( sprintf("ascii %s is '%s'", $arg, $result) );
399 if ($message =~ /^ord(\s+(.*))$/) {
400 return unless (&IsChanConfOrWarn('allowConv'));
404 if (!defined $arg or length $arg != 1) {
409 if (ord($arg) < 32) {
410 $arg = chr(ord($arg) + 64);
411 if ($arg eq chr(64)) {
418 &performReply( sprintf("'%s' is ascii %s", $arg, ord $arg) );
423 if ($message =~ /^hex(\s+(.*))?$/i) {
424 return unless (&IsChanConfOrWarn('allowConv'));
432 if (length $arg > 80) {
433 &msg($who, "Too long.");
438 foreach (split //, $arg) {
439 $retval .= sprintf(" %X", ord($_));
442 &performStrictReply("$arg is$retval");
448 if ($message =~ /^crypt\s+(\S*)?\s*(.*)?$/i) {
449 &status("crypt: $1:$2:$3");
451 &performStrictReply(crypt($2, $1));
453 &performStrictReply(&mkcrypt($1));
459 if ($message =~ /^(cycle)(\s+(\S+))?$/i) {
460 return unless (&hasFlag('o'));
464 if ($msgType =~ /public/) {
465 $chan = $talkchannel;
466 &DEBUG("cycle: setting chan to '$chan'.");
473 if (&validChan($chan) == 0) {
474 &msg($who,"error: invalid channel \002$chan\002");
478 &msg($chan, "I'm coming back. (courtesy of $who)");
480 ### &ScheduleThis(5, 'getNickInUse') if (@_);
481 &status("Schedule rejoin in 5secs to $chan by $who.");
482 $conn->schedule(5, sub { &joinchan($chan); });
488 if ($message =~ /^reload$/i) {
489 return unless (&hasFlag('n'));
491 &status("USER reload $who");
492 &performStrictReply("reloading...");
493 my $modules = &reloadAllModules();
494 &performStrictReply("reloaded:$modules");
499 if ($message =~ /^redir(\s+(.*))?/i) {
500 return unless (&hasFlag('o'));
503 if (!defined $factoid) {
508 my $val = &getFactInfo($factoid, "factoid_value");
509 if (!defined $val or $val eq '') {
510 &msg($who, "error: '$factoid' does not exist.");
513 &DEBUG("val => '$val'.");
514 my @list = &searchTable('factoids', "factoid_key",
515 "factoid_value", "^$val\$");
517 if (scalar @list == 1) {
518 &msg($who, "hrm... '$factoid' is unique.");
521 if (scalar @list > 5) {
522 &msg($who, "A bit too many factoids to be redirected, hey?");
527 &status("Redirect '$factoid' (". ($#list) .")...");
530 next if (/^\Q$factoid\E$/i);
532 &status(" Redirecting '$_'.");
533 my $was = &getFactoid($_);
534 if ($was =~ /<REPLY> see/i) {
535 &status("warn: not redirecting a redirection.");
539 &DEBUG(" was '$was'.");
541 &setFactInfo($x, "factoid_value", "<REPLY> see $factoid");
545 &msg($who, &formListReply(0, "'$factoid' is redirected to by '", @redir));
551 if ($message =~ /^rot([0-9]*)(\s+(.*))?/i) {
554 if (!defined $reply) {
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/;";
564 #$reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
565 &performStrictReply($reply);
571 if ($message =~ /^cpustats$/i) {
572 if ($^O !~ /linux/) {
573 &ERROR("cpustats: your OS is not supported yet.");
577 ### poor method to get info out of file, please fix.
578 open(STAT,"/proc/$$/stat");
581 my @data = split(/ /, $line);
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;
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);
605 $perc = sprintf("%.03f", $raw_perc);
606 $perc2 = sprintf("%.03f", $raw_perc2);
607 $total = sprintf("%.03f", $raw_perc+$raw_perc2);
609 $ratio = sprintf("%.01f", 100*$perc/($perc+$perc2) );
611 &performStrictReply("Total CPU usage: \002$cpu_usage\002 s ... ".
612 "Total used: \002$total\002 % ".
613 "(parent/child ratio: $ratio %)"
620 if ($message =~ /^ircstats?$/i) {
621 $ircstats{'TotalTime'} ||= 0;
622 $ircstats{'OffTime'} ||= 0;
624 my $count = $ircstats{'ConnectCount'};
625 my $format_time = &Time2String(time() - $ircstats{'ConnectTime'});
626 my $total_time = time() - $ircstats{'ConnectTime'} +
627 $ircstats{'TotalTime'};
630 my $connectivity = 100 * ($total_time - $ircstats{'OffTime'}) /
632 my $p = sprintf("%.03f", $connectivity);
633 $p =~ s/(\.\d*)0+$/$1/;
634 if ($p =~ s/\.0$//) {
635 # this should not happen... but why...
640 if ($total_time != (time() - $ircstats{'ConnectTime'}) ) {
641 my $tt_format = &Time2String($total_time);
642 &DEBUG("tt_format => $tt_format");
646 if ($count == 1) { # good.
647 $reply = "I'm connected to $ircstats{'Server'} and have been so".
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 %";
657 my $reason = $ircstats{'DisconnectReason'};
658 if (defined $reason) {
659 $reply .= ". I was last disconnected for '$reason'.";
662 &performStrictReply($reply);
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');
674 foreach (keys %forked) {
675 $forks += scalar keys %{ $forked{$_} };
678 $count{'Commands'} = 0;
679 foreach (keys %cmdstats) {
680 $count{'Commands'} += $cmdstats{$_};
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"
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();
713 if ($mynick eq $wantnick) {
714 &msg($who, "I hope you're right. I'll try anyway (mynick=$mynick, wantnick=$wantnick).");
717 # fallback check, I guess. needed?
718 if (! &IsNickInAnyChan( $wantnick ) ) {
719 my $str = "attempting to change nick from $mynick to $wantnick";
726 # idea from dondelecarlo :)
727 # TODO: use cache{nickserv}
728 if ($param{'nickServ_pass'}) {
729 my $str = "someone is using nick $wantnick; GHOSTing";
732 &msg('NickServ', "GHOST $wantnick $param{'nickServ_pass'}");
734 $conn->schedule(5, sub {
735 &status("going to change nick from $mynick to $wantnick after GHOST.");