From 8addf484a5b78fe043ac663129be6c05e075f260 Mon Sep 17 00:00:00 2001 From: dondelelcaro Date: Sat, 26 Apr 2008 08:14:57 +0000 Subject: [PATCH] * Merge back with trunk to r1810 git-svn-id: https://svn.code.sf.net/p/infobot/code/branches/don/dpkg@1812 c11ca15a-4712-0410-83d8-924469b57eb5 --- BUGS | 4 + ChangeLog | 39 + VERSION | 2 +- files/infobot.help | 200 ++- files/sample/infobot.chan | 2 + infobot | 87 +- patches/Google.pm | 335 ---- patches/Net_IRC_Connection_pm.patch | 32 - patches/WWW..Search.patch | 444 ----- patches/WWW..Search.patch.old | 31 - patches/WWW_Search.patch | 444 ----- patches/WWW_Search.patch.old | 31 - scripts/backup_table-slave.pl | 95 +- scripts/dbm2mysql.pl | 32 +- scripts/dbm2txt.pl | 12 +- scripts/findparam.pl | 78 +- scripts/fixbadchars.pl | 60 +- scripts/insertDB.pl | 14 +- scripts/irclog2html.pl | 477 ++--- scripts/makepasswd | 4 +- scripts/mysql2txt.pl | 14 +- scripts/oreilly_dumpvar.pl | 36 +- scripts/oreilly_prettyp.pl | 104 +- scripts/parse_warn.pl | 116 +- scripts/showvars.pl | 134 +- scripts/symname.pl | 168 +- scripts/txt2mysql.pl | 57 +- scripts/vartree.pl | 80 +- scripts/webbackup.pl | 91 +- setup/setup.pl | 82 +- src/CLI/Support.pl | 86 +- src/CommandStubs.pl | 1049 +++++------ src/DynaConfig.pl | 1115 ++++++------ src/Factoids/Core.pl | 1028 ++++++----- src/Factoids/DBCommon.pl | 104 +- src/Factoids/Norm.pl | 151 +- src/Factoids/Question.pl | 448 ++--- src/Factoids/Reply.pl | 494 +++--- src/Factoids/Statement.pl | 152 +- src/Factoids/Update.pl | 416 +++-- src/Files.pl | 79 +- src/IRC/Irc.pl | 1128 ++++++------ src/IRC/IrcHelpers.pl | 493 +++--- src/IRC/IrcHooks.pl | 1522 ++++++++-------- src/IRC/Schedulers.pl | 1445 ++++++++------- src/Misc.pl | 726 ++++---- src/Modules/BZFlag.pl | 698 ++++---- src/Modules/Debian.pl | 1552 ++++++++-------- src/Modules/DebianBugs.pm | 205 ++- src/Modules/DebianExtra.pl | 217 ++- src/Modules/Dict.pl | 283 +-- src/Modules/DumpVars.pl | 165 +- src/Modules/DumpVars2.pl | 49 +- src/Modules/Exchange.pl | 683 +++---- src/Modules/Factoids.pl | 1446 +++++++-------- src/Modules/HTTPDtype.pl | 24 +- src/Modules/Kernel.pl | 95 +- src/Modules/Math.pl | 187 +- src/Modules/News.pl | 1468 ++++++++-------- src/Modules/OnJoin.pl | 227 +-- src/Modules/Plug.pl | 63 +- src/Modules/Quote.pl | 38 +- src/Modules/RSSFeeds.pl | 219 +-- src/Modules/RootWarn.pl | 146 +- src/Modules/Rss.pl | 14 +- src/Modules/Search.pl | 31 +- src/Modules/Topic.pl | 583 +++--- src/Modules/Units.pl | 33 +- src/Modules/Uptime.pl | 116 +- src/Modules/UserDCC.pl | 2538 ++++++++++++++------------- src/Modules/UserInfo.pl | 221 +-- src/Modules/W3Search.pl | 59 +- src/Modules/Weather.pl | 196 ++- src/Modules/Wingate.pl | 102 +- src/Modules/Zippy.pl | 14 +- src/Modules/babelfish.pl | 188 +- src/Modules/botmail.pl | 138 +- src/Modules/case.pl | 9 +- src/Modules/countdown.pl | 160 +- src/Modules/dice.pl | 53 +- src/Modules/dns.pl | 51 +- src/Modules/hex2ip.pl | 11 +- src/Modules/insult.pl | 26 +- src/Modules/md5.pl | 4 +- src/Modules/nickometer.pl | 408 ++--- src/Modules/pager.pl | 153 +- src/Modules/piglatin.pl | 65 +- src/Modules/reverse.pl | 4 +- src/Modules/scramble.pl | 83 +- src/Modules/slashdot.pl | 64 +- src/Modules/spell.pl | 118 +- src/Modules/upsidedown.pl | 158 ++ src/Modules/wikipedia.pl | 386 ++-- src/Modules/wtf.pl | 57 +- src/Modules/zfi.pl | 99 +- src/Modules/zsi.pl | 99 +- src/Net.pl | 258 +-- src/Process.pl | 561 +++--- src/Shm.pl | 371 ++-- src/UserExtra.pl | 1109 ++++++------ src/core.pl | 698 ++++---- src/dbi.pl | 827 +++++---- src/logger.pl | 544 +++--- src/modules.pl | 386 ++-- 104 files changed, 16581 insertions(+), 15920 deletions(-) delete mode 100644 patches/Google.pm delete mode 100644 patches/Net_IRC_Connection_pm.patch delete mode 100644 patches/WWW..Search.patch delete mode 100644 patches/WWW..Search.patch.old delete mode 100644 patches/WWW_Search.patch delete mode 100644 patches/WWW_Search.patch.old create mode 100644 src/Modules/upsidedown.pl diff --git a/BUGS b/BUGS index 48d079c..79763d4 100644 --- a/BUGS +++ b/BUGS @@ -17,4 +17,8 @@ Known bugs that should be dealt with soon as possible: * Bot can be flooded offline with a crash if !+factstats help and /msg nick factstats help, are used at the same time + * Wildcards in --HOSTS section has problems. + eg: nick!*@foo.*.someisp.com doesnt recognize for removing factoids but: + nick!foobar@*.someisp.com does + # vim:ts=4:sw=4:expandtab:tw=80 diff --git a/ChangeLog b/ChangeLog index e69de29..4864c93 100644 --- a/ChangeLog +++ b/ChangeLog @@ -0,0 +1,39 @@ +1.5.2 +===== + +* Correction to factoid updates to treat appending as a modification + +* Code formatting cleanups + +* Removed unmaintained patches directory + +* Changed +chan to chanadd + +* Changed -chan to chandel + +* Changed +ban to banadd + +* Changed -ban to bandel + +* Changed +host to hostadd + +* Changed -host to hostdel + +* Changed adduser to useradd + +* Changed deluser to userdel + +1.5.1 +===== + +* Fixed bug in factoid modification code that prevented matching against +created_by properly + +* New +M flag to allow modifying factoids created by same nick + +1.5.0 +===== + +* Rebranding from blootbot + +# vim:ts=4:sw=4:expandtab:tw=80 diff --git a/VERSION b/VERSION index bc80560..4cda8f1 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -1.5.0 +1.5.2 diff --git a/files/infobot.help b/files/infobot.help index c0370ee..5b3853c 100644 --- a/files/infobot.help +++ b/files/infobot.help @@ -2,76 +2,32 @@ # Author: Tim Riker ### +# Special entry main: I learn mainly by observing declarative statements such as "x is at http://www.xxx.com", and then reply when people ask things like "where can i find x?" action: This is used to override the usual response. "x is does the hokey-pokey". When asked about x, the bot does this "* infobot does the hokey-pokey" +addressing: It is a good idea if I stay in REQUIRE mode so that I won't yell out random crap if I listen in too hard. Currently there is no way to turn this off on-the-fly. (REQUIRE mode requires me to be addressed by name if I am to respond) + alternation: The || symbol in an entry causes an infobot to choose one of the replies at random. "X is Y||Z" will produce "X is Y" or "X is Z" randomly. author: oznoid (mailto:lenzo@ri.cmu.edu) is my original author. -dollar variables: D: To be used in factoids -dollar variables: $Fdunno - ... -dollar variables: $Fquestion - ... -dollar variables: $Fupdate - ... -dollar variables: $channel - channel from which the factoid was requested -dollar variables: $date - current date (GMT) -dollar variables: $day - day of week (full name, locale) -dollar variables: $factoids - factoid count -dollar variables: $host - hostname of factoid requester -dollar variables: $ident - bot nick -dollar variables: $lastspeaker - ... -dollar variables: $memusage - ... -dollar variables: $rand - random number, also $rand100.2 -dollar variables: $randnick - random nick -dollar variables: $startTime - start time -dollar variables: $time - current time (GMT) -dollar variables: $uptime - ... -dollar variables: $user - username of factoid requester -dollar variables: $who - nick of factoid requester - -corrections: If I come back with "...but x is at http://xx.xx.xx" or something like that, and you want to change the entry, use "no, x is at http://sdfsdfsdf". The "No," tells me to supercede the existing value. -corrections: you can append stuff to a factoid with "also". "x is also at ..." - -math: D: math expresions can be evaluated. This uses Perl syntax. -math: E: 1+1 -math: + - add -math: - - subtract -math: * - multiply -math: / - division -math: ** - to the power -math: pi - pi -math: & - and -math: | = or -math: ^ - xor - -redirection: If a factoid x contains simply " see y", then when asked for x, I will deliver factoidor command result y instead. - -reply: There is a special tag, , that is used to override the usual response. Usually, a response is "X is Y", but it can be made "Y" by making the entry "X is Y". - -# now the commands... - -adduser: D: Administrative command to add new user to the .users file -adduser: U: ## -adduser: E: ## bloot bloot!bloot@example.com - -addressing: It is a good idea if I stay in REQUIRE mode so that I won't yell out random crap if I listen in too hard. Currently there is no way to turn this off on-the-fly. (REQUIRE mode requires me to be addressed by name if I am to respond) - babelfish: D: Frontend to babelfish translating service provided by http://babelfish.altavista.com/ Note that utf8 is used for non-ascii characters. babelfish: U: x babelfish: U: translate babelfish: E: x en de your cars rock --ban: D: FIXME: --ban: U: ## --ban: E: ## *!*@owns.org --ban: E: ## MoronMan +bandel: D: FIXME: +bandel: U: ## +bandel: E: ## *!*@owns.org +bandel: E: ## MoronMan -+ban: D: FIXME: -+ban: U: ## [chan] [time] [reason] -+ban: E: ## *!*@owns.org #bots 60 stop flooding. -+ban: E: ## *!*@*microsoft.com STOOPID -+ban: E: ## MoronMan +banadd: D: FIXME: +banadd: U: ## [chan] [time] [reason] +banadd: E: ## *!*@owns.org #bots 60 stop flooding. +banadd: E: ## *!*@*microsoft.com STOOPID +banadd: E: ## MoronMan botmail: D: Send someone botmail botmail: U: ## {for [:] }|stats|check|read @@ -80,13 +36,13 @@ botmail: E: ## stats botmail: E: ## check botmail: E: ## read --chan: D: Leave a channel permanently --chan: U: ## -#channel --chan: E: ## -#botpark +chanadd: D: Join a channel permanently +chanadd: U: ## #channel +chanadd: E: ## #botpark -+chan: D: Join a channel permanently -+chan: U: ## #channel -+chan: E: ## #botpark +chandel: D: Leave a channel permanently +chandel: U: ## -#channel +chandel: E: ## -#botpark chaninfo: D: Display channel statistics on Op, Ban, Deop, Unban, Part, Join, SignOff, PublicMsg, Kick and Topic chaninfo: U: ## [#channel] @@ -129,6 +85,9 @@ contents: E: ## x11amp potato cookie: I can feed your appetite with random factoids. +corrections: If I come back with "...but x is at http://xx.xx.xx" or something like that, and you want to change the entry, use "no, x is at http://sdfsdfsdf". The "No," tells me to supercede the existing value. +corrections: you can append stuff to a factoid with "also". "x is also at ..." + cpustats: cpustats dumps the bot's cpu usage this session crypt: It's good that you thought about encryption. I can do it for you. @@ -149,10 +108,6 @@ dauthor: E: ## Wichert potato dbugs: D: Show the current count of release critical bugs (latest versions) dbugs: U: ## -deluser: D: Administrative command to remove a user from the .users file -deluser: U: ## -deluser: E: ## bloot - ddesc: D: Search the Description: lines in Debian packages ddesc: U: ## [dist] ddesc: E: ## mule @@ -176,6 +131,26 @@ dns: E: ## 3.1.33.7 do: D: operator command to do things in a channel do: U: ## +dollar variables: D: To be used in factoids +dollar variables: $Fdunno - ... +dollar variables: $Fquestion - ... +dollar variables: $Fupdate - ... +dollar variables: $channel - channel from which the factoid was requested +dollar variables: $date - current date (GMT) +dollar variables: $day - day of week (full name, locale) +dollar variables: $factoids - factoid count +dollar variables: $host - hostname of factoid requester +dollar variables: $ident - bot nick +dollar variables: $lastspeaker - ... +dollar variables: $memusage - ... +dollar variables: $rand - random number, also $rand100.2 +dollar variables: $randnick - random nick +dollar variables: $startTime - start time +dollar variables: $time - current time (GMT) +dollar variables: $uptime - ... +dollar variables: $user - username of factoid requester +dollar variables: $who - nick of factoid requester + dstats: D: Show basic stats on the current size of the Debian distros dstats: U: ## [dist] dstats: E: ## @@ -208,6 +183,22 @@ factstats: == unrequest -- unrequested factoids. factstats: == vandalism -- ?? factstats: E: ## new +flags: D: Flags for chattr command +flags: D: "A" - bot administration over /msg (default is only via DCC CHAT) +flags: D: "O" - dynamic ops (as on channel). (automatic +o) +flags: D: "T" - add topics. +flags: D: "a" - ask/request factoid. +flags: D: "m" - modify all factoids. (includes renaming) +flags: D: "M" - modify own factoids. (includes renaming) +flags: D: "n" - bot owner, can "reload" +flags: D: "o" - master of bot (automatic +amrt) +flags: D: - can search on factoid strings shorter than 2 chars +flags: D: - can tell bot to join new channels +flags: D: - can [un]lock factoids +flags: D: "r" - remove factoid. +flags: D: "t" - teach/add factoid. +flags: D: "s" - Bypass +silent on channels + forget: If I have an old/redundant factoid x, "forget x" will cause me to erase it. freshmeat: D: Frontend to www.freshmeat.net @@ -218,6 +209,21 @@ hex: D: Convert ascii to hex hex: U: ## hex: E: ## carrot +hex2ip: D: Convert Hex idents for some gateways to an IP address +hex2ip: U: ## <8 char hex value> +hex2ip: E: ## AabBcC12 + +hostadd: D: admin command to list or add hostmasks to a user account +hostadd: U: ## [user] [] +hostadd: E: ## owner +hostadd: E: ## *!*@owns.org +hostadd: E: ## owner leet!leet@*.heh.org + +hostdel: D: admin command to remove hostmask from a user account +hostdel: U: ## [user] +hostdel: E: ## *!*@owns.org +hostdel: E: ## owner leet!leet@*.heh.org + httpdtype: D: Get httpd server software version / configuration httpdtype: U: ## httpdtype: E: ## example.com @@ -275,6 +281,18 @@ lock: E: ## abuse lock: N: By default, only registered "ops" on the bots or factoids matching the user's nick are able to lock factoids. lock: N: Requires factoid extension (extra) support enabled. +math: D: math expresions can be evaluated. This uses Perl syntax. +math: E: 1+1 +math: + - add +math: - - subtract +math: * - multiply +math: / - division +math: ** - to the power +math: pi - pi +math: & - and +math: | = or +math: ^ - xor + md5: D: calculates the md5sum of a given string md5: U: ## md5: E: ## When will infobot achieve world domination? @@ -349,10 +367,14 @@ quote: D: Frontend to yahoo's online stock market share listing quote: U: ## quote: E: ## RHAT,MSFT +redirection: If a factoid x contains simply " see y", then when asked for x, I will deliver factoidor command result y instead. + rename: D: Factoid renaming rename: U: ## 'from' 'to' rename: E: ## 'infobot' 'infobot' +reply: There is a special tag, , that is used to override the usual response. Usually, a response is "X is Y", but it can be made "Y" by making the entry "X is Y". + reverse: D: reverses a given string reverse: U: ## reverse: E: ## When will infobot achieve world domination? @@ -444,11 +466,27 @@ unlock: D: Factoid unlocking to allow removal by others. unlock: U: ## unlock: E: ## abuse +upsidedown: D: display a string in pseudo upside down unicode text +upsidedown: U: ## +upsidedown: E: ## When will infobot achieve world domination? + uptime: D: Show the current uptime, and the top 3 uptimes recorded uptime: U: ## +useradd: D: Administrative command to add new user to the .users file +useradd: U: ## +useradd: E: ## SomeAccount SomeAccount!someguy@example.com + +userdel: D: Administrative command to remove a user from the .users file +userdel: U: ## +userdel: E: ## SomeAccount + wantnick: If someone's taken my nick (I hope not) and I'm using some temporary nick, I can change back to my original nick if it's not taken (again). +whois: D: List available information for an account on the bot +whois: U: ## +whois: E: ## SomeAccount + wikipedia: D: Frontend to the Wikipedia at http://www.wikipedia.org/wiki/ Note that utf8 is used for non-ascii characters. wikipedia: U: ## wikipedia: U: wiki @@ -458,40 +496,10 @@ wtf: D: Interface to the BSD wtf command wtf: U: ## wtf: E: ## iirc --host: D: admin command to remove hostmask from a user account --host: U: ## [user] --host: E: ## *!*@owns.org --host: E: ## owner leet!leet@*.heh.org - -+host: D: admin command to list or add hostmasks to a user account -+host: U: ## [user] [] -+host: E: ## owner -+host: E: ## *!*@owns.org -+host: E: ## owner leet!leet@*.heh.org - -flags: D: Flags for chattr command -flags: D: "A" - bot administration over /msg (default is only via DCC CHAT) -flags: D: "O" - dynamic ops (as on channel). (automatic +o) -flags: D: "T" - add topics. -flags: D: "a" - ask/request factoid. -flags: D: "m" - modify factoid. (includes renaming) -flags: D: "n" - bot owner, can "reload" -flags: D: "o" - master of bot (automatic +amrt) -flags: D: - can search on factoid strings shorter than 2 chars -flags: D: - can tell bot to join new channels -flags: D: - can [un]lock factoids -flags: D: "r" - remove factoid. -flags: D: "t" - teach/add factoid. -flags: D: "s" - Bypass +silent on channels - rssfeeds: D: rssfeeds is used to control the RSS Feed tracking module rssfeeds: U: rssfeeds [command] rssfeeds: E: rssfeeds flush rssfeeds: D: flush - Will erase the cache file. (Must be chattr +o) rssfeeds: D: update - Force a manual update of the feeds. (Must be chattr +o) -hex2ip: D: Convert Hex idents for some gateways to an IP address -hex2ip: U: ## <8 char hex value> -hex2ip: E: ## AabBcC12 - # vim:ts=4:sw=4:expandtab:tw=80 diff --git a/files/sample/infobot.chan b/files/sample/infobot.chan index c721138..adb5dc1 100644 --- a/files/sample/infobot.chan +++ b/files/sample/infobot.chan @@ -99,6 +99,8 @@ _default +slashdot +spell +tell + +upsidedown + +wikipedia +wtf +zfi +zsi diff --git a/infobot b/infobot index f20af53..7fc8989 100755 --- a/infobot +++ b/infobot @@ -7,27 +7,28 @@ use strict; use vars qw($bot_base_dir $bot_src_dir $bot_misc_dir $bot_state_dir - $bot_data_dir $bot_config_dir $bot_log_dir $bot_run_dir - $bot_pid $memusage %param + $bot_data_dir $bot_config_dir $bot_log_dir $bot_run_dir + $bot_pid $memusage %param ); BEGIN { - if (@ARGV and -f $ARGV[0]) { - # source passed config to allow $bot_*_dir to be set. - do $ARGV[0]; + if ( @ARGV and -f $ARGV[0] ) { + + # source passed config to allow $bot_*_dir to be set. + do $ARGV[0]; } # set any $bot_*_dir var's that aren't already set - $bot_base_dir ||= '.'; - $bot_config_dir ||= 'files/'; - $bot_data_dir ||= 'files/'; - $bot_state_dir ||= 'files/'; - $bot_run_dir ||= '.'; - $bot_src_dir ||= "$bot_base_dir/src"; - $bot_log_dir ||= "$bot_base_dir/log"; - $bot_misc_dir ||= "$bot_base_dir/files"; + $bot_base_dir ||= '.'; + $bot_config_dir ||= 'files/'; + $bot_data_dir ||= 'files/'; + $bot_state_dir ||= 'files/'; + $bot_run_dir ||= '.'; + $bot_src_dir ||= "$bot_base_dir/src"; + $bot_log_dir ||= "$bot_base_dir/log"; + $bot_misc_dir ||= "$bot_base_dir/files"; - $bot_pid = $$; + $bot_pid = $$; require "$bot_src_dir/logger.pl"; require "$bot_src_dir/core.pl"; @@ -36,7 +37,7 @@ BEGIN { # load the configuration (params) file. &setupConfig(); - &showProc(); # to get the first value. + &showProc(); # to get the first value. &status("Initial memory usage: $memusage kB"); &loadCoreModules(); &loadDBModules(); @@ -50,17 +51,19 @@ BEGIN { &duperuncheck(); # initialize everything -&startup(); # first time initialization. +&startup(); # first time initialization. &setup(); -if (!&IsParam("Interface") or $param{'Interface'} =~ /IRC/) { +if ( !&IsParam("Interface") or $param{'Interface'} =~ /IRC/ ) { + # launch the irc event loop &ircloop(); -} else { +} +else { &cliloop(); } -exit 0; # just so you don't look farther down in this file :) +exit 0; # just so you don't look farther down in this file :) # --- support routines @@ -68,30 +71,32 @@ exit 0; # just so you don't look farther down in this file :) # added by the xk sub duperuncheck { - my $pid = $$; - my $file = $file{PID}; - - if ( -f $file) { - open(PIDFILE,$file) or die "error: cannot open $file."; - my $thispid = || "NULL\n"; - close PIDFILE; - chop $thispid; - - if ($thispid =~ /^\D$/) { - &staus("warning: pidfile is invalid; wiping out."); - } else { - if ( -d "/proc/$thispid/") { - &ERROR("bot is already running from this directory."); - &ERROR("if this is incorrect, erase '*.pid'."); - &ERROR("verify with 'ps -axu | grep $thispid'."); - exit 1; - } else { - &status("warning: stale $file found; wiping."); - } - } + my $pid = $$; + my $file = $file{PID}; + + if ( -f $file ) { + open( PIDFILE, $file ) or die "error: cannot open $file."; + my $thispid = || "NULL\n"; + close PIDFILE; + chop $thispid; + + if ( $thispid =~ /^\D$/ ) { + &staus("warning: pidfile is invalid; wiping out."); + } + else { + if ( -d "/proc/$thispid/" ) { + &ERROR("bot is already running from this directory."); + &ERROR("if this is incorrect, erase '*.pid'."); + &ERROR("verify with 'ps -axu | grep $thispid'."); + exit 1; + } + else { + &status("warning: stale $file found; wiping."); + } + } } - open(PIDFILE,">$file") or die "error: cannot write to $file."; + open( PIDFILE, ">$file" ) or die "error: cannot write to $file."; print PIDFILE "$pid\n"; close PIDFILE; diff --git a/patches/Google.pm b/patches/Google.pm deleted file mode 100644 index 04f586e..0000000 --- a/patches/Google.pm +++ /dev/null @@ -1,335 +0,0 @@ -########################################################## -# Google.pm -# by Jim Smyser -# Copyright (C) 1996-1999 by Jim Smyser & USC/ISI -# $Id: Google.pm,v 2.20 2000/07/09 14:29:22 jims Exp $ -########################################################## - - -package WWW::Search::Google; - - -=head1 NAME - -WWW::Search::Google - class for searching Google - - -=head1 SYNOPSIS - -use WWW::Search; -my $Search = new WWW::Search('Google'); # cAsE matters -my $Query = WWW::Search::escape_query("Where is Jimbo"); -$Search->native_query($Query); -while (my $Result = $Search->next_result()) { -print $Result->url, "\n"; -} - -=head1 DESCRIPTION - -This class is a Google specialization of WWW::Search. -It handles making and interpreting Google searches. -F. - -This class exports no public interface; all interaction should -be done through L objects. - -=head1 LINUX SEARCH - -For LINUX lovers like me, you can put Googles in a LINUX only search -mode by changing search URL from: - - 'search_url' => 'http://www.google.com/search', - -to: - - 'search_url' => 'http://www.google.com/linux', - -=head1 SEE ALSO - -To make new back-ends, see L. - -=head1 HOW DOES IT WORK? - -C is called (from C) -before we do anything. It initializes our private variables (which -all begin with underscore) and sets up a URL to the first results -page in C<{_next_url}>. - -C is called (from C) -whenever more hits are needed. It calls C -to fetch the page specified by C<{_next_url}>. -It then parses this page, appending any search hits it finds to -C<{cache}>. If it finds a ``next'' button in the text, -it sets C<{_next_url}> to point to the page for the next -set of results, otherwise it sets it to undef to indicate we''re done. - - -=head1 TESTING - -This module adheres to the C test suite mechanism. - -=head1 AUTHOR - -This backend is written and maintained/supported by Jim Smyser. - - -=head1 BUGS - -Google is not an easy search engine to parse in that it is capable -of altering it's output ever so slightly on different search terms. -There may be new slight results output the author has not yet seen that -will pop at any given time for certain searches. So, if you think you see -a bug keep the above in mind and send me the search words you used so I -may code for any new variations. - -=head1 CHANGES - -2.21.1 -Parsing update from Tim Riker - -2.21 -Minor code correction for empty returned titles - -2.20 -Forgot to add new next url regex in 2.19! - -2.19 -Regex work on some search results url's that has changed. Number found -return should be right now. - -2.17 -Insert url as a title when no title is found. - -2.13 -New regexp to parse newly found results format with certain search terms. - -2.10 -removed warning on absence of description; new test case - -2.09 -Google NOW returning url and title on one line. - -2.07 -Added a new parsing routine for yet another found result line. -Added a substitute for whacky url links some queries can produce. -Added Kingpin's new hash_to_cgi_string() 10/12/99 - -2.06 -Fixed missing links / regexp crap. - -2.05 -Matching overhaul to get the code parsing right due to multiple -tags being used by google on the hit lines. 9/25/99 - -2.02 -Last Minute description changes 7/13/99 - -2.01 -New test mechanism 7/13/99 - -1.00 -First release 7/11/99 - -=head1 LEGALESE - -THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - - -=cut -#' - - -##################################################################### - -require Exporter; -@EXPORT = qw(); -@EXPORT_OK = qw(); -@ISA = qw(WWW::Search Exporter); -$VERSION = '2.21.1'; - -$MAINTAINER = 'Jim Smyser '; -$TEST_CASES = <<"ENDTESTCASES"; -# Google looks for partial words it can find results for so it will end up finding "Bogus" pages. -&test('Google', '$MAINTAINER', 'zero', '4036e7757s5', \$TEST_EXACTLY); -&test('Google', '$MAINTAINER', 'one_page', '+LS'.'AM +rep'.'lication', \$TEST_RANGE, 2,99); -&test('Google', '$MAINTAINER', 'multi', 'dir'.'ty ha'.'rr'.'y bimbo', \$TEST_GREATER_THAN, 101); -ENDTESTCASES - -use Carp (); -use WWW::Search(qw(generic_option strip_tags)); -require WWW::SearchResult; - - -sub undef_to_emptystring { -return defined($_[0]) ? $_[0] : ""; -} -# private -sub native_setup_search - { - my($self, $native_query, $native_options_ref) = @_; - $self->user_agent('user'); - $self->{_next_to_retrieve} = 0; - $self->{'_num_hits'} = 100; - if (!defined($self->{_options})) { - $self->{_options} = { - 'search_url' => 'http://www.google.com/search', - 'num' => $self->{'_num_hits'}, - }; - }; - my($options_ref) = $self->{_options}; - if (defined($native_options_ref)) { - # Copy in new options. - foreach (keys %$native_options_ref) { - $options_ref->{$_} = $native_options_ref->{$_}; - }; - }; - # Process the options. - my($options) = ''; - foreach (keys %$options_ref) { - # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n"; - next if (generic_option($_)); - $options .= $_ . '=' . $options_ref->{$_} . '&'; - }; - $self->{_debug} = $options_ref->{'search_debug'}; - $self->{_debug} = 2 if ($options_ref->{'search_parse_debug'}); - $self->{_debug} = 0 if (!defined($self->{_debug})); - - # Finally figure out the url. - $self->{_base_url} = - $self->{_next_url} = - $self->{_options}{'search_url'} . - "?" . $options . - "q=" . $native_query; - } - -# private -sub begin_new_hit { - my($self) = shift; - my($old_hit) = shift; - my($old_raw) = shift; - if (defined($old_hit)) { - $old_hit->raw($old_raw) if (defined($old_raw)); - push(@{$self->{cache}}, $old_hit); - }; - return (new WWW::SearchResult, ''); - } -sub native_retrieve_some { - my ($self) = @_; - # fast exit if already done - return undef if (!defined($self->{_next_url})); - # get some - print STDERR "Fetching " . $self->{_next_url} . "\n" if ($self->{_debug}); - my($response) = $self->http_request('GET', $self->{_next_url}); - $self->{response} = $response; - if (!$response->is_success) { - return undef; - }; - - # parse the output - my($HEADER, $HITS, $TRAILER, $POST_NEXT) = (1..10); - my($hits_found) = 0; - my($state) = ($HEADER); - my($hit) = undef; - my($raw) = ''; - foreach ($self->split_lines($response->content())) { - next if m@^$@; # short circuit for blank lines - - if ($state == $HEADER && m/about ([\d,]+)<\/b>/) - { - my($n) = $1; - $self->approximate_result_count($n); - print STDERR "Found Total: $n\n" ; - $state = $HITS; - } - if ($state == $HITS && - m|

]*)\>(.*?)|i) { - my ($url, $title) = ($1,$2); - ($hit, $raw) = $self->begin_new_hit($hit, $raw); - print STDERR "**Found HIT0 Line** $url - $title\n" if ($self->{_debug}); - $raw .= $_; - $url =~ s/(>.*)//g; - $hit->add_url(strip_tags($url)); - $hits_found++; - $title = "No Title" if ($title =~ /^\s+/); - $hit->title(strip_tags($title)); - $state = $HITS; - } - elsif ($state == $HITS && - m|(.*?)
<.*?>|i) { - my ($url, $title) = ($1,$2); - ($hit, $raw) = $self->begin_new_hit($hit, $raw); - print STDERR "**Found HIT1 Line**\n" if ($self->{_debug}); - $raw .= $_; - $url =~ s/(>.*)//g; - $hit->add_url(strip_tags($url)); - $hits_found++; - $title = "No Title" if ($title =~ /^\s+/); - $hit->title(strip_tags($title)); - $state = $HITS; - } - elsif ($state == $HITS && - m@^

(.*)
(.*)@i || - m@^

(.*).*?
(.*)@i) - { - ($hit, $raw) = $self->begin_new_hit($hit, $raw); - print STDERR "**Found HIT2 Line**\n" if ($self->{_debug}); - my ($url, $title) = ($1,$2); - $mDesc = $3; - $url =~ s/\/url\?sa=\w&start=\d+&q=//g; - $url =~ s/&(.*)//g; - $url =~ s/(>.*)//g; - $raw .= $_; - $hit->add_url(strip_tags($url)); - $hits_found++; - $title = "No Title" if ($title =~ /^\s+/); - $hit->title(strip_tags($title)); - $mDesc =~ s/<.*?>//g; - $mDesc = $mDesc . '
' if not $mDesc =~ m@
@; - $hit->description($mDesc) if (defined($hit)); - $state = $HITS; - } - elsif ($state == $HITS && m@^(\.\.(.+))@i) - { - print STDERR "**Parsing Description Line**\n" if ($self->{_debug}); - $raw .= $_; - $sDesc = $1; - $sDesc ||= ''; - $sDesc =~ s/<.*?>//g; - $sDesc = $mDesc . $sDesc; - $hit->description($sDesc) if $sDesc =~ m@^\.@; - $sDesc = ''; - $state = $HITS; - } - elsif ($state == $HITS && m@

@i) - { - ($hit, $raw) = $self->begin_new_hit($hit, $raw); - print STDERR "**Found Last Line**\n" if ($self->{_debug}); - # end of hits - $state = $TRAILER; - } - elsif ($state == $TRAILER && - m|.*?|i) - { - my($relative_url) = $1; - print STDERR "**Fetching >>Next<< Page**\n" if ($self->{_debug}); - $self->{_next_url} = 'http://www.google.com' . $relative_url; - $state = $POST_NEXT; - } else { - }; - }; - if ($state != $POST_NEXT) { - # No "Next" Tag - $self->{_next_url} = undef; - if ($state == $HITS) { - $self->begin_new_hit($hit, $raw); - }; - $self->{_next_url} = undef; - }; - # ZZZzzzzZZZZzzzzzzZZZZZZzzz - $self->user_agent_delay if (defined($self->{_next_url})); - return $hits_found; - } -1; - diff --git a/patches/Net_IRC_Connection_pm.patch b/patches/Net_IRC_Connection_pm.patch deleted file mode 100644 index 400a1f8..0000000 --- a/patches/Net_IRC_Connection_pm.patch +++ /dev/null @@ -1,32 +0,0 @@ ---- Connection.pm.orig Fri Nov 1 00:20:36 2002 -+++ Connection.pm Sat Nov 2 18:00:42 2002 -@@ -1300,14 +1300,13 @@ - # the line from the server. - sub parse_ctcp { - my ($self, $type, $from, $stuff, $line) = @_; -- - my ($one, $two); - my ($odd, @foo) = (&dequote($line)); - - while (($one, $two) = (splice @foo, 0, 2)) { - - ($one, $two) = ($two, $one) if $odd; -- -+ - my ($ctype) = $one =~ /^(\w+)\b/; - my $prefix = undef; - if ($type eq 'notice') { -@@ -1326,10 +1325,10 @@ - # -- #perl was here! -- - # fimmtiu: Words cannot describe my joy. Sil, you kick ass. - # fimmtiu: I was passing the wrong arg to Event::new() -- -- $one =~ s/^$ctype //i; # strip the CTCP type off the args -+ -+ # this is what it used to be in version 0.63 or so. - $self->handler(Net::IRC::Event->new( $handler, $from, $stuff, -- $handler, $one )); -+ $handler, (split /\s/, $one))); - } - - $self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two)) diff --git a/patches/WWW..Search.patch b/patches/WWW..Search.patch deleted file mode 100644 index a276101..0000000 --- a/patches/WWW..Search.patch +++ /dev/null @@ -1,444 +0,0 @@ ---- Google.pm.orig Wed May 24 16:55:47 2000 -+++ Google.pm Wed Jan 16 22:02:53 2002 -@@ -2,7 +2,7 @@ - # Google.pm - # by Jim Smyser - # Copyright (C) 1996-1999 by Jim Smyser & USC/ISI --# $Id$ -+# $Id$ - ########################################################## - - -@@ -30,8 +30,6 @@ - It handles making and interpreting Google searches. - F. - --Googles returns 100 Hits per page. Custom Linux Only search capable. -- - This class exports no public interface; all interaction should - be done through L objects. - -@@ -70,33 +68,41 @@ - - This module adheres to the C test suite mechanism. - --=head1 BUGS -- --2.07 now parses for most of what Google produces, but not all. --Because Google does not produce universial formatting for all --results it produces, there are undoublty a few line formats yet --uncovered by the author. Different search terms creates various --differing format out puts for each line of results. Example, --searching for "visual basic" will create whacky url links, --whereas searching for "Visual C++" does not. It is a parsing --nitemare really! If you think you uncovered a BUG just remember --the above comments! -- --With the above said, this back-end will produce proper formated --results for 96+% of what it is asked to produce. Your milage --will vary. -- - =head1 AUTHOR - --This backend is maintained and supported by Jim Smyser. -+This backend is written and maintained/supported by Jim Smyser. - - - =head1 BUGS - --2.09 seems now to parse all hits with the new format change so there really shouldn't be --any like there were with 2.08. -+Google is not an easy search engine to parse in that it is capable -+of altering it's output ever so slightly on different search terms. -+There may be new slight results output the author has not yet seen that -+will pop at any given time for certain searches. So, if you think you see -+a bug keep the above in mind and send me the search words you used so I -+may code for any new variations. -+ -+=head1 CHANGES -+ -+2.22 -+Fixed up changed format from google -+reformatted code -+ -+2.21 -+Minor code correction for empty returned titles -+ -+2.20 -+Forgot to add new next url regex in 2.19! -+ -+2.19 -+Regex work on some search results url's that has changed. Number found -+return should be right now. -+ -+2.17 -+Insert url as a title when no title is found. - --=head1 VERSION HISTORY -+2.13 -+New regexp to parse newly found results format with certain search terms. - - 2.10 - removed warning on absence of description; new test case -@@ -131,15 +137,18 @@ - WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - -+ - =cut - #' -- -+ -+ - ##################################################################### -+ - require Exporter; - @EXPORT = qw(); - @EXPORT_OK = qw(); - @ISA = qw(WWW::Search Exporter); --$VERSION = '2.10'; -+$VERSION = '2.22'; - - $MAINTAINER = 'Jim Smyser '; - $TEST_CASES = <<"ENDTESTCASES"; -@@ -148,160 +157,187 @@ - &test('Google', '$MAINTAINER', 'one_page', '+LS'.'AM +rep'.'lication', \$TEST_RANGE, 2,99); - &test('Google', '$MAINTAINER', 'multi', 'dir'.'ty ha'.'rr'.'y bimbo', \$TEST_GREATER_THAN, 101); - ENDTESTCASES -- -+ - use Carp (); --use WWW::Search(generic_option); -+use WWW::Search(qw(generic_option strip_tags)); - require WWW::SearchResult; -- -+ -+ -+sub undef_to_emptystring { -+return defined($_[0]) ? $_[0] : ""; -+} -+# private - sub native_setup_search { -- my($self, $native_query, $native_options_ref) = @_; -- $self->{_debug} = $native_options_ref->{'search_debug'}; -- $self->{_debug} = 2 if ($native_options_ref->{'search_parse_debug'}); -- $self->{_debug} = 0 if (!defined($self->{_debug})); -- $self->{agent_e_mail} = 'jsmyser@bigfoot.com'; -- $self->user_agent('user'); -- $self->{_next_to_retrieve} = 1; -- $self->{'_num_hits'} = 0; -- if (!defined($self->{_options})) { -- $self->{'search_base_url'} = 'http://www.google.com'; -- $self->{_options} = { -- 'search_url' => 'http://www.google.com/search', -- 'num' => '100', -- 'q' => $native_query, -- }; -- } -- my $options_ref = $self->{_options}; -- if (defined($native_options_ref)) -- { -- # Copy in new options. -- foreach (keys %$native_options_ref) -- { -- $options_ref->{$_} = $native_options_ref->{$_}; -- } # foreach -- } # if -- # Process the options. -- my($options) = ''; -- foreach (sort keys %$options_ref) -- { -- # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n"; -- next if (generic_option($_)); -- $options .= $_ . '=' . $options_ref->{$_} . '&'; -- } -- chop $options; -- # Finally figure out the url. -- $self->{_next_url} = $self->{_options}{'search_url'} .'?'. $self->hash_to_cgi_string($self->{_options}); -- } # native_setup_search -- -+ my($self, $native_query, $native_options_ref) = @_; -+ $self->user_agent('user'); -+ $self->{_next_to_retrieve} = 0; -+ $self->{'_num_hits'} = 100; -+ -+ if (!defined $self->{_options}) { -+ $self->{_options} = { -+ 'search_url' => 'http://www.google.com/search', -+ 'num' => $self->{'_num_hits'}, -+ }; -+ } -+ -+ my($options_ref) = $self->{_options}; -+ -+ if (defined $native_options_ref) { -+ # Copy in new options. -+ foreach (keys %$native_options_ref) { -+ $options_ref->{$_} = $native_options_ref->{$_}; -+ } -+ } -+ -+ # Process the options. -+ my($options) = ''; -+ foreach (keys %$options_ref) { -+ # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n"; -+ next if (generic_option($_)); -+ $options .= $_ . '=' . $options_ref->{$_} . '&'; -+ } -+ -+ $self->{_debug} = $options_ref->{'search_debug'}; -+ $self->{_debug} = 2 if ($options_ref->{'search_parse_debug'}); -+ $self->{_debug} = 0 if (!defined $self->{_debug}); -+ -+ # Finally figure out the url. -+ $self->{_base_url} = -+ $self->{_next_url} = -+ $self->{_options}{'search_url'} . -+ "?" . $options . -+ "q=" . $native_query; -+} -+ - # private --sub native_retrieve_some -- { -- my ($self) = @_; -- print STDERR "**Google::native_retrieve_some()**\n" if $self->{_debug}; -- # Fast exit if already done: -- return undef if (!defined($self->{_next_url})); -- -- # If this is not the first page of results, sleep so as to not -- # overload the server: -- $self->user_agent_delay if 1 < $self->{'_next_to_retrieve'}; -- -- # Get some if were not already scoring somewhere else: -- print STDERR "*Sending request (",$self->{_next_url},")\n" if $self->{_debug}; -- my($response) = $self->http_request('GET', $self->{_next_url}); -- $self->{response} = $response; -- if (!$response->is_success) -- { -- return undef; -- } -- $self->{'_next_url'} = undef; -- print STDERR "**Response\n" if $self->{_debug}; -- -- # parse the output -- my ($HEADER, $START, $HITS, $NEXT) = qw(HE HI ST NX); -- my $hits_found = 0; -- my $state = $HEADER; -- my $hit = (); -- foreach ($self->split_lines($response->content())) -- { -- next if m@^$@; # short circuit for blank lines -- print STDERR " $state ===$_=== " if 2 <= $self->{'_debug'}; -- if (m|(\d+) matches|i) { -- print STDERR "**Found Header Count**\n" if ($self->{_debug}); -- $self->approximate_result_count($1); -- $state = $START; -- # set-up attempting the tricky task of -- # fetching the very first HIT line -- } -- elsif ($state eq $START && m|Search took|i) -- { -- print STDERR "**Found Start Line**\n" if ($self->{_debug}); -- $state = $HITS; -- # Attempt to pull the very first hit line -- } -- if ($state eq $HITS) { -- print "\n**state == HITS**\n" if 2 <= $self->{_debug}; -- } -- if ($state eq $HITS && m@^

(.*)$@i) -- { -- print "**Found HIT**\n" if 2 <= $self->{_debug}; -- my ($url, $title) = ($1,$2); -- if (defined($hit)) -- { -- push(@{$self->{cache}}, $hit); -- }; -- $hit = new WWW::SearchResult; -- # some queries *can* create internal junk in the url link -- # remove them! -- $url =~ s/\/url\?sa=U&start=\d+&q=//g; -- $hits_found++; -- $hit->add_url($url); -- $hit->title($title); -- $state = $HITS; -- } -- if ($state eq $HITS && m@^
(.*)@i) -- { -- print "**Found First Description**\n" if 2 <= $self->{_debug}; -- $mDesc = $1; -- if (not $mDesc =~ m@ @) -- { -- $mDesc =~ s/<.*?>//g; -- $mDesc = $mDesc . '
' if not $mDesc =~ m@
@; -- $hit->description($mDesc); -- $state = $HITS; -- } -- } -- elsif ($state eq $HITS && -- m@^(\.(.+))@i || -- m@^
(.*)\s@i) { -- print "**Found Second Description**\n" if 2 <= $self->{_debug}; -- $sDesc = $1; -- $sDesc ||= ''; -- $sDesc =~ s/<.*?>//g; -- $sDesc = $mDesc . $sDesc; -- $hit->description($sDesc); -- $sDesc =''; -- $state = $HITS; -- } -- elsif ($state eq $HITS && -- m|
<.*?>.*?|i) { -- my $nexturl = $self->{'_next_url'}; -- if (defined $nexturl) { -- print STDERR "**Fetching Next URL-> ", $nexturl, "\n" if 2 <= $self->{_debug}; -- } else { -- print STDERR "**Fetching Next URL-> UNDEF\n" if 2 <= $self->{_debug}; -- } -- -- my $iURL = $1; -- $self->{'_next_url'} = $self->{'search_base_url'} . $iURL; -- } -- else -- { -- print STDERR "**Nothing matched.**\n" if 2 <= $self->{_debug}; -- } -- } -- if (defined($hit)) -- { -- push(@{$self->{cache}}, $hit); -- } -- return $hits_found; -- } # native_retrieve_some --1; -+sub begin_new_hit { -+ my($self) = shift; -+ my($old_hit) = shift; -+ my($old_raw) = shift; -+ -+ if (defined $old_hit) { -+ $old_hit->raw($old_raw) if (defined $old_raw); -+ push(@{$self->{cache}}, $old_hit); -+ } -+ -+ return (new WWW::SearchResult, ''); -+} -+ -+sub native_retrieve_some { -+ my ($self) = @_; -+ # fast exit if already done -+ return undef if (!defined $self->{_next_url}); -+ -+ # get some -+ print STDERR "Fetching " . $self->{_next_url} . "\n" if ($self->{_debug}); -+ my($response) = $self->http_request('GET', $self->{_next_url}); -+ $self->{response} = $response; -+ -+ return undef if (!$response->is_success); -+ -+ # parse the output -+ my($HEADER, $HITS, $TRAILER, $POST_NEXT) = (1..10); -+ my($hits_found) = 0; -+ my($state) = ($HEADER); -+ my($hit) = undef; -+ my($raw) = ''; -+ -+ foreach ($self->split_lines($response->content())) { -+ next if m@^$@; # short circuit for blank lines -+ -+ if ($state == $HEADER && m/about ([\d,]+)<\/b>/) { -+ my($n) = $1; -+ $self->approximate_result_count($n); -+ print STDERR "Found Total: $n\n" if ($self->{_debug}); -+ $state = $HITS; -+ -+ } elsif ($state == $HITS && -+ m|(.*?)
<.*?>|i -+ ) { -+ -+ my ($url, $title) = ($1,$2); -+ ($hit, $raw) = $self->begin_new_hit($hit, $raw); -+ print STDERR "**Found HIT1 Line**\n" if ($self->{_debug}); -+ $raw .= $_; -+ $url =~ s/(>.*)//g; -+ $hit->add_url(strip_tags($url)); -+ $hits_found++; -+ $title = "No Title" if ($title =~ /^\s+/); -+ $hit->title(strip_tags($title)); -+ $state = $HITS; -+ -+ } elsif ($state == $HITS && -+ m@^

(.*)
(.*)@i || -+ m@^

(.*).*?(.*)@i -+ ) { -+ print STDERR "**Found HIT2 Line**\n" if ($self->{_debug}); -+ -+ ($hit, $raw) = $self->begin_new_hit($hit, $raw); -+ -+ my ($url, $title) = ($1,$2); -+ $mDesc = $3; -+ -+ $url =~ s/\/url\?sa=\w&start=\d+&q=//g; -+ $url =~ s/\?lang=(\S+)$//g; -+ $url =~ s/&(.*)//g; -+ $url =~ s/(>.*)//g; -+ $url =~ s/\/$//g; # kill trailing slash. -+ -+ $raw .= $_; -+ $hit->add_url(strip_tags($url)); -+ $hits_found++; -+ -+ $title = "No Title" if ($title =~ /^\s+/); -+ $hit->title(strip_tags($title)); -+ -+ $mDesc =~ s/<.*?>//g; -+### $mDesc = $mDesc . '
' if not $mDesc =~ m@
@; -+ $hit->description($mDesc) if (defined $hit); -+ $state = $HITS; -+ -+# description parsing -+ } elsif ($state == $HITS && m@(\.\.(.+)) @i -+ ) { -+ print STDERR "**Parsing Description Line**\n" if ($self->{_debug}); -+ $raw .= $_; -+ # uhm... -+ $sDesc = $1 || ""; -+ -+ $sDesc =~ s/<.*?>//g; -+ $mDesc ||= ""; -+ $sDesc = $mDesc . $sDesc; -+# $hit->description($sDesc) if $sDesc =~ m@^\.@; -+ $sDesc = ''; -+ $state = $HITS; -+ -+ } elsif ($state == $HITS && m@

@i -+ ) { -+ ($hit, $raw) = $self->begin_new_hit($hit, $raw); -+ print STDERR "**Found Last Line**\n" if ($self->{_debug}); -+ # end of hits -+ $state = $TRAILER; -+ -+ } elsif ($state == $TRAILER && -+ m|.*?|i -+ ) { -+ my($relative_url) = $1; -+ print STDERR "**Fetching >>Next<< Page**\n" if ($self->{_debug}); -+ $self->{_next_url} = 'http://www.google.com' . $relative_url; -+ $state = $POST_NEXT; -+ } -+ } -+ -+ if ($state != $POST_NEXT) { -+ # No "Next" Tag -+ $self->{_next_url} = undef; -+ $self->begin_new_hit($hit, $raw) if ($state == $HITS); -+ $self->{_next_url} = undef; -+ } -+ -+ # ZZZzzzzZZZZzzzzzzZZZZZZzzz -+ $self->user_agent_delay if (defined($self->{_next_url})); -+ return $hits_found; -+} -+ -+1; -+ diff --git a/patches/WWW..Search.patch.old b/patches/WWW..Search.patch.old deleted file mode 100644 index eec3ce3..0000000 --- a/patches/WWW..Search.patch.old +++ /dev/null @@ -1,31 +0,0 @@ ---- WWW/Search/Google.pm.orig Wed May 24 16:55:47 2000 -+++ WWW/Search/Google.pm Wed May 24 16:56:19 2000 -@@ -240,7 +240,7 @@ - if ($state eq $HITS) { - print "\n**state == HITS**\n" if 2 <= $self->{_debug}; - } -- if ($state eq $HITS && m@^

(.*)$@i) -+ if ($state eq $HITS && m@^

(.*)@i) - { - print "**Found HIT**\n" if 2 <= $self->{_debug}; - my ($url, $title) = ($1,$2); -@@ -252,6 +252,7 @@ - # some queries *can* create internal junk in the url link - # remove them! - $url =~ s/\/url\?sa=U&start=\d+&q=//g; -+ $url =~ s/\&exp\=OneBoxNews\s//g; # new junk. - $hits_found++; - $hit->add_url($url); - $hit->title($title); -@@ -275,9 +276,8 @@ - print "**Found Second Description**\n" if 2 <= $self->{_debug}; - $sDesc = $1; - $sDesc ||= ''; -- $sDesc =~ s/<.*?>//g; -- $sDesc = $mDesc . $sDesc; -- $hit->description($sDesc); -+ $sDesc = $mDesc . $sDesc if (defined $mDesc); -+ $hit->description($sDesc) if (defined $hit and $sDesc ne ''); - $sDesc =''; - $state = $HITS; - } diff --git a/patches/WWW_Search.patch b/patches/WWW_Search.patch deleted file mode 100644 index a276101..0000000 --- a/patches/WWW_Search.patch +++ /dev/null @@ -1,444 +0,0 @@ ---- Google.pm.orig Wed May 24 16:55:47 2000 -+++ Google.pm Wed Jan 16 22:02:53 2002 -@@ -2,7 +2,7 @@ - # Google.pm - # by Jim Smyser - # Copyright (C) 1996-1999 by Jim Smyser & USC/ISI --# $Id$ -+# $Id$ - ########################################################## - - -@@ -30,8 +30,6 @@ - It handles making and interpreting Google searches. - F. - --Googles returns 100 Hits per page. Custom Linux Only search capable. -- - This class exports no public interface; all interaction should - be done through L objects. - -@@ -70,33 +68,41 @@ - - This module adheres to the C test suite mechanism. - --=head1 BUGS -- --2.07 now parses for most of what Google produces, but not all. --Because Google does not produce universial formatting for all --results it produces, there are undoublty a few line formats yet --uncovered by the author. Different search terms creates various --differing format out puts for each line of results. Example, --searching for "visual basic" will create whacky url links, --whereas searching for "Visual C++" does not. It is a parsing --nitemare really! If you think you uncovered a BUG just remember --the above comments! -- --With the above said, this back-end will produce proper formated --results for 96+% of what it is asked to produce. Your milage --will vary. -- - =head1 AUTHOR - --This backend is maintained and supported by Jim Smyser. -+This backend is written and maintained/supported by Jim Smyser. - - - =head1 BUGS - --2.09 seems now to parse all hits with the new format change so there really shouldn't be --any like there were with 2.08. -+Google is not an easy search engine to parse in that it is capable -+of altering it's output ever so slightly on different search terms. -+There may be new slight results output the author has not yet seen that -+will pop at any given time for certain searches. So, if you think you see -+a bug keep the above in mind and send me the search words you used so I -+may code for any new variations. -+ -+=head1 CHANGES -+ -+2.22 -+Fixed up changed format from google -+reformatted code -+ -+2.21 -+Minor code correction for empty returned titles -+ -+2.20 -+Forgot to add new next url regex in 2.19! -+ -+2.19 -+Regex work on some search results url's that has changed. Number found -+return should be right now. -+ -+2.17 -+Insert url as a title when no title is found. - --=head1 VERSION HISTORY -+2.13 -+New regexp to parse newly found results format with certain search terms. - - 2.10 - removed warning on absence of description; new test case -@@ -131,15 +137,18 @@ - WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF - MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. - -+ - =cut - #' -- -+ -+ - ##################################################################### -+ - require Exporter; - @EXPORT = qw(); - @EXPORT_OK = qw(); - @ISA = qw(WWW::Search Exporter); --$VERSION = '2.10'; -+$VERSION = '2.22'; - - $MAINTAINER = 'Jim Smyser '; - $TEST_CASES = <<"ENDTESTCASES"; -@@ -148,160 +157,187 @@ - &test('Google', '$MAINTAINER', 'one_page', '+LS'.'AM +rep'.'lication', \$TEST_RANGE, 2,99); - &test('Google', '$MAINTAINER', 'multi', 'dir'.'ty ha'.'rr'.'y bimbo', \$TEST_GREATER_THAN, 101); - ENDTESTCASES -- -+ - use Carp (); --use WWW::Search(generic_option); -+use WWW::Search(qw(generic_option strip_tags)); - require WWW::SearchResult; -- -+ -+ -+sub undef_to_emptystring { -+return defined($_[0]) ? $_[0] : ""; -+} -+# private - sub native_setup_search { -- my($self, $native_query, $native_options_ref) = @_; -- $self->{_debug} = $native_options_ref->{'search_debug'}; -- $self->{_debug} = 2 if ($native_options_ref->{'search_parse_debug'}); -- $self->{_debug} = 0 if (!defined($self->{_debug})); -- $self->{agent_e_mail} = 'jsmyser@bigfoot.com'; -- $self->user_agent('user'); -- $self->{_next_to_retrieve} = 1; -- $self->{'_num_hits'} = 0; -- if (!defined($self->{_options})) { -- $self->{'search_base_url'} = 'http://www.google.com'; -- $self->{_options} = { -- 'search_url' => 'http://www.google.com/search', -- 'num' => '100', -- 'q' => $native_query, -- }; -- } -- my $options_ref = $self->{_options}; -- if (defined($native_options_ref)) -- { -- # Copy in new options. -- foreach (keys %$native_options_ref) -- { -- $options_ref->{$_} = $native_options_ref->{$_}; -- } # foreach -- } # if -- # Process the options. -- my($options) = ''; -- foreach (sort keys %$options_ref) -- { -- # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n"; -- next if (generic_option($_)); -- $options .= $_ . '=' . $options_ref->{$_} . '&'; -- } -- chop $options; -- # Finally figure out the url. -- $self->{_next_url} = $self->{_options}{'search_url'} .'?'. $self->hash_to_cgi_string($self->{_options}); -- } # native_setup_search -- -+ my($self, $native_query, $native_options_ref) = @_; -+ $self->user_agent('user'); -+ $self->{_next_to_retrieve} = 0; -+ $self->{'_num_hits'} = 100; -+ -+ if (!defined $self->{_options}) { -+ $self->{_options} = { -+ 'search_url' => 'http://www.google.com/search', -+ 'num' => $self->{'_num_hits'}, -+ }; -+ } -+ -+ my($options_ref) = $self->{_options}; -+ -+ if (defined $native_options_ref) { -+ # Copy in new options. -+ foreach (keys %$native_options_ref) { -+ $options_ref->{$_} = $native_options_ref->{$_}; -+ } -+ } -+ -+ # Process the options. -+ my($options) = ''; -+ foreach (keys %$options_ref) { -+ # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n"; -+ next if (generic_option($_)); -+ $options .= $_ . '=' . $options_ref->{$_} . '&'; -+ } -+ -+ $self->{_debug} = $options_ref->{'search_debug'}; -+ $self->{_debug} = 2 if ($options_ref->{'search_parse_debug'}); -+ $self->{_debug} = 0 if (!defined $self->{_debug}); -+ -+ # Finally figure out the url. -+ $self->{_base_url} = -+ $self->{_next_url} = -+ $self->{_options}{'search_url'} . -+ "?" . $options . -+ "q=" . $native_query; -+} -+ - # private --sub native_retrieve_some -- { -- my ($self) = @_; -- print STDERR "**Google::native_retrieve_some()**\n" if $self->{_debug}; -- # Fast exit if already done: -- return undef if (!defined($self->{_next_url})); -- -- # If this is not the first page of results, sleep so as to not -- # overload the server: -- $self->user_agent_delay if 1 < $self->{'_next_to_retrieve'}; -- -- # Get some if were not already scoring somewhere else: -- print STDERR "*Sending request (",$self->{_next_url},")\n" if $self->{_debug}; -- my($response) = $self->http_request('GET', $self->{_next_url}); -- $self->{response} = $response; -- if (!$response->is_success) -- { -- return undef; -- } -- $self->{'_next_url'} = undef; -- print STDERR "**Response\n" if $self->{_debug}; -- -- # parse the output -- my ($HEADER, $START, $HITS, $NEXT) = qw(HE HI ST NX); -- my $hits_found = 0; -- my $state = $HEADER; -- my $hit = (); -- foreach ($self->split_lines($response->content())) -- { -- next if m@^$@; # short circuit for blank lines -- print STDERR " $state ===$_=== " if 2 <= $self->{'_debug'}; -- if (m|(\d+) matches|i) { -- print STDERR "**Found Header Count**\n" if ($self->{_debug}); -- $self->approximate_result_count($1); -- $state = $START; -- # set-up attempting the tricky task of -- # fetching the very first HIT line -- } -- elsif ($state eq $START && m|Search took|i) -- { -- print STDERR "**Found Start Line**\n" if ($self->{_debug}); -- $state = $HITS; -- # Attempt to pull the very first hit line -- } -- if ($state eq $HITS) { -- print "\n**state == HITS**\n" if 2 <= $self->{_debug}; -- } -- if ($state eq $HITS && m@^

(.*)$@i) -- { -- print "**Found HIT**\n" if 2 <= $self->{_debug}; -- my ($url, $title) = ($1,$2); -- if (defined($hit)) -- { -- push(@{$self->{cache}}, $hit); -- }; -- $hit = new WWW::SearchResult; -- # some queries *can* create internal junk in the url link -- # remove them! -- $url =~ s/\/url\?sa=U&start=\d+&q=//g; -- $hits_found++; -- $hit->add_url($url); -- $hit->title($title); -- $state = $HITS; -- } -- if ($state eq $HITS && m@^
(.*)@i) -- { -- print "**Found First Description**\n" if 2 <= $self->{_debug}; -- $mDesc = $1; -- if (not $mDesc =~ m@ @) -- { -- $mDesc =~ s/<.*?>//g; -- $mDesc = $mDesc . '
' if not $mDesc =~ m@
@; -- $hit->description($mDesc); -- $state = $HITS; -- } -- } -- elsif ($state eq $HITS && -- m@^(\.(.+))@i || -- m@^
(.*)\s@i) { -- print "**Found Second Description**\n" if 2 <= $self->{_debug}; -- $sDesc = $1; -- $sDesc ||= ''; -- $sDesc =~ s/<.*?>//g; -- $sDesc = $mDesc . $sDesc; -- $hit->description($sDesc); -- $sDesc =''; -- $state = $HITS; -- } -- elsif ($state eq $HITS && -- m|
<.*?>.*?|i) { -- my $nexturl = $self->{'_next_url'}; -- if (defined $nexturl) { -- print STDERR "**Fetching Next URL-> ", $nexturl, "\n" if 2 <= $self->{_debug}; -- } else { -- print STDERR "**Fetching Next URL-> UNDEF\n" if 2 <= $self->{_debug}; -- } -- -- my $iURL = $1; -- $self->{'_next_url'} = $self->{'search_base_url'} . $iURL; -- } -- else -- { -- print STDERR "**Nothing matched.**\n" if 2 <= $self->{_debug}; -- } -- } -- if (defined($hit)) -- { -- push(@{$self->{cache}}, $hit); -- } -- return $hits_found; -- } # native_retrieve_some --1; -+sub begin_new_hit { -+ my($self) = shift; -+ my($old_hit) = shift; -+ my($old_raw) = shift; -+ -+ if (defined $old_hit) { -+ $old_hit->raw($old_raw) if (defined $old_raw); -+ push(@{$self->{cache}}, $old_hit); -+ } -+ -+ return (new WWW::SearchResult, ''); -+} -+ -+sub native_retrieve_some { -+ my ($self) = @_; -+ # fast exit if already done -+ return undef if (!defined $self->{_next_url}); -+ -+ # get some -+ print STDERR "Fetching " . $self->{_next_url} . "\n" if ($self->{_debug}); -+ my($response) = $self->http_request('GET', $self->{_next_url}); -+ $self->{response} = $response; -+ -+ return undef if (!$response->is_success); -+ -+ # parse the output -+ my($HEADER, $HITS, $TRAILER, $POST_NEXT) = (1..10); -+ my($hits_found) = 0; -+ my($state) = ($HEADER); -+ my($hit) = undef; -+ my($raw) = ''; -+ -+ foreach ($self->split_lines($response->content())) { -+ next if m@^$@; # short circuit for blank lines -+ -+ if ($state == $HEADER && m/about ([\d,]+)<\/b>/) { -+ my($n) = $1; -+ $self->approximate_result_count($n); -+ print STDERR "Found Total: $n\n" if ($self->{_debug}); -+ $state = $HITS; -+ -+ } elsif ($state == $HITS && -+ m|(.*?)
<.*?>|i -+ ) { -+ -+ my ($url, $title) = ($1,$2); -+ ($hit, $raw) = $self->begin_new_hit($hit, $raw); -+ print STDERR "**Found HIT1 Line**\n" if ($self->{_debug}); -+ $raw .= $_; -+ $url =~ s/(>.*)//g; -+ $hit->add_url(strip_tags($url)); -+ $hits_found++; -+ $title = "No Title" if ($title =~ /^\s+/); -+ $hit->title(strip_tags($title)); -+ $state = $HITS; -+ -+ } elsif ($state == $HITS && -+ m@^

(.*)
(.*)@i || -+ m@^

(.*).*?(.*)@i -+ ) { -+ print STDERR "**Found HIT2 Line**\n" if ($self->{_debug}); -+ -+ ($hit, $raw) = $self->begin_new_hit($hit, $raw); -+ -+ my ($url, $title) = ($1,$2); -+ $mDesc = $3; -+ -+ $url =~ s/\/url\?sa=\w&start=\d+&q=//g; -+ $url =~ s/\?lang=(\S+)$//g; -+ $url =~ s/&(.*)//g; -+ $url =~ s/(>.*)//g; -+ $url =~ s/\/$//g; # kill trailing slash. -+ -+ $raw .= $_; -+ $hit->add_url(strip_tags($url)); -+ $hits_found++; -+ -+ $title = "No Title" if ($title =~ /^\s+/); -+ $hit->title(strip_tags($title)); -+ -+ $mDesc =~ s/<.*?>//g; -+### $mDesc = $mDesc . '
' if not $mDesc =~ m@
@; -+ $hit->description($mDesc) if (defined $hit); -+ $state = $HITS; -+ -+# description parsing -+ } elsif ($state == $HITS && m@(\.\.(.+)) @i -+ ) { -+ print STDERR "**Parsing Description Line**\n" if ($self->{_debug}); -+ $raw .= $_; -+ # uhm... -+ $sDesc = $1 || ""; -+ -+ $sDesc =~ s/<.*?>//g; -+ $mDesc ||= ""; -+ $sDesc = $mDesc . $sDesc; -+# $hit->description($sDesc) if $sDesc =~ m@^\.@; -+ $sDesc = ''; -+ $state = $HITS; -+ -+ } elsif ($state == $HITS && m@

@i -+ ) { -+ ($hit, $raw) = $self->begin_new_hit($hit, $raw); -+ print STDERR "**Found Last Line**\n" if ($self->{_debug}); -+ # end of hits -+ $state = $TRAILER; -+ -+ } elsif ($state == $TRAILER && -+ m|.*?|i -+ ) { -+ my($relative_url) = $1; -+ print STDERR "**Fetching >>Next<< Page**\n" if ($self->{_debug}); -+ $self->{_next_url} = 'http://www.google.com' . $relative_url; -+ $state = $POST_NEXT; -+ } -+ } -+ -+ if ($state != $POST_NEXT) { -+ # No "Next" Tag -+ $self->{_next_url} = undef; -+ $self->begin_new_hit($hit, $raw) if ($state == $HITS); -+ $self->{_next_url} = undef; -+ } -+ -+ # ZZZzzzzZZZZzzzzzzZZZZZZzzz -+ $self->user_agent_delay if (defined($self->{_next_url})); -+ return $hits_found; -+} -+ -+1; -+ diff --git a/patches/WWW_Search.patch.old b/patches/WWW_Search.patch.old deleted file mode 100644 index eec3ce3..0000000 --- a/patches/WWW_Search.patch.old +++ /dev/null @@ -1,31 +0,0 @@ ---- WWW/Search/Google.pm.orig Wed May 24 16:55:47 2000 -+++ WWW/Search/Google.pm Wed May 24 16:56:19 2000 -@@ -240,7 +240,7 @@ - if ($state eq $HITS) { - print "\n**state == HITS**\n" if 2 <= $self->{_debug}; - } -- if ($state eq $HITS && m@^

(.*)$@i) -+ if ($state eq $HITS && m@^

(.*)@i) - { - print "**Found HIT**\n" if 2 <= $self->{_debug}; - my ($url, $title) = ($1,$2); -@@ -252,6 +252,7 @@ - # some queries *can* create internal junk in the url link - # remove them! - $url =~ s/\/url\?sa=U&start=\d+&q=//g; -+ $url =~ s/\&exp\=OneBoxNews\s//g; # new junk. - $hits_found++; - $hit->add_url($url); - $hit->title($title); -@@ -275,9 +276,8 @@ - print "**Found Second Description**\n" if 2 <= $self->{_debug}; - $sDesc = $1; - $sDesc ||= ''; -- $sDesc =~ s/<.*?>//g; -- $sDesc = $mDesc . $sDesc; -- $hit->description($sDesc); -+ $sDesc = $mDesc . $sDesc if (defined $mDesc); -+ $hit->description($sDesc) if (defined $hit and $sDesc ne ''); - $sDesc =''; - $state = $HITS; - } diff --git a/scripts/backup_table-slave.pl b/scripts/backup_table-slave.pl index c743d48..133fd74 100755 --- a/scripts/backup_table-slave.pl +++ b/scripts/backup_table-slave.pl @@ -11,91 +11,94 @@ use strict; use LWP; use POSIX qw(strftime); -my $backup_interval = 1; # every: 1,7,14,30. -my $backup_count = 7; -my $backup_url = "http://achilles.nyip.net/~apt/tables.tar.bz2"; -my $backup_file = "tables-##DATE.tar.bz2"; -my $backup_destdir = "/home/xk/public_html/"; -my $backup_indexfile = "tables-index.txt"; +my $backup_interval = 1; # every: 1,7,14,30. +my $backup_count = 7; +my $backup_url = "http://achilles.nyip.net/~apt/tables.tar.bz2"; +my $backup_file = "tables-##DATE.tar.bz2"; +my $backup_destdir = "/home/xk/public_html/"; +my $backup_indexfile = "tables-index.txt"; my %index; # Usage: &getURL($url); sub getURL { my ($url) = @_; - my ($ua,$res,$req); + my ( $ua, $res, $req ); $ua = new LWP::UserAgent; - $ua->proxy('http', $ENV{'http_proxy'}) if (exists $ENV{'http_proxy'}); - $ua->proxy('http', $ENV{'HTTP_PROXY'}) if (exists $ENV{'HTTP_PROXY'}); + $ua->proxy( 'http', $ENV{'http_proxy'} ) if ( exists $ENV{'http_proxy'} ); + $ua->proxy( 'http', $ENV{'HTTP_PROXY'} ) if ( exists $ENV{'HTTP_PROXY'} ); - $req = new HTTP::Request('GET',$url); + $req = new HTTP::Request( 'GET', $url ); $res = $ua->request($req); # return NULL upon error. - if ($res->is_success) { - return $res->content; - } else { - print "error: failure.\n"; - exit 1; + if ( $res->is_success ) { + return $res->content; + } + else { + print "error: failure.\n"; + exit 1; } } #... -if ( -f "$backup_destdir/$backup_indexfile") { - if (open(INDEX, "$backup_destdir/$backup_indexfile")) { - while () { - chop; - - # days since 1970, file. - if (/^(\d+) (\S+)$/) { - $index{$1} = $2; - } - } - close INDEX; - } else { - print "WARNING: can't open $backup_indexfile.\n"; +if ( -f "$backup_destdir/$backup_indexfile" ) { + if ( open( INDEX, "$backup_destdir/$backup_indexfile" ) ) { + while () { + chop; + + # days since 1970, file. + if (/^(\d+) (\S+)$/) { + $index{$1} = $2; + } + } + close INDEX; + } + else { + print "WARNING: can't open $backup_indexfile.\n"; } } -my $now_days = (localtime)[7] + (((localtime)[5] - 70) * 365); -my $now_date = strftime("%Y%m%d", localtime); +my $now_days = (localtime)[7] + ( ( (localtime)[5] - 70 ) * 365 ); +my $now_date = strftime( "%Y%m%d", localtime ); -if (scalar keys %index) { - my $last_days = (sort {$b <=> $a} keys %index)[0]; +if ( scalar keys %index ) { + my $last_days = ( sort { $b <=> $a } keys %index )[0]; - if ($now_days - $last_days < $backup_interval) { - print "error: shouldn't run today.\n"; - goto recycle; + if ( $now_days - $last_days < $backup_interval ) { + print "error: shouldn't run today.\n"; + goto recycle; } } $backup_file =~ s/##DATE/$now_date/; print "backup_file => '$backup_file'.\n"; -if ( -f $backup_file) { +if ( -f $backup_file ) { print "error: $backup_file already exists.\n"; exit 1; } my $file = &getURL($backup_url); -open(OUT,">$backup_destdir/$backup_file"); +open( OUT, ">$backup_destdir/$backup_file" ); print OUT $file; close OUT; $index{$now_days} = $backup_file; recycle:; -my @index = sort {$b <=> $a} keys %index; +my @index = sort { $b <=> $a } keys %index; -open(OUT,">$backup_destdir/$backup_indexfile"); -for(my $i=0; $i$backup_destdir/$backup_indexfile" ); +for ( my $i = 0 ; $i < scalar(@index) ; $i++ ) { my $day = $index[$i]; print "fe: day => '$day'.\n"; - if ($backup_count - 1 >= $i) { - print "DEBUG: $day $index{$day}\n"; - print OUT "$day $index{$day}\n"; - } else { - print "Deleting $backup_destdir/$index{$day}\n"; - unlink "$backup_destdir/$index{$day}"; + if ( $backup_count - 1 >= $i ) { + print "DEBUG: $day $index{$day}\n"; + print OUT "$day $index{$day}\n"; + } + else { + print "Deleting $backup_destdir/$index{$day}\n"; + unlink "$backup_destdir/$index{$day}"; } } close OUT; diff --git a/scripts/dbm2mysql.pl b/scripts/dbm2mysql.pl index b259282..a199cf7 100755 --- a/scripts/dbm2mysql.pl +++ b/scripts/dbm2mysql.pl @@ -10,11 +10,12 @@ require "src/Misc.pl"; require "src/Files.pl"; &loadDBModules(); require "src/dbi.pl"; + package main; # todo: main() -if (!scalar @ARGV) { +if ( !scalar @ARGV ) { print "Usage: dbm2mysql \n"; print "Example: dbm2mysql.pl apt\n"; print "NOTE: suffix '-is' and '-extra' are used.\n"; @@ -26,7 +27,7 @@ my $key; my %db; # open dbm. -if (!dbmopen(%db, $dbfile, 0666)) { +if ( !dbmopen( %db, $dbfile, 0666 ) ) { &ERROR("Failed open to dbm file ($dbfile)."); exit 1; } @@ -35,22 +36,27 @@ if (!dbmopen(%db, $dbfile, 0666)) { # open all the data... &loadConfig("files/infobot.config"); $dbname = $param{'DBName'}; -my $dbh_mysql = sqlOpenDB($param{'DBName'}, - $param{'DBType'}, $param{'SQLUser'}, $param{'SQLPass'}); -print "DEBUG: scalar db == '". scalar(keys %db) ."'.\n"; +my $dbh_mysql = sqlOpenDB( + $param{'DBName'}, $param{'DBType'}, + $param{'SQLUser'}, $param{'SQLPass'} +); +print "DEBUG: scalar db == '" . scalar( keys %db ) . "'.\n"; my $factoid; my $ndef = 1; -my $i = 1; -foreach $factoid (keys %db) { - &sqlReplace("factoids", { - factoid_key => $_, - factoid_value => $db{$_}, - } ); +my $i = 1; +foreach $factoid ( keys %db ) { + &sqlReplace( + "factoids", + { + factoid_key => $_, + factoid_value => $db{$_}, + } + ); $i++; - print "i=$i... " if ($i % 100 == 0); - print "ndef=$ndef... " if ($ndef % 1000 == 0); + print "i=$i... " if ( $i % 100 == 0 ); + print "ndef=$ndef... " if ( $ndef % 1000 == 0 ); } print "Done.\n"; diff --git a/scripts/dbm2txt.pl b/scripts/dbm2txt.pl index ed9e354..9a2b299 100755 --- a/scripts/dbm2txt.pl +++ b/scripts/dbm2txt.pl @@ -2,7 +2,7 @@ use strict; use DB_File; -if (!scalar @ARGV) { +if ( !scalar @ARGV ) { print "Usage: dbm2txt \n"; print "Example: dbm2txt.pl factoids\n"; exit 0; @@ -15,11 +15,11 @@ if (0) { openDB(); } -dbmopen(%db, $dbfile, 0644) or die "error: cannot open db. $dbfile\n"; -my ($key, $val); -while (($key, $val) = each %db) { - chomp $val; - print "$key => $val\n"; +dbmopen( %db, $dbfile, 0644 ) or die "error: cannot open db. $dbfile\n"; +my ( $key, $val ); +while ( ( $key, $val ) = each %db ) { + chomp $val; + print "$key => $val\n"; } dbmclose %db; diff --git a/scripts/findparam.pl b/scripts/findparam.pl index 0a559d1..679b9ca 100755 --- a/scripts/findparam.pl +++ b/scripts/findparam.pl @@ -2,72 +2,72 @@ use strict; -my(%param, %conf, %both); +my ( %param, %conf, %both ); foreach (`find -name "*.pl"`) { chop; - my $file = $_; + my $file = $_; my $debug = 0; - open(IN, $file); + open( IN, $file ); while () { - chop; + chop; - if (/IsParam\(['"](\S+?)['"]\)/) { - print "File: $file: IsParam: $1\n" if $debug; - $param{$1}++; - next; - } + if (/IsParam\(['"](\S+?)['"]\)/) { + print "File: $file: IsParam: $1\n" if $debug; + $param{$1}++; + next; + } - if (/IsChanConfOrWarn\(['"](\S+?)['"]\)/) { - print "File: $file: IsChanConfOrWarn: $1\n" if $debug; - $both{$1}++; - next; - } + if (/IsChanConfOrWarn\(['"](\S+?)['"]\)/) { + print "File: $file: IsChanConfOrWarn: $1\n" if $debug; + $both{$1}++; + next; + } - if (/getChanConfDefault\(['"](\S+?)['"]/) { - print "File: $file: gCCD: $1\n" if $debug; - $both{$1}++; - next; - } + if (/getChanConfDefault\(['"](\S+?)['"]/) { + print "File: $file: gCCD: $1\n" if $debug; + $both{$1}++; + next; + } - if (/getChanConf\(['"](\S+?)['"]/) { - print "File: $file: gCC: $1\n" if $debug; - $conf{$1}++; - next; - } + if (/getChanConf\(['"](\S+?)['"]/) { + print "File: $file: gCC: $1\n" if $debug; + $conf{$1}++; + next; + } - if (/IsChanConf\(['"](\S+?)['"]\)/) { - print "File: $file: ICC: $1\n" if $debug; - $conf{$1}++; - next; - } + if (/IsChanConf\(['"](\S+?)['"]\)/) { + print "File: $file: ICC: $1\n" if $debug; + $conf{$1}++; + next; + } - # command hooks => IsChanConfOrWarn => both. - # note: this does not support multiple lines. - if (/\'Identifier\'[\s\t]=>[\s\t]+\'(\S+?)\'/) { - print "File: $file: command hook: $1\n" if $debug; - $both{$1}++; - next; - } + # command hooks => IsChanConfOrWarn => both. + # note: this does not support multiple lines. + if (/\'Identifier\'[\s\t]=>[\s\t]+\'(\S+?)\'/) { + print "File: $file: command hook: $1\n" if $debug; + $both{$1}++; + next; + } } close IN; } print "Conf AND/OR Params:\n"; -foreach (sort keys %both) { +foreach ( sort keys %both ) { print " $_\n"; } print "\n"; print "Params:\n"; -foreach (sort keys %param) { +foreach ( sort keys %param ) { print " $_\n"; } print "\n"; print "Conf:\n"; -foreach (sort keys %conf) { +foreach ( sort keys %conf ) { print " $_\n"; } diff --git a/scripts/fixbadchars.pl b/scripts/fixbadchars.pl index 2662993..b7066a4 100755 --- a/scripts/fixbadchars.pl +++ b/scripts/fixbadchars.pl @@ -3,7 +3,7 @@ use DBI; my $dsn = "DBI:mysql:infobot:localhost"; -my $dbh = DBI->connect($dsn, "USERNAME", "PASSWORD"); +my $dbh = DBI->connect( $dsn, "USERNAME", "PASSWORD" ); my @factkey; my %factval; @@ -13,52 +13,60 @@ my $regex = '\\\\([\_\%])'; $query = "SELECT factoid_key,factoid_value from factoids"; my $sth = $dbh->prepare($query); $sth->execute; -while (my @row = $sth->fetchrow_array) { - if ($row[0] =~ /$regex/) { - push(@factkey,$row[0]); - } else { - $factval{$row[0]} = $row[1] if ($row[1] =~ /$regex/); +while ( my @row = $sth->fetchrow_array ) { + if ( $row[0] =~ /$regex/ ) { + push( @factkey, $row[0] ); + } + else { + $factval{ $row[0] } = $row[1] if ( $row[1] =~ /$regex/ ); } } $sth->finish; -print "scalar factkey => '". scalar(@factkey) ."'\n"; +print "scalar factkey => '" . scalar(@factkey) . "'\n"; foreach (@factkey) { print "factkey => '$_'.\n"; my $new = $_; $new =~ s/$regex/$1/g; - next if ($new eq $_); + next if ( $new eq $_ ); - $query = "SELECT factoid_key FROM factoids where factoid_key=". - $dbh->quote($new); + $query = + "SELECT factoid_key FROM factoids where factoid_key=" . $dbh->quote($new); my $sth = $dbh->prepare($query); $sth->execute; - if (scalar $sth->fetchrow_array) { # exist. - print "please remove $new or $_.\n"; - } else { # ! exist. - $sth->finish; + if ( scalar $sth->fetchrow_array ) { # exist. + print "please remove $new or $_.\n"; + } + else { # ! exist. + $sth->finish; - $query = "UPDATE factoids SET factoid_key=".$dbh->quote($new). - " WHERE factoid_key=".$dbh->quote($_); - my $sth = $dbh->prepare($query); - $sth->execute; - $sth->finish; + $query = + "UPDATE factoids SET factoid_key=" + . $dbh->quote($new) + . " WHERE factoid_key=" + . $dbh->quote($_); + my $sth = $dbh->prepare($query); + $sth->execute; + $sth->finish; } } -print "scalar factval => '". scalar(keys %factval) ."\n"; -foreach (keys %factval) { +print "scalar factval => '" . scalar( keys %factval ) . "\n"; +foreach ( keys %factval ) { print "factval => '$_'.\n"; my $fact = $_; - my $old = $factval{$_}; - my $new = $old; + my $old = $factval{$_}; + my $new = $old; $new =~ s/$regex/$1/g; - next if ($new eq $old); + next if ( $new eq $old ); - $query = "UPDATE factoids SET factoid_value=".$dbh->quote($new). - " WHERE factoid_key=".$dbh->quote($fact); + $query = + "UPDATE factoids SET factoid_value=" + . $dbh->quote($new) + . " WHERE factoid_key=" + . $dbh->quote($fact); my $sth = $dbh->prepare($query); $sth->execute; $sth->finish; diff --git a/scripts/insertDB.pl b/scripts/insertDB.pl index 802149b..1206414 100755 --- a/scripts/insertDB.pl +++ b/scripts/insertDB.pl @@ -9,7 +9,7 @@ require "src/logger.pl"; require "src/modules.pl"; require "src/Factoids/DBCommon.pl"; -&loadConfig($bot_config_dir."/infobot.config"); +&loadConfig( $bot_config_dir . "/infobot.config" ); &loadDBModules(); unless (@_) { @@ -18,18 +18,18 @@ unless (@_) { } foreach (@_) { - next unless ( -f $_); + next unless ( -f $_ ); - open(IN, $_) or die "error: cannot open $_\n"; + open( IN, $_ ) or die "error: cannot open $_\n"; print "Opened $_ for input...\n"; print "inserting... "; while () { - next unless (/^(.*?) => (.*)$/); + next unless (/^(.*?) => (.*)$/); - ### TODO: check if it already exists. if so, don't add. - &setFactInfo($1, "factoid_value", $2); - print ":: $1 "; + ### TODO: check if it already exists. if so, don't add. + &setFactInfo( $1, "factoid_value", $2 ); + print ":: $1 "; } close IN; diff --git a/scripts/irclog2html.pl b/scripts/irclog2html.pl index 40e4ed2..c2affbe 100755 --- a/scripts/irclog2html.pl +++ b/scripts/irclog2html.pl @@ -22,15 +22,13 @@ # irclog2html will write out a colourised irc log, appending a .html # extension to the output file. - #################################################################################### # Perl Configuration use strict; -$^W = 1; #RW# turn on warnings +$^W = 1; #RW# turn on warnings use POSIX qw(strftime); - #################################################################################### # Preferences @@ -39,29 +37,29 @@ use POSIX qw(strftime); #my $STYLE = "tt"; #my $STYLE = "simplett"; #my $STYLE = "table"; -my $STYLE = "simpletable"; +my $STYLE = "simpletable"; -my $colour_left = "#000099"; # nick leaving channel -my $colour_joined = "#009900"; # nick joining channel -my $colour_server = "#009900"; # server message (***) -my $colour_nickchange = "#009900"; # nick change -my $colour_action = "#CC00CC"; # nick action (/me waves) +my $colour_left = "#000099"; # nick leaving channel +my $colour_joined = "#009900"; # nick joining channel +my $colour_server = "#009900"; # server message (***) +my $colour_nickchange = "#009900"; # nick change +my $colour_action = "#CC00CC"; # nick action (/me waves) my %prefs_colour_nick = ( - "jdub" => "#993333", - "cantanker" => "#006600", - "chuckd" => "#339999", + "jdub" => "#993333", + "cantanker" => "#006600", + "chuckd" => "#339999", ); - #################################################################################### # Utility Functions sub header { - my ($channel, $date) = @_; - my $return = ''; + my ( $channel, $date ) = @_; + my $return = ''; - $return .= qq{ + $return .= + qq{ irclog2html for $channel on $date @@ -73,19 +71,19 @@ sub header {

irclog2html for $channel on $date

}; - if ($STYLE =~ /table/) { - $return .= "\n"; - } - return $return; + if ( $STYLE =~ /table/ ) { + $return .= "
\n"; + } + return $return; } sub footer { - my $return = ''; - if ($STYLE =~ /table/) { - $return .= "
\n"; - } + my $return = ''; + if ( $STYLE =~ /table/ ) { + $return .= "\n"; + } - $return .= qq{ + $return .= qq{
Generated by irclog2html.pl by Jeff Waugh - find it at freshmeat.net! @@ -93,231 +91,268 @@ Modified by Tim Riker to work with infobot logs, split per channel, etc. }; - return $return; + return $return; } my $lastdate = ''; sub add_footers { - my $filename; - - return if not $lastdate; - - my @files=`ls $lastdate.html */$lastdate.html`; - foreach $filename (@files) { - chomp $filename; - if (!open(OUTPUT, ">>$filename")) { - print "Cannot open $filename for writing!\n\n"; - return; - } - print OUTPUT footer(); - close OUTPUT; - } + my $filename; + + return if not $lastdate; + + my @files = `ls $lastdate.html */$lastdate.html`; + foreach $filename (@files) { + chomp $filename; + if ( !open( OUTPUT, ">>$filename" ) ) { + print "Cannot open $filename for writing!\n\n"; + return; + } + print OUTPUT footer(); + close OUTPUT; + } } sub output_line { - my ($date, $time, $channel, $lineout) = @_; + my ( $date, $time, $channel, $lineout ) = @_; + + add_footers() if $lastdate ne $date; + + $lastdate = $date; + my $filename = ""; + $filename .= "$channel/" if $channel; + $filename .= "$date.html"; - add_footers() if $lastdate ne $date; + mkdir( $channel, oct('755') ) if ( $channel && !-d $channel ); + if ( !open( OUTPUT, ">>$filename" ) ) { - $lastdate = $date; - my $filename = ""; - $filename .= "$channel/" if $channel; - $filename .= "$date.html"; + #print "Cannot open $filename for writing!\n\n"; + return; + } - mkdir($channel,oct('755')) if ($channel && ! -d $channel); - if (!open(OUTPUT, ">>$filename")) { - #print "Cannot open $filename for writing!\n\n"; - return; - } - # Begin output # - print OUTPUT header($channel, $date) if -z $filename; + # Begin output # + print OUTPUT header( $channel, $date ) if -z $filename; - print OUTPUT $lineout; + print OUTPUT $lineout; - close OUTPUT; + close OUTPUT; } sub output_timenicktext { - my ($date, $time, $channel, $nick, $text, $htmlcolour) = @_; - my $lineout = ''; - - if ($STYLE eq "table") { - $lineout .= ""; - $lineout .= "$time" if $time; - $lineout .= "$nick"; - $lineout .= "$text<\/font>\n"; - } - elsif ($STYLE eq "simpletable") { - $lineout .= ""; - $lineout .= "$time" if $time; - $lineout .= "$nick"; - $lineout .= "$text\n"; - } - elsif ($STYLE eq "simplett") { - $lineout .= "$time " if $time; - $lineout .= "<\;$nick>\; $text
\n"; - } - else { - $lineout .= "$time " if $time; - $lineout .= "<\;$nick>\; $text<\/font>
\n"; - } - output_line($date, $time, $channel, $lineout); + my ( $date, $time, $channel, $nick, $text, $htmlcolour ) = @_; + my $lineout = ''; + + if ( $STYLE eq "table" ) { + $lineout .= ""; + $lineout .= +"$time" + if $time; + $lineout .= +"$nick"; + $lineout .= +"$text<\/font>\n"; + } + elsif ( $STYLE eq "simpletable" ) { + $lineout .= ""; + $lineout .= "$time" if $time; + $lineout .= + "$nick"; + $lineout .= "$text\n"; + } + elsif ( $STYLE eq "simplett" ) { + $lineout .= "$time " if $time; + $lineout .= "<\;$nick>\; $text
\n"; + } + else { + $lineout .= "$time " if $time; + $lineout .= + "<\;$nick>\; $text<\/font>
\n"; + } + output_line( $date, $time, $channel, $lineout ); } sub output_timeservermsg { - my ($date, $time, $channel, $line) = @_; - my $lineout = ''; - - if ($STYLE =~ /table/) { - $lineout .= ""; - $lineout .= "$time" if $time; - $lineout .= "$line\n"; - } - else { - $lineout .= "$time " if $time; - $lineout .= "$line
\n"; - } - output_line($date, $time, $channel, $lineout); + my ( $date, $time, $channel, $line ) = @_; + my $lineout = ''; + + if ( $STYLE =~ /table/ ) { + $lineout .= ""; + $lineout .= "$time" if $time; + $lineout .= "$line\n"; + } + else { + $lineout .= "$time " if $time; + $lineout .= "$line
\n"; + } + output_line( $date, $time, $channel, $lineout ); } -sub html_rgb -{ - my ($i,$ncolours) = @_; - $ncolours = 1 if $ncolours == 0; - - my $rgbmax = 125; # tune these two for the outmost ranges of colour depth - my $rgbmin = 240; - - my $a = 0.95; # tune these for the starting and ending concentrations of R,G,B - my $c = 0.5; - - my $rgb = [ [$a,$c,$c], [$c,$a,$c], [$c,$c,$a], [$a,$a,$c], [$a,$c,$a], [$c,$a,$a] ]; - my $n = $i % @$rgb; - my $m = $rgbmin + ($rgbmax - $rgbmin) * ($ncolours - $i) / $ncolours; - - my $r = $rgb->[$n][0] * $m; - my $g = $rgb->[$n][1] * $m; - my $b = $rgb->[$n][2] * $m; - sprintf("#%02x%02x%02x",$r,$g,$b); +sub html_rgb { + my ( $i, $ncolours ) = @_; + $ncolours = 1 if $ncolours == 0; + + my $rgbmax = 125; # tune these two for the outmost ranges of colour depth + my $rgbmin = 240; + + my $a = + 0.95; # tune these for the starting and ending concentrations of R,G,B + my $c = 0.5; + + my $rgb = [ + [ $a, $c, $c ], + [ $c, $a, $c ], + [ $c, $c, $a ], + [ $a, $a, $c ], + [ $a, $c, $a ], + [ $c, $a, $a ] + ]; + my $n = $i % @$rgb; + my $m = $rgbmin + ( $rgbmax - $rgbmin ) * ( $ncolours - $i ) / $ncolours; + + my $r = $rgb->[$n][0] * $m; + my $g = $rgb->[$n][1] * $m; + my $b = $rgb->[$n][2] * $m; + sprintf( "#%02x%02x%02x", $r, $g, $b ); } #################################################################################### # Main sub main { - my ($date) = @_; - my $files; - - my $line; - my $time; - my $lastdate = ""; - my $nick; - my $channel; - my $text; - - my $htmlcolour; - my $nickcount = 0; - my $NICKMAX = 30; - - my %colour_nick = %prefs_colour_nick; - - while ($line = ) { - - chomp $line; - - if (!$line eq "") { - # parse out the time - if ($line =~ s/^([0-9:\.]*) (.*)$/$2/) { - $time = $1; - } else { - $time = ''; - } - $channel = ''; - - # Replace ampersands, pointies, control characters # - $line =~ s/&/&\;/g; - $line =~ s//>\;/g; - $line =~ s/\e\[[0-1]*m//g; - $line =~ s/[\x00-\x1f]+//g; - - # Replace possible URLs with links # - $line =~ s/((http|https|ftp|gopher|news):\/\/\S*)/$1<\/a>/g; - - # Colourise the comments - if ($line =~ /^<\;[^\/]*?\/\#.*?>\; .*$/) { - # Split $nick, $channel and $line - $nick = $line; - $nick =~ s/^<\;([^\/]*?)\/\#.*?>\; .*$/$1/; - $channel = $line; - $channel =~ s/^<\;[^\/]*?\/(\#.*?)>\; .*$/$1/; - - # $nick =~ tr/[A-Z]/[a-z]/; - # <======= move this into another function when getting nick colour - - $text = $line; - $text =~ s/^<\;.*?>\; (.*)$/$1/; - $text =~ s/^ .*/<\;PROTECTED>\;/g; - $text =~ s/ / \; \;/g; - - $htmlcolour = $colour_nick{$nick}; - if (!defined($htmlcolour)) { - # new nick - $nickcount++; - - # if we've exceeded our estimate of the number of nicks, double it - $NICKMAX *= 2 if $nickcount >= $NICKMAX; - - $htmlcolour = $colour_nick{$nick} = html_rgb($nickcount, $NICKMAX); - } - output_timenicktext($date, $time, $channel, $nick, $text, $htmlcolour); - } elsif ($line =~ /^>\;>\;>\; /) { - $line =~ s/^>\;>\;>\; /\*\*\* /; - - # Process changed nick results, and remember colours accordingly # - if ($line =~ /\*\*\* (.*?) materializes into (.*)/) { - my $nick_old = $1; - my $nick_new = $2; - - #$nick_old = $line; - #$nick_old =~ s/\*\*\* (.*?) materializes into .*/$1/; - #$nick_new = $line; - #$nick_new =~ s/\*\*\* (.*?) materializes into (.*)/$2/; - - $colour_nick{$nick_new} = $colour_nick{$nick_old}; - $colour_nick{$nick_old} = undef; - - $line =~ s/(\*\*\* .*)/$1<\/font>/ - } elsif ($line =~ /\*\*\* (join|mode|topic)\/(.*?) .*/) { - $channel = lc $2; - $line =~ s/(\*\*\* .*)/$1<\/font>/; - } elsif ($line =~ /\*\*\* (part|kick|banned)\/(.*?) .*/) { - $channel = lc $2; - $line =~ s/(\*\*\* .*)/$1<\/font>/; - } elsif ($line =~ /\*\*\* .* has signed off IRC .*/) { - # Colourise joined/left/server messages # - $line =~ s/(\*\*\* .*)/$1<\/font>/; - } elsif ($line =~ /\*\*\* /) { - $line =~ s/(\*\*\* .*)$/$1<\/font>/; - } elsif ($line =~ /^\* .*$/) { - # Colourise the /me's # - $line =~ s/^(\*.*)$/$1<\/font>/; - } - - output_timeservermsg($date, $time, $channel, $line); - } - } - } - - add_footers(); - - return 0; + my ($date) = @_; + my $files; + + my $line; + my $time; + my $lastdate = ""; + my $nick; + my $channel; + my $text; + + my $htmlcolour; + my $nickcount = 0; + my $NICKMAX = 30; + + my %colour_nick = %prefs_colour_nick; + + while ( $line = ) { + + chomp $line; + + if ( !$line eq "" ) { + + # parse out the time + if ( $line =~ s/^([0-9:\.]*) (.*)$/$2/ ) { + $time = $1; + } + else { + $time = ''; + } + $channel = ''; + + # Replace ampersands, pointies, control characters # + $line =~ s/&/&\;/g; + $line =~ s//>\;/g; + $line =~ s/\e\[[0-1]*m//g; + $line =~ s/[\x00-\x1f]+//g; + + # Replace possible URLs with links # + $line =~ + s/((http|https|ftp|gopher|news):\/\/\S*)/$1<\/a>/g; + + # Colourise the comments + if ( $line =~ /^<\;[^\/]*?\/\#.*?>\; .*$/ ) { + + # Split $nick, $channel and $line + $nick = $line; + $nick =~ s/^<\;([^\/]*?)\/\#.*?>\; .*$/$1/; + $channel = $line; + $channel =~ s/^<\;[^\/]*?\/(\#.*?)>\; .*$/$1/; + + # $nick =~ tr/[A-Z]/[a-z]/; + # <======= move this into another function when getting nick colour + + $text = $line; + $text =~ s/^<\;.*?>\; (.*)$/$1/; + $text =~ s/^ .*/<\;PROTECTED>\;/g; + $text =~ s/ / \; \;/g; + + $htmlcolour = $colour_nick{$nick}; + if ( !defined($htmlcolour) ) { + + # new nick + $nickcount++; + + # if we've exceeded our estimate of the number of nicks, double it + $NICKMAX *= 2 if $nickcount >= $NICKMAX; + + $htmlcolour = $colour_nick{$nick} = + html_rgb( $nickcount, $NICKMAX ); + } + output_timenicktext( $date, $time, $channel, $nick, $text, + $htmlcolour ); + } + elsif ( $line =~ /^>\;>\;>\; / ) { + $line =~ s/^>\;>\;>\; /\*\*\* /; + + # Process changed nick results, and remember colours accordingly # + if ( $line =~ /\*\*\* (.*?) materializes into (.*)/ ) { + my $nick_old = $1; + my $nick_new = $2; + + #$nick_old = $line; + #$nick_old =~ s/\*\*\* (.*?) materializes into .*/$1/; + #$nick_new = $line; + #$nick_new =~ s/\*\*\* (.*?) materializes into (.*)/$2/; + + $colour_nick{$nick_new} = $colour_nick{$nick_old}; + $colour_nick{$nick_old} = undef; + + $line =~ +s/(\*\*\* .*)/$1<\/font>/; + } + elsif ( $line =~ /\*\*\* (join|mode|topic)\/(.*?) .*/ ) { + $channel = lc $2; + $line =~ + s/(\*\*\* .*)/$1<\/font>/; + } + elsif ( $line =~ /\*\*\* (part|kick|banned)\/(.*?) .*/ ) { + $channel = lc $2; + $line =~ + s/(\*\*\* .*)/$1<\/font>/; + } + elsif ( $line =~ /\*\*\* .* has signed off IRC .*/ ) { + + # Colourise joined/left/server messages # + $line =~ + s/(\*\*\* .*)/$1<\/font>/; + } + elsif ( $line =~ /\*\*\* / ) { + $line =~ + s/(\*\*\* .*)$/$1<\/font>/; + } + elsif ( $line =~ /^\* .*$/ ) { + + # Colourise the /me's # + $line =~ + s/^(\*.*)$/$1<\/font>/; + } + + output_timeservermsg( $date, $time, $channel, $line ); + } + } + } + + add_footers(); + + return 0; } -if (!scalar @ARGV) { - print "Usage: irclog2html.pl < logfile\n"; - print "Example: bzcat log/infobot.log-20021104.bz2 | irclog2html.pl 20021104\n"; +if ( !scalar @ARGV ) { + print "Usage: irclog2html.pl < logfile\n"; + print + "Example: bzcat log/infobot.log-20021104.bz2 | irclog2html.pl 20021104\n"; exit 0; } my $date = shift; diff --git a/scripts/makepasswd b/scripts/makepasswd index 7b9d47c..e700e29 100755 --- a/scripts/makepasswd +++ b/scripts/makepasswd @@ -12,10 +12,10 @@ while (<>) { sub mkpasswd { my $what = $_[0]; - my $salt = chr(65+rand(27)).chr(65+rand(27)); + my $salt = chr( 65 + rand(27) ) . chr( 65 + rand(27) ); $salt =~ s/\W/x/g; - return crypt($what, $salt); + return crypt( $what, $salt ); } # vim:ts=4:sw=4:expandtab:tw=80 diff --git a/scripts/mysql2txt.pl b/scripts/mysql2txt.pl index bc7fad6..b733e76 100755 --- a/scripts/mysql2txt.pl +++ b/scripts/mysql2txt.pl @@ -11,7 +11,7 @@ require "src/Files.pl"; $bot_src_dir = "./src/"; my $dbname = shift; -if (!defined $dbname) { +if ( !defined $dbname ) { print "Usage: $0 \n"; print "Example: $0 factoids\n"; exit 0; @@ -21,25 +21,25 @@ if (!defined $dbname) { &loadConfig("files/infobot.config"); &loadDBModules(); -&openDB($param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'}); +&openDB( $param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'} ); # retrieve a list of db's from the server. my %db; -foreach ($dbh->func('_ListTables')) { +foreach ( $dbh->func('_ListTables') ) { $db{$_} = 1; } # factoid db. -if (!exists $db{$dbname}) { +if ( !exists $db{$dbname} ) { print "error: $dbname does not exist as a table.\n"; exit 1; } my $query = "SELECT factoid_key,factoid_value from $param{'DBName'}.$dbname"; -my $sth = $dbh->prepare($query); +my $sth = $dbh->prepare($query); $sth->execute; -while (my @row = $sth->fetchrow_array) { - print "$row[0] => $row[1]\n"; +while ( my @row = $sth->fetchrow_array ) { + print "$row[0] => $row[1]\n"; } $sth->finish; diff --git a/scripts/oreilly_dumpvar.pl b/scripts/oreilly_dumpvar.pl index 70410d8..354ac47 100755 --- a/scripts/oreilly_dumpvar.pl +++ b/scripts/oreilly_dumpvar.pl @@ -1,28 +1,30 @@ package DUMPVAR; + sub dumpvar { ($packageName) = @_; - $rPackage = \%{"${packageName}::"}; # Get a reference to the appropriate symbol table hash. - $, = " " ; - while (($varName, $globValue) = each %$rPackage) { - print "$varName ============================= \n"; - *var = $globValue; - if (defined ($var)) { - print "\t \$$varName $var \n"; - } - if (defined (@var)) { - print "\t \@$varName @var \n"; - } - if (defined (%var)) { - print "\t \%$varName ",%var," \n"; - } + $rPackage = + \%{"${packageName}::" + }; # Get a reference to the appropriate symbol table hash. + $, = " "; + while ( ( $varName, $globValue ) = each %$rPackage ) { + print "$varName ============================= \n"; + *var = $globValue; + if ( defined($var) ) { + print "\t \$$varName $var \n"; + } + if ( defined(@var) ) { + print "\t \@$varName @var \n"; + } + if ( defined(%var) ) { + print "\t \%$varName ", %var, " \n"; + } } } - package Test; $x = 10; -@y = (1,3,4); -%z = (1,2,3,4, 5, 6, \@y); +@y = ( 1, 3, 4 ); +%z = ( 1, 2, 3, 4, 5, 6, \@y ); $z = 300; DUMPVAR::dumpvar("Test"); diff --git a/scripts/oreilly_prettyp.pl b/scripts/oreilly_prettyp.pl index 3d25165..9c858e3 100755 --- a/scripts/oreilly_prettyp.pl +++ b/scripts/oreilly_prettyp.pl @@ -1,83 +1,91 @@ -@sample = (11.233,{3 => 4, "hello" => [6,7]}); +@sample = ( 11.233, { 3 => 4, "hello" => [ 6, 7 ] } ); pretty_print(@sample); -$level = -1; # Level of indentation +$level = -1; # Level of indentation sub pretty_print { my $var; foreach $var (@_) { - if (ref ($var)) { - print_ref($var); - } else { - print_scalar($var); - } + if ( ref($var) ) { + print_ref($var); + } + else { + print_scalar($var); + } } } sub print_scalar { ++$level; - print_indented ($_[0]); + print_indented( $_[0] ); --$level; } sub print_ref { my $r = $_[0]; - if (exists ($already_seen{$r})) { - print_indented ("$r (Seen earlier)"); - return; - } else { - $already_seen{$r}=1; + if ( exists( $already_seen{$r} ) ) { + print_indented("$r (Seen earlier)"); + return; + } + else { + $already_seen{$r} = 1; } my $ref_type = ref($r); - if ($ref_type eq "ARRAY") { - print_array($r); - } elsif ($ref_type eq "SCALAR") { - print "Ref -> $r"; - print_scalar($$r); - } elsif ($ref_type eq "HASH") { - print_hash($r); - } elsif ($ref_type eq "REF") { - ++$level; - print_indented("Ref -> ($r)"); - print_ref($$r); - --$level; - } else { - print_indented ("$ref_type (not supported)"); + if ( $ref_type eq "ARRAY" ) { + print_array($r); + } + elsif ( $ref_type eq "SCALAR" ) { + print "Ref -> $r"; + print_scalar($$r); + } + elsif ( $ref_type eq "HASH" ) { + print_hash($r); + } + elsif ( $ref_type eq "REF" ) { + ++$level; + print_indented("Ref -> ($r)"); + print_ref($$r); + --$level; + } + else { + print_indented("$ref_type (not supported)"); } } sub print_array { my ($r_array) = @_; ++$level; - print_indented ("[ # $r_array"); + print_indented("[ # $r_array"); foreach $var (@$r_array) { - if (ref ($var)) { - print_ref($var); - } else { - print_scalar($var); - } + if ( ref($var) ) { + print_ref($var); + } + else { + print_scalar($var); + } } - print_indented ("]"); + print_indented("]"); --$level; } sub print_hash { - my($r_hash) = @_; - my($key, $val); + my ($r_hash) = @_; + my ( $key, $val ); ++$level; - print_indented ("{ # $r_hash"); - while (($key, $val) = each %$r_hash) { - $val = ($val ? $val : '""'); - ++$level; - if (ref ($val)) { - print_indented ("$key => "); - print_ref($val); - } else { - print_indented ("$key => $val"); - } - --$level; + print_indented("{ # $r_hash"); + while ( ( $key, $val ) = each %$r_hash ) { + $val = ( $val ? $val : '""' ); + ++$level; + if ( ref($val) ) { + print_indented("$key => "); + print_ref($val); + } + else { + print_indented("$key => $val"); + } + --$level; } - print_indented ("}"); + print_indented("}"); --$level; } diff --git a/scripts/parse_warn.pl b/scripts/parse_warn.pl index e22e024..7437996 100755 --- a/scripts/parse_warn.pl +++ b/scripts/parse_warn.pl @@ -1,13 +1,13 @@ #!/usr/bin/perl -w # leading and trailing context lines. -my $contextspread = 2; +my $contextspread = 2; use strict; $| = 1; -if (!scalar @ARGV) { +if ( !scalar @ARGV ) { print "Usage: parse_warn.pl \n"; print "Example: parse_warn.pl log/*\n"; exit 0; @@ -17,76 +17,84 @@ my %done; my $file; foreach $file (@ARGV) { - if (! -f $file) { - print "warning: $file does not exist.\n"; - next; + if ( !-f $file ) { + print "warning: $file does not exist.\n"; + next; } my $str = ' at .* line '; print "Opening $file... "; - if ($file =~ /bz2$/) { # bz2 - open(FILE, "bzcat $file | egrep '$str' |"); - } elsif ($file =~ /gz$/) { # gz - open(FILE, "zegrep '$str' $file |"); - } else { # raw - open(FILE, "egrep '$str' $file |"); + if ( $file =~ /bz2$/ ) { # bz2 + open( FILE, "bzcat $file | egrep '$str' |" ); + } + elsif ( $file =~ /gz$/ ) { # gz + open( FILE, "zegrep '$str' $file |" ); + } + else { # raw + open( FILE, "egrep '$str' $file |" ); } print "Parsing... "; while () { - if (/ at (\S+) line (\d+)/) { - my ($file,$lineno) = ($1,$2+1); - $done{$file}{$lineno}++; - } + if (/ at (\S+) line (\d+)/) { + my ( $file, $lineno ) = ( $1, $2 + 1 ); + $done{$file}{$lineno}++; + } } close FILE; print "Done.\n"; } -foreach $file (keys %done) { - my $count = scalar(keys %{$done{$file}}); +foreach $file ( keys %done ) { + my $count = scalar( keys %{ $done{$file} } ); print "warn $file: $count unique warnings.\n"; - if (! -f $file) { - print "=> error: does not exist.\n\n"; - next; + if ( !-f $file ) { + print "=> error: does not exist.\n\n"; + next; } - if (open(IN,$file)) { - my @lines = ; - close IN; - - my $total = scalar @lines; - my $spread = 0; - my $done = 0; - for(my $i=0; $i<=$total; $i++) { - next unless (exists $done{$file}{$i+$contextspread} or $spread); - - if (exists $done{$file}{$i+$contextspread}) { - print "@@ $i @@\n" unless ($spread); - # max lines between offending lines should be 2*context-1. - # coincidence that it is! - $spread = 2*$contextspread; - } else { - $spread--; - } - - if (exists $done{$file}{$i}) { - print "*** "; - } else { - print "--- "; - } - - if ($i >= $total) { - print "EOF\n"; - } else { - print $lines[$i]; - } - } - print "\n"; - } else { - print "=> error: could not open file.\n"; + if ( open( IN, $file ) ) { + my @lines = ; + close IN; + + my $total = scalar @lines; + my $spread = 0; + my $done = 0; + for ( my $i = 0 ; $i <= $total ; $i++ ) { + next + unless ( exists $done{$file}{ $i + $contextspread } or $spread ); + + if ( exists $done{$file}{ $i + $contextspread } ) { + print "@@ $i @@\n" unless ($spread); + + # max lines between offending lines should be 2*context-1. + # coincidence that it is! + $spread = 2 * $contextspread; + } + else { + $spread--; + } + + if ( exists $done{$file}{$i} ) { + print "*** "; + } + else { + print "--- "; + } + + if ( $i >= $total ) { + print "EOF\n"; + } + else { + print $lines[$i]; + } + } + print "\n"; + } + else { + print "=> error: could not open file.\n"; } } diff --git a/scripts/showvars.pl b/scripts/showvars.pl index 80b9c35..e96da2c 100755 --- a/scripts/showvars.pl +++ b/scripts/showvars.pl @@ -2,105 +2,115 @@ sub dumpvar { ($packageName) = @_; - $rPackage = \%{"${packageName}::"}; # Get a reference to the appropriate symbol table hash. - $, = " " ; - while (($varName, $globValue) = each %$rPackage) { - last if ($varName eq "main::"); - print "$varName ============================= \n"; - *var = $globValue; - if (defined ($var)) { - print "\t \$$varName = '$var' \n"; - } - if (defined (@var)) { - pretty_print(@var); + $rPackage = + \%{"${packageName}::" + }; # Get a reference to the appropriate symbol table hash. + $, = " "; + while ( ( $varName, $globValue ) = each %$rPackage ) { + last if ( $varName eq "main::" ); + print "$varName ============================= \n"; + *var = $globValue; + if ( defined($var) ) { + print "\t \$$varName = '$var' \n"; + } + if ( defined(@var) ) { + pretty_print(@var); ### print "\t \@$varName @var \n"; - } - if (defined (%var)) { - pretty_print(%var); + } + if ( defined(%var) ) { + pretty_print(%var); ### print "\t \%$varName ",%var," \n"; - } + } } } dumpvar("main"); -$level = -1; # Level of indentation +$level = -1; # Level of indentation sub pretty_print { my $var; foreach $var (@_) { - if (ref ($var)) { - print_ref($var); - } else { - print_scalar($var); - } + if ( ref($var) ) { + print_ref($var); + } + else { + print_scalar($var); + } } } sub print_scalar { ++$level; - print_indented ($_[0]); + print_indented( $_[0] ); --$level; } sub print_ref { my $r = $_[0]; - if (exists ($already_seen{$r})) { - print_indented ("$r (Seen earlier)"); - return; - } else { - $already_seen{$r}=1; + if ( exists( $already_seen{$r} ) ) { + print_indented("$r (Seen earlier)"); + return; + } + else { + $already_seen{$r} = 1; } my $ref_type = ref($r); - if ($ref_type eq "ARRAY") { - print_array($r); - } elsif ($ref_type eq "SCALAR") { - print "Ref -> $r"; - print_scalar($$r); - } elsif ($ref_type eq "HASH") { - print_hash($r); - } elsif ($ref_type eq "REF") { - ++$level; - print_indented("Ref -> ($r)"); - print_ref($$r); - --$level; - } else { - print_indented ("$ref_type (not supported)"); + if ( $ref_type eq "ARRAY" ) { + print_array($r); + } + elsif ( $ref_type eq "SCALAR" ) { + print "Ref -> $r"; + print_scalar($$r); + } + elsif ( $ref_type eq "HASH" ) { + print_hash($r); + } + elsif ( $ref_type eq "REF" ) { + ++$level; + print_indented("Ref -> ($r)"); + print_ref($$r); + --$level; + } + else { + print_indented("$ref_type (not supported)"); } } sub print_array { my ($r_array) = @_; ++$level; - print_indented ("[ # $r_array"); + print_indented("[ # $r_array"); foreach $var (@$r_array) { - if (ref ($var)) { - print_ref($var); - } else { - print_scalar($var); - } + if ( ref($var) ) { + print_ref($var); + } + else { + print_scalar($var); + } } - print_indented ("]"); + print_indented("]"); --$level; } sub print_hash { - my($r_hash) = @_; - my($key, $val); + my ($r_hash) = @_; + my ( $key, $val ); ++$level; - print_indented ("{ # $r_hash"); - while (($key, $val) = each %$r_hash) { - $val = ($val ? $val : '""'); - ++$level; - if (ref ($val)) { - print_indented ("$key => "); - print_ref($val); - } else { - print_indented ("$key => $val"); - } - --$level; + print_indented("{ # $r_hash"); + while ( ( $key, $val ) = each %$r_hash ) { + $val = ( $val ? $val : '""' ); + ++$level; + if ( ref($val) ) { + print_indented("$key => "); + print_ref($val); + } + else { + print_indented("$key => $val"); + } + --$level; } - print_indented ("}"); + print_indented("}"); --$level; } diff --git a/scripts/symname.pl b/scripts/symname.pl index 86e2649..f0562ab 100755 --- a/scripts/symname.pl +++ b/scripts/symname.pl @@ -7,100 +7,110 @@ my @test; my @test1; my %test; -$test{'hash0r'} = 2; +$test{'hash0r'} = 2; $test{'hegdfgsd'} = 'GSDFSDfsd'; -push(@test1,"Aeh."); -push(@test1,"Beh."); -push(@test1,"Ceh."); -push(@test1,"Deh."); +push( @test1, "Aeh." ); +push( @test1, "Beh." ); +push( @test1, "Ceh." ); +push( @test1, "Deh." ); + +push( @test, "heh." ); +push( @test, \%test ); -push(@test,"heh."); -push(@test,\%test); #push(@test,\%ENV); -push(@test,\@test1); +push( @test, \@test1 ); print "=============start=================\n"; + #&DumpArray(0, '@test', \@test); -&DumpPackage(0, 'main::', \%main::); +&DumpPackage( 0, 'main::', \%main:: ); # SCALAR ARRAY HASH CODE REF GLOB LVALUE sub DumpArray { - my ($pad, $symname, $arrayref) = @_; - my $padding = " " x $pad; - my $scalar = 0; - my $size = 0; - - print "$padding$symname\n"; - foreach (@{$arrayref}) { - my $ref = ref $_; - if ($ref eq 'ARRAY') { - $size += &DumpArray($pad+1, "@" . $_, $_); - } elsif ($ref eq 'HASH') { - $size += &DumpHash($pad+1, "%" . $_, $_); - } else { - print "$padding $_ $ref\n"; - $scalar++; - $size += length($_); - } - } - print $padding."scalars $scalar, size $size\n"; - return $size; + my ( $pad, $symname, $arrayref ) = @_; + my $padding = " " x $pad; + my $scalar = 0; + my $size = 0; + + print "$padding$symname\n"; + foreach ( @{$arrayref} ) { + my $ref = ref $_; + if ( $ref eq 'ARRAY' ) { + $size += &DumpArray( $pad + 1, "@" . $_, $_ ); + } + elsif ( $ref eq 'HASH' ) { + $size += &DumpHash( $pad + 1, "%" . $_, $_ ); + } + else { + print "$padding $_ $ref\n"; + $scalar++; + $size += length($_); + } + } + print $padding. "scalars $scalar, size $size\n"; + return $size; } -sub DumpHash{ - my ($pad, $symname, $hashref) = @_; - my $padding = " " x $pad; - my $scalar = 0; - my $size = 0; - - my %sym = %{$hashref}; - my @list = sort keys %sym; - print "$padding$symname\n"; - - foreach (@list) { - my $ref = ref %{$symname}; #FIXME - $size += length($_); - if ($ref eq 'ARRAY') { - $size += &DumpArray($pad+1, "@" . $_, $_); - } elsif ($ref eq 'HASH') { - $size += &DumpHash($pad+1, "%" . $_, $_); - } else { - print "$padding $_=$sym{$_} $ref\n"; - $scalar++; - $size += length($sym{$_}); - } - } - print $padding."scalars $scalar, size $size\n"; - return $size; +sub DumpHash { + my ( $pad, $symname, $hashref ) = @_; + my $padding = " " x $pad; + my $scalar = 0; + my $size = 0; + + my %sym = %{$hashref}; + my @list = sort keys %sym; + print "$padding$symname\n"; + + foreach (@list) { + my $ref = ref %{$symname}; #FIXME + $size += length($_); + if ( $ref eq 'ARRAY' ) { + $size += &DumpArray( $pad + 1, "@" . $_, $_ ); + } + elsif ( $ref eq 'HASH' ) { + $size += &DumpHash( $pad + 1, "%" . $_, $_ ); + } + else { + print "$padding $_=$sym{$_} $ref\n"; + $scalar++; + $size += length( $sym{$_} ); + } + } + print $padding. "scalars $scalar, size $size\n"; + return $size; } sub DumpPackage { - my ($pad, $packname, $package) = @_; - my $padding = " " x $pad; - my $scalar = 0; - my $size = 0; - - print $padding . "\%$packname\n"; - my $symname; - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - if (defined $sym) { - print "$padding \$$symname='$sym'\n"; - $scalar++; - $size += length($sym); - } elsif (defined @sym) { - $size += &DumpArray($pad+1, $symname, \@sym); - } elsif (defined %sym) { - $size += &DumpHash($pad+1, $symname, \%sym); - } elsif (($symname =~ /::/) and ($symname ne 'main::')) { - $size += &DumpPackage($pad+1, \%sym, $symname); - } else { - print("ERROR $symname" . ref $symname . "\n"); - } - } - print $padding."scalars $scalar, size $size\n"; - return $size; + my ( $pad, $packname, $package ) = @_; + my $padding = " " x $pad; + my $scalar = 0; + my $size = 0; + + print $padding . "\%$packname\n"; + my $symname; + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + if ( defined $sym ) { + print "$padding \$$symname='$sym'\n"; + $scalar++; + $size += length($sym); + } + elsif ( defined @sym ) { + $size += &DumpArray( $pad + 1, $symname, \@sym ); + } + elsif ( defined %sym ) { + $size += &DumpHash( $pad + 1, $symname, \%sym ); + } + elsif ( ( $symname =~ /::/ ) and ( $symname ne 'main::' ) ) { + $size += &DumpPackage( $pad + 1, \%sym, $symname ); + } + else { + print( "ERROR $symname" . ref $symname . "\n" ); + } + } + print $padding. "scalars $scalar, size $size\n"; + return $size; } # vim:ts=4:sw=4:expandtab:tw=80 diff --git a/scripts/txt2mysql.pl b/scripts/txt2mysql.pl index 68b134d..70e3744 100755 --- a/scripts/txt2mysql.pl +++ b/scripts/txt2mysql.pl @@ -9,47 +9,52 @@ require "src/Files.pl"; require "src/Misc.pl"; require "src/Factoids/DBCommon.pl"; -if (!scalar @ARGV) { - print "Usage: txt2mysql.pl \n"; - exit 0; +if ( !scalar @ARGV ) { + print "Usage: txt2mysql.pl \n"; + exit 0; } # open the txtfile. my $txtfile = shift; -open(IN,$txtfile) or die "error: cannot open txtfile '$txtfile'.\n"; +open( IN, $txtfile ) or die "error: cannot open txtfile '$txtfile'.\n"; # read the bot config file. &loadConfig("files/infobot.config"); &loadDBModules(); -&openDB($param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'}); +&openDB( $param{'DBName'}, $param{'SQLUser'}, $param{'SQLPass'} ); ### now pipe all the data to the mysql server... my $i = 1; print "converting factoid db to mysql...\n"; while () { - chop; - next if !length; - if (/^(.*)\s+=>\s+(.*)$/) { - # verify if it already exists? - my ($key,$val) = ($1,$2); - if ($key =~ /^\s*$/ or $val =~ /^\s*$/) { - print "warning: broken => '$_'.\n"; - next; - } + chop; + next if !length; + if (/^(.*)\s+=>\s+(.*)$/) { - if (&IsParam("freshmeat") and &dbGet("freshmeat", "name", $key, "name")) { - if (&getFactoid($key)) { - &delFactoid($key); - } - } else { - &setFactInfo(lc $key, "factoid_value", $val); - $i++; - } + # verify if it already exists? + my ( $key, $val ) = ( $1, $2 ); + if ( $key =~ /^\s*$/ or $val =~ /^\s*$/ ) { + print "warning: broken => '$_'.\n"; + next; + } + + if ( &IsParam("freshmeat") + and &dbGet( "freshmeat", "name", $key, "name" ) ) + { + if ( &getFactoid($key) ) { + &delFactoid($key); + } + } + else { + &setFactInfo( lc $key, "factoid_value", $val ); + $i++; + } - print "$i... " if ($i % 100 == 0); - } else { - print "warning: invalid => '$_'.\n"; - } + print "$i... " if ( $i % 100 == 0 ); + } + else { + print "warning: invalid => '$_'.\n"; + } } close IN; diff --git a/scripts/vartree.pl b/scripts/vartree.pl index 1b53de8..f22bbac 100755 --- a/scripts/vartree.pl +++ b/scripts/vartree.pl @@ -6,74 +6,74 @@ local @test; local %test; -$test{'hash0r'} = 2; +$test{'hash0r'} = 2; $test{'hegdfgsd'} = 'GSDFSDfsd'; -push(@test,"heh."); -push(@test,\%test); - -&vartree(\%main::, 'main::'); +push( @test, "heh." ); +push( @test, \%test ); +&vartree( \%main::, 'main::' ); sub tree { - my ($pad, $ref, $symname) = @_; + my ( $pad, $ref, $symname ) = @_; my $padded = " " x $pad; my @list; my $scalar = 0; my $size = 0; - @list = keys %{$symname} if ($ref eq 'HASH'); - @list = @{$symname} if ($ref eq 'ARRAY'); + @list = keys %{$symname} if ( $ref eq 'HASH' ); + @list = @{$symname} if ( $ref eq 'ARRAY' ); foreach (@list) { - my $ref = ref $_; - - if ($ref eq 'HASH' or $ref eq 'ARRAY') { - print $padded."recursing $ref($_).\n"; - &tree($pad+2, $ref, $_); - } elsif ($ref eq '') { - $scalar++; - $size += length($_); - } + my $ref = ref $_; + + if ( $ref eq 'HASH' or $ref eq 'ARRAY' ) { + print $padded. "recursing $ref($_).\n"; + &tree( $pad + 2, $ref, $_ ); + } + elsif ( $ref eq '' ) { + $scalar++; + $size += length($_); + } } - print $padded."scalars $scalar, size $size\n"; + print $padded. "scalars $scalar, size $size\n"; } sub vartree { - my ($package, $packname) = @_; + my ( $package, $packname ) = @_; my $symname; # scalar. - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined $sym); - print "scalar => $symname = '$sym'\n"; + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined $sym ); + print "scalar => $symname = '$sym'\n"; } # array. - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined @sym); - print "\@$symname\n"; - &tree(2, "ARRAY", $symname); + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined @sym ); + print "\@$symname\n"; + &tree( 2, "ARRAY", $symname ); } # hash. - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined %sym); - print "\%$symname\n"; - &tree(2, "HASH", $symname); + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined %sym ); + print "\%$symname\n"; + &tree( 2, "HASH", $symname ); } - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined %sym); - next unless ($symname =~ /::/); - next if ($symname eq 'main::'); + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined %sym ); + next unless ( $symname =~ /::/ ); + next if ( $symname eq 'main::' ); - print "recurse: $symname.\n"; - &vartree(\%sym, $symname); + print "recurse: $symname.\n"; + &vartree( \%sym, $symname ); } print "end.\n"; diff --git a/scripts/webbackup.pl b/scripts/webbackup.pl index 41e43c7..c8c8bb4 100755 --- a/scripts/webbackup.pl +++ b/scripts/webbackup.pl @@ -4,90 +4,93 @@ use strict; use LWP; use POSIX qw(strftime); -my $backup_interval = 1; # every: 1,7,14,30. -my $backup_count = 7; -my $backup_url = "http://core.junker.org/~apt/tables.tar.bz2"; -my $backup_file = "tables-##DATE.tar.bz2"; -my $backup_destdir = "/home/xk/public_html/"; -my $backup_indexfile = "tables-index.txt"; +my $backup_interval = 1; # every: 1,7,14,30. +my $backup_count = 7; +my $backup_url = "http://core.junker.org/~apt/tables.tar.bz2"; +my $backup_file = "tables-##DATE.tar.bz2"; +my $backup_destdir = "/home/xk/public_html/"; +my $backup_indexfile = "tables-index.txt"; my %index; # Usage: &getURL($url); sub getURL { my ($url) = @_; - my ($ua,$res,$req); + my ( $ua, $res, $req ); $ua = new LWP::UserAgent; ### $ua->proxy('http', $proxy); - $req = new HTTP::Request('GET',$url); + $req = new HTTP::Request( 'GET', $url ); $res = $ua->request($req); # return NULL upon error. - if ($res->is_success) { - return $res->content; - } else { - print "error: failure.\n"; - exit 1; + if ( $res->is_success ) { + return $res->content; + } + else { + print "error: failure.\n"; + exit 1; } } #... -if ( -f "$backup_destdir/$backup_indexfile") { - if (open(INDEX, "$backup_destdir/$backup_indexfile")) { - while () { - chop; - - # days since 1970, file. - if (/^(\d+) (\S+)$/) { - $index{$1} = $2; - } - } - close INDEX; - } else { - print "WARNING: can't open $backup_indexfile.\n"; +if ( -f "$backup_destdir/$backup_indexfile" ) { + if ( open( INDEX, "$backup_destdir/$backup_indexfile" ) ) { + while () { + chop; + + # days since 1970, file. + if (/^(\d+) (\S+)$/) { + $index{$1} = $2; + } + } + close INDEX; + } + else { + print "WARNING: can't open $backup_indexfile.\n"; } } -my $now_days = (localtime)[7] + (((localtime)[5] - 70) * 365); -my $now_date = strftime("%Y%m%d", localtime); +my $now_days = (localtime)[7] + ( ( (localtime)[5] - 70 ) * 365 ); +my $now_date = strftime( "%Y%m%d", localtime ); -if (scalar keys %index) { - my $last_days = (sort {$b <=> $a} keys %index)[0]; +if ( scalar keys %index ) { + my $last_days = ( sort { $b <=> $a } keys %index )[0]; - if ($now_days - $last_days < $backup_interval) { - print "error: shouldn't run today.\n"; - goto cycle; + if ( $now_days - $last_days < $backup_interval ) { + print "error: shouldn't run today.\n"; + goto cycle; } } $backup_file =~ s/##DATE/$now_date/; print "backup_file => '$backup_file'.\n"; -if ( -f $backup_file) { +if ( -f $backup_file ) { print "error: $backup_file already exists.\n"; exit 1; } my $file = &getURL($backup_url); -open(OUT,">$backup_destdir/$backup_file"); +open( OUT, ">$backup_destdir/$backup_file" ); print OUT $file; close OUT; $index{$now_days} = $backup_file; cycle:; -my @index = sort {$b <=> $a} keys %index; +my @index = sort { $b <=> $a } keys %index; -open(OUT,">$backup_destdir/$backup_indexfile"); -for(my $i=0; $i$backup_destdir/$backup_indexfile" ); +for ( my $i = 0 ; $i < scalar(@index) ; $i++ ) { my $day = $index[$i]; print "fe: day => '$day'.\n"; - if ($backup_count - 1 >= $i) { - print "DEBUG: $day $index{$day}\n"; - print OUT "$day $index{$day}\n"; - } else { - print "Deleting $index{$day}\n"; - unlink $backup_destdir."/".$index{$day}; + if ( $backup_count - 1 >= $i ) { + print "DEBUG: $day $index{$day}\n"; + print OUT "$day $index{$day}\n"; + } + else { + print "Deleting $index{$day}\n"; + unlink $backup_destdir . "/" . $index{$day}; } } close OUT; diff --git a/setup/setup.pl b/setup/setup.pl index c9562ae..89393bd 100755 --- a/setup/setup.pl +++ b/setup/setup.pl @@ -18,78 +18,90 @@ $bot_src_dir = "src/"; my $dbname = $param{'DBName'}; my $query; -if ($dbname eq "") { - print "error: appears that the config file was not loaded properly.\n"; - exit 1; +if ( $dbname eq "" ) { + print "error: appears that the config file was not loaded properly.\n"; + exit 1; } -if ($param{'DBType'} =~ /mysql/i) { +if ( $param{'DBType'} =~ /mysql/i ) { use DBI; print "Enter root information...\n"; + # username. print "Username: "; - chop (my $adminuser = ); + chop( my $adminuser = ); # passwd. system "stty -echo"; print "Password: "; - chop(my $adminpass = ); + chop( my $adminpass = ); print "\n"; system "stty echo"; - if ($adminuser eq "" or $adminpass eq "") { - &ERROR("error: adminuser || adminpass is NULL."); - exit 1; + if ( $adminuser eq "" or $adminpass eq "" ) { + &ERROR("error: adminuser || adminpass is NULL."); + exit 1; } - &sqlOpenDB("mysql", "mysql", $adminuser, $adminpass); + &sqlOpenDB( "mysql", "mysql", $adminuser, $adminpass ); my $database_exists = 0; - foreach $database (&sqlRawReturn("SHOW DATABASES")) { - $database_exists++ if $database eq $param{DBName}; + foreach $database ( &sqlRawReturn("SHOW DATABASES") ) { + $database_exists++ if $database eq $param{DBName}; } if ($database_exists) { - &status("Database '$param{DBName}' already exists. Continuing..."); - } else { - &status("Creating db ..."); - &sqlRaw("create(database)", "CREATE DATABASE $param{DBName}"); + &status("Database '$param{DBName}' already exists. Continuing..."); + } + else { + &status("Creating db ..."); + &sqlRaw( "create(database)", "CREATE DATABASE $param{DBName}" ); } &status("--- Adding user information for user '$param{'SQLUser'}'"); - if (!&sqlSelect("user", "user", { 'user' => &sqlQuote($param{'SQLUser'}) })) { - &status("--- Adding user '$param{'SQLUser'}' $dbname/user table..."); + if ( + !&sqlSelect( + "user", "user", { 'user' => &sqlQuote( $param{'SQLUser'} ) } + ) + ) + { + &status("--- Adding user '$param{'SQLUser'}' $dbname/user table..."); - $query = "INSERT INTO user VALUES ". - "('localhost', '$param{'SQLUser'}', ". - "password('$param{'SQLPass'}'), "; + $query = + "INSERT INTO user VALUES " + . "('localhost', '$param{'SQLUser'}', " + . "password('$param{'SQLPass'}'), "; - $query .= "'Y','Y','Y','Y','Y','Y','N','N','N','N','N','N','N','N')"; + $query .= "'Y','Y','Y','Y','Y','Y','N','N','N','N','N','N','N','N')"; - &sqlRaw("create(user)", $query); - } else { - &status("... user information already present."); + &sqlRaw( "create(user)", $query ); + } + else { + &status("... user information already present."); } - if (!&sqlSelect("db", "db", { 'db' => &sqlQuote($param{'SQLUser'}) })) { - &status("--- Adding database information for database '$dbname'."); + if ( !&sqlSelect( "db", "db", { 'db' => &sqlQuote( $param{'SQLUser'} ) } ) ) + { + &status("--- Adding database information for database '$dbname'."); - $query = "INSERT INTO db VALUES ". - "('localhost', '$dbname', ". - "'$param{'SQLUser'}', "; + $query = + "INSERT INTO db VALUES " + . "('localhost', '$dbname', " + . "'$param{'SQLUser'}', "; - $query .= "'Y','Y','Y','Y','Y','Y','Y','N','N','N')"; + $query .= "'Y','Y','Y','Y','Y','Y','Y','N','N','N')"; - &sqlRaw("create(db)", $query); - } else { - &status("... db info already present."); + &sqlRaw( "create(db)", $query ); + } + else { + &status("... db info already present."); } # flush. &status("Flushing privileges..."); $query = "FLUSH PRIVILEGES"; - &sqlRaw("mysql(flush)", $query); + &sqlRaw( "mysql(flush)", $query ); } &status("Done."); diff --git a/src/CLI/Support.pl b/src/CLI/Support.pl index 33034a3..849e438 100644 --- a/src/CLI/Support.pl +++ b/src/CLI/Support.pl @@ -11,54 +11,56 @@ my $postprocess; use vars qw($uh $message); sub cliloop { - &status("Using CLI..."); - &status("Now type what you want."); + &status('Using CLI...'); + &status('Now type what you want.'); - $nuh = "local!local\@local"; - $uh = "local\@local"; - $who = 'local'; + $nuh = "local!local\@local"; + $uh = "local\@local"; + $who = 'local'; $orig{who} = 'local'; - $ident = $param{'ircUser'}; - $chan = $talkchannel = "_local"; + $ident = $param{'ircUser'}; + $chan = $talkchannel = '_local'; $addressed = 1; - $msgType = 'private'; - $host = 'local'; + $msgType = 'private'; + $host = 'local'; # install libterm-readline-gnu-perl to get history support use Term::ReadLine; - my $term = new Term::ReadLine 'infobot'; + my $term = new Term::ReadLine 'infobot'; my $prompt = "$who> "; + #$OUT = $term->OUT || STDOUT; - while ( defined ($_ = $term->readline($prompt)) ) { - $orig{message} = $_; - $message = $_; - chomp $message; - last if ($message =~ m/^quit$/); - $_ = &process() if $message; + while ( defined( $_ = $term->readline($prompt) ) ) { + $orig{message} = $_; + $message = $_; + chomp $message; + last if ( $message =~ m/^quit$/ ); + $_ = &process() if $message; } &doExit(); } sub msg { - my ($nick, $msg) = @_; - if (!defined $nick) { - &ERROR("msg: nick == NULL."); - return; + my ( $nick, $msg ) = @_; + if ( !defined $nick ) { + &ERROR('msg: nick == NULL.'); + return; } - if (!defined $msg) { - $msg ||= 'NULL'; - &WARN("msg: msg == $msg."); - return; + if ( !defined $msg ) { + $msg ||= 'NULL'; + &WARN("msg: msg == $msg."); + return; } - if ( $postprocess ) { - undef $postprocess; - } elsif ($postprocess = &getChanConf('postprocess', $talkchannel)) { - &DEBUG("say: $postprocess $msg"); - &parseCmdHook($postprocess . ' ' . $msg); - undef $postprocess; - return; + if ($postprocess) { + undef $postprocess; + } + elsif ( $postprocess = &getChanConf( 'postprocess', $talkchannel ) ) { + &DEBUG("say: $postprocess $msg"); + &parseCmdHook( $postprocess . ' ' . $msg ); + undef $postprocess; + return; } &status(">$nick< $msg"); @@ -68,36 +70,36 @@ sub msg { # Usage: &action(nick || chan, txt); sub action { - my ($target, $txt) = @_; - if (!defined $txt) { - &WARN("action: txt == NULL."); - return; + my ( $target, $txt ) = @_; + if ( !defined $txt ) { + &WARN('action: txt == NULL.'); + return; } - if (length $txt > 480) { - &status("action: txt too long; truncating."); - chop($txt) while (length $txt > 480); + if ( length $txt > 480 ) { + &status('action: txt too long; truncating.'); + chop($txt) while ( length $txt > 480 ); } &status("* $ident/$target $txt"); } sub IsNickInChan { - my ($nick,$chan) = @_; + my ( $nick, $chan ) = @_; return 1; } sub performStrictReply { - &msg($who, @_); + &msg( $who, @_ ); } sub performReply { - &msg($who, @_); + &msg( $who, @_ ); } sub performAddressedReply { return unless ($addressed); - &msg($who, @_); + &msg( $who, @_ ); } 1; diff --git a/src/CommandStubs.pl b/src/CommandStubs.pl index 4a3fb57..d3c4e4d 100644 --- a/src/CommandStubs.pl +++ b/src/CommandStubs.pl @@ -25,14 +25,14 @@ use vars qw($total $x $type $i $good %wingateToDo); ### sub addCmdHook { - my ($ident, %hash) = @_; + my ( $ident, %hash ) = @_; - if (exists $cmdhooks{$ident}) { - &WARN("aCH: \$cmdhooks{$ident} already exists."); - return; + if ( exists $cmdhooks{$ident} ) { + &WARN("aCH: \$cmdhooks{$ident} already exists."); + return; } - &VERB("aCH: added $ident",2); # use $hash{'Identifier'}? + &VERB( "aCH: added $ident", 2 ); # use $hash{'Identifier'}? ### hrm... prevent warnings? $cmdhooks{$ident} = \%hash; } @@ -40,113 +40,119 @@ sub addCmdHook { # RUN IF ADDRESSED. sub parseCmdHook { my ($line) = @_; - $line =~ s/^\s+|\s+$//g; # again. + $line =~ s/^\s+|\s+$//g; # again. $line =~ /^(\S+)(\s+(.*))?$/; - my $cmd = $1; # command name is whitespaceless. - my $flatarg = $3; - my @args = split(/\s+/, $flatarg || ''); - my $done = 0; + my $cmd = $1; # command name is whitespaceless. + my $flatarg = $3; + my @args = split( /\s+/, $flatarg || '' ); + my $done = 0; &shmFlush(); - if (!defined %cmdhooks) { - &WARN('%cmdhooks does not exist.'); - return 0; + if ( !defined %cmdhooks ) { + &WARN('%cmdhooks does not exist.'); + return 0; + } + + if ( !defined $cmd ) { + &WARN('cstubs: cmd == NULL.'); + return 0; } - if (!defined $cmd) { - &WARN('cstubs: cmd == NULL.'); - return 0; - } - - foreach (keys %cmdhooks) { - # rename to something else! like $id or $label? - my $ident = $_; - - next unless ($cmd =~ /^$ident$/i); + foreach ( keys %cmdhooks ) { - if ($done) { - &WARN("pCH: Multiple hook match: $ident"); - next; - } + # rename to something else! like $id or $label? + my $ident = $_; - &status("cmdhooks: $cmd matched '$ident' '$flatarg'"); - my %hash = %{ $cmdhooks{$ident} }; + next unless ( $cmd =~ /^$ident$/i ); - if (!scalar keys %hash) { - &WARN('CmdHook: hash is NULL?'); - return 1; - } + if ($done) { + &WARN("pCH: Multiple hook match: $ident"); + next; + } - if ($hash{NoArgs} and $flatarg) { - &DEBUG("cmd $ident does not take args ('$flatarg'); skipping."); - next; - } + &status("cmdhooks: $cmd matched '$ident' '$flatarg'"); + my %hash = %{ $cmdhooks{$ident} }; - if (!exists $hash{CODEREF}) { - &ERROR("CODEREF undefined for $cmd or $ident."); - return 1; - } + if ( !scalar keys %hash ) { + &WARN('CmdHook: hash is NULL?'); + return 1; + } - ### DEBUG. - foreach (keys %hash) { - &VERB(" $cmd->$_ => '$hash{$_}'.",2); - } + if ( $hash{NoArgs} and $flatarg ) { + &DEBUG("cmd $ident does not take args ('$flatarg'); skipping."); + next; + } - ### HELP. - if (exists $hash{'Help'} and !scalar(@args)) { - &help( $hash{'Help'} ); - return 1; - } + if ( !exists $hash{CODEREF} ) { + &ERROR("CODEREF undefined for $cmd or $ident."); + return 1; + } - ### IDENTIFIER. - if (exists $hash{'Identifier'}) { - return 1 unless (&IsChanConfOrWarn($hash{'Identifier'})); - } + ### DEBUG. + foreach ( keys %hash ) { + &VERB( " $cmd->$_ => '$hash{$_}'.", 2 ); + } - ### USER FLAGS. - if (exists $hash{'UserFlag'}) { - return 1 unless (&hasFlag($hash{'UserFlag'})); - } + ### HELP. + if ( exists $hash{'Help'} and !scalar(@args) ) { + &help( $hash{'Help'} ); + return 1; + } - ### FORKER,IDENTIFIER,CODEREF. - if (($$ == $bot_pid) && exists $hash{'Forker'}) { - if (exists $hash{'ArrayArgs'}) { - &Forker($hash{'Identifier'}, sub { \&{ $hash{'CODEREF'} }(@args) } ); - } else { - &Forker($hash{'Identifier'}, sub { \&{ $hash{'CODEREF'} }($flatarg) } ); - } + ### IDENTIFIER. + if ( exists $hash{'Identifier'} ) { + return 1 unless ( &IsChanConfOrWarn( $hash{'Identifier'} ) ); + } - } else { - if (exists $hash{'Module'}) { - &loadMyModule($hash{'Module'}); - } + ### USER FLAGS. + if ( exists $hash{'UserFlag'} ) { + return 1 unless ( &hasFlag( $hash{'UserFlag'} ) ); + } - # check if CODEREF exists. - if (!defined &{ $hash{'CODEREF'} }) { - &WARN("coderef $hash{'CODEREF'} does not exist."); - if (defined $who) { - &msg($who, "coderef does not exist for $ident."); - } + ### FORKER,IDENTIFIER,CODEREF. + if ( ( $$ == $bot_pid ) && exists $hash{'Forker'} ) { + if ( exists $hash{'ArrayArgs'} ) { + &Forker( $hash{'Identifier'}, + sub { \&{ $hash{'CODEREF'} }(@args) } ); + } + else { + &Forker( $hash{'Identifier'}, + sub { \&{ $hash{'CODEREF'} }($flatarg) } ); + } - return 1; - } + } + else { + if ( exists $hash{'Module'} ) { + &loadMyModule( $hash{'Module'} ); + } - if (exists $hash{'ArrayArgs'}) { - &{ $hash{'CODEREF'} }(@args); - } else { - &{ $hash{'CODEREF'} }($flatarg); - } - } + # check if CODEREF exists. + if ( !defined &{ $hash{'CODEREF'} } ) { + &WARN("coderef $hash{'CODEREF'} does not exist."); + if ( defined $who ) { + &msg( $who, "coderef does not exist for $ident." ); + } - ### CMDSTATS. - if (exists $hash{'Cmdstats'}) { - $cmdstats{ $hash{'Cmdstats'} }++; - } + return 1; + } - &VERB('hooks: End of command.',2); + if ( exists $hash{'ArrayArgs'} ) { + &{ $hash{'CODEREF'} }(@args); + } + else { + &{ $hash{'CODEREF'} }($flatarg); + } + } - $done = 1; + ### CMDSTATS. + if ( exists $hash{'Cmdstats'} ) { + $cmdstats{ $hash{'Cmdstats'} }++; + } + + &VERB( 'hooks: End of command.', 2 ); + + $done = 1; } return 1 if ($done); @@ -154,141 +160,150 @@ sub parseCmdHook { } sub Modules { - if (!defined $message) { - &WARN('Modules: message is undefined. should never happen.'); - return; + if ( !defined $message ) { + &WARN('Modules: message is undefined. should never happen.'); + return; } - my $debiancmd = 'conflicts?|depends?|desc|file|(?:d)?info|provides?'; - $debiancmd .= '|recommends?|suggests?|maint|maintainer'; + my $debiancmd = 'conflicts?|depends?|desc|file|(?:d)?info|provides?'; + $debiancmd .= '|recommends?|suggests?|maint|maintainer'; - if ($message =~ /^($debiancmd)(\s+(.*))?$/i) { - return unless (&IsChanConfOrWarn('Debian')); - my $package = lc $3; + if ( $message =~ /^($debiancmd)(\s+(.*))?$/i ) { + return unless ( &IsChanConfOrWarn('Debian') ); + my $package = lc $3; - if (defined $package) { - &Forker('Debian', sub { &Debian::infoPackages($1, $package); } ); - } else { - &help($1); - } + if ( defined $package ) { + &Forker( 'Debian', sub { &Debian::infoPackages( $1, $package ); } ); + } + else { + &help($1); + } - return; + return; } # google searching. Simon++ - my $w3search_regex = 'google'; - if ($message =~ /^(?:search\s+)?($w3search_regex)\s+(?:for\s+)?['"]?(.*?)["']?\s*\?*$/i) { - return unless (&IsChanConfOrWarn('W3Search')); + my $w3search_regex = 'google'; + if ( $message =~ + /^(?:search\s+)?($w3search_regex)\s+(?:for\s+)?['"]?(.*?)["']?\s*\?*$/i + ) + { + return unless ( &IsChanConfOrWarn('W3Search') ); - &Forker('W3Search', sub { &W3Search::W3Search($1,$2); } ); + &Forker( 'W3Search', sub { &W3Search::W3Search( $1, $2 ); } ); - $cmdstats{'W3Search'}++; - return; + $cmdstats{'W3Search'}++; + return; } # text counters. (eg: hehstats) my $itc; $itc = &getChanConf('ircTextCounters'); $itc = &findChanConf('ircTextCounters') unless ($itc); - return if ($itc && &do_text_counters($itc) == 1); + return if ( $itc && &do_text_counters($itc) == 1 ); + # end of text counters. # list{keys|values}. xk++. Idea taken from #linuxwarez@EFNET - if ($message =~ /^list(\S+)(\s+(.*))?$/i) { - return unless (&IsChanConfOrWarn('Search')); + if ( $message =~ /^list(\S+)(\s+(.*))?$/i ) { + return unless ( &IsChanConfOrWarn('Search') ); - my $thiscmd = lc $1; - my $args = $3 || ''; + my $thiscmd = lc $1; + my $args = $3 || ''; - $thiscmd =~ s/^vals$/values/; - return if ($thiscmd ne 'keys' && $thiscmd ne 'values'); + $thiscmd =~ s/^vals$/values/; + return if ( $thiscmd ne 'keys' && $thiscmd ne 'values' ); - # Usage: - if (!defined $args or $args =~ /^\s*$/) { - &help('list'. $thiscmd); - return; - } + # Usage: + if ( !defined $args or $args =~ /^\s*$/ ) { + &help( 'list' . $thiscmd ); + return; + } - # suggested by asuffield and \broken. - if ($args =~ /^["']/ and $args =~ /["']$/) { - &DEBUG('list*: removed quotes.'); - $args =~ s/^["']|["']$//g; - } + # suggested by asuffield and \broken. + if ( $args =~ /^["']/ and $args =~ /["']$/ ) { + &DEBUG('list*: removed quotes.'); + $args =~ s/^["']|["']$//g; + } - if (length $args < 2 && &IsFlag('o') ne 'o') { - &msg($who, 'search string is too short.'); - return; - } + if ( length $args < 2 && &IsFlag('o') ne 'o' ) { + &msg( $who, 'search string is too short.' ); + return; + } - &Forker('Search', sub { &Search::Search($thiscmd, $args); } ); + &Forker( 'Search', sub { &Search::Search( $thiscmd, $args ); } ); - $cmdstats{'Factoid Search'}++; - return; + $cmdstats{'Factoid Search'}++; + return; } # Topic management. xk++ # may want to add a userflags for topic. -xk - if ($message =~ /^topic(\s+(.*))?$/i) { - return unless (&IsChanConfOrWarn('Topic')); - - my $chan = $talkchannel; - my @args = split / /, $2 || ''; - - if (!scalar @args) { - &msg($who,"Try 'help topic'"); - return; - } - - $chan = lc(shift @args) if ($msgType eq 'private'); - my $thiscmd = shift @args; - - # topic over public: - if ($msgType eq 'public' && $thiscmd =~ /^#/) { - &msg($who, 'error: channel argument is not required.'); - &msg($who, "\002Usage\002: topic "); - return; - } - - # topic over private: - if ($msgType eq 'private' && $chan !~ /^#/) { - &msg($who, 'error: channel argument is required.'); - &msg($who, "\002Usage\002: topic #channel "); - return; - } - - if (&validChan($chan) == 0) { - &msg($who,"error: invalid channel \002$chan\002"); - return; - } - - # for semi-outsiders. - if (!&IsNickInChan($who,$chan)) { - &msg($who, "Failed. You ($who) are not in $chan, hey?"); - return; - } - - # now lets do it. - &loadMyModule('Topic'); - &Topic($chan, $thiscmd, join(' ', @args)); - $cmdstats{'Topic'}++; - return; + if ( $message =~ /^topic(\s+(.*))?$/i ) { + return unless ( &IsChanConfOrWarn('Topic') ); + + my $chan = $talkchannel; + my @args = split / /, $2 || ''; + + if ( !scalar @args ) { + &msg( $who, "Try 'help topic'" ); + return; + } + + $chan = lc( shift @args ) if ( $msgType eq 'private' ); + my $thiscmd = shift @args; + + # topic over public: + if ( $msgType eq 'public' && $thiscmd =~ /^#/ ) { + &msg( $who, 'error: channel argument is not required.' ); + &msg( $who, "\002Usage\002: topic " ); + return; + } + + # topic over private: + if ( $msgType eq 'private' && $chan !~ /^#/ ) { + &msg( $who, 'error: channel argument is required.' ); + &msg( $who, "\002Usage\002: topic #channel " ); + return; + } + + if ( &validChan($chan) == 0 ) { + &msg( $who, "error: invalid channel \002$chan\002" ); + return; + } + + # for semi-outsiders. + if ( !&IsNickInChan( $who, $chan ) ) { + &msg( $who, "Failed. You ($who) are not in $chan, hey?" ); + return; + } + + # now lets do it. + &loadMyModule('Topic'); + &Topic( $chan, $thiscmd, join( ' ', @args ) ); + $cmdstats{'Topic'}++; + return; } # wingate. - if ($message =~ /^wingate$/i) { - return unless (&IsChanConfOrWarn('Wingate')); + if ( $message =~ /^wingate$/i ) { + return unless ( &IsChanConfOrWarn('Wingate') ); - my $reply = "Wingate statistics: scanned \002" - .scalar(keys %wingateToDo)."\002 hosts"; - my $queue = scalar(keys %wingateToDo); - if ($queue) { - $reply .= ". I have \002$queue\002 hosts in the queue"; - $reply .= '. Started the scan '.&Time2String(time() - $wingaterun).' ago'; - } + my $reply = + "Wingate statistics: scanned \002" + . scalar( keys %wingateToDo ) + . "\002 hosts"; + my $queue = scalar( keys %wingateToDo ); + if ($queue) { + $reply .= ". I have \002$queue\002 hosts in the queue"; + $reply .= + '. Started the scan ' + . &Time2String( time() - $wingaterun ) . ' ago'; + } - &performStrictReply("$reply."); + &performStrictReply("$reply."); - return; + return; } # do nothing and let the other routines have a go @@ -298,52 +313,58 @@ sub Modules { # Uptime. xk++ sub uptime { my $count = 1; - &msg($who, "- Uptime for $ident -"); - &msg($who, "Now: ". &Time2String(&uptimeNow()) ." running $bot_version"); + &msg( $who, "- Uptime for $ident -" ); + &msg( $who, + 'Now: ' . &Time2String( &uptimeNow() ) . " running $bot_version" ); - foreach (&uptimeGetInfo()) { - /^(\d+)\.\d+ (.*)/; - my $time = &Time2String($1); - my $info = $2; + foreach ( &uptimeGetInfo() ) { + /^(\d+)\.\d+ (.*)/; + my $time = &Time2String($1); + my $info = $2; - &msg($who, "$count: $time $2"); - $count++; + &msg( $who, "$count: $time $2" ); + $count++; } } # seen. sub seen { - my($person) = lc shift; + my ($person) = lc shift; $person =~ s/\?*$//; - if (!defined $person or $person =~ /^$/) { - &help('seen'); + if ( !defined $person or $person =~ /^$/ ) { + &help('seen'); - my $i = &countKeys('seen'); - &msg($who,'there '. &fixPlural('is',$i) ." \002$i\002 ". - 'seen '. &fixPlural('entry',$i) .' that I know of.'); + my $i = &countKeys('seen'); + &msg( $who, + 'there ' + . &fixPlural( 'is', $i ) + . " \002$i\002 " . 'seen ' + . &fixPlural( 'entry', $i ) + . ' that I know of.' ); - return; + return; } my @seen; - &seenFlush(); # very evil hack. oh well, better safe than sorry. + &seenFlush(); # very evil hack. oh well, better safe than sorry. # TODO: convert to &sqlSelectRowHash(); my $select = 'nick,time,channel,host,message'; - if ($person eq 'random') { - @seen = &randKey('seen', $select); - } else { - @seen = &sqlSelect('seen', $select, { nick => $person } ); + if ( $person eq 'random' ) { + @seen = &randKey( 'seen', $select ); + } + else { + @seen = &sqlSelect( 'seen', $select, { nick => $person } ); } - if (scalar @seen < 2) { - foreach (@seen) { - &DEBUG("seen: _ => '$_'."); - } - &performReply("i haven't seen '$person'"); - return; + if ( scalar @seen < 2 ) { + foreach (@seen) { + &DEBUG("seen: _ => '$_'."); + } + &performReply("i haven't seen '$person'"); + return; } # valid seen. @@ -351,29 +372,35 @@ sub seen { ### TODO: multi channel support. may require &IsNick() to return ### all channels or something. - my @chans = &getNickInChans($seen[0]); - if (scalar @chans) { - $reply = "$seen[0] is currently on"; - - foreach (@chans) { - $reply .= ' '.$_; - next unless (exists $userstats{lc $seen[0]}{'Join'}); - $reply .= ' ('.&Time2String(time() - $userstats{lc $seen[0]}{'Join'}).')'; - } - - if (&IsChanConf('seenStats') > 0) { - my $i; - $i = $userstats{lc $seen[0]}{'Count'}; - $reply .= ". Has said a total of \002$i\002 messages" if (defined $i); - $i = $userstats{lc $seen[0]}{'Time'}; - $reply .= '. Is idling for '.&Time2String(time() - $i) if (defined $i); - } - $reply .= ", last said\002:\002 '$seen[4]'."; - } else { - my $howlong = &Time2String(time() - $seen[1]); - $reply = "$seen[0] <$seen[3]> was last seen on IRC ". - "in channel $seen[2], $howlong ago, ". - "saying\002:\002 '$seen[4]'."; + my @chans = &getNickInChans( $seen[0] ); + if ( scalar @chans ) { + $reply = "$seen[0] is currently on"; + + foreach (@chans) { + $reply .= ' ' . $_; + next unless ( exists $userstats{ lc $seen[0] }{'Join'} ); + $reply .= ' (' + . &Time2String( time() - $userstats{ lc $seen[0] }{'Join'} ) + . ')'; + } + + if ( &IsChanConf('seenStats') > 0 ) { + my $i; + $i = $userstats{ lc $seen[0] }{'Count'}; + $reply .= ". Has said a total of \002$i\002 messages" + if ( defined $i ); + $i = $userstats{ lc $seen[0] }{'Time'}; + $reply .= '. Is idling for ' . &Time2String( time() - $i ) + if ( defined $i ); + } + $reply .= ", last said\002:\002 '$seen[4]'."; + } + else { + my $howlong = &Time2String( time() - $seen[1] ); + $reply = + "$seen[0] <$seen[3]> was last seen on IRC " + . "in channel $seen[2], $howlong ago, " + . "saying\002:\002 '$seen[4]'."; } &performStrictReply($reply); @@ -382,26 +409,28 @@ sub seen { # User Information Services. requested by Flugh. sub userinfo { - my ($arg) = join(' ',@_); - - if ($arg =~ /^set(\s+(.*))?$/i) { - $arg = $2; - if (!defined $arg) { - &help('userinfo set'); - return; - } - - &UserInfoSet(split /\s+/, $arg, 2); - } elsif ($arg =~ /^unset(\s+(.*))?$/i) { - $arg = $2; - if (!defined $arg) { - &help('userinfo unset'); - return; - } - - &UserInfoSet($arg, ''); - } else { - &UserInfoGet($arg); + my ($arg) = join( ' ', @_ ); + + if ( $arg =~ /^set(\s+(.*))?$/i ) { + $arg = $2; + if ( !defined $arg ) { + &help('userinfo set'); + return; + } + + &UserInfoSet( split /\s+/, $arg, 2 ); + } + elsif ( $arg =~ /^unset(\s+(.*))?$/i ) { + $arg = $2; + if ( !defined $arg ) { + &help('userinfo unset'); + return; + } + + &UserInfoSet( $arg, '' ); + } + else { + &UserInfoGet($arg); } } @@ -410,90 +439,96 @@ sub cookie { my ($arg) = @_; # lets find that secret cookie. - my $target = ($msgType ne 'public') ? $who : $talkchannel; - my $cookiemsg = &getRandom(keys %{ $lang{'cookie'} }); - my ($key,$value); + my $target = ( $msgType ne 'public' ) ? $who : $talkchannel; + my $cookiemsg = &getRandom( keys %{ $lang{'cookie'} } ); + my ( $key, $value ); ### WILL CHEW TONS OF MEM. ### TODO: convert this to a Forker function! if ($arg) { - my @list = &searchTable('factoids', 'factoid_key', 'factoid_value', $arg); - $key = &getRandom(@list); - $value = &getFactInfo($key, 'factoid_value'); - } else { - ($key,$value) = &randKey('factoids','factoid_key,factoid_value'); + my @list = + &searchTable( 'factoids', 'factoid_key', 'factoid_value', $arg ); + $key = &getRandom(@list); + $value = &getFactInfo( $key, 'factoid_value' ); + } + else { + ( $key, $value ) = &randKey( 'factoids', 'factoid_key,factoid_value' ); } for ($cookiemsg) { - s/##KEY/\002$key\002/; - s/##VALUE/$value/; - s/##WHO/$who/; - s/\$who/$who/; # cheap fix. - s/(\S+)?\s*<\S+>/$1 /; - s/\s+/ /g; + s/##KEY/\002$key\002/; + s/##VALUE/$value/; + s/##WHO/$who/; + s/\$who/$who/; # cheap fix. + s/(\S+)?\s*<\S+>/$1 /; + s/\s+/ /g; } - if ($cookiemsg =~ s/^ACTION //i) { - &action($target, $cookiemsg); - } else { - &msg($target, $cookiemsg); + if ( $cookiemsg =~ s/^ACTION //i ) { + &action( $target, $cookiemsg ); + } + else { + &msg( $target, $cookiemsg ); } } sub convert { - my $arg = join(' ',@_); - my ($from,$to) = ('',''); + my $arg = join( ' ', @_ ); + my ( $from, $to ) = ( '', '' ); - ($from,$to) = ($1,$2) if ($arg =~ /^(.*?) to (.*)$/i); - ($from,$to) = ($2,$1) if ($arg =~ /^(.*?) from (.*)$/i); + ( $from, $to ) = ( $1, $2 ) if ( $arg =~ /^(.*?) to (.*)$/i ); + ( $from, $to ) = ( $2, $1 ) if ( $arg =~ /^(.*?) from (.*)$/i ); - if (!$to or !$from) { - &msg($who, 'Invalid format!'); - &help('convert'); - return; + if ( !$to or !$from ) { + &msg( $who, 'Invalid format!' ); + &help('convert'); + return; } - &Units::convertUnits($from, $to); + &Units::convertUnits( $from, $to ); return; } sub lart { - my ($target) = &fixString($_[0]); - my $extra = 0; - my $chan = $talkchannel; + my ($target) = &fixString( $_[0] ); + my $extra = 0; + my $chan = $talkchannel; my ($for); my $mynick = $conn->nick(); - if ($msgType eq 'private') { - if ($target =~ /^($mask{chan})\s+(.*)$/) { - $chan = $1; - $target = $2; - $extra = 1; - } else { - &msg($who, 'error: invalid format or missing arguments.'); - &help('lart'); - return; - } - } - if ($target =~ /^(.*)(\s+for\s+.*)$/) { - $target = $1; - $for = $2; - } - - my $line = &getRandomLineFromFile($bot_data_dir. '/infobot.lart'); - if (defined $line) { - if ($target =~ /^(me|you|itself|\Q$mynick\E)$/i) { - $line =~ s/WHO/$who/g; - } else { - $line =~ s/WHO/$target/g; - } - $line .= $for if ($for); - $line .= ", courtesy of $who" if ($extra); - - &action($chan, $line); - } else { - &status('lart: error reading file?'); + if ( $msgType eq 'private' ) { + if ( $target =~ /^($mask{chan})\s+(.*)$/ ) { + $chan = $1; + $target = $2; + $extra = 1; + } + else { + &msg( $who, 'error: invalid format or missing arguments.' ); + &help('lart'); + return; + } + } + if ( $target =~ /^(.*)(\s+for\s+.*)$/ ) { + $target = $1; + $for = $2; + } + + my $line = &getRandomLineFromFile( $bot_data_dir . '/infobot.lart' ); + if ( defined $line ) { + if ( $target =~ /^(me|you|itself|\Q$mynick\E)$/i ) { + $line =~ s/WHO/$who/g; + } + else { + $line =~ s/WHO/$target/g; + } + $line .= $for if ($for); + $line .= ", courtesy of $who" if ($extra); + + &action( $chan, $line ); + } + else { + &status('lart: error reading file?'); } } @@ -503,135 +538,143 @@ sub DebianNew { my %pkg; my @new; - $error++ unless ( -e $idx); - $error++ unless ( -e "$idx-old"); + $error++ unless ( -e $idx ); + $error++ unless ( -e "$idx-old" ); if ($error) { - $error = 'no sid/sid-old index file found.'; - &ERROR("Debian: $error"); - &msg($who, $error); - return; + $error = 'no sid/sid-old index file found.'; + &ERROR("Debian: $error"); + &msg( $who, $error ); + return; } - open(IDX1, $idx); - open(IDX2, "$idx-old"); + open( IDX1, $idx ); + open( IDX2, "$idx-old" ); while () { - chop; - next if (/^\*/); + chop; + next if (/^\*/); - $pkg{$_} = 1; + $pkg{$_} = 1; } close IDX2; - open(IDX1,$idx); + open( IDX1, $idx ); while () { - chop; - next if (/^\*/); - next if (exists $pkg{$_}); + chop; + next if (/^\*/); + next if ( exists $pkg{$_} ); - push(@new, $_); + push( @new, $_ ); } close IDX1; - &::performStrictReply( &::formListReply(0, 'New debian packages:', @new) ); + &::performStrictReply( + &::formListReply( 0, 'New debian packages:', @new ) ); } sub do_verstats { - my ($chan) = @_; - - if (!defined $chan) { - &help('verstats'); - return; - } - - if (!&validChan($chan)) { - &msg($who, "chan $chan is invalid."); - return; - } - - if (scalar @vernick > scalar(keys %{ $channels{lc $chan}{''} })/4) { - &msg($who, 'verstats already in progress for someone else.'); - return; - } - - &msg($who, "Sending CTCP VERSION to $chan; results in 60s."); - $conn->ctcp('VERSION', $chan); - $cache{verstats}{chan} = $chan; - $cache{verstats}{who} = $who; - $cache{verstats}{msgType} = $msgType; - - $conn->schedule(30, sub { - my $c = lc $cache{verstats}{chan}; - @vernicktodo = (); - - foreach (keys %{ $channels{$c}{''} } ) { - next if (grep /^\Q$_\E$/i, @vernick); - push(@vernicktodo, $_); - } - - &verstats_flush(); - } ); - - $conn->schedule(60, sub { - my $vtotal = 0; - my $c = lc $cache{verstats}{chan}; - my $total = keys %{ $channels{$c}{''} }; - $chan = $c; - $who = $cache{verstats}{who}; - $msgType = $cache{verstats}{msgType}; - delete $cache{verstats}; # sufficient? - - foreach (keys %ver) { - $vtotal += scalar keys %{ $ver{$_} }; - } - - my %sorted; - my $unknown = $total - $vtotal; - my $perc = sprintf("%.1f", $unknown * 100 / $total); - $perc =~ s/.0$//; - $sorted{$perc}{'unknown/cloak'} = "$unknown ($perc%)" if ($unknown); - - foreach (keys %ver) { - my $count = scalar keys %{ $ver{$_} }; - $perc = sprintf("%.01f", $count * 100 / $total); - $perc =~ s/.0$//; # lame compression. - - $sorted{$perc}{$_} = "$count ($perc%)"; - } - - ### can be compressed to a map? - my @list; - foreach ( sort { $b <=> $a } keys %sorted ) { - my $perc = $_; - foreach (sort keys %{ $sorted{$perc} }) { - push(@list, "$_ - $sorted{$perc}{$_}"); - } - } - - # hack. this is one major downside to scheduling. - $chan = $c; - &performStrictReply( &formListReply(0, "IRC Client versions for $c ", @list) ); - - # clean up not-needed data structures. - undef %ver; - undef @vernick; - } ); + my ($chan) = @_; + + if ( !defined $chan ) { + &help('verstats'); + return; + } + + if ( !&validChan($chan) ) { + &msg( $who, "chan $chan is invalid." ); + return; + } + + if ( scalar @vernick > scalar( keys %{ $channels{ lc $chan }{''} } ) / 4 ) { + &msg( $who, 'verstats already in progress for someone else.' ); + return; + } + + &msg( $who, "Sending CTCP VERSION to $chan; results in 60s." ); + $conn->ctcp( 'VERSION', $chan ); + $cache{verstats}{chan} = $chan; + $cache{verstats}{who} = $who; + $cache{verstats}{msgType} = $msgType; + + $conn->schedule( + 30, + sub { + my $c = lc $cache{verstats}{chan}; + @vernicktodo = (); + + foreach ( keys %{ $channels{$c}{''} } ) { + next if ( grep /^\Q$_\E$/i, @vernick ); + push( @vernicktodo, $_ ); + } + + &verstats_flush(); + } + ); + + $conn->schedule( + 60, + sub { + my $vtotal = 0; + my $c = lc $cache{verstats}{chan}; + my $total = keys %{ $channels{$c}{''} }; + $chan = $c; + $who = $cache{verstats}{who}; + $msgType = $cache{verstats}{msgType}; + delete $cache{verstats}; # sufficient? + + foreach ( keys %ver ) { + $vtotal += scalar keys %{ $ver{$_} }; + } + + my %sorted; + my $unknown = $total - $vtotal; + my $perc = sprintf( '%.1f', $unknown * 100 / $total ); + $perc =~ s/.0$//; + $sorted{$perc}{'unknown/cloak'} = "$unknown ($perc%)" if ($unknown); + + foreach ( keys %ver ) { + my $count = scalar keys %{ $ver{$_} }; + $perc = sprintf( '%.01f', $count * 100 / $total ); + $perc =~ s/.0$//; # lame compression. + + $sorted{$perc}{$_} = "$count ($perc%)"; + } + + ### can be compressed to a map? + my @list; + foreach ( sort { $b <=> $a } keys %sorted ) { + my $perc = $_; + foreach ( sort keys %{ $sorted{$perc} } ) { + push( @list, "$_ - $sorted{$perc}{$_}" ); + } + } + + # hack. this is one major downside to scheduling. + $chan = $c; + &performStrictReply( + &formListReply( 0, "IRC Client versions for $c ", @list ) ); + + # clean up not-needed data structures. + undef %ver; + undef @vernick; + } + ); return; } sub verstats_flush { - for (1..5) { - last unless (scalar @vernicktodo); + for ( 1 .. 5 ) { + last unless ( scalar @vernicktodo ); - my $n = shift(@vernicktodo); - $conn->ctcp('VERSION', $n); + my $n = shift(@vernicktodo); + $conn->ctcp( 'VERSION', $n ); } - return unless (scalar @vernicktodo); + return unless ( scalar @vernicktodo ); - $conn->schedule(3, \&verstats_flush() ); + $conn->schedule( 3, \&verstats_flush() ); } sub do_text_counters { @@ -639,100 +682,100 @@ sub do_text_counters { $itc =~ s/([^\w\s])/\\$1/g; my $z = join '|', split ' ', $itc; - if ($msgType eq 'privmsg' and $message =~ / ($mask{chan})$/) { - &DEBUG("ircTC: privmsg detected; chan = $1"); - $chan = $1; + if ( $msgType eq 'privmsg' and $message =~ / ($mask{chan})$/ ) { + &DEBUG("ircTC: privmsg detected; chan = $1"); + $chan = $1; } - my ($type,$arg); - if ($message =~ /^($z)stats(\s+(\S+))?$/i) { - $type = $1; - $arg = $3; - } else { - return 0; + my ( $type, $arg ); + if ( $message =~ /^($z)stats(\s+(\S+))?$/i ) { + $type = $1; + $arg = $3; + } + else { + return 0; } - my $c = $chan || 'PRIVATE'; + my $c = $chan || 'PRIVATE'; # Define various types of stats in one place. # Note: sqlSelectColHash has built in sqlQuote - my $where_chan_type = { channel => $c, type => $type }; - my $where_chan_type_nick = { channel => $c, type => $type, nick => $arg}; - - my $sum = (&sqlSelect('stats', 'SUM(counter)', $where_chan_type))[0]; - - if (!defined $arg or $arg =~ /^\s*$/) { - - # get top 3 stats of $type in $chan - my %hash = &sqlSelectColHash('stats', 'nick,counter', - $where_chan_type, - 'ORDER BY counter DESC LIMIT 3', 1 - ); - my $i; - my @top; - - # unfortunately we have to sort it again! - my $tp = 0; - foreach $i (sort { $b <=> $a } keys %hash) { - foreach (keys %{ $hash{$i} }) { - my $p = sprintf("%.01f", 100*$i/$sum); - $tp += $p; - push(@top, "\002$_\002 -- $i ($p%)"); - } - } - my $topstr = ''; - if (scalar @top) { - $topstr = '. Top '.scalar(@top).': '.join(', ', @top); - } - - if (defined $sum) { - &performStrictReply("total count of \037$type\037 on \002$c\002: $sum$topstr"); - } else { - &performStrictReply("zero counter for \037$type\037."); - } - } else { - my $x = (&sqlSelect('stats', 'SUM(counter)', $where_chan_type_nick))[0]; - - if (!defined $x) { # If no stats were found - &performStrictReply("$arg has not said $type yet."); - return 1; - } - - # Get list of all nicks for channel $c and $type - my @array = &sqlSelectColArray('stats', 'nick', - $where_chan_type, - 'ORDER BY counter DESC' - ); - - my $total = scalar(@array); - my $rank; - # Find position of nick $arg in the list - for (my $i=0; $i < $total; $i++) { - next unless ($array[$i] =~ /^\Q$arg\E$/); - $rank = $i + 1; - last; - } - - my $xtra; - if ($total and $rank) { - my $pct = sprintf("%.01f", 100*($rank)/$total); - $xtra = ", ranked $rank\002/\002$total (percentile: \002$pct\002 %)"; - } - - my $pct1 = sprintf("%.01f", 100*$x/$sum); - &performStrictReply("\002$arg\002 has said \037$type\037 \002$x\002 times (\002$pct1\002 %)$xtra"); + my $where_chan_type = { channel => $c, type => $type }; + my $where_chan_type_nick = { channel => $c, type => $type, nick => $arg }; + + my $sum = ( &sqlSelect( 'stats', 'SUM(counter)', $where_chan_type ) )[0]; + + if ( !defined $arg or $arg =~ /^\s*$/ ) { + + # get top 3 stats of $type in $chan + my %hash = + &sqlSelectColHash( 'stats', 'nick,counter', $where_chan_type, + 'ORDER BY counter DESC LIMIT 3', 1 ); + my $i; + my @top; + + # unfortunately we have to sort it again! + my $tp = 0; + foreach $i ( sort { $b <=> $a } keys %hash ) { + foreach ( keys %{ $hash{$i} } ) { + my $p = sprintf( '%.01f', 100 * $i / $sum ); + $tp += $p; + push( @top, "\002$_\002 -- $i ($p%)" ); + } + } + my $topstr = ''; + if ( scalar @top ) { + $topstr = '. Top ' . scalar(@top) . ': ' . join( ', ', @top ); + } + + if ( defined $sum ) { + &performStrictReply( + "total count of \037$type\037 on \002$c\002: $sum$topstr"); + } + else { + &performStrictReply("zero counter for \037$type\037."); + } + } + else { + my $x = + ( &sqlSelect( 'stats', 'SUM(counter)', $where_chan_type_nick ) )[0]; + + if ( !defined $x ) { # If no stats were found + &performStrictReply("$arg has not said $type yet."); + return 1; + } + + # Get list of all nicks for channel $c and $type + my @array = + &sqlSelectColArray( 'stats', 'nick', $where_chan_type, + 'ORDER BY counter DESC' ); + + my $total = scalar(@array); + my $rank; + + # Find position of nick $arg in the list + for ( my $i = 0 ; $i < $total ; $i++ ) { + next unless ( $array[$i] =~ /^\Q$arg\E$/ ); + $rank = $i + 1; + last; + } + + my $xtra; + if ( $total and $rank ) { + my $pct = sprintf( '%.01f', 100 * ($rank) / $total ); + $xtra = + ", ranked $rank\002/\002$total (percentile: \002$pct\002 %)"; + } + + my $pct1 = sprintf( '%.01f', 100 * $x / $sum ); + &performStrictReply( +"\002$arg\002 has said \037$type\037 \002$x\002 times (\002$pct1\002 %)$xtra" + ); } return 1; } -sub nullski { - my ($arg) = @_; - return unless (defined $arg); - # big security hole - #foreach (`$arg`) { &msg($who,$_); } -} - %cmdhooks=(); ### ### START ADDING HOOKS. @@ -776,14 +819,13 @@ sub nullski { &addCmdHook('metar', ('CODEREF' => 'Weather::Metar', 'Identifier' => 'Weather', 'Help' => 'weather', 'Cmdstats' => 'Weather', 'Forker' => 1) ); &addCmdHook('News', ('CODEREF' => 'News::Parse', Module => 'News', 'Cmdstats' => 'News', 'Identifier' => 'News' ) ); &addCmdHook('(?:nick|lame)ometer(?: for)?', ('CODEREF' => 'nickometer::query', 'Identifier' => 'nickometer', 'Cmdstats' => 'nickometer', 'Forker' => 1) ); -&addCmdHook('nullski', ('CODEREF' => 'nullski', ) ); +&addCmdHook('OnJoin', ('CODEREF' => 'Cmdonjoin', 'Identifier' => 'OnJoin', 'Module' => 'OnJoin') ); &addCmdHook('page', ('CODEREF' => 'pager::page', 'Identifier' => 'pager', 'Cmdstats' => 'pager', 'Forker' => 1, 'Help' => 'page') ); &addCmdHook('piglatin', ('CODEREF' => 'piglatin::piglatin', 'Identifier' => 'piglatin', 'Cmdstats' => 'piglatin', 'Forker' => 1) ); &addCmdHook('Plug', ('CODEREF' => 'Plug::Plug', 'Identifier' => 'Plug', 'Forker' => 1, 'Cmdstats' => 'Plug') ); &addCmdHook('quote', ('CODEREF' => 'Quote::Quote', 'Forker' => 1, 'Identifier' => 'Quote', 'Help' => 'quote', 'Cmdstats' => 'Quote') ); &addCmdHook('reverse', ('CODEREF' => 'reverse::reverse', 'Identifier' => 'reverse', 'Cmdstats' => 'reverse', 'Forker' => 1, 'Module' => 'reverse') ); &addCmdHook('RootWarn', ('CODEREF' => 'CmdrootWarn', 'Identifier' => 'RootWarn', 'Module' => 'RootWarn') ); -&addCmdHook('OnJoin', ('CODEREF' => 'Cmdonjoin', 'Identifier' => 'OnJoin', 'Module' => 'OnJoin') ); &addCmdHook('Rss', ('CODEREF' => 'Rss::Rss', 'Identifier' => 'Rss', 'Cmdstats' => 'Rss', 'Forker' => 1, 'Help' => 'rss') ); &addCmdHook('RSSFeeds',('CODEREF' => 'RSSFeeds::RSS', 'Identifier' => 'RSSFeeds', 'Forker' => 1, 'Help' => 'rssfeeds', 'Cmdstats' => 'RSSFeeds', 'Module' => 'RSSFeeds') ); &addCmdHook('sched(stats|info)', ('CODEREF' => 'scheduleList', ) ); @@ -792,6 +834,7 @@ sub nullski { &addCmdHook('slashdot', ('CODEREF' => 'Slashdot::Slashdot', 'Identifier' => 'slashdot', 'Forker' => 1, 'Cmdstats' => 'slashdot') ); &addCmdHook('tell|explain', ('CODEREF' => 'tell', Help => 'tell', Identifier => 'allowTelling', Cmdstats => 'Tell') ); &addCmdHook('uc', ('CODEREF' => 'case::upper', 'Identifier' => 'case', 'Cmdstats' => 'case', 'Forker' => 1, 'Module' => 'case') ); +&addCmdHook('upsidedown', ('CODEREF' => 'upsidedown::upsidedown', 'Identifier' => 'upsidedown', 'Cmdstats' => 'upsidedown', 'Forker' => 1, 'Module' => 'upsidedown') ); &addCmdHook('Uptime', ('CODEREF' => 'uptime', 'Identifier' => 'Uptime', 'Cmdstats' => 'Uptime') ); &addCmdHook('u(ser)?info', ('CODEREF' => 'userinfo', 'Identifier' => 'UserInfo', 'Help' => 'userinfo', 'Module' => 'UserInfo') ); &addCmdHook('verstats', ('CODEREF' => 'do_verstats' ) ); @@ -805,7 +848,7 @@ sub nullski { ### END OF ADDING HOOKS. ### -&status('loaded '.scalar(keys %cmdhooks).' command hooks.'); +&status( 'loaded ' . scalar( keys %cmdhooks ) . ' command hooks.' ); 1; diff --git a/src/DynaConfig.pl b/src/DynaConfig.pl index 4bdcf99..6f4de07 100644 --- a/src/DynaConfig.pl +++ b/src/DynaConfig.pl @@ -9,11 +9,31 @@ use strict; use vars qw(%chanconf %cache %bans %channels %nuh %users %ignore - %talkWho %dcc %mask); + %talkWho %dcc %mask); use vars qw($utime_userfile $ucount_userfile $utime_chanfile $who - $ucount_chanfile $userHandle $chan $msgType $talkchannel - $ident $bot_state_dir $talkWho $flag_quit $wtime_userfile - $wcount_userfile $wtime_chanfile $nuh $message); + $ucount_chanfile $userHandle $chan $msgType $talkchannel + $ident $bot_state_dir $talkWho $flag_quit $wtime_userfile + $wcount_userfile $wtime_chanfile $nuh $message); + +my @regFlagsUser = ( + + # possible chars to include in FLAG + 'A', # bot administration over /msg + # default is only via DCC CHAT + 'O', # dynamic ops (as on channel). (automatic +o) + 'T', # add topics. + 'a', # ask/request factoid. + 'm', # modify all factoids. (includes renaming) + 'M', # modify own factoids. (includes renaming) + 'n', # bot owner, can 'reload' + 'o', # master of bot (automatic +amrt) + # can search on factoid strings shorter than 2 chars + # can tell bot to join new channels + # can [un]lock factoids + 'r', # remove factoid. + 't', # teach/add factoid. + 's', # Bypass +silent on channels +); ##### ##### USERFILE CONFIGURATION READER/WRITER @@ -25,211 +45,229 @@ sub readUserFile { $f = "$bot_state_dir/blootbot.users"; } - if (! -f $f) { - &DEBUG("userfile not found; new fresh run detected."); - return; + if ( !-f $f ) { + &DEBUG('userfile not found; new fresh run detected.'); + return; } - if ( -f $f and -f "$f~") { - my $s1 = -s $f; - my $s2 = -s "$f~"; + if ( -f $f and -f "$f~" ) { + my $s1 = -s $f; + my $s2 = -s "$f~"; - if ($s2 > $s1*3) { - &FIXME("rUF: backup file bigger than current file."); - } + if ( $s2 > $s1 * 3 ) { + &FIXME('rUF: backup file bigger than current file.'); + } } - if (!open IN, $f) { - &ERROR("Cannot read userfile ($f): $!"); - &closeLog(); - exit 1; + if ( !open IN, $f ) { + &ERROR("Cannot read userfile ($f): $!"); + &closeLog(); + exit 1; } - undef %users; # clear on reload. - undef %bans; # reset. - undef %ignore; # reset. + undef %users; # clear on reload. + undef %bans; # reset. + undef %ignore; # reset. my $ver = ; - if ($ver !~ /^#v1/) { - &ERROR("old or invalid user file found."); - &closeLog(); - exit 1; # correct? + if ( $ver !~ /^#v1/ ) { + &ERROR('old or invalid user file found.'); + &closeLog(); + exit 1; # correct? } my $nick; my $type; while () { - chop; - - next if /^$/; - next if /^#/; - - if (/^--(\S+)[\s\t]+(.*)$/) { # user: middle entry. - my ($what,$val) = ($1,$2); - - if (!defined $val or $val eq '') { - &WARN("$what: val == NULL."); - next; - } - - if (!defined $nick) { - &WARN("DynaConfig: invalid line: $_"); - next; - } - - # nice little hack. - if ($what eq 'HOSTS') { - $users{$nick}{$what}{$val} = 1; - } else { - $users{$nick}{$what} = $val; - } - - } elsif (/^(\S+)$/) { # user: start entry. - $nick = $1; - - } elsif (/^::(\S+) ignore$/) { # ignore: start entry. - $chan = $1; - $type = 'ignore'; - - } elsif (/^- (\S+):\+(\d+):\+(\d+):(\S+):(.*)$/ and $type eq 'ignore') { - ### ignore: middle entry. - my $mask = $1; - my(@array) = ($2,$3,$4,$5); - ### DEBUG purposes only! - if ($mask !~ /^$mask{nuh}$/) { - &WARN("ignore: mask $mask is invalid."); - next; - } - $ignore{$chan}{$mask} = \@array; - - } elsif (/^::(\S+) bans$/) { # bans: start entry. - $chan = $1; - $type = 'bans'; - - } elsif (/^- (\S+):\+(\d+):\+(\d+):(\d+):(\S+):(.*)$/ and $type eq 'bans') { - ### bans: middle entry. - # $btime, $atime, $count, $whoby, $reason. - my(@array) = ($2,$3,$4,$5,$6); - $bans{$chan}{$1} = \@array; - - } else { # unknown. - &WARN("unknown line: $_"); - } + chop; + + next if /^$/; + next if /^#/; + + if (/^--(\S+)[\s\t]+(.*)$/) { # user: middle entry. + my ( $what, $val ) = ( $1, $2 ); + + if ( !defined $val or $val eq '' ) { + &WARN("$what: val == NULL."); + next; + } + + if ( !defined $nick ) { + &WARN("DynaConfig: invalid line: $_"); + next; + } + + # nice little hack. + if ( $what eq 'HOSTS' ) { + $users{$nick}{$what}{$val} = 1; + } + else { + $users{$nick}{$what} = $val; + } + + } + elsif (/^(\S+)$/) { # user: start entry. + $nick = $1; + + } + elsif (/^::(\S+) ignore$/) { # ignore: start entry. + $chan = $1; + $type = 'ignore'; + + } + elsif ( /^- (\S+):\+(\d+):\+(\d+):(\S+):(.*)$/ and $type eq 'ignore' ) { + ### ignore: middle entry. + my $mask = $1; + my (@array) = ( $2, $3, $4, $5 ); + ### DEBUG purposes only! + if ( $mask !~ /^$mask{nuh}$/ ) { + &WARN("ignore: mask $mask is invalid."); + next; + } + $ignore{$chan}{$mask} = \@array; + + } + elsif (/^::(\S+) bans$/) { # bans: start entry. + $chan = $1; + $type = 'bans'; + + } + elsif ( /^- (\S+):\+(\d+):\+(\d+):(\d+):(\S+):(.*)$/ + and $type eq 'bans' ) + { + ### bans: middle entry. + # $btime, $atime, $count, $whoby, $reason. + my (@array) = ( $2, $3, $4, $5, $6 ); + $bans{$chan}{$1} = \@array; + + } + else { # unknown. + &WARN("unknown line: $_"); + } } close IN; - &status( sprintf("USERFILE: Loaded: %d users, %d bans, %d ignore", - scalar(keys %users)-1, - scalar(keys %bans), # ?? - scalar(keys %ignore), # ?? - ) + &status( + sprintf( + 'USERFILE: Loaded: %d users, %d bans, %d ignore', + scalar( keys %users ) - 1, + scalar( keys %bans ), # ?? + scalar( keys %ignore ), # ?? + ) ); } sub writeUserFile { - if (!scalar keys %users) { - &DEBUG("wUF: nothing to write."); - return; + if ( !scalar keys %users ) { + &DEBUG('wUF: nothing to write.'); + return; } - if (!open OUT,">$bot_state_dir/infobot.users") { - &ERROR("Cannot write userfile ($bot_state_dir/infobot.users): $!"); - return; + if ( !open OUT, ">$bot_state_dir/infobot.users" ) { + &ERROR("Cannot write userfile ($bot_state_dir/infobot.users): $!"); + return; } - my $time = scalar(gmtime); + my $time = scalar(gmtime); print OUT "#v1: infobot -- $ident -- written $time\n\n"; ### USER LIST. - my $cusers = 0; - foreach (sort keys %users) { - my $user = $_; - $cusers++; - my $count = scalar keys %{ $users{$user} }; - if (!$count) { - &WARN("user $user has no other attributes; skipping."); - next; - } - - print OUT "$user\n"; - - foreach (sort keys %{ $users{$user} }) { - my $what = $_; - my $val = $users{$user}{$_}; - - if (ref($val) eq 'HASH') { - foreach (sort keys %{ $users{$user}{$_} }) { - print OUT "--$what\t\t$_\n"; - } - - } elsif ($_ eq 'FLAGS') { - print OUT "--$_\t\t" . join('', sort split('', $val)) . "\n"; - } else { - print OUT "--$_\t\t$val\n"; - } - } - print OUT "\n"; + my $cusers = 0; + foreach ( sort keys %users ) { + my $user = $_; + $cusers++; + my $count = scalar keys %{ $users{$user} }; + if ( !$count ) { + &WARN("user $user has no other attributes; skipping."); + next; + } + + print OUT "$user\n"; + + foreach ( sort keys %{ $users{$user} } ) { + my $what = $_; + my $val = $users{$user}{$_}; + + if ( ref($val) eq 'HASH' ) { + foreach ( sort keys %{ $users{$user}{$_} } ) { + print OUT "--$what\t\t$_\n"; + } + + } + elsif ( $_ eq 'FLAGS' ) { + print OUT "--$_\t\t" + . join( '', sort split( '', $val ) ) . "\n"; + } + else { + print OUT "--$_\t\t$val\n"; + } + } + print OUT "\n"; } ### BAN LIST. - my $cbans = 0; - foreach (keys %bans) { - my $chan = $_; - $cbans++; - - my $count = scalar keys %{ $bans{$chan} }; - if (!$count) { - &WARN("bans: chan $chan has no other attributes; skipping."); - next; - } - - print OUT "::$chan bans\n"; - foreach (keys %{ $bans{$chan} }) { -# format: bans: mask expire time-added count who-added reason - my @array = @{ $bans{$chan}{$_} }; - if (scalar @array != 5) { - &WARN("bans: $chan/$_ is corrupted."); - next; - } - - printf OUT "- %s:+%d:+%d:%d:%s:%s\n", $_, @array; - } + my $cbans = 0; + foreach ( keys %bans ) { + my $chan = $_; + $cbans++; + + my $count = scalar keys %{ $bans{$chan} }; + if ( !$count ) { + &WARN("bans: chan $chan has no other attributes; skipping."); + next; + } + + print OUT "::$chan bans\n"; + foreach ( keys %{ $bans{$chan} } ) { + + # format: bans: mask expire time-added count who-added reason + my @array = @{ $bans{$chan}{$_} }; + if ( scalar @array != 5 ) { + &WARN("bans: $chan/$_ is corrupted."); + next; + } + + printf OUT "- %s:+%d:+%d:%d:%s:%s\n", $_, @array; + } } print OUT "\n" if ($cbans); ### IGNORE LIST. - my $cignore = 0; - foreach (keys %ignore) { - my $chan = $_; - $cignore++; - - my $count = scalar keys %{ $ignore{$chan} }; - if (!$count) { - &WARN("ignore: chan $chan has no other attributes; skipping."); - next; - } - - ### TODO: use hash instead of array for flexibility? - print OUT "::$chan ignore\n"; - foreach (keys %{ $ignore{$chan} }) { -# format: ignore: mask expire time-added who-added reason - my @array = @{ $ignore{$chan}{$_} }; - if (scalar @array != 4) { - &WARN("ignore: $chan/$_ is corrupted."); - next; - } - - printf OUT "- %s:+%d:+%d:%s:%s\n", $_, @array; - } + my $cignore = 0; + foreach ( keys %ignore ) { + my $chan = $_; + $cignore++; + + my $count = scalar keys %{ $ignore{$chan} }; + if ( !$count ) { + &WARN("ignore: chan $chan has no other attributes; skipping."); + next; + } + + ### TODO: use hash instead of array for flexibility? + print OUT "::$chan ignore\n"; + foreach ( keys %{ $ignore{$chan} } ) { + + # format: ignore: mask expire time-added who-added reason + my @array = @{ $ignore{$chan}{$_} }; + if ( scalar @array != 4 ) { + &WARN("ignore: $chan/$_ is corrupted."); + next; + } + + printf OUT "- %s:+%d:+%d:%s:%s\n", $_, @array; + } } close OUT; $wtime_userfile = time(); - &status("--- Saved USERFILE ($cusers users; $cbans bans; $cignore ignore) at $time"); - if (defined $msgType and $msgType =~ /^chat$/) { - &performStrictReply("--- Writing user file..."); + &status( +"--- Saved USERFILE ($cusers users; $cbans bans; $cignore ignore) at $time" + ); + if ( defined $msgType and $msgType =~ /^chat$/ ) { + &performStrictReply('--- Writing user file...'); } } @@ -242,166 +280,177 @@ sub readChanFile { if (-e "$bot_state_dir/infobot.chan" and -e "$bot_state_dir/blootbot.chan") { $f = "$bot_state_dir/blootbot.chan"; } - if ( -f $f and -f "$f~") { - my $s1 = -s $f; - my $s2 = -s "$f~"; + if ( -f $f and -f "$f~" ) { + my $s1 = -s $f; + my $s2 = -s "$f~"; - if ($s2 > $s1*3) { - &FIXME("rCF: backup file bigger than current file."); - } + if ( $s2 > $s1 * 3 ) { + &FIXME('rCF: backup file bigger than current file.'); + } } - if (!open IN, $f) { - &ERROR("Cannot read chanfile ($f): $!"); - return; + if ( !open IN, $f ) { + &ERROR("Cannot read chanfile ($f): $!"); + return; } - undef %chanconf; # reset. + undef %chanconf; # reset. - $_ = ; # version string. + $_ = ; # version string. my $chan; while () { - chop; + chop; - next if /^\s*$/; - next if /^\// or /^\;/; # / or ; are comment lines. + next if /^\s*$/; + next if /^\// or /^\;/; # / or ; are comment lines. - if (/^(\S+)\s*$/) { - $chan = $1; - next; - } - next unless (defined $chan); + if (/^(\S+)\s*$/) { + $chan = $1; + next; + } + next unless ( defined $chan ); - if (/^[\s\t]+\+(\S+)$/) { # bool, true. - $chanconf{$chan}{$1} = 1; + if (/^[\s\t]+\+(\S+)$/) { # bool, true. + $chanconf{$chan}{$1} = 1; - } elsif (/^[\s\t]+\-(\S+)$/) { # bool, false. - # although this is supported in run-time configuration. - $chanconf{$chan}{$1} = 0; + } + elsif (/^[\s\t]+\-(\S+)$/) { # bool, false. + # although this is supported in run-time configuration. + $chanconf{$chan}{$1} = 0; - } elsif (/^[\s\t]+(\S+)[\s\t]+(.*)$/) {# what = val. - $chanconf{$chan}{$1} = $2; + } + elsif (/^[\s\t]+(\S+)[\s\t]+(.*)$/) { # what = val. + $chanconf{$chan}{$1} = $2; - } else { - &WARN("unknown line: $_") unless (/^#/); - } + } + else { + &WARN("unknown line: $_") unless (/^#/); + } } close IN; # verify configuration ### TODO: check against valid params. - foreach $chan (keys %chanconf) { - foreach (keys %{ $chanconf{$chan} }) { - next unless /^[+-]/; + foreach $chan ( keys %chanconf ) { + foreach ( keys %{ $chanconf{$chan} } ) { + next unless /^[+-]/; - &WARN("invalid param: chanconf{$chan}{$_}; removing."); - delete $chanconf{$chan}{$_}; - undef $chanconf{$chan}{$_}; - } + &WARN("invalid param: chanconf{$chan}{$_}; removing."); + delete $chanconf{$chan}{$_}; + undef $chanconf{$chan}{$_}; + } } - &status("CHANFILE: Loaded: ".(scalar(keys %chanconf)-1)." chans"); + &status( + 'CHANFILE: Loaded: ' . ( scalar( keys %chanconf ) - 1 ) . ' chans' ); } sub writeChanFile { - if (!scalar keys %chanconf) { - &DEBUG("wCF: nothing to write."); - return; + if ( !scalar keys %chanconf ) { + &DEBUG('wCF: nothing to write.'); + return; } - if (!open OUT,">$bot_state_dir/infobot.chan") { - &ERROR("Cannot write chanfile ($bot_state_dir/infobot.chan): $!"); - return; + if ( !open OUT, ">$bot_state_dir/infobot.chan" ) { + &ERROR("Cannot write chanfile ($bot_state_dir/infobot.chan): $!"); + return; } - my $time = scalar(gmtime); + my $time = scalar(gmtime); print OUT "#v1: infobot -- $ident -- written $time\n\n"; if ($flag_quit) { - ### Process 1: if defined in _default, remove same definition - ### from non-default channels. - foreach (keys %{ $chanconf{_default} }) { - my $opt = $_; - my $val = $chanconf{_default}{$opt}; - my @chans; - - foreach (keys %chanconf) { - $chan = $_; - - next if ($chan eq "_default"); - next unless (exists $chanconf{$chan}{$opt}); - next unless ($val eq $chanconf{$chan}{$opt}); - - push(@chans,$chan); - delete $chanconf{$chan}{$opt}; - } - - if (scalar @chans) { - &DEBUG("Removed config $opt to @chans since it's defiend in '_default'"); - } - } - - ### Process 2: if defined in all chans but _default, set in - ### _default and remove all others. - my (%optsval, %opts); - foreach (keys %chanconf) { - $chan = $_; - next if ($chan eq "_default"); - my $opt; - - foreach (keys %{ $chanconf{$chan} }) { - $opt = $_; - if (exists $optsval{$opt} and $optsval{$opt} eq $chanconf{$chan}{$opt}) { - $opts{$opt}++; - next; - } - $optsval{$opt} = $chanconf{$chan}{$opt}; - $opts{$opt} = 1; - } - } - - foreach (keys %opts) { - next unless ($opts{$_} > 2); - &DEBUG(" opts{$_} => $opts{$_}"); - } - - ### other optimizations are in UserDCC.pl + ### Process 1: if defined in _default, remove same definition + ### from non-default channels. + foreach ( keys %{ $chanconf{_default} } ) { + my $opt = $_; + my $val = $chanconf{_default}{$opt}; + my @chans; + + foreach ( keys %chanconf ) { + $chan = $_; + + next if ( $chan eq '_default' ); + next unless ( exists $chanconf{$chan}{$opt} ); + next unless ( $val eq $chanconf{$chan}{$opt} ); + + push( @chans, $chan ); + delete $chanconf{$chan}{$opt}; + } + + if ( scalar @chans ) { + &DEBUG( +"Removed config $opt to @chans since it's defiend in '_default'" + ); + } + } + + ### Process 2: if defined in all chans but _default, set in + ### _default and remove all others. + my ( %optsval, %opts ); + foreach ( keys %chanconf ) { + $chan = $_; + next if ( $chan eq '_default' ); + my $opt; + + foreach ( keys %{ $chanconf{$chan} } ) { + $opt = $_; + if ( exists $optsval{$opt} + and $optsval{$opt} eq $chanconf{$chan}{$opt} ) + { + $opts{$opt}++; + next; + } + $optsval{$opt} = $chanconf{$chan}{$opt}; + $opts{$opt} = 1; + } + } + + foreach ( keys %opts ) { + next unless ( $opts{$_} > 2 ); + &DEBUG(" opts{$_} => $opts{$_}"); + } + + ### other optimizations are in UserDCC.pl } ### lets do it... - foreach (sort keys %chanconf) { - $chan = $_; + foreach ( sort keys %chanconf ) { + $chan = $_; - print OUT "$chan\n"; + print OUT "$chan\n"; - foreach (sort keys %{ $chanconf{$chan} }) { - my $val = $chanconf{$chan}{$_}; + foreach ( sort keys %{ $chanconf{$chan} } ) { + my $val = $chanconf{$chan}{$_}; - if ($val =~ /^0$/) { # bool, false. - print OUT " -$_\n"; + if ( $val =~ /^0$/ ) { # bool, false. + print OUT " -$_\n"; - } elsif ($val =~ /^1$/) { # bool, true. - print OUT " +$_\n"; + } + elsif ( $val =~ /^1$/ ) { # bool, true. + print OUT " +$_\n"; - } else { # what = val. - print OUT " $_ $val\n"; + } + else { # what = val. + print OUT " $_ $val\n"; - } + } - } - print OUT "\n"; + } + print OUT "\n"; } close OUT; $wtime_chanfile = time(); - &status("--- Saved CHANFILE (".scalar(keys %chanconf). - " chans) at $time"); + &status('--- Saved CHANFILE (' + . scalar( keys %chanconf ) + . " chans) at $time" ); - if (defined $msgType and $msgType =~ /^chat$/) { - &performStrictReply("--- Writing chan file..."); + if ( defined $msgType and $msgType =~ /^chat$/ ) { + &performStrictReply('--- Writing chan file...'); } } @@ -413,189 +462,203 @@ sub writeChanFile { # TODO: return all flags for opers sub IsFlag { my $flags = shift; - my ($ret, $f, $o) = ''; + my ( $ret, $f, $o ) = ''; - &verifyUser($who, $nuh); + &verifyUser( $who, $nuh ); - foreach $f (split //, $users{$userHandle}{FLAGS}) { - foreach $o ( split //, $flags ) { - next unless ($f eq $o); + foreach $f ( split //, $users{$userHandle}{FLAGS} ) { + foreach $o ( split //, $flags ) { + next unless ( $f eq $o ); - $ret = $f; - last; - } + $ret = $f; + last; + } } $ret; } sub verifyUser { - my ($nick, $lnuh) = @_; - my ($user, $m); + my ( $nick, $lnuh ) = @_; + my ( $user, $m ); - if ($userHandle = $dcc{'CHATvrfy'}{$who}) { - &VERB("vUser: cached auth for $who.",2); - return $userHandle; + if ( $userHandle = $dcc{'CHATvrfy'}{$who} ) { + &VERB( "vUser: cached auth for $who.", 2 ); + return $userHandle; } $userHandle = ''; - foreach $user (keys %users) { - next if ($user eq "_default"); + foreach $user ( keys %users ) { + next if ( $user eq '_default' ); - foreach $m (keys %{ $users{$user}{HOSTS} }) { - $m =~ s/\?/./g; - $m =~ s/\*/.*?/g; - $m =~ s/([\@\(\)\[\]])/\\$1/g; + foreach $m ( keys %{ $users{$user}{HOSTS} } ) { + $m =~ s/\?/./g; + $m =~ s/\*/.*?/g; + $m =~ s/([\@\(\)\[\]])/\\$1/g; - next unless ($lnuh =~ /^$m$/i); + next unless ( $lnuh =~ /^$m$/i ); - if ($user !~ /^\Q$nick\E$/i and !exists $cache{VUSERWARN}{$user}) { - &status("vU: host matched but diff nick ($nick != $user)."); - $cache{VUSERWARN}{$user} = 1; - } + if ( $user !~ /^\Q$nick\E$/i and !exists $cache{VUSERWARN}{$user} ) + { + &status("vU: host matched but diff nick ($nick != $user)."); + $cache{VUSERWARN}{$user} = 1; + } - $userHandle = $user; - last; - } + $userHandle = $user; + last; + } - last if ($userHandle ne ''); + last if ( $userHandle ne '' ); - if ($user =~ /^\Q$nick\E$/i and !exists $cache{VUSERWARN}{$user}) { - &status("vU: nick matched but host is not in list ($lnuh)."); - $cache{VUSERWARN}{$user} = 1; - } + if ( $user =~ /^\Q$nick\E$/i and !exists $cache{VUSERWARN}{$user} ) { + &status("vU: nick matched but host is not in list ($lnuh)."); + $cache{VUSERWARN}{$user} = 1; + } } - $userHandle ||= "_default"; + $userHandle ||= '_default'; + # what's talkchannel for? - $talkWho{$talkchannel} = $who if (defined $talkchannel); + $talkWho{$talkchannel} = $who if ( defined $talkchannel ); $talkWho = $who; return $userHandle; } sub ckpasswd { + # returns true if arg1 encrypts to arg2 - my ($plain, $encrypted) = @_; - if ($encrypted eq '') { - ($plain, $encrypted) = split(/\s+/, $plain, 2); + my ( $plain, $encrypted ) = @_; + if ( $encrypted eq '' ) { + ( $plain, $encrypted ) = split( /\s+/, $plain, 2 ); } - return 0 unless ($plain ne '' and $encrypted ne ''); + return 0 unless ( $plain ne '' and $encrypted ne '' ); # MD5 // DES. Bobby Billingsley++. my $salt; - if ($encrypted =~ /^(\S{2})/ and length $encrypted == 13) { - $salt = $1; - } elsif ($encrypted =~ /^\$\d\$(\w\w)\$/) { - $salt = $1; - } else { - &DEBUG("unknown salt from $encrypted."); - return 0; + if ( $encrypted =~ /^(\S{2})/ and length $encrypted == 13 ) { + $salt = $1; + } + elsif ( $encrypted =~ /^\$\d\$(\w\w)\$/ ) { + $salt = $1; + } + else { + &DEBUG("unknown salt from $encrypted."); + return 0; } - return ($encrypted eq crypt($plain, $salt)); + return ( $encrypted eq crypt( $plain, $salt ) ); } # mainly for dcc chat... hrm. sub hasFlag { my ($flag) = @_; - if (&IsFlag($flag) eq $flag) { - return 1; - } else { - &status("DCC CHAT: <$who> $message -- not enough flags."); - &performStrictReply("error: you do not have enough flags for that. ($flag required)"); - return 0; + if ( &IsFlag($flag) eq $flag ) { + return 1; + } + else { + &status("DCC CHAT: <$who> $message -- not enough flags."); + &performStrictReply( + "error: you do not have enough flags for that. ($flag required)"); + return 0; } } # expire is time in minutes sub ignoreAdd { - my($mask,$chan,$expire,$comment) = @_; + my ( $mask, $chan, $expire, $comment ) = @_; - $chan ||= '*'; # global if undefined. - $comment ||= ''; # optional. - $expire ||= 0; # permament. - my $count ||= 0; + $chan ||= '*'; # global if undefined. + $comment ||= ''; # optional. + $expire ||= 0; # permament. + my $count ||= 0; - if ($expire > 0) { - $expire = ($expire*60) + time(); - } else { - $expire = 0; + if ( $expire > 0 ) { + $expire = ( $expire * 60 ) + time(); + } + else { + $expire = 0; } - my $exist = 0; - $exist++ if (exists $ignore{$chan}{$mask}); + my $exist = 0; + $exist++ if ( exists $ignore{$chan}{$mask} ); - $ignore{$chan}{$mask} = [$expire, time(), $who, $comment]; + $ignore{$chan}{$mask} = [ $expire, time(), $who, $comment ]; # TODO: improve this. - if ($expire == 0) { - &status("ignore: Added $mask for $chan to NEVER expire, by $who, for $comment"); - } else { - &status("ignore: Added $mask for $chan to expire $expire mins, by $who, for $comment"); + if ( $expire == 0 ) { + &status( +"ignore: Added $mask for $chan to NEVER expire, by $who, for $comment" + ); + } + else { + &status( +"ignore: Added $mask for $chan to expire $expire mins, by $who, for $comment" + ); } if ($exist) { - $utime_userfile = time(); - $ucount_userfile++; + $utime_userfile = time(); + $ucount_userfile++; - return 2; - } else { - return 1; + return 2; + } + else { + return 1; } } sub ignoreDel { - my($mask) = @_; + my ($mask) = @_; my @match; ### TODO: support wildcards. - foreach (keys %ignore) { - my $chan = $_; + foreach ( keys %ignore ) { + my $chan = $_; - foreach (grep /^\Q$mask\E$/i, keys %{ $ignore{$chan} }) { - delete $ignore{$chan}{$mask}; - push(@match,$chan); - } + foreach ( grep /^\Q$mask\E$/i, keys %{ $ignore{$chan} } ) { + delete $ignore{$chan}{$mask}; + push( @match, $chan ); + } - &DEBUG("iD: scalar => ".scalar(keys %{ $ignore{$chan} }) ); + &DEBUG( 'iD: scalar => ' . scalar( keys %{ $ignore{$chan} } ) ); } - if (scalar @match) { - $utime_userfile = time(); - $ucount_userfile++; + if ( scalar @match ) { + $utime_userfile = time(); + $ucount_userfile++; } return @match; } sub userAdd { - my($nick,$mask) = @_; + my ( $nick, $mask ) = @_; - if (exists $users{$nick}) { - return 0; + if ( exists $users{$nick} ) { + return 0; } $utime_userfile = time(); $ucount_userfile++; - if (defined $mask and $mask !~ /^\s*$/) { - &DEBUG("userAdd: mask => $mask"); - $users{$nick}{HOSTS}{$mask} = 1; + if ( defined $mask and $mask !~ /^\s*$/ ) { + &DEBUG("userAdd: mask => $mask"); + $users{$nick}{HOSTS}{$mask} = 1; } - $users{$nick}{FLAGS} ||= $users{_default}{FLAGS}; + $users{$nick}{FLAGS} ||= $users{_default}{FLAGS}; return 1; } sub userDel { - my($nick) = @_; + my ($nick) = @_; - if (!exists $users{$nick}) { - return 0; + if ( !exists $users{$nick} ) { + return 0; } $utime_userfile = time(); @@ -607,250 +670,240 @@ sub userDel { } sub banAdd { - my($mask,$chan,$expire,$reason) = @_; + my ( $mask, $chan, $expire, $reason ) = @_; - $chan ||= '*'; - $expire ||= 0; + $chan ||= '*'; + $expire ||= 0; - if ($expire > 0) { - $expire = $expire*60 + time(); + if ( $expire > 0 ) { + $expire = $expire * 60 + time(); } - my $exist = 1; - $exist++ if (exists $bans{$chan}{$mask} or - exists $bans{'*'}{$mask}); - $bans{$chan}{$mask} = [$expire, time(), 0, $who, $reason]; + my $exist = 1; + $exist++ if ( exists $bans{$chan}{$mask} + or exists $bans{'*'}{$mask} ); + $bans{$chan}{$mask} = [ $expire, time(), 0, $who, $reason ]; - my @chans = ($chan eq '*') ? keys %channels : $chan; - my $m = $mask; - $m =~ s/\?/\\./g; - $m =~ s/\*/\\S*/g; + my @chans = ( $chan eq '*' ) ? keys %channels : $chan; + my $m = $mask; + $m =~ s/\?/\\./g; + $m =~ s/\*/\\S*/g; foreach (@chans) { - my $chan = $_; - foreach (keys %{ $channels{$chan}{''} }) { - next unless (exists $nuh{lc $_}); - next unless ($nuh{lc $_} =~ /^$m$/i); - &FIXME("nuh{$_} =~ /$m/"); - } + my $chan = $_; + foreach ( keys %{ $channels{$chan}{''} } ) { + next unless ( exists $nuh{ lc $_ } ); + next unless ( $nuh{ lc $_ } =~ /^$m$/i ); + &FIXME("nuh{$_} =~ /$m/"); + } } - if ($exist == 1) { - $utime_userfile = time(); - $ucount_userfile++; + if ( $exist == 1 ) { + $utime_userfile = time(); + $ucount_userfile++; } return $exist; } sub banDel { - my($mask) = @_; + my ($mask) = @_; my @match; - foreach (keys %bans) { - my $chan = $_; + foreach ( keys %bans ) { + my $chan = $_; - foreach (grep /^\Q$mask\E$/i, keys %{ $bans{$chan} }) { - delete $bans{$chan}{$_}; - push(@match, $chan); - } + foreach ( grep /^\Q$mask\E$/i, keys %{ $bans{$chan} } ) { + delete $bans{$chan}{$_}; + push( @match, $chan ); + } - &DEBUG("bans: scalar => ".scalar(keys %{ $bans{$chan} }) ); + &DEBUG( 'bans: scalar => ' . scalar( keys %{ $bans{$chan} } ) ); } - if (scalar @match) { - $utime_userfile = time(); - $ucount_userfile++; + if ( scalar @match ) { + $utime_userfile = time(); + $ucount_userfile++; } return @match; } sub IsUser { - my($user) = @_; + my ($user) = @_; if ( &getUser($user) ) { - return 1; - } else { - return 0; + return 1; + } + else { + return 0; } } sub getUser { - my($user) = @_; + my ($user) = @_; - if (!defined $user) { - &WARN("getUser: user == NULL."); - return; + if ( !defined $user ) { + &WARN('getUser: user == NULL.'); + return; } - if (my @retval = grep /^\Q$user\E$/i, keys %users) { - if ($retval[0] ne $user) { - &WARN("getUser: retval[0] ne user ($retval[0] ne $user)"); - } - my $count = scalar keys %{ $users{$retval[0]} }; - &DEBUG("count => $count."); + if ( my @retval = grep /^\Q$user\E$/i, keys %users ) { + if ( $retval[0] ne $user ) { + &WARN("getUser: retval[0] ne user ($retval[0] ne $user)"); + } + my $count = scalar keys %{ $users{ $retval[0] } }; + &DEBUG("count => $count."); - return $retval[0]; - } else { - return; + return $retval[0]; + } + else { + return; } } sub chanSet { - my($cmd, $chan, $what, $val) = @_; + my ( $cmd, $chan, $what, $val ) = @_; - if ($cmd eq "+chan") { - if (exists $chanconf{$chan}) { - &performStrictReply("chan $chan already exists."); - return; - } - $chanconf{$chan}{_time_added} = time(); - $chanconf{$chan}{autojoin} = $conn->nick(); + if ( $cmd eq 'chanadd' ) { + if ( exists $chanconf{$chan} ) { + &performStrictReply("chan $chan already exists."); + return; + } + $chanconf{$chan}{_time_added} = time(); + $chanconf{$chan}{autojoin} = $conn->nick(); - &performStrictReply("Joining $chan..."); - &joinchan($chan); + &performStrictReply("Joining $chan..."); + &joinchan($chan); - return; + return; } - if (!exists $chanconf{$chan}) { - &performStrictReply("no such channel $chan"); - return; + if ( !exists $chanconf{$chan} ) { + &performStrictReply("no such channel $chan"); + return; } - my $update = 0; + my $update = 0; - if (defined $what and $what =~ s/^([+-])(\S+)/$2/) { - ### ".chanset +blah" - ### ".chanset +blah 10" -- error. + if ( defined $what and $what =~ s/^([+-])(\S+)/$2/ ) { + ### '.chanset +blah' + ### '.chanset +blah 10' -- error. - my $set = ($1 eq "+") ? 1 : 0; - my $was = $chanconf{$chan}{$what}; + my $set = ( $1 eq '+' ) ? 1 : 0; + my $was = $chanconf{$chan}{$what}; - if ($set) { # add/set. - if (defined $was and $was eq '1') { - &performStrictReply("setting $what for $chan already 1."); - return; - } + if ($set) { # add/set. + if ( defined $was and $was eq '1' ) { + &performStrictReply("setting $what for $chan already 1."); + return; + } - $val = 1; + $val = 1; - } else { # delete/unset. - if (!defined $was) { - &performStrictReply("setting $what for $chan is not set."); - return; - } + } + else { # delete/unset. + if ( !defined $was ) { + &performStrictReply("setting $what for $chan is not set."); + return; + } - $val = 0; - } + $val = 0; + } - # alter for cosmetic (print out) reasons only. - $was = (defined $was) ? "; was '$was'" : ''; + # alter for cosmetic (print out) reasons only. + $was = ( defined $was ) ? "; was '$was'" : ''; - if ($val eq '0') { - &performStrictReply("Unsetting $what for $chan$was."); - delete $chanconf{$chan}{$what}; - delete $cache{ircTextCounters} if $what eq 'ircTextCounters'; - } else { - &performStrictReply("Setting $what for $chan to '$val'$was."); - $chanconf{$chan}{$what} = $val; - delete $cache{ircTextCounters} if $what eq 'ircTextCounters'; - } + if ( $val eq '0' ) { + &performStrictReply("Unsetting $what for $chan$was."); + delete $chanconf{$chan}{$what}; + delete $cache{ircTextCounters} if $what eq 'ircTextCounters'; + } + else { + &performStrictReply("Setting $what for $chan to '$val'$was."); + $chanconf{$chan}{$what} = $val; + delete $cache{ircTextCounters} if $what eq 'ircTextCounters'; + } - $update++; + $update++; - } elsif (defined $val) { - ### ".chanset blah testing" + } + elsif ( defined $val ) { + ### '.chanset blah testing' - my $was = $chanconf{$chan}{$what}; - if (defined $was and $was eq $val) { - &performStrictReply("setting $what for $chan already '$val'."); - return; - } - $was = ($was) ? "; was '$was'" : ''; - &performStrictReply("Setting $what for $chan to '$val'$was."); + my $was = $chanconf{$chan}{$what}; + if ( defined $was and $was eq $val ) { + &performStrictReply("setting $what for $chan already '$val'."); + return; + } + $was = ($was) ? "; was '$was'" : ''; + &performStrictReply("Setting $what for $chan to '$val'$was."); - $chanconf{$chan}{$what} = $val; - delete $cache{ircTextCounters} if $what eq 'ircTextCounters'; + $chanconf{$chan}{$what} = $val; + delete $cache{ircTextCounters} if $what eq 'ircTextCounters'; - $update++; + $update++; - } else { # read only. - ### ".chanset" - ### ".chanset blah" + } + else { # read only. + ### '.chanset' + ### '.chanset blah' - if (!defined $what) { - &WARN("chanset/DC: what == undefine."); - return; - } + if ( !defined $what ) { + &WARN('chanset/DC: what == undefine.'); + return; + } - if (exists $chanconf{$chan}{$what}) { - &performStrictReply("$what for $chan is '$chanconf{$chan}{$what}'"); - } else { - &performStrictReply("$what for $chan is not set."); - } + if ( exists $chanconf{$chan}{$what} ) { + &performStrictReply("$what for $chan is '$chanconf{$chan}{$what}'"); + } + else { + &performStrictReply("$what for $chan is not set."); + } } if ($update) { - $utime_chanfile = time(); - $ucount_chanfile++; + $utime_chanfile = time(); + $ucount_chanfile++; } return; } sub rehashConfVars { + # this is an attempt to fix where an option is enabled but the module # has been not loaded. it also can be used for other things. - foreach (keys %{ $cache{confvars} }) { - my $i = $cache{confvars}{$_}; - &DEBUG("rehashConfVars: _ => $_"); + foreach ( keys %{ $cache{confvars} } ) { + my $i = $cache{confvars}{$_}; + &DEBUG("rehashConfVars: _ => $_"); - if (/^news$/ and $i) { - &loadMyModule('News'); - delete $cache{confvars}{$_}; - } + if ( /^news$/ and $i ) { + &loadMyModule('News'); + delete $cache{confvars}{$_}; + } - if (/^uptime$/ and $i) { - &loadMyModule('Uptime'); - delete $cache{confvars}{$_}; - } + if ( /^uptime$/ and $i ) { + &loadMyModule('Uptime'); + delete $cache{confvars}{$_}; + } - if (/^rootwarn$/i and $i) { - &loadMyModule('RootWarn'); - delete $cache{confvars}{$_}; - } + if ( /^rootwarn$/i and $i ) { + &loadMyModule('RootWarn'); + delete $cache{confvars}{$_}; + } - if (/^onjoin$/i and $i) { - &loadMyModule('OnJoin'); - delete $cache{confvars}{$_}; - } + if ( /^onjoin$/i and $i ) { + &loadMyModule('OnJoin'); + delete $cache{confvars}{$_}; + } } - &DEBUG("end of rehashConfVars"); + &DEBUG('end of rehashConfVars'); delete $cache{confvars}; } -my @regFlagsUser = ( - # possible chars to include in FLAG - 'A', # bot administration over /msg - # default is only via DCC CHAT - 'O', # dynamic ops (as on channel). (automatic +o) - 'T', # add topics. - 'a', # ask/request factoid. - 'm', # modify factoid. (includes renaming) - 'n', # bot owner, can 'reload' - 'o', # master of bot (automatic +amrt) - # can search on factoid strings shorter than 2 chars - # can tell bot to join new channels - # can [un]lock factoids - 'r', # remove factoid. - 't', # teach/add factoid. - 's', # Bypass +silent on channels -); - 1; # vim:ts=4:sw=4:expandtab:tw=80 diff --git a/src/Factoids/Core.pl b/src/Factoids/Core.pl index 4898008..bb814dc 100644 --- a/src/Factoids/Core.pl +++ b/src/Factoids/Core.pl @@ -9,533 +9,635 @@ use vars qw(%param %cache %lang %cmdstats %bots); use vars qw($message $who $addressed $chan $h $nuh $ident $msgType - $correction_plausable); + $correction_plausable); # Usage: &validFactoid($lhs,$rhs); sub validFactoid { - my ($lhs,$rhs) = @_; + my ( $lhs, $rhs ) = @_; my $valid = 0; - for (lc $lhs) { - # allow the following only if they have been made on purpose. - if ($rhs ne '' and $rhs !~ /^/ and last; # '=>'. - /\;\;/ and last; # ';;'. - /\|\|/ and last; # '||'. - - /^\Q$ident\E[\'\,\: ]/ and last;# dupe addressed. - /^[\-\, ]/ and last; - /\\$/ and last; # forgot shift for '?'. - /^all / and last; - /^also / and last; - / also$/ and last; - / and$/ and last; - /^because / and last; - /^but / and last; - /^gives / and last; - /^h(is|er) / and last; - /^if / and last; - / is,/ and last; - / it$/ and last; - /^or / and last; - / says$/ and last; - /^should / and last; - /^so / and last; - /^supposedly/ and last; - /^to / and last; - /^was / and last; - / which$/ and last; - - # nasty bug I introduced _somehow_, probably by fixMySQLBug(). - /\\\%/ and last; - /\\\_/ and last; - - # weird/special stuff. also old infobot bugs. - $rhs =~ /( \Q$ident\E's|\Q$ident\E's )/i and last; # ownership. - - # duplication. - $rhs =~ /^\Q$lhs /i and last; - last if ($rhs =~ /^is /i and / is$/); - - $valid++; + for ( lc $lhs ) { + + # allow the following only if they have been made on purpose. + if ( $rhs ne '' and $rhs !~ /^/ and last; # '=>'. + /\;\;/ and last; # ';;'. + /\|\|/ and last; # '||'. + + /^\Q$ident\E[\'\,\: ]/ and last; # dupe addressed. + /^[\-\, ]/ and last; + /\\$/ and last; # forgot shift for '?'. + /^all / and last; + /^also / and last; + / also$/ and last; + / and$/ and last; + /^because / and last; + /^but / and last; + /^gives / and last; + /^h(is|er) / and last; + /^if / and last; + / is,/ and last; + / it$/ and last; + /^or / and last; + / says$/ and last; + /^should / and last; + /^so / and last; + /^supposedly/ and last; + /^to / and last; + /^was / and last; + / which$/ and last; + + # nasty bug I introduced _somehow_, probably by fixMySQLBug(). + /\\\%/ and last; + /\\\_/ and last; + + # weird/special stuff. also old infobot bugs. + $rhs =~ /( \Q$ident\E's|\Q$ident\E's )/i and last; # ownership. + + # duplication. + $rhs =~ /^\Q$lhs /i and last; + last if ( $rhs =~ /^is /i and / is$/ ); + + $valid++; } return $valid; } sub FactoidStuff { + # inter-infobot. - if ($msgType =~ /private/ and $message =~ s/^:INFOBOT://) { - ### identification. - &status("infobot <$nuh> identified") unless $bots{$nuh}; - $bots{$nuh} = $who; + if ( $msgType =~ /private/ and $message =~ s/^:INFOBOT:// ) { + ### identification. + &status("infobot <$nuh> identified") unless $bots{$nuh}; + $bots{$nuh} = $who; - ### communication. + ### communication. - # query. - if ($message =~ /^QUERY (<.*?>) (.*)/) { # query. - my ($target,$item) = ($1,$2); - $item =~ s/[.\?]$//; + # query. + if ( $message =~ /^QUERY (<.*?>) (.*)/ ) { # query. + my ( $target, $item ) = ( $1, $2 ); + $item =~ s/[.\?]$//; - &status(":INFOBOT:QUERY $who: $message"); + &status(":INFOBOT:QUERY $who: $message"); - if ($_ = &getFactoid($item)) { - &msg($who, ":INFOBOT:REPLY $target $item =is=> $_"); - } + if ( $_ = &getFactoid($item) ) { + &msg( $who, ":INFOBOT:REPLY $target $item =is=> $_" ); + } - return 'INFOBOT QUERY'; - } elsif ($message =~ /^REPLY <(.*?)> (.*)/) { # reply. - my ($target,$item) = ($1,$2); + return 'INFOBOT QUERY'; + } + elsif ( $message =~ /^REPLY <(.*?)> (.*)/ ) { # reply. + my ( $target, $item ) = ( $1, $2 ); - &status(":INFOBOT:REPLY $who: $message"); + &status(":INFOBOT:REPLY $who: $message"); - my ($lhs,$mhs,$rhs) = $item =~ /^(.*?) =(.*?)=> (.*)/; + my ( $lhs, $mhs, $rhs ) = $item =~ /^(.*?) =(.*?)=> (.*)/; - if ($param{'acceptUrl'} !~ /REQUIRE/ or $rhs =~ /(http|ftp|mailto|telnet|file):/) { - &msg($target, "$who knew: $lhs $mhs $rhs"); + if ( $param{'acceptUrl'} !~ /REQUIRE/ + or $rhs =~ /(http|ftp|mailto|telnet|file):/ ) + { + &msg( $target, "$who knew: $lhs $mhs $rhs" ); - # 'are' hack :) - $rhs = " are" if ($mhs eq 'are'); - &setFactInfo($lhs, 'factoid_value', $rhs); - } + # 'are' hack :) + $rhs = " are" if ( $mhs eq 'are' ); + &setFactInfo( $lhs, 'factoid_value', $rhs ); + } - return 'INFOBOT REPLY'; - } else { - &ERROR(":INFOBOT:UNKNOWN $who: $message"); - return 'INFOBOT UNKNOWN'; - } + return 'INFOBOT REPLY'; + } + else { + &ERROR(":INFOBOT:UNKNOWN $who: $message"); + return 'INFOBOT UNKNOWN'; + } } # factoid forget. - if ($message =~ s/^forget\s+//i) { - return 'forget: no addr' unless ($addressed); - - my $faqtoid = $message; - if ($faqtoid eq '') { - &help('forget'); - return; - } - - $faqtoid =~ tr/A-Z/a-z/; - my $result = &getFactoid($faqtoid); - - # if it doesn't exist, well... it doesn't! - if (!defined $result) { - &performReply("i didn't have anything called '$faqtoid' to forget"); - return; - } - - # TODO: squeeze 3 getFactInfo calls into one? - my $author = &getFactInfo($faqtoid, 'created_by'); - my $count = &getFactInfo($faqtoid, 'requested_count') || 0; - # don't delete if requested $limit times - my $limit = &getChanConfDefault('factoidPreventForgetLimit', 100, $chan); - # don't delete if older than $limitage seconds (modified by requests below) - my $limitage = &getChanConfDefault('factoidPreventForgetLimitTime', 7 * 24 * 60 * 60, $chan); - my $t = &getFactInfo($faqtoid, 'created_time') || 0; - my $age = time() - $t; - - # lets scale limitage from 1 (nearly 0) to $limit (full time). - $limitage = $limitage*($count+1)/$limit if ($count < $limit); - # isauthor and isop. - my $isau = (defined $author and &IsHostMatch($author) == 2) ? 1 : 0; - my $isop = (&IsFlag('o') eq 'o') ? 1 : 0; - - if (IsFlag('r') ne 'r' && !$isop) { - &msg($who, "you don't have access to remove factoids"); - return; - } - - return 'locked factoid' if (&IsLocked($faqtoid) == 1); - - ### - ### lets go do some checking. - ### - - # factoidPreventForgetLimitTime: - if (!($isop or $isau) and $age/(60*60*24) > $limitage) { - &msg($who, "cannot remove factoid '$faqtoid', too old. (" . - $age/(60*60*24) . ">$limitage) use 'no,' instead"); - return; - } - - # factoidPreventForgetLimit: - if (!($isop or $isau) and $limit and $count > $limit) { - &msg($who, "will not delete '$faqtoid', count > limit ($count > $limit) use 'no, ' instead."); - return; - } - - # this may eat some memory. - # prevent deletion if other factoids redirect to it. - # TODO: use hash instead of array. - my @list; - if (&getChanConf('factoidPreventForgetRedirect')) { - &status("Factoids/Core: forget: checking for redirect factoids"); - @list = &searchTable('factoids', 'factoid_key', - 'factoid_value', "^ see "); - } - - my $match = 0; - for (@list) { - my $f = $_; - my $v = &getFactInfo($f, 'factoid_value'); - my $fsafe = quotemeta($faqtoid); - next unless ($v =~ /^ ?see( also)? $fsafe\.?$/i); - - &DEBUG("Factoids/Core: match! ($f || $faqtoid)"); - - $match++; - } - # TODO: warn for op aswell, but allow force delete. - if (!$isop and $match) { - &msg($who, "uhm, other (redirection) factoids depend on this one."); - return; - } - - # minimize abuse. - if (!$isop and &IsHostMatch($author) != 2) { - $cache{forget}{$h}++; - - # warn. - if ($cache{forget}{$h} > 3) { - &msg($who, "Stop abusing forget!"); - } - - # ignore. - # TODO: make forget limit configurable. - # TODO: make forget ignore time configurable. - if ($cache{forget}{$h} > 5) { - &ignoreAdd(&makeHostMask($nuh), '*', 3*24*60, "abuse of forget"); - &msg($who, "forget: Ignoring you for abuse!"); - } - } - - # lets do it! - - if (&IsParam('factoidDeleteDelay') or &IsChanConf('factoidDeleteDelay') > 0) { - if (!($isop or $isau) and $faqtoid =~ / #DEL#$/) { - &msg($who, "cannot delete it ($faqtoid)."); - return; - } - - &status("forgot (safe delete): '$faqtoid' - ". scalar(gmtime)); - ### TODO: check if the 'backup' exists and overwrite it - my $check = &getFactoid("$faqtoid #DEL#"); - - if (!defined $check or $check =~ /^\s*$/) { - if ($faqtoid !~ / #DEL#$/) { - my $new = $faqtoid." #DEL#"; - - my $backup = &getFactoid($new); - if ($backup) { - &DEBUG("forget: not overwriting backup: $faqtoid"); - } else { - &status("forget: backing up '$faqtoid'"); - &setFactInfo($faqtoid, 'factoid_key', $new); - &setFactInfo($new, 'modified_by', $who); - &setFactInfo($new, 'modified_time', time()); - } - - } else { - &status("forget: not backing up $faqtoid."); - } - - } else { - &status("forget: not overwriting backup!"); - } - } - - &status("forget: <$who> '$faqtoid' =is=> '$result'"); - &delFactoid($faqtoid); - - &performReply("i forgot $faqtoid"); - - $count{'Update'}++; - - return; + if ( $message =~ s/^forget\s+//i ) { + return 'forget: no addr' unless ($addressed); + + my $faqtoid = $message; + if ( $faqtoid eq '' ) { + &help('forget'); + return; + } + + $faqtoid =~ tr/A-Z/a-z/; + my $result = &getFactoid($faqtoid); + + # if it doesn't exist, well... it doesn't! + if ( !defined $result ) { + &performReply("i didn't have anything called '$faqtoid' to forget"); + return; + } + + # TODO: squeeze 3 getFactInfo calls into one? + my $author = &getFactInfo( $faqtoid, 'created_by' ); + my $count = &getFactInfo( $faqtoid, 'requested_count' ) || 0; + + # don't delete if requested $limit times + my $limit = + &getChanConfDefault( 'factoidPreventForgetLimit', 100, $chan ); + + # don't delete if older than $limitage seconds (modified by requests below) + my $limitage = &getChanConfDefault( 'factoidPreventForgetLimitTime', + 7 * 24 * 60 * 60, $chan ); + my $t = &getFactInfo( $faqtoid, 'created_time' ) || 0; + my $age = time() - $t; + + # lets scale limitage from 1 (nearly 0) to $limit (full time). + $limitage = $limitage * ( $count + 1 ) / $limit if ( $count < $limit ); + + # isauthor and isop. + my $isau = ( defined $author and &IsHostMatch($author) == 2 ) ? 1 : 0; + my $isop = ( &IsFlag('o') eq 'o' ) ? 1 : 0; + + if ( IsFlag('r') ne 'r' && !$isop ) { + &msg( $who, "you don't have access to remove factoids" ); + return; + } + + return 'locked factoid' if ( &IsLocked($faqtoid) == 1 ); + + ### + ### lets go do some checking. + ### + + # factoidPreventForgetLimitTime: + if ( !( $isop or $isau ) and $age / ( 60 * 60 * 24 ) > $limitage ) { + &msg( $who, + "cannot remove factoid '$faqtoid', too old. (" + . $age / ( 60 * 60 * 24 ) + . ">$limitage) use 'no,' instead" ); + return; + } + + # factoidPreventForgetLimit: + if ( !( $isop or $isau ) and $limit and $count > $limit ) { + &msg( $who, +"will not delete '$faqtoid', count > limit ($count > $limit) use 'no, ' instead." + ); + return; + } + + # this may eat some memory. + # prevent deletion if other factoids redirect to it. + # TODO: use hash instead of array. + my @list; + if ( &getChanConf('factoidPreventForgetRedirect') ) { + &status("Factoids/Core: forget: checking for redirect factoids"); + @list = + &searchTable( 'factoids', 'factoid_key', 'factoid_value', + "^ see " ); + } + + my $match = 0; + for (@list) { + my $f = $_; + my $v = &getFactInfo( $f, 'factoid_value' ); + my $fsafe = quotemeta($faqtoid); + next unless ( $v =~ /^ ?see( also)? $fsafe\.?$/i ); + + &DEBUG("Factoids/Core: match! ($f || $faqtoid)"); + + $match++; + } + + # TODO: warn for op aswell, but allow force delete. + if ( !$isop and $match ) { + &msg( $who, + "uhm, other (redirection) factoids depend on this one." ); + return; + } + + # minimize abuse. + if ( !$isop and &IsHostMatch($author) != 2 ) { + $cache{forget}{$h}++; + + # warn. + if ( $cache{forget}{$h} > 3 ) { + &msg( $who, "Stop abusing forget!" ); + } + + # ignore. + # TODO: make forget limit configurable. + # TODO: make forget ignore time configurable. + if ( $cache{forget}{$h} > 5 ) { + &ignoreAdd( + &makeHostMask($nuh), '*', + 3 * 24 * 60, + "abuse of forget" + ); + &msg( $who, "forget: Ignoring you for abuse!" ); + } + } + + # lets do it! + + if ( &IsParam('factoidDeleteDelay') + or &IsChanConf('factoidDeleteDelay') > 0 ) + { + if ( !( $isop or $isau ) and $faqtoid =~ / #DEL#$/ ) { + &msg( $who, "cannot delete it ($faqtoid)." ); + return; + } + + &status( "forgot (safe delete): '$faqtoid' - " . scalar(gmtime) ); + ### TODO: check if the 'backup' exists and overwrite it + my $check = &getFactoid("$faqtoid #DEL#"); + + if ( !defined $check or $check =~ /^\s*$/ ) { + if ( $faqtoid !~ / #DEL#$/ ) { + my $new = $faqtoid . " #DEL#"; + + my $backup = &getFactoid($new); + if ($backup) { + &DEBUG("forget: not overwriting backup: $faqtoid"); + } + else { + &status("forget: backing up '$faqtoid'"); + &setFactInfo( $faqtoid, 'factoid_key', $new ); + &setFactInfo( $new, 'modified_by', $who ); + &setFactInfo( $new, 'modified_time', time() ); + } + + } + else { + &status("forget: not backing up $faqtoid."); + } + + } + else { + &status("forget: not overwriting backup!"); + } + } + + &status("forget: <$who> '$faqtoid' =is=> '$result'"); + &delFactoid($faqtoid); + + &performReply("i forgot $faqtoid"); + + $count{'Update'}++; + + return; } # factoid unforget/undelete. - if ($message =~ s/^un(forget|delete)\s+//i) { - return 'unforget: no addr' unless ($addressed); - - my $i = 0; - $i++ if (&IsParam('factoidDeleteDelay')); - $i++ if (&IsChanConf('factoidDeleteDelay') > 0); - if (!$i) { - &performReply("safe delete has been disable so what is there to undelete?"); - return; - } - - my $faqtoid = $message; - if ($faqtoid eq '') { - &help('unforget'); - return; - } - - $faqtoid =~ tr/A-Z/a-z/; - my $result = &getFactoid($faqtoid." #DEL#"); - my $check = &getFactoid($faqtoid); - - if (defined $check) { - &performReply("cannot undeleted '$faqtoid' because it already exists!"); - return; - } - - if (!defined $result) { - &performReply("that factoid was not backedup :/"); - return; - } - - &setFactInfo($faqtoid." #DEL#", 'factoid_key', $faqtoid); -# &setFactInfo($faqtoid, 'modified_by', ''); -# &setFactInfo($faqtoid, 'modified_time', 0); - - $check = &getFactoid($faqtoid); - # TODO: check if $faqtoid." #DEL#" exists? - if (defined $check) { - &performReply("Successfully recovered '$faqtoid'. Have fun now."); - $count{'Undelete'}++; - } else { - &performReply("did not recover '$faqtoid'. What happened?"); - } - - return; + if ( $message =~ s/^un(forget|delete)\s+//i ) { + return 'unforget: no addr' unless ($addressed); + + my $i = 0; + $i++ if ( &IsParam('factoidDeleteDelay') ); + $i++ if ( &IsChanConf('factoidDeleteDelay') > 0 ); + if ( !$i ) { + &performReply( + "safe delete has been disable so what is there to undelete?"); + return; + } + + my $faqtoid = $message; + if ( $faqtoid eq '' ) { + &help('unforget'); + return; + } + + $faqtoid =~ tr/A-Z/a-z/; + my $result = &getFactoid( $faqtoid . " #DEL#" ); + my $check = &getFactoid($faqtoid); + + if ( defined $check ) { + &performReply( + "cannot undeleted '$faqtoid' because it already exists!"); + return; + } + + if ( !defined $result ) { + &performReply("that factoid was not backedup :/"); + return; + } + + &setFactInfo( $faqtoid . " #DEL#", 'factoid_key', $faqtoid ); + + # &setFactInfo($faqtoid, 'modified_by', ''); + # &setFactInfo($faqtoid, 'modified_time', 0); + + $check = &getFactoid($faqtoid); + + # TODO: check if $faqtoid." #DEL#" exists? + if ( defined $check ) { + &performReply("Successfully recovered '$faqtoid'. Have fun now."); + $count{'Undelete'}++; + } + else { + &performReply("did not recover '$faqtoid'. What happened?"); + } + + return; } # factoid locking. - if ($message =~ /^((un)?lock)(\s+(.*))?\s*?$/i) { - return 'lock: no addr 2' unless ($addressed); - - my $function = lc $1; - my $faqtoid = lc $4; - - if ($faqtoid eq '') { - &help($function); - return; - } - - if (&getFactoid($faqtoid) eq '') { - &msg($who, "factoid \002$faqtoid\002 does not exist"); - return; - } - - if ($function eq 'lock') { - # strongly requested by #debian on 19991028. -xk - if (1 and $faqtoid !~ /^\Q$who\E$/i and &IsFlag('o') ne 'o') { - &msg($who,"sorry, locking cannot be used since it can be abused unneccesarily."); - &status("Replace 1 with 0 in Process.pl#~324 for locking support."); - return; - } - - &CmdLock($faqtoid); - } else { - &CmdUnLock($faqtoid); - } - - return; + if ( $message =~ /^((un)?lock)(\s+(.*))?\s*?$/i ) { + return 'lock: no addr 2' unless ($addressed); + + my $function = lc $1; + my $faqtoid = lc $4; + + if ( $faqtoid eq '' ) { + &help($function); + return; + } + + if ( &getFactoid($faqtoid) eq '' ) { + &msg( $who, "factoid \002$faqtoid\002 does not exist" ); + return; + } + + if ( $function eq 'lock' ) { + + # strongly requested by #debian on 19991028. -xk + if ( 1 and $faqtoid !~ /^\Q$who\E$/i and &IsFlag('o') ne 'o' ) { + &msg( $who, +"sorry, locking cannot be used since it can be abused unneccesarily." + ); + &status( + "Replace 1 with 0 in Process.pl#~324 for locking support."); + return; + } + + &CmdLock($faqtoid); + } + else { + &CmdUnLock($faqtoid); + } + + return; } # factoid rename. - if ($message =~ s/^rename(\s+|$)//) { - return 'rename: no addr' unless ($addressed); - - if ($message eq '') { - &help('rename'); - return; - } - - if ($message =~ /^'(.*)'\s+'(.*)'$/) { - my ($from,$to) = (lc $1, lc $2); - - my $result = &getFactoid($from); - if (!defined $result) { - &performReply("i didn't have anything called '$from' to rename"); - return; - } - - # who == nick!user@host. - if (&IsFlag('m') ne 'm' and $author !~ /^\Q$who\E\!/i) { - &msg($who, "factoid '$from' is not yours to modify."); - return; - } - - if ($_ = &getFactoid($to)) { - &performReply("destination factoid already exists."); - return; - } - - &setFactInfo($from,'factoid_key',$to); - - &status("rename: <$who> '$from' is now '$to'"); - &performReply("i renamed '$from' to '$to'"); - } else { - &msg($who,"error: wrong format. ask me about 'help rename'."); - } - - return; + if ( $message =~ s/^rename(\s+|$)// ) { + return 'rename: no addr' unless ($addressed); + + if ( $message eq '' ) { + &help('rename'); + return; + } + + if ( $message =~ /^'(.*)'\s+'(.*)'$/ ) { + my ( $from, $to ) = ( lc $1, lc $2 ); + + my $result = &getFactoid($from); + if ( !defined $result ) { + &performReply( + "i didn't have anything called '$from' to rename"); + return; + } + + # author == nick!user@host + # created_by == nick + my $author = &getFactInfo( $from, 'created_by' ); + $author =~ /^(.*)!/; + my $created_by = $1; + + # Can they even modify factoids? + if ( &IsFlag('m') ne 'm' + and &IsFlag('M') ne 'M' + and &IsFlag('o') ne 'o' ) + { + &performReply("You do not have permission to modify factoids"); + return; + + # If they have +M but they didnt create the factoid + } + elsif ( &IsFlag('M') eq 'M' + and $who !~ /^\Q$created_by\E$/i + and &IsFlag('m') ne 'm' + and &IsFlag('o') ne 'o' ) + { + &performReply("factoid '$from' is not yours to modify."); + return; + } + + # Else they have permission, so continue + + if ( $_ = &getFactoid($to) ) { + &performReply("destination factoid already exists."); + return; + } + + &setFactInfo( $from, 'factoid_key', $to ); + + &status("rename: <$who> '$from' is now '$to'"); + &performReply("i renamed '$from' to '$to'"); + } + else { + &msg( $who, "error: wrong format. ask me about 'help rename'." ); + } + + return; } # factoid substitution. (X =~ s/A/B/FLAG) - if ($message =~ m|^(.*?)\s+=~\s+s([/,#])(.+?)\2(.*?)\2([a-z]*);?\s*$|) { - my ($faqtoid,$delim,$op,$np,$flags) = (lc $1, $2, $3, $4, $5); - return 'subst: no addr' unless ($addressed); - - # incorrect format. - if ($np =~ /$delim/) { - &msg($who,"looks like you used the delimiter too many times. You may want to use a different delimiter, like ':' or '#'."); - return; - } - - # success. - if (my $result = &getFactoid($faqtoid)) { - return 'subst: locked' if (&IsLocked($faqtoid) == 1); - my $was = $result; - - if (($flags eq 'g' && $result =~ s/\Q$op/$np/gi) || $result =~ s/\Q$op/$np/i) { - # excessive length. - if (length $result > $param{'maxDataSize'}) { - &performReply("that's too long"); - return; - } - # empty - if (length $result == 0) { - &performReply("factoid would be empty. use forget?"); - return; - } - # min length. - my $faqauth = &getFactInfo($faqtoid, 'created_by'); - if ((length $result)*2 < length $was and - &IsFlag('o') ne 'o' and - &IsHostMatch($faqauth) != 2 - ) { - &performReply("too drastic change of factoid."); - } - - &setFactInfo($faqtoid, 'factoid_value', $result); - &status("update: '$faqtoid' =is=> '$result'; was '$was'"); - &performReply('OK'); - } else { - &performReply("that doesn't contain '$op'"); - } - } else { - &performReply("i didn't have anything called '$faqtoid' to modify"); - } - - return; + if ( $message =~ m|^(.*?)\s+=~\s+s([/,#])(.+?)\2(.*?)\2([a-z]*);?\s*$| ) { + my ( $faqtoid, $delim, $op, $np, $flags ) = ( lc $1, $2, $3, $4, $5 ); + return 'subst: no addr' unless ($addressed); + + # incorrect format. + if ( $np =~ /$delim/ ) { + &msg( $who, +"looks like you used the delimiter too many times. You may want to use a different delimiter, like ':' or '#'." + ); + return; + } + + # success. + if ( my $result = &getFactoid($faqtoid) ) { + return 'subst: locked' if ( &IsLocked($faqtoid) == 1 ); + my $was = $result; + my $faqauth = &getFactInfo( $faqtoid, 'created_by' ); + + if ( ( $flags eq 'g' && $result =~ s/\Q$op/$np/gi ) + || $result =~ s/\Q$op/$np/i ) + { + my $author = $faqauth; + $author =~ /^(.*)!/; + my $created_by = $1; + + # Can they even modify factoids? + if ( &IsFlag('m') ne 'm' + and &IsFlag('M') ne 'M' + and &IsFlag('o') ne 'o' ) + { + &performReply( + "You do not have permission to modify factoids"); + return; + + # If they have +M but they didnt create the factoid + } + elsif ( &IsFlag('M') eq 'M' + and $who !~ /^\Q$created_by\E$/i + and &IsFlag('m') ne 'm' + and &IsFlag('o') ne 'o' ) + { + &performReply("factoid '$faqtoid' is not yours to modify."); + return; + } + + # excessive length. + if ( length $result > $param{'maxDataSize'} ) { + &performReply("that's too long"); + return; + } + + # empty + if ( length $result == 0 ) { + &performReply( + "factoid would be empty. Use forget instead."); + return; + } + + # min length. + if ( ( length $result ) * 2 < length $was + and &IsFlag('o') ne 'o' + and &IsHostMatch($faqauth) != 2 ) + { + &performReply("too drastic change of factoid."); + } + + &setFactInfo( $faqtoid, 'factoid_value', $result ); + &status("update: '$faqtoid' =is=> '$result'; was '$was'"); + &performReply('OK'); + } + else { + &performReply("that doesn't contain '$op'"); + } + } + else { + &performReply("i didn't have anything called '$faqtoid' to modify"); + } + + return; } # Fix up $message for question. my $question = $message; for ($question) { - # fix the string. - s/^hey([, ]+)where/where/i; - s/\s+\?$/?/; - s/^whois /who is /i; # Must match ^, else factoids with "whois" anywhere break - s/where can i find/where is/i; - s/how about/where is/i; - s/ da / the /ig; - - # clear the string of useless words. - s/^(stupid )?q(uestion)?:\s+//i; - s/^(does )?(any|ne)(1|one|body) know //i; - - s/^[uh]+m*[,\.]* +//i; - - s/^well([, ]+)//i; - s/^still([, ]+)//i; - s/^(gee|boy|golly|gosh)([, ]+)//i; - s/^(well|and|but|or|yes)([, ]+)//i; - - s/^o+[hk]+(a+y+)?([,. ]+)//i; - s/^g(eez|osh|olly)([,. ]+)//i; - s/^w(ow|hee|o+ho+)([,. ]+)//i; - s/^heya?,?( folks)?([,. ]+)//i; + + # fix the string. + s/^hey([, ]+)where/where/i; + s/\s+\?$/?/; + s/^whois /who is /i + ; # Must match ^, else factoids with "whois" anywhere break + s/where can i find/where is/i; + s/how about/where is/i; + s/ da / the /ig; + + # clear the string of useless words. + s/^(stupid )?q(uestion)?:\s+//i; + s/^(does )?(any|ne)(1|one|body) know //i; + + s/^[uh]+m*[,\.]* +//i; + + s/^well([, ]+)//i; + s/^still([, ]+)//i; + s/^(gee|boy|golly|gosh)([, ]+)//i; + s/^(well|and|but|or|yes)([, ]+)//i; + + s/^o+[hk]+(a+y+)?([,. ]+)//i; + s/^g(eez|osh|olly)([,. ]+)//i; + s/^w(ow|hee|o+ho+)([,. ]+)//i; + s/^heya?,?( folks)?([,. ]+)//i; } - if ($addressed and $message =~ s/^no([, ]+)(\Q$ident\E\,+)?\s*//i) { - $correction_plausible = 1; - &status("correction is plausible, initial negative and nick deleted ($&)") if ($param{VERBOSITY}); - } else { - $correction_plausible = 0; + if ( $addressed and $message =~ s/^no([, ]+)(\Q$ident\E\,+)?\s*//i ) { + $correction_plausible = 1; + &status( + "correction is plausible, initial negative and nick deleted ($&)") + if ( $param{VERBOSITY} ); + } + else { + $correction_plausible = 0; } my $result = &doQuestion($question); - if (!defined $result or $result eq $noreply) { - return 'result from doQ undef.'; + if ( !defined $result or $result eq $noreply ) { + return 'result from doQ undef.'; } - if (defined $result and $result !~ /^0?$/) { # question. - &status("question: <$who> $message"); - $count{'Question'}++; - } elsif (&IsChanConf('Math') > 0 and $addressed) { # perl math. - &loadMyModule('Math'); - my $newresult = &perlMath(); - - if (defined $newresult and $newresult ne '') { - $cmdstats{'Maths'}++; - $result = $newresult; - &status("math: <$who> $message => $result"); - } + if ( defined $result and $result !~ /^0?$/ ) { # question. + &status("question: <$who> $message"); + $count{'Question'}++; + } + elsif ( &IsChanConf('Math') > 0 and $addressed ) { # perl math. + &loadMyModule('Math'); + my $newresult = &perlMath(); + + if ( defined $newresult and $newresult ne '' ) { + $cmdstats{'Maths'}++; + $result = $newresult; + &status("math: <$who> $message => $result"); + } } - if ($result !~ /^0?$/) { - &performStrictReply($result); - return; + if ( $result !~ /^0?$/ ) { + &performStrictReply($result); + return; } # why would a friendly bot get passed here? - if (&IsParam('friendlyBots')) { - return if (grep lc($_) eq lc($who), split(/\s+/, $param{'friendlyBots'})); + if ( &IsParam('friendlyBots') ) { + return + if ( grep lc($_) eq lc($who), + split( /\s+/, $param{'friendlyBots'} ) ); } # do the statement. - if (!defined &doStatement($message)) { - return; + if ( !defined &doStatement($message) ) { + return; } - return unless ($addressed and !$addrchar); + return unless ( $addressed and !$addrchar ); + + if ( length $message > 64 ) { + &status("unparseable-moron: $message"); - if (length $message > 64) { - &status("unparseable-moron: $message"); -# &performReply( &getRandom(keys %{ $lang{'moron'} }) ); - $count{'Moron'}++; + # &performReply( &getRandom(keys %{ $lang{'moron'} }) ); + $count{'Moron'}++; - &performReply("You are moron \002#". $count{'Moron'} ."\002"); - return; + &performReply( "You are moron \002#" . $count{'Moron'} . "\002" ); + return; } &status("unparseable: $message"); - &performReply( &getRandom(keys %{ $lang{'dunno'} }) ); + &performReply( &getRandom( keys %{ $lang{'dunno'} } ) ); $count{'Dunno'}++; } diff --git a/src/Factoids/DBCommon.pl b/src/Factoids/DBCommon.pl index ab37eeb..5321c25 100644 --- a/src/Factoids/DBCommon.pl +++ b/src/Factoids/DBCommon.pl @@ -10,22 +10,19 @@ ##### # Usage: &setFactInfo($faqtoid, $key, $val); sub setFactInfo { - &sqlSet('factoids', - { factoid_key => $_[0] }, - { $_[1] => $_[2] } - ); + &sqlSet( 'factoids', { factoid_key => $_[0] }, { $_[1] => $_[2] } ); } ##### # Usage: &getFactInfo($faqtoid, [$what]); sub getFactInfo { - return &sqlSelect('factoids', $_[1], { factoid_key => $_[0] } ); + return &sqlSelect( 'factoids', $_[1], { factoid_key => $_[0] } ); } ##### # Usage: &getFactoid($faqtoid); sub getFactoid { - return &getFactInfo($_[0], 'factoid_value'); + return &getFactInfo( $_[0], 'factoid_value' ); } ##### @@ -33,7 +30,7 @@ sub getFactoid { sub delFactoid { my ($faqtoid) = @_; - &sqlDelete('factoids', { factoid_key => $faqtoid } ); + &sqlDelete( 'factoids', { factoid_key => $faqtoid } ); &status("DELETED $faqtoid"); return 1; @@ -43,13 +40,13 @@ sub delFactoid { # Usage: &IsLocked($faqtoid); sub IsLocked { my ($faqtoid) = @_; - my $thisnuh = &getFactInfo($faqtoid, 'locked_by'); + my $thisnuh = &getFactInfo( $faqtoid, 'locked_by' ); - if (defined $thisnuh and $thisnuh ne '') { - if (!&IsHostMatch($thisnuh) and &IsFlag('o') ne 'o') { - &performReply("cannot alter locked factoids"); - return 1; - } + if ( defined $thisnuh and $thisnuh ne '' ) { + if ( !&IsHostMatch($thisnuh) and &IsFlag('o') ne 'o' ) { + &performReply("cannot alter locked factoids"); + return 1; + } } return 0; @@ -58,33 +55,33 @@ sub IsLocked { ##### # Usage: &AddModified($faqtoid,$nuh); sub AddModified { - my ($faqtoid,$nuh) = @_; - my $modified_by = &getFactInfo($faqtoid, 'modified_by'); - my (@modifiedlist, @modified, %modified); + my ( $faqtoid, $nuh ) = @_; + my $modified_by = &getFactInfo( $faqtoid, 'modified_by' ); + my ( @modifiedlist, @modified, %modified ); - if (defined $modified_by) { - push(@modifiedlist, split(/\,/, $modified_by)); + if ( defined $modified_by ) { + push( @modifiedlist, split( /\,/, $modified_by ) ); } - push(@modifiedlist,$nuh); + push( @modifiedlist, $nuh ); - foreach (reverse @modifiedlist) { - /^(\S+)!(\S+)@(\S+)$/; - my $nick = lc $1; - next if (exists $modified{$nick}); + foreach ( reverse @modifiedlist ) { + /^(\S+)!(\S+)@(\S+)$/; + my $nick = lc $1; + next if ( exists $modified{$nick} ); - $modified{$nick} = $_; - push(@modified,$nick); + $modified{$nick} = $_; + push( @modified, $nick ); } undef @modifiedlist; - foreach (reverse @modified) { - push(@modifiedlist, $modified{$_}); + foreach ( reverse @modified ) { + push( @modifiedlist, $modified{$_} ); } - shift(@modifiedlist) while (scalar @modifiedlist > 3); + shift(@modifiedlist) while ( scalar @modifiedlist > 3 ); - &setFactInfo($faqtoid, 'modified_by', join(",",@modifiedlist)); - &setFactInfo($faqtoid, 'modified_time', time()); + &setFactInfo( $faqtoid, 'modified_by', join( ",", @modifiedlist ) ); + &setFactInfo( $faqtoid, 'modified_time', time() ); return 1; } @@ -98,28 +95,29 @@ sub AddModified { sub CmdLock { my ($faqtoid) = @_; - my $thisnuh = &getFactInfo($faqtoid,'locked_by'); + my $thisnuh = &getFactInfo( $faqtoid, 'locked_by' ); - if (defined $thisnuh and $thisnuh ne '') { - my $locked_by = (split(/\!/,$thisnuh))[0]; - &msg($who,"factoid \002$faqtoid\002 has already been locked by $locked_by."); - return 0; + if ( defined $thisnuh and $thisnuh ne '' ) { + my $locked_by = ( split( /\!/, $thisnuh ) )[0]; + &msg( $who, + "factoid \002$faqtoid\002 has already been locked by $locked_by." ); + return 0; } - $thisnuh ||= &getFactInfo($faqtoid,'created_by'); + $thisnuh ||= &getFactInfo( $faqtoid, 'created_by' ); # fixes bug found on 19991103. # code needs to be reorganised though. - if ($thisnuh ne '') { - if (!&IsHostMatch($thisnuh) && IsFlag('o') ne 'o') { - &msg($who, "sorry, you are not allowed to lock '$faqtoid'."); - return 0; - } + if ( $thisnuh ne '' ) { + if ( !&IsHostMatch($thisnuh) && IsFlag('o') ne 'o' ) { + &msg( $who, "sorry, you are not allowed to lock '$faqtoid'." ); + return 0; + } } &performReply("locking factoid \002$faqtoid\002"); - &setFactInfo($faqtoid,'locked_by',$nuh); - &setFactInfo($faqtoid,'locked_time', time()); + &setFactInfo( $faqtoid, 'locked_by', $nuh ); + &setFactInfo( $faqtoid, 'locked_time', time() ); return 1; } @@ -129,21 +127,23 @@ sub CmdLock { sub CmdUnLock { my ($faqtoid) = @_; - my $thisnuh = &getFactInfo($faqtoid,'locked_by'); + my $thisnuh = &getFactInfo( $faqtoid, 'locked_by' ); - if (!defined $thisnuh) { - &msg($who, "factoid \002$faqtoid\002 is not locked."); - return 0; + if ( !defined $thisnuh ) { + &msg( $who, "factoid \002$faqtoid\002 is not locked." ); + return 0; } - if ($thisnuh ne '' and !&IsHostMatch($thisnuh) and &IsFlag('o') ne 'o') { - &msg($who, "sorry, you are not allowed to unlock factoid '$faqtoid'."); - return 0; + if ( $thisnuh ne '' and !&IsHostMatch($thisnuh) and &IsFlag('o') ne 'o' ) { + &msg( $who, + "sorry, you are not allowed to unlock factoid '$faqtoid'." ); + return 0; } &performReply("unlocking factoid \002$faqtoid\002"); - &setFactInfo($faqtoid,'locked_by', ''); - &setFactInfo($faqtoid,'locked_time', '0'); # pgsql complains if NOT NULL set. So set 0 which is the default + &setFactInfo( $faqtoid, 'locked_by', '' ); + &setFactInfo( $faqtoid, 'locked_time', '0' ) + ; # pgsql complains if NOT NULL set. So set 0 which is the default return 1; } diff --git a/src/Factoids/Norm.pl b/src/Factoids/Norm.pl index ba97e7d..120e7ba 100644 --- a/src/Factoids/Norm.pl +++ b/src/Factoids/Norm.pl @@ -13,52 +13,57 @@ sub normquery { $in = " $in "; for ($in) { - # where blah is -> where is blah - s/ (where|what|who)\s+(\S+)\s+(is|are) / $1 $3 $2 /i; - - # where blah is -> where is blah - s/ (where|what|who)\s+(.*)\s+(is|are) / $1 $3 $2 /i; - - s/^\s*(.*?)\s*/$1/; - - s/be tellin\'?g?/tell/i; - s/ \'?bout/ about/i; - - s/,? any(hoo?w?|ways?)/ /ig; - s/,?\s*(pretty )*please\??\s*$/\?/i; - - # what country is ... - if ($in =~ - s/wh(at|ich)\s+(add?res?s|country|place|net (suffix|domain))/wh$1 /ig) { - if ((length($in) == 2) && ($in !~ /^\./)) { - $in = '.'.$in; - } - $in .= '?'; - } - - # profanity filters. just delete it - s/th(e|at|is) (((m(o|u)th(a|er) ?)?fuck(in\'?g?)?|hell|heck|(god-?)?damn?(ed)?) ?)+//ig; - s/wtf/where/gi; - s/this (.*) thingy?/ $1/gi; - s/this thingy? (called )?//gi; - s/ha(s|ve) (an?y?|some|ne) (idea|clue|guess|seen) /know /ig; - s/does (any|ne|some) ?(1|one|body) know //ig; - s/do you know //ig; - s/can (you|u|((any|ne|some) ?(1|one|body)))( please)? tell (me|us|him|her)//ig; - s/where (\S+) can \S+ (a|an|the)?//ig; - s/(can|do) (i|you|one|we|he|she) (find|get)( this)?/is/i; # where can i find - s/(i|one|we|he|she) can (find|get)/is/gi; # where i can find - s/(the )?(address|url) (for|to) //i; # this should be more specific - s/(where is )+/where is /ig; - s/\s+/ /g; - s/^\s+//; - if ($in =~ s/\s*[\/?!]*\?+\s*$//) { - $finalQMark = 1; - } - - s/\s+/ /g; - s/^\s*(.*?)\s*$/$1/; - s/^\s+|\s+$//g; # why twice, see Question.pl + + # where blah is -> where is blah + s/ (where|what|who)\s+(\S+)\s+(is|are) / $1 $3 $2 /i; + + # where blah is -> where is blah + s/ (where|what|who)\s+(.*)\s+(is|are) / $1 $3 $2 /i; + + s/^\s*(.*?)\s*/$1/; + + s/be tellin\'?g?/tell/i; + s/ \'?bout/ about/i; + + s/,? any(hoo?w?|ways?)/ /ig; + s/,?\s*(pretty )*please\??\s*$/\?/i; + + # what country is ... + if ( $in =~ +s/wh(at|ich)\s+(add?res?s|country|place|net (suffix|domain))/wh$1 /ig + ) + { + if ( ( length($in) == 2 ) && ( $in !~ /^\./ ) ) { + $in = '.' . $in; + } + $in .= '?'; + } + + # profanity filters. just delete it +s/th(e|at|is) (((m(o|u)th(a|er) ?)?fuck(in\'?g?)?|hell|heck|(god-?)?damn?(ed)?) ?)+//ig; + s/wtf/where/gi; + s/this (.*) thingy?/ $1/gi; + s/this thingy? (called )?//gi; + s/ha(s|ve) (an?y?|some|ne) (idea|clue|guess|seen) /know /ig; + s/does (any|ne|some) ?(1|one|body) know //ig; + s/do you know //ig; +s/can (you|u|((any|ne|some) ?(1|one|body)))( please)? tell (me|us|him|her)//ig; + s/where (\S+) can \S+ (a|an|the)?//ig; + s/(can|do) (i|you|one|we|he|she) (find|get)( this)?/is/i + ; # where can i find + s/(i|one|we|he|she) can (find|get)/is/gi; # where i can find + s/(the )?(address|url) (for|to) //i; # this should be more specific + s/(where is )+/where is /ig; + s/\s+/ /g; + s/^\s+//; + + if ( $in =~ s/\s*[\/?!]*\?+\s*$// ) { + $finalQMark = 1; + } + + s/\s+/ /g; + s/^\s*(.*?)\s*$/$1/; + s/^\s+|\s+$//g; # why twice, see Question.pl } return $in; @@ -69,32 +74,34 @@ sub switchPerson { my ($in) = @_; for ($in) { - # # fix genitives - s/(^|\W)\Q$who\Es\s+/$1${who}\'s /ig; - s/(^|\W)\Q$who\Es$/$1${who}\'s/ig; - s/(^|\W)\Q$who\E\'(\s|$)/$1${who}\'s$2/ig; - - s/(^|\s)i\'m(\W|$)/$1$who is$2/ig; - s/(^|\s)i\'ve(\W|$)/$1$who has$2/ig; - s/(^|\s)i have(\W|$)/$1$who has$2/ig; - s/(^|\s)i haven\'?t(\W|$)/$1$who has not$2/ig; - s/(^|\s)i(\W|$)/$1$who$2/ig; - s/ am\b/ is/i; - s/\bam /is/i; - s/(^|\s)(me|myself)(\W|$)/$1$who$3/ig; - s/(^|\s)my(\W|$)/$1${who}\'s$2/ig; # turn 'my' into name's - s/(^|\W)you\'?re(\W|$)/$1you are$2/ig; - - if ($addressed) { - my $mynick = 'UNDEF'; - $mynick = $conn->nick() if ($conn); - # is it safe to remove $in from here, too? - $in =~ s/yourself/$mynick/i; - $in =~ s/(^|\W)are you(\W|$)/$1is $mynick$2/ig; - $in =~ s/(^|\W)you are(\W|$)/$1$mynick is$2/ig; - $in =~ s/(^|\W)you(\W|$)/$1$mynick$2/ig; - $in =~ s/(^|\W)your(\W|$)/$1$mynick\'s$2/ig; - } + + # # fix genitives + s/(^|\W)\Q$who\Es\s+/$1${who}\'s /ig; + s/(^|\W)\Q$who\Es$/$1${who}\'s/ig; + s/(^|\W)\Q$who\E\'(\s|$)/$1${who}\'s$2/ig; + + s/(^|\s)i\'m(\W|$)/$1$who is$2/ig; + s/(^|\s)i\'ve(\W|$)/$1$who has$2/ig; + s/(^|\s)i have(\W|$)/$1$who has$2/ig; + s/(^|\s)i haven\'?t(\W|$)/$1$who has not$2/ig; + s/(^|\s)i(\W|$)/$1$who$2/ig; + s/ am\b/ is/i; + s/\bam /is/i; + s/(^|\s)(me|myself)(\W|$)/$1$who$3/ig; + s/(^|\s)my(\W|$)/$1${who}\'s$2/ig; # turn 'my' into name's + s/(^|\W)you\'?re(\W|$)/$1you are$2/ig; + + if ($addressed) { + my $mynick = 'UNDEF'; + $mynick = $conn->nick() if ($conn); + + # is it safe to remove $in from here, too? + $in =~ s/yourself/$mynick/i; + $in =~ s/(^|\W)are you(\W|$)/$1is $mynick$2/ig; + $in =~ s/(^|\W)you are(\W|$)/$1$mynick is$2/ig; + $in =~ s/(^|\W)you(\W|$)/$1$mynick$2/ig; + $in =~ s/(^|\W)your(\W|$)/$1$mynick\'s$2/ig; + } } return $in; diff --git a/src/Factoids/Question.pl b/src/Factoids/Question.pl index 7a99e6b..71ae23c 100644 --- a/src/Factoids/Question.pl +++ b/src/Factoids/Question.pl @@ -17,285 +17,303 @@ use vars qw($query $reply $finalQMark $nuh $result $talkok $who $nuh); use vars qw(%bots %forked); sub doQuestion { + # my doesn't allow variables to be inherinted, local does. # following is used in math()... - local($query) = @_; - local($reply) = ''; - local $finalQMark = $query =~ s/\?+\s*$//; - $finalQMark += $query =~ s/\?\s*$//; - $query =~ s/^\s+|\s+$//g; - - if (!defined $query or $query =~ /^\s*$/) { - return ''; + local ($query) = @_; + local ($reply) = ''; + local $finalQMark = $query =~ s/\?+\s*$//; + $finalQMark += $query =~ s/\?\s*$//; + $query =~ s/^\s+|\s+$//g; + + if ( !defined $query or $query =~ /^\s*$/ ) { + return ''; } - my $questionWord = ''; - - if (!$addressed) { - return '' unless ($finalQMark); - return '' unless &IsChanConf('minVolunteerLength') > 0; - return '' if (length $query < &::getChanConf('minVolunteerLength')); - } else { - ### TODO: this should be caught in Process.pl? - return '' unless ($talkok); - - # there is no flag to disable/enable asking factoids... - # so it was added... thanks zyxep! :) - if (&IsFlag('a') ne 'a' && &IsFlag('o') ne 'o') { - &status("$who tried to ask us when not allowed."); - return; - } + my $questionWord = ''; + + if ( !$addressed ) { + return '' unless ($finalQMark); + return '' unless &IsChanConf('minVolunteerLength') > 0; + return '' if ( length $query < &::getChanConf('minVolunteerLength') ); + } + else { + ### TODO: this should be caught in Process.pl? + return '' unless ($talkok); + + # there is no flag to disable/enable asking factoids... + # so it was added... thanks zyxep! :) + if ( &IsFlag('a') ne 'a' && &IsFlag('o') ne 'o' ) { + &status("$who tried to ask us when not allowed."); + return; + } } # dangerous; common preambles should be stripped before here - if ($query =~ /^forget /i or $query =~ /^no, /) { - return if (exists $bots{$nuh}); + if ( $query =~ /^forget /i or $query =~ /^no, / ) { + return if ( exists $bots{$nuh} ); } - if ($query =~ s/^literal\s+//i) { - &status("literal ask of '$query'."); - $literal = 1; + if ( $query =~ s/^literal\s+//i ) { + &status("literal ask of '$query'."); + $literal = 1; } # convert to canonical reference form my $x; my @query; - push(@query, $query); # 1: push original. + push( @query, $query ); # 1: push original. # valid factoid. - if ($query =~ s/[!.]$//) { - push(@query, $query); + if ( $query =~ s/[!.]$// ) { + push( @query, $query ); } $x = &normquery($query); - push(@query, $x) if ($x ne $query); + push( @query, $x ) if ( $x ne $query ); $query = $x; $x = &switchPerson($query); - push(@query, $x) if ($x ne $query); + push( @query, $x ) if ( $x ne $query ); $query = $x; - $query =~ s/\s+at\s*(\?*)$/$1/; # where is x at? - $query =~ s/^explain\s*(\?*)/$1/i; # explain x - $query = " $query "; # side whitespaces. + $query =~ s/\s+at\s*(\?*)$/$1/; # where is x at? + $query =~ s/^explain\s*(\?*)/$1/i; # explain x + $query = " $query "; # side whitespaces. my $qregex = join '|', keys %{ $lang{'qWord'} }; # purge prefix question string. - if ($query =~ s/^ ($qregex)//i) { - $questionWord = lc($1); + if ( $query =~ s/^ ($qregex)//i ) { + $questionWord = lc($1); } - if ($questionWord eq '' and $finalQMark and $addressed) { - $questionWord = 'where'; + if ( $questionWord eq '' and $finalQMark and $addressed ) { + $questionWord = 'where'; } - $query =~ s/^\s+|\s+$//g; # bleh. hacked. - push(@query, $query) if ($query ne $x); + $query =~ s/^\s+|\s+$//g; # bleh. hacked. + push( @query, $query ) if ( $query ne $x ); - if (&IsChanConf('factoidArguments') > 0) { - $result = &factoidArgs($query[0]); + if ( &IsChanConf('factoidArguments') > 0 ) { + $result = &factoidArgs( $query[0] ); - return $result if (defined $result); + return $result if ( defined $result ); } my @link; - for (my$i=0; $i= 5) { - &status("recursive link limit (5) reached."); - last; - } - - push(@link, $link); - my $newr = &getReply($link); - - # no such factoid. try commands - if (!defined $newr || $newr =~ /^0?$/) { - # support command redirection. - # recursive cmdHooks aswell :) - my $done = 0; - $done++ if &parseCmdHook($link); - $message = $link; - $done++ unless (&Modules()); - - return; - } - last if (!defined $newr or $newr eq ''); - $result = $newr; - } - - if (@link) { - &status("'$query' linked to: ".join(" => ", @link) ); - } - - if ($i != 0) { - &VERB("Question.pl: '$query[0]' did not exist; '$query[$i]' ($i) did",2); - } - - return $result; + for ( my $i = 0 ; $i < scalar @query ; $i++ ) { + $query = $query[$i]; + $result = &getReply($query); + next if ( !defined $result or $result eq '' ); + + # 'see also' factoid redirection support. + + while ( $result =~ /^see( also)? (.*?)\.?$/ ) { + my $link = $2; + + # #debian@OPN was having problems with libstdc++ factoid + # redirection :) 20021116. -xk. + # hrm... allow recursive loops... next if statement handles + # that. + if ( grep /^\Q$link\E$/i, @link ) { + &status("recursive link found; bailing out."); + last; + } + + if ( scalar @link >= 5 ) { + &status("recursive link limit (5) reached."); + last; + } + + push( @link, $link ); + my $newr = &getReply($link); + + # no such factoid. try commands + if ( !defined $newr || $newr =~ /^0?$/ ) { + + # support command redirection. + # recursive cmdHooks aswell :) + my $done = 0; + $done++ if &parseCmdHook($link); + $message = $link; + $done++ unless ( &Modules() ); + + return; + } + last if ( !defined $newr or $newr eq '' ); + $result = $newr; + } + + if (@link) { + &status( "'$query' linked to: " . join( " => ", @link ) ); + } + + if ( $i != 0 ) { + &VERB( + "Question.pl: '$query[0]' did not exist; '$query[$i]' ($i) did", + 2 + ); + } + + return $result; } ### TODO: Use &Forker(); move function to Debian.pl - if (&IsChanConf('debianForFactoid') > 0) { - &loadMyModule('Debian'); - $result = &Debian::DebianFind($query); # ??? - ### TODO: debian module should tell, through shm, that it went - ### ok or not. + if ( &IsChanConf('debianForFactoid') > 0 ) { + &loadMyModule('Debian'); + $result = &Debian::DebianFind($query); # ??? + ### TODO: debian module should tell, through shm, that it went + ### ok or not. ### return $result if (defined $result); } - if ($questionWord ne '' or $finalQMark) { - # if it has not been explicitly marked as a question - if ($addressed and $reply eq '') { - &status("notfound: <$who> ".join(' :: ', @query)) - if ($finalQMark); + if ( $questionWord ne '' or $finalQMark ) { + + # if it has not been explicitly marked as a question + if ( $addressed and $reply eq '' ) { + &status( "notfound: <$who> " . join( ' :: ', @query ) ) + if ($finalQMark); - return '' unless (&IsParam('friendlyBots')); + return '' unless ( &IsParam('friendlyBots') ); - foreach (split /\s+/, $param{'friendlyBots'}) { - &msg($_, ":INFOBOT:QUERY <$who> $query"); - } - } + foreach ( split /\s+/, $param{'friendlyBots'} ) { + &msg( $_, ":INFOBOT:QUERY <$who> $query" ); + } + } } return $reply; } sub factoidArgs { - my($str) = @_; + my ($str) = @_; my $result; # to make it eleeter, split each arg and use "blah OR blah or BLAH" # which will make it less than linear => quicker! # TODO: cache this, update cache when altered. !!! !!! !!! -# my $t = &timeget(); - my ($first) = split(/\s+/, $str); + # my $t = &timeget(); + my ($first) = split( /\s+/, $str ); # ignore split to commands [dumb commands vs. factoids] (editing commands?) return undef if $str =~ /\s+\=\~\s+s[\#\/\:]/; - my @list = &searchTable('factoids', 'factoid_key', 'factoid_key', "^cmd: $first "); -# my $delta_time = &timedelta($t); -# &DEBUG("factArgs: delta_time = $delta_time s"); -# &DEBUG("factArgs: list => ".scalar(@list) ); + my @list = + &searchTable( 'factoids', 'factoid_key', 'factoid_key', "^cmd: $first " ); + + # my $delta_time = &timedelta($t); + # &DEBUG("factArgs: delta_time = $delta_time s"); + # &DEBUG("factArgs: list => ".scalar(@list) ); # from a design perspective, it's better to have the regex in # the factoid key to reduce repetitive processing. # it does not matter if it's not alphabetically sorted. - foreach (sort { length($b) <=> length($a) } @list) { - next if (/#DEL#/); # deleted. - - s/^cmd: //i; -# &DEBUG("factarg: '$str' =~ /^$_\$/"); - my $arg = $_; - - # eval (evil!) code. cleaned up courtesy of lear. - my @vals; - eval { - @vals = ($str =~ /^$arg$/i); - }; - - if ($@) { - &WARN("factargs: regex failed! '$str' =~ /^$_\$/"); - next; - } - - next unless (@vals); - - if (defined $result) { - &WARN("factargs: '$_' matches aswell."); - next; - } - -# &DEBUG("vals => @vals"); - - &status("Question: factoid Arguments for '$str'"); - # TODO: use getReply() - need to modify it :( - my $i = 0; - my $q = "cmd: $_"; - my $r = &getFactoid($q); - if (!defined $r) { - &DEBUG("question: !result... should this happen?"); - return; - } - - # update stats. old mysql/sqlite don't do +1 - my ($count) = &sqlSelect('factoids', 'requested_count', { factoid_key => $q }); - $count++; - &sqlSet('factoids', {'factoid_key' => $q}, { - requested_by => $nuh, - requested_time => time(), - requested_count => $count - } ); - - # end of update stats. - - $result = $r; - - $result =~ s/^\((.*?)\): //; - my $vars = $1; - - # start nasty hack to get partial &getReply() functionality. - $result = &SARit($result); - - foreach ( split(',', $vars) ) { - my $val = $vals[$i]; - &DEBUG("val => $val"); - - if (!defined $val) { - &status("factArgs: vals[$i] == undef; not SARing '$_' for '$str'"); - next; - } - - my $done = 0; - my $old = $result; - while (1) { - &DEBUG("Q: result => $result (1before)"); - $result = &substVars($result,1); - &DEBUG("Q: result => $result (1after)"); - - last if ($old eq $result); - $old = $result; - $done++; - } - - # hack. - $vals[$i] =~ s/^me$/$who/gi; - -# if (!$done) { - &status("factArgs: SARing '$_' to '$vals[$i]'."); - $result =~ s/\Q$_\E/$vals[$i]/g; -# } - $i++; - } - - $result = &SARit($result); - # rest of nasty hack to get partial &getReply() functionality. - $result =~ s/^\s*\s*(.*)/\cAACTION $1\cA/i; - $result =~ s/^\s*\s*//i; - -# well... lets go through all of them. not advisable if we have like -# 1000 commands, heh. -# return $result; - $cmdstats{'Factoid Commands'}++; + foreach ( sort { length($b) <=> length($a) } @list ) { + next if (/#DEL#/); # deleted. + + s/^cmd: //i; + + # &DEBUG("factarg: '$str' =~ /^$_\$/"); + my $arg = $_; + + # eval (evil!) code. cleaned up courtesy of lear. + my @vals; + eval { @vals = ( $str =~ /^$arg$/i ); }; + + if ($@) { + &WARN("factargs: regex failed! '$str' =~ /^$_\$/"); + next; + } + + next unless (@vals); + + if ( defined $result ) { + &WARN("factargs: '$_' matches aswell."); + next; + } + + # &DEBUG("vals => @vals"); + + &status("Question: factoid Arguments for '$str'"); + + # TODO: use getReply() - need to modify it :( + my $i = 0; + my $q = "cmd: $_"; + my $r = &getFactoid($q); + if ( !defined $r ) { + &DEBUG("question: !result... should this happen?"); + return; + } + + # update stats. old mysql/sqlite don't do +1 + my ($count) = + &sqlSelect( 'factoids', 'requested_count', { factoid_key => $q } ); + $count++; + &sqlSet( + 'factoids', + { 'factoid_key' => $q }, + { + requested_by => $nuh, + requested_time => time(), + requested_count => $count + } + ); + + # end of update stats. + + $result = $r; + + $result =~ s/^\((.*?)\): //; + my $vars = $1; + + # start nasty hack to get partial &getReply() functionality. + $result = &SARit($result); + + foreach ( split( ',', $vars ) ) { + my $val = $vals[$i]; + + # &DEBUG("val => $val"); + + if ( !defined $val ) { + &status( + "factArgs: vals[$i] == undef; not SARing '$_' for '$str'"); + next; + } + + my $done = 0; + my $old = $result; + while (1) { + + # &DEBUG("Q: result => $result (1before)"); + $result = &substVars( $result, 1 ); + + # &DEBUG("Q: result => $result (1after)"); + + last if ( $old eq $result ); + $old = $result; + $done++; + } + + # hack. + $vals[$i] =~ s/^me$/$who/gi; + + # if (!$done) { + &status("factArgs: SARing '$_' to '$vals[$i]'."); + $result =~ s/\Q$_\E/$vals[$i]/g; + + # } + $i++; + } + + # rest of nasty hack to get partial &getReply() functionality. + $result =~ s/^\s*\s*(.*)/\cAACTION $1\cA/i; + $result =~ s/^\s*\s*//i; + + # well... lets go through all of them. not advisable if we have like + # 1000 commands, heh. + # return $result; + $cmdstats{'Factoid Commands'}++; } return $result; diff --git a/src/Factoids/Reply.pl b/src/Factoids/Reply.pl index ec3649b..89faac2 100644 --- a/src/Factoids/Reply.pl +++ b/src/Factoids/Reply.pl @@ -17,349 +17,375 @@ use vars qw($msgType $uh $lastWho $ident); use vars qw(%lang %lastWho); sub getReply { - my($message) = @_; - my($lhs,$mhs,$rhs); - my($reply, $count, $fauthor, $result, $factoid, $search, @searches); + my ($message) = @_; + my ( $lhs, $mhs, $rhs ); + my ( $reply, $count, $fauthor, $result, $factoid, $search, @searches ); $orig{message} = $message; - if (!defined $message or $message =~ /^\s*$/) { - &WARN("getR: message == NULL."); - return ''; + if ( !defined $message or $message =~ /^\s*$/ ) { + &WARN("getR: message == NULL."); + return ''; } $message =~ tr/A-Z/a-z/; - @searches = split(/\s+/, &getChanConfDefault('factoidSearch', '_default', $chan)); - &::DEBUG("factoidSearch: $chan is: " . join(':', @searches)); + @searches = + split( /\s+/, &getChanConfDefault( 'factoidSearch', '_default', $chan ) ); + &::DEBUG( "factoidSearch: $chan is: " . join( ':', @searches ) ); + # requesting the _default one, ignore factoidSearch - if ($message =~ /^_default\s+/) { - @searches = ('_default'); - $message =~ s/^_default\s+//; + if ( $message =~ /^_default\s+/ ) { + @searches = ('_default'); + $message =~ s/^_default\s+//; } # check for factoids with each prefix foreach $search (@searches) { - if ($search eq '$chan') { - $factoid = "$chan $message"; - } elsif ($search eq '_default') { - $factoid = $message; - } else { - $factoid = "$search $message"; - } - ($count, $fauthor, $result) = &sqlSelect('factoids', - "requested_count,created_by,factoid_value", - { factoid_key => $factoid } - ); - last if ($result); + if ( $search eq '$chan' ) { + $factoid = "$chan $message"; + } + elsif ( $search eq '_default' ) { + $factoid = $message; + } + else { + $factoid = "$search $message"; + } + ( $count, $fauthor, $result ) = &sqlSelect( + 'factoids', + "requested_count,created_by,factoid_value", + { factoid_key => $factoid } + ); + last if ($result); } if ($result) { - $lhs = $message; - $mhs = 'is'; - $rhs = $result; + $lhs = $message; + $mhs = 'is'; + $rhs = $result; - return "\"$factoid\" $mhs \"$rhs\"" if ($literal); - } else { - return ''; + return "\"$factoid\" $mhs \"$rhs\"" if ($literal); + } + else { + return ''; } # if there was a head... - my(@poss) = split '\|\|', $result; - $poss[0] =~ s/^\s//; + my (@poss) = split '\|\|', $result; + $poss[0] =~ s/^\s//; $poss[$#poss] =~ s/\s$//; - if (@poss > 1) { - $result = &getRandom(@poss); - $result =~ s/^\s*//; + if ( @poss > 1 ) { + $result = &getRandom(@poss); + $result =~ s/^\s*//; } - $result = &SARit($result); - - $reply = $result; - if ($result ne '') { - ### AT LAST, REPEAT PREVENTION CODE REMOVED IN FAVOUR OF GLOBAL - ### FLOOD REPETION AND PROTECTION. -20000124 - - # stats code. - ### FIXME: old mysql/sqlite doesn't support - ### "requested_count=requested_count+1". - $count++; - &sqlSet('factoids', {'factoid_key' => $factoid}, { - requested_by => $nuh, - requested_time => time(), - requested_count => $count - } ); - - # TODO: rename $real to something else! - my $real = 0; -# my $author = &getFactInfo($lhs,'created_by') || ''; -# $real++ if ($author =~ /^\Q$who\E\!/); -# $real++ if (&IsFlag('n')); - $real = 0 if ($msgType =~ /public/); - - ### fix up the reply. - # only remove '' - if (!$real and $reply =~ s/^\s*\s*//i) { - # 'are' fix. - if ($reply =~ s/^are /$lhs are /i) { - &VERB("Reply.pl: el-cheapo 'are' fix executed.",2); - } - - } elsif (!$real and $reply =~ s/^\s*\s*(.*)/\cAACTION $1\cA/i) { - # only remove '' and make it an action. - } else { # not a short reply - - ### bot->bot reply. - if (exists $bots{$nuh} and $rhs !~ /^\s*$/) { - return "$lhs $mhs $rhs"; - } - - ### bot->person reply. - # result is random if separated by '||'. - # rhs is full factoid with '||'. - if ($mhs eq 'is') { - $reply = &getRandom(keys %{ $lang{'factoid'} }); - $reply =~ s/##KEY/$lhs/; - $reply =~ s/##VALUE/$result/; - } else { - $reply = "$lhs $mhs $result"; - } - - if ($reply =~ s/^\Q$who\E is/you are/i) { - # fix the person. - } else { - if ($reply =~ /^you are / or $reply =~ / you are /) { - return if ($addressed); - } - } - } + $result = &SARit($result); + + $reply = $result; + if ( $result ne '' ) { + ### AT LAST, REPEAT PREVENTION CODE REMOVED IN FAVOUR OF GLOBAL + ### FLOOD REPETION AND PROTECTION. -20000124 + + # stats code. + ### FIXME: old mysql/sqlite doesn't support + ### "requested_count=requested_count+1". + $count++; + &sqlSet( + 'factoids', + { 'factoid_key' => $factoid }, + { + requested_by => $nuh, + requested_time => time(), + requested_count => $count + } + ); + + # TODO: rename $real to something else! + my $real = 0; + + # my $author = &getFactInfo($lhs,'created_by') || ''; + # $real++ if ($author =~ /^\Q$who\E\!/); + # $real++ if (&IsFlag('n')); + $real = 0 if ( $msgType =~ /public/ ); + + ### fix up the reply. + # only remove '' + if ( !$real and $reply =~ s/^\s*\s*//i ) { + + # 'are' fix. + if ( $reply =~ s/^are /$lhs are /i ) { + &VERB( "Reply.pl: el-cheapo 'are' fix executed.", 2 ); + } + + } + elsif ( !$real and $reply =~ s/^\s*\s*(.*)/\cAACTION $1\cA/i ) { + + # only remove '' and make it an action. + } + else { # not a short reply + + ### bot->bot reply. + if ( exists $bots{$nuh} and $rhs !~ /^\s*$/ ) { + return "$lhs $mhs $rhs"; + } + + ### bot->person reply. + # result is random if separated by '||'. + # rhs is full factoid with '||'. + if ( $mhs eq 'is' ) { + $reply = &getRandom( keys %{ $lang{'factoid'} } ); + $reply =~ s/##KEY/$lhs/; + $reply =~ s/##VALUE/$result/; + } + else { + $reply = "$lhs $mhs $result"; + } + + if ( $reply =~ s/^\Q$who\E is/you are/i ) { + + # fix the person. + } + else { + if ( $reply =~ /^you are / or $reply =~ / you are / ) { + return if ($addressed); + } + } + } } # remove excessive beginning and end whitespaces. - $reply =~ s/^\s+|\s+$//g; + $reply =~ s/^\s+|\s+$//g; - if ($reply =~ /^\s+$/) { - &DEBUG("Reply: Null factoid ($message)"); - return ''; + if ( $reply =~ /^\s+$/ ) { + &DEBUG("Reply: Null factoid ($message)"); + return ''; } - return $reply unless ($reply =~ /\$/); + return $reply unless ( $reply =~ /\$/ ); ### ### $ SUBSTITUTION. ### # don't evaluate if it has factoid arguments. -# if ($message =~ /^cmd:/i) { -# &status("Reply: not doing substVars (eval dollar vars)"); -# } else { - $reply = &substVars($reply,1); -# } + # if ($message =~ /^cmd:/i) { + # &status("Reply: not doing substVars (eval dollar vars)"); + # } else { + $reply = &substVars( $reply, 1 ); + + # } $reply; } sub smart_replace { my ($string) = @_; - my ($l,$r) = (0,0); # l = left, r = right. - my ($s,$t) = (0,0); # s = start, t = marker. - my $i = 0; - my $old = $string; + my ( $l, $r ) = ( 0, 0 ); # l = left, r = right. + my ( $s, $t ) = ( 0, 0 ); # s = start, t = marker. + my $i = 0; + my $old = $string; my @rand; - foreach (split //, $string) { + foreach ( split //, $string ) { - if ($_ eq "(") { - if (!$l and !$r) { - $s = $i; - $t = $i; - } + if ( $_ eq "(" ) { + if ( !$l and !$r ) { + $s = $i; + $t = $i; + } - $l++; - $r--; - } + $l++; + $r--; + } - if ($_ eq ")") { - $r++; - $l--; + if ( $_ eq ")" ) { + $r++; + $l--; - if (!$l and !$r) { - my $substr = substr($old,$s,$i-$s+1); - push(@rand, substr($old,$t+1,$i-$t-1) ); + if ( !$l and !$r ) { + my $substr = substr( $old, $s, $i - $s + 1 ); + push( @rand, substr( $old, $t + 1, $i - $t - 1 ) ); - my $rand = $rand[rand @rand]; -# &status("SARing '$substr' to '$rand'."); - $string =~ s/\Q$substr\E/$rand/; - undef @rand; - } - } + my $rand = $rand[ rand @rand ]; - if ($_ eq "|" and $l+$r== 0 and $l==1) { - push(@rand, substr($old,$t+1,$i-$t-1) ); - $t = $i; - } + # &status("SARing '$substr' to '$rand'."); + $string =~ s/\Q$substr\E/$rand/; + undef @rand; + } + } - $i++; + if ( $_ eq "|" and $l + $r == 0 and $l == 1 ) { + push( @rand, substr( $old, $t + 1, $i - $t - 1 ) ); + $t = $i; + } + + $i++; } - if ($old eq $string) { - &WARN("smart_replace: no subst made. (string => $string)"); + if ( $old eq $string ) { + &WARN("smart_replace: no subst made. (string => $string)"); } return $string; } sub SARit { - my($txt) = @_; + my ($txt) = @_; my $done = 0; # (blah1|blah2)? - while ($txt =~ /\((.*?)\)\?/) { - my $str = $1; - if (rand() > 0.5) { # fix. - &status("Factoid transform: keeping '$str'."); - $txt =~ s/\(\Q$str\E\)\?/$str/; - } else { # remove - &status("Factoid transform: removing '$str'."); - $txt =~ s/\(\Q$str\E\)\?\s?//; - } - $done++; - last if ($done >= 10); # just in case. + while ( $txt =~ /\((.*?)\)\?/ ) { + my $str = $1; + if ( rand() > 0.5 ) { # fix. + &status("Factoid transform: keeping '$str'."); + $txt =~ s/\(\Q$str\E\)\?/$str/; + } + else { # remove + &status("Factoid transform: removing '$str'."); + $txt =~ s/\(\Q$str\E\)\?\s?//; + } + $done++; + last if ( $done >= 10 ); # just in case. } $done = 0; # EG: (0-32768) => 6325 ### TODO: (1-10,20-30,40) => 24 - while ($txt =~ /\((\d+)-(\d+)\)/) { - my ($lower,$upper) = ($1,$2); - my $new = int(rand $upper-$lower) + $lower; - - &status("SARing '$&' to '$new' (2)."); - $txt =~ s/$&/$new/; - $done++; - last if ($done >= 10); # just in case. + while ( $txt =~ /\((\d+)-(\d+)\)/ ) { + my ( $lower, $upper ) = ( $1, $2 ); + my $new = int( rand $upper - $lower ) + $lower; + + &status("SARing '$&' to '$new' (2)."); + $txt =~ s/$&/$new/; + $done++; + last if ( $done >= 10 ); # just in case. } $done = 0; # EG: (blah1|blah2|blah3|) => blah1 - while ($txt =~ /.*\((.*\|.*?)\).*/) { - $txt = &smart_replace($txt); + while ( $txt =~ /.*\((.*\|.*?)\).*/ ) { + $txt = &smart_replace($txt); - $done++; - last if ($done >= 10); # just in case. + $done++; + last if ( $done >= 10 ); # just in case. } &status("Reply.pl: $done SARs done.") if ($done); # type # - while ($txt =~ /(.*)<\/URL>/){ - &status("we have to norm this stuff, SARing"); - my $foobar = $1; - if ($foobar =~ m/(http:\/\/[^?]+)\?(.*)/){ - my ($pig1,$pig2) = ($1,$2); - &status("SARing using URLencode"); - $pig2=~s/([^\w])/sprintf("%%%02x",ord($1))/gie; - $foobar=$pig1."?".$pig2; - } - $txt =~ s/(.*)<\/URL>/$foobar/; + while ( $txt =~ /(.*)<\/URL>/ ) { + &status("we have to norm this stuff, SARing"); + my $foobar = $1; + if ( $foobar =~ m/(http:\/\/[^?]+)\?(.*)/ ) { + my ( $pig1, $pig2 ) = ( $1, $2 ); + &status("SARing using URLencode"); + $pig2 =~ s/([^\w])/sprintf("%%%02x",ord($1))/gie; + $foobar = $pig1 . "?" . $pig2; + } + $txt =~ s/(.*)<\/URL>/$foobar/; } return $txt; } sub substVars { - my($reply,$flag) = @_; + my ( $reply, $flag ) = @_; # $date, $time, $day. # TODO: support localtime. - my $date = strftime("%Y.%m.%d", gmtime()); - $reply =~ s/\$date/$date/gi; - my $time = strftime("%k:%M:%S", gmtime()); - $reply =~ s/\$time/$time/gi; - my $day = strftime("%A", gmtime()); - $reply =~ s/\$day/$day/gi; + my $date = strftime( "%Y.%m.%d", gmtime() ); + $reply =~ s/\$date/$date/gi; + my $time = strftime( "%k:%M:%S", gmtime() ); + $reply =~ s/\$time/$time/gi; + my $day = strftime( "%A", gmtime() ); + $reply =~ s/\$day/$day/gi; # support $ident when I have multiple nicks my $mynick = $conn->nick() if $conn; # dollar variables. if ($flag) { - $reply =~ s/\$nick/$who/g; - $reply =~ s/\$who/$who/g; # backward compat. + $reply =~ s/\$nick/$who/g; + $reply =~ s/\$who/$who/g; # backward compat. } - if ($reply =~ /\$(user(name)?|host)/) { - my ($username, $hostname) = split /\@/, $uh; - $reply =~ s/\$user(name)?/$username/g; - $reply =~ s/\$host(name)?/$hostname/g; + if ( $reply =~ /\$(user(name)?|host)/ ) { + my ( $username, $hostname ) = split /\@/, $uh; + $reply =~ s/\$user(name)?/$username/g; + $reply =~ s/\$host(name)?/$hostname/g; + } + $reply =~ s/\$chan(nel)?/$talkchannel/g; + if ( $msgType =~ /public/ ) { + $reply =~ s/\$lastspeaker/$lastWho{$talkchannel}/g; } - $reply =~ s/\$chan(nel)?/$talkchannel/g; - if ($msgType =~ /public/) { - $reply =~ s/\$lastspeaker/$lastWho{$talkchannel}/g; - } else { - $reply =~ s/\$lastspeaker/$lastWho/g; + else { + $reply =~ s/\$lastspeaker/$lastWho/g; } - if ($reply =~ /\$rand/) { - my $rand = rand(); - - # $randnick. - if ($reply =~ /\$randnick/) { - my @nicks = keys %{ $channels{$chan}{''} }; - my $randnick = $nicks[ int($rand*$#nicks) ]; - $reply =~ s/\$randnick/$randnick/g; - } - - # eg: $rand100.3 - if ($reply =~ /\$rand(\d+)(\.(\d+))?/) { - my $max = $1; - my $dot = $3 || 0; - my $orig = $&; - #&DEBUG("dot => $dot, max => $max, rand=>$rand"); - $rand = sprintf("%.*f", $dot, $rand*$max); - - &DEBUG("swapping $orig to $rand"); - $reply =~ s/\Q$orig\E/$rand/eg; - } else { - $reply =~ s/\$rand/$rand/g; - } + if ( $reply =~ /\$rand/ ) { + my $rand = rand(); + + # $randnick. + if ( $reply =~ /\$randnick/ ) { + my @nicks = keys %{ $channels{$chan}{''} }; + my $randnick = $nicks[ int( $rand * $#nicks ) ]; + $reply =~ s/\$randnick/$randnick/g; + } + + # eg: $rand100.3 + if ( $reply =~ /\$rand(\d+)(\.(\d+))?/ ) { + my $max = $1; + my $dot = $3 || 0; + my $orig = $&; + + #&DEBUG("dot => $dot, max => $max, rand=>$rand"); + $rand = sprintf( "%.*f", $dot, $rand * $max ); + + &DEBUG("swapping $orig to $rand"); + $reply =~ s/\Q$orig\E/$rand/eg; + } + else { + $reply =~ s/\$rand/$rand/g; + } } - $reply =~ s/\$ident/$mynick/g; + $reply =~ s/\$ident/$mynick/g; - if ($reply =~ /\$startTime/) { - my $time = scalar(gmtime $^T); - $reply =~ s/\$startTime/$time/; + if ( $reply =~ /\$startTime/ ) { + my $time = scalar( gmtime $^T ); + $reply =~ s/\$startTime/$time/; } - if ($reply =~ /\$uptime/) { - my $uptime = &Time2String(time() - $^T); - $reply =~ s/\$uptime/$uptime/; + if ( $reply =~ /\$uptime/ ) { + my $uptime = &Time2String( time() - $^T ); + $reply =~ s/\$uptime/$uptime/; } - if ($reply =~ /\$factoids/) { - my $factoids = &countKeys('factoids'); - $reply =~ s/\$factoids/$factoids/; + if ( $reply =~ /\$factoids/ ) { + my $factoids = &countKeys('factoids'); + $reply =~ s/\$factoids/$factoids/; } - if ($reply =~ /\$Fupdate/) { - my $x = "\002$count{'Update'}\002 ". - &fixPlural('modification', $count{'Update'}); - $reply =~ s/\$Fupdate/$x/; + if ( $reply =~ /\$Fupdate/ ) { + my $x = + "\002$count{'Update'}\002 " + . &fixPlural( 'modification', $count{'Update'} ); + $reply =~ s/\$Fupdate/$x/; } - if ($reply =~ /\$Fquestion/) { - my $x = "\002$count{'Question'}\002 ". - &fixPlural('question', $count{'Question'}); - $reply =~ s/\$Fquestion/$x/; + if ( $reply =~ /\$Fquestion/ ) { + my $x = + "\002$count{'Question'}\002 " + . &fixPlural( 'question', $count{'Question'} ); + $reply =~ s/\$Fquestion/$x/; } - if ($reply =~ /\$Fdunno/) { - my $x = "\002$count{'Dunno'}\002 ". - &fixPlural('dunno', $count{'Dunno'}); - $reply =~ s/\$Fdunno/$x/; + if ( $reply =~ /\$Fdunno/ ) { + my $x = + "\002$count{'Dunno'}\002 " . &fixPlural( 'dunno', $count{'Dunno'} ); + $reply =~ s/\$Fdunno/$x/; } - $reply =~ s/\$memusage/$memusage/; + $reply =~ s/\$memusage/$memusage/; return $reply; } diff --git a/src/Factoids/Statement.pl b/src/Factoids/Statement.pl index 0df4918..2c5a8e2 100644 --- a/src/Factoids/Statement.pl +++ b/src/Factoids/Statement.pl @@ -16,96 +16,100 @@ # use strict; # TODO sub doStatement { - my($in) = @_; + my ($in) = @_; - $in =~ s/\\(\S+)/\#$1\#/g; # fix the backslash. - $in =~ s/^no([, ]+)//i; # 'no, '. + $in =~ s/\\(\S+)/\#$1\#/g; # fix the backslash. + $in =~ s/^no([, ]+)//i; # 'no, '. # check if we need to be addressed and if we are return unless ($learnok); - my($urlType) = ''; + my ($urlType) = ''; # prefix www with http:// and ftp with ftp:// $in =~ s/ www\./ http:\/\/www\./ig; $in =~ s/ ftp\./ ftp:\/\/ftp\./ig; - $urlType = 'about' if ($in =~ /\babout:/i); - $urlType = 'afp' if ($in =~ /\bafp:/); - $urlType = 'file' if ($in =~ /\bfile:/); - $urlType = 'palace' if ($in =~ /\bpalace:/); - $urlType = 'phoneto' if ($in =~ /\bphone(to)?:/); - if ($in =~ /\b(news|http|ftp|gopher|telnet):\s*\/\/[\-\w]+(\.[\-\w]+)+/) { - $urlType = $1; + $urlType = 'about' if ( $in =~ /\babout:/i ); + $urlType = 'afp' if ( $in =~ /\bafp:/ ); + $urlType = 'file' if ( $in =~ /\bfile:/ ); + $urlType = 'palace' if ( $in =~ /\bpalace:/ ); + $urlType = 'phoneto' if ( $in =~ /\bphone(to)?:/ ); + if ( $in =~ /\b(news|http|ftp|gopher|telnet):\s*\/\/[\-\w]+(\.[\-\w]+)+/ ) { + $urlType = $1; } # acceptUrl. - if (&IsParam('acceptUrl')) { - if ($param{'acceptUrl'} eq 'REQUIRE') { # require url type. - return if ($urlType eq ''); - } elsif ($param{'acceptUrl'} eq 'REJECT') { - &status("REJECTED URL entry") if (&IsParam('VERBOSITY')); - return unless ($urlType eq ''); - } else { - # OPTIONAL - } + if ( &IsParam('acceptUrl') ) { + if ( $param{'acceptUrl'} eq 'REQUIRE' ) { # require url type. + return if ( $urlType eq '' ); + } + elsif ( $param{'acceptUrl'} eq 'REJECT' ) { + &status("REJECTED URL entry") if ( &IsParam('VERBOSITY') ); + return unless ( $urlType eq '' ); + } + else { + + # OPTIONAL + } } # learn statement. '$lhs is|are $rhs' - if ($in =~ /(^|\s)(is|are)(\s|$)/i) { - my($lhs, $mhs, $rhs) = ($`, $&, $'); - - # allows factoid arguments to be updated. -lear. - $lhs =~ s/^(cmd: )?(.*)/$1||'' . lc $2/e; - - # discard article. - $lhs =~ s/^(the|da|an?)\s+//i; - - # remove excessive initial and final whitespaces. - $lhs =~ s/^\s+|\s+$//g; - $mhs =~ s/^\s+|\s+$//g; - $rhs =~ s/^\s+|\s+$//g; - - # break if either lhs or rhs is NULL. - if ($lhs eq '' or $rhs eq '') { - return "NOT-A-STATEMENT"; - } - - # lets check if it failed. - if (&validFactoid($lhs,$rhs) == 0) { - if ($addressed) { - &status("IGNORE statement: <$who> $message"); - &performReply( &getRandom(keys %{ $lang{'confused'} }) ); - } - return; - } - - # uncomment to prevent HUNGRY learning of rhs with whitespace - #return if (!$addressed and $lhs =~ /\s+/); - &::DEBUG("doStatement: $in:$lhs:$mhs:$rhs"); - - &status("statement: <$who> $message"); - - # change "#*#" back to '*' because of '\' sar to '#blah#'. - $lhs =~ s/\#(\S+)\#/$1/g; - $rhs =~ s/\#(\S+)\#/$1/g; - - $lhs =~ s/\?+\s*$//; # strip off '?'. - - # verify the update statement whether there are any weird - # characters. - ### this can be simplified. - foreach (split //, $lhs.$rhs) { - my $ord = ord $_; - if ($ord > 170 and $ord < 220) { - &status("statement: illegal character '$_' $ord."); - &performAddressedReply("i'm not going to learn illegal characters"); - return; - } - } - - # success. - return if (&update($lhs, $mhs, $rhs)); + if ( $in =~ /(^|\s)(is|are)(\s|$)/i ) { + my ( $lhs, $mhs, $rhs ) = ( $`, $&, $' ); + + # allows factoid arguments to be updated. -lear. + $lhs =~ s/^(cmd: )?(.*)/$1||'' . lc $2/e; + + # discard article. + $lhs =~ s/^(the|da|an?)\s+//i; + + # remove excessive initial and final whitespaces. + $lhs =~ s/^\s+|\s+$//g; + $mhs =~ s/^\s+|\s+$//g; + $rhs =~ s/^\s+|\s+$//g; + + # break if either lhs or rhs is NULL. + if ( $lhs eq '' or $rhs eq '' ) { + return "NOT-A-STATEMENT"; + } + + # lets check if it failed. + if ( &validFactoid( $lhs, $rhs ) == 0 ) { + if ($addressed) { + &status("IGNORE statement: <$who> $message"); + &performReply( &getRandom( keys %{ $lang{'confused'} } ) ); + } + return; + } + + # uncomment to prevent HUNGRY learning of rhs with whitespace + #return if (!$addressed and $lhs =~ /\s+/); + &::DEBUG("doStatement: $in:$lhs:$mhs:$rhs"); + + &status("statement: <$who> $message"); + + # change "#*#" back to '*' because of '\' sar to '#blah#'. + $lhs =~ s/\#(\S+)\#/$1/g; + $rhs =~ s/\#(\S+)\#/$1/g; + + $lhs =~ s/\?+\s*$//; # strip off '?'. + + # verify the update statement whether there are any weird + # characters. + ### this can be simplified. + foreach ( split //, $lhs . $rhs ) { + my $ord = ord $_; + if ( $ord > 170 and $ord < 220 ) { + &status("statement: illegal character '$_' $ord."); + &performAddressedReply( + "i'm not going to learn illegal characters"); + return; + } + } + + # success. + return if ( &update( $lhs, $mhs, $rhs ) ); } return 'CONTINUE'; diff --git a/src/Factoids/Update.pl b/src/Factoids/Update.pl index 9ee8e22..faefd32 100644 --- a/src/Factoids/Update.pl +++ b/src/Factoids/Update.pl @@ -9,233 +9,291 @@ # use strict; # TODO sub update { - my($lhs, $mhs, $rhs) = @_; + my ( $lhs, $mhs, $rhs ) = @_; for ($lhs) { - s/^i (heard|think) //i; - s/^some(one|1|body) said //i; - s/\s+/ /g; + s/^i (heard|think) //i; + s/^some(one|1|body) said //i; + s/\s+/ /g; } # locked. - return if (&IsLocked($lhs) == 1); + return if ( &IsLocked($lhs) == 1 ); # profanity. - if (&IsParam('profanityCheck') and &hasProfanity($rhs)) { - &performReply("please, watch your language."); - return 1; + if ( &IsParam('profanityCheck') and &hasProfanity($rhs) ) { + &performReply("please, watch your language."); + return 1; } # teaching. - if (&IsFlag('t') ne 't' && &IsFlag('o') ne 'o') { - &msg($who, "permission denied."); - &status("alert: $who wanted to teach me."); - return 1; + if ( &IsFlag('t') ne 't' && &IsFlag('o') ne 'o' ) { + &msg( $who, "permission denied." ); + &status("alert: $who wanted to teach me."); + return 1; } # invalid verb. - if ($mhs !~ /^(is|are)$/i) { - &ERROR("UNKNOWN verb: $mhs."); - return; + if ( $mhs !~ /^(is|are)$/i ) { + &ERROR("UNKNOWN verb: $mhs."); + return; } # check if the arguments are too long to be stored in our table. - my $toolong = 0; - $toolong++ if (length $lhs > $param{'maxKeySize'}); - $toolong++ if (length $rhs > $param{'maxDataSize'}); + my $toolong = 0; + $toolong++ if ( length $lhs > $param{'maxKeySize'} ); + $toolong++ if ( length $rhs > $param{'maxDataSize'} ); if ($toolong) { - &performAddressedReply("that's too long"); - return 1; + &performAddressedReply("that's too long"); + return 1; } # also checking. - my $also = ($rhs =~ s/^-?also //i); - my $also_or = ($also and $rhs =~ s/\s+(or|\|\|)\s+//); + my $also = ( $rhs =~ s/^-?also //i ); + my $also_or = ( $also and $rhs =~ s/\s+(or|\|\|)\s+// ); + + if ( $also or $also_or ) { + my $author = &getFactInfo( $from, 'created_by' ); + $author =~ /^(.*)!/; + my $created_by = $1; + + # Can they even modify factoids? + if ( &IsFlag('m') ne 'm' + and &IsFlag('M') ne 'M' + and &IsFlag('o') ne 'o' ) + { + &performReply("You do not have permission to modify factoids"); + return 1; + + # If they have +M but they didnt create the factoid + } + elsif ( &IsFlag('M') eq 'M' + and $who !~ /^\Q$created_by\E$/i + and &IsFlag('m') ne 'm' + and &IsFlag('o') ne 'o' ) + { + &performReply("factoid '$lhs' is not yours to modify."); + return 1; + } + } # factoid arguments handler. # must start with a non-variable - if (&IsChanConf('factoidArguments') > 0 and $lhs =~ /^[^\$]+.*\$/) { - &status("Update: Factoid Arguments found."); - &status("Update: orig lhs => '$lhs'."); - &status("Update: orig rhs => '$rhs'."); - - my @list; - my $count = 0; - $lhs =~ s/^/cmd: /; - while ($lhs =~ s/\$(\S+)/(.*?)/) { - push(@list, "\$$1"); - $count++; - last if ($count >= 10); - } - - if ($count >= 10) { - &msg($who, "error: could not SAR properly."); - &DEBUG("error: lhs => '$lhs' rhs => '$rhs'."); - return; - } - - my $z = join(',',@list); - $rhs =~ s/^/($z): /; - - &status("Update: new lhs => '$lhs' rhs => '$rhs'."); + if ( &IsChanConf('factoidArguments') > 0 and $lhs =~ /^[^\$]+.*\$/ ) { + &status("Update: Factoid Arguments found."); + &status("Update: orig lhs => '$lhs'."); + &status("Update: orig rhs => '$rhs'."); + + my @list; + my $count = 0; + $lhs =~ s/^/cmd: /; + while ( $lhs =~ s/\$(\S+)/(.*?)/ ) { + push( @list, "\$$1" ); + $count++; + last if ( $count >= 10 ); + } + + if ( $count >= 10 ) { + &msg( $who, "error: could not SAR properly." ); + &DEBUG("error: lhs => '$lhs' rhs => '$rhs'."); + return; + } + + my $z = join( ',', @list ); + $rhs =~ s/^/($z): /; + + &status("Update: new lhs => '$lhs' rhs => '$rhs'."); } # the fun begins. my $exists = &getFactoid($lhs); - if (!$exists) { - # nice 'are' hack (or work-around). - if ($mhs =~ /^are$/i and $rhs !~ /<\S+>/) { - &status("Update: 'are' hack detected."); - $mhs = 'is'; - $rhs = " are ". $rhs; - } + if ( !$exists ) { + + # nice 'are' hack (or work-around). + if ( $mhs =~ /^are$/i and $rhs !~ /<\S+>/ ) { + &status("Update: 'are' hack detected."); + $mhs = 'is'; + $rhs = " are " . $rhs; + } - &status("enter: <$who> \'$lhs\' =$mhs=> \'$rhs\'"); - $count{'Update'}++; + &status("enter: <$who> \'$lhs\' =$mhs=> \'$rhs\'"); + $count{'Update'}++; - &performAddressedReply('okay'); + &performAddressedReply('okay'); - &sqlInsert('factoids', { - created_by => $nuh, - created_time => time(), # modified time. - factoid_key => $lhs, - factoid_value => $rhs, - } ); + &sqlInsert( + 'factoids', + { + created_by => $nuh, + created_time => time(), # modified time. + factoid_key => $lhs, + factoid_value => $rhs, + } + ); - if (!defined $rhs or $rhs eq '') { - &ERROR("Update: rhs1 == NULL."); - } + if ( !defined $rhs or $rhs eq '' ) { + &ERROR("Update: rhs1 == NULL."); + } - return 1; + return 1; } # factoid exists. - if ($exists eq $rhs) { - # this catches the following situation: (right or wrong?) - # "test is test" - # "test is also test" - &performAddressedReply("i already had it that way"); - return 1; + if ( $exists eq $rhs ) { + + # this catches the following situation: (right or wrong?) + # "test is test" + # "test is also test" + &performAddressedReply("i already had it that way"); + return 1; } - if ($also) { # 'is also'. + if ($also) { # 'is also'. my $redircount = 5; - my $origlhs = $lhs; - while ($exists =~ /^ ?see (.*)/i) { + my $origlhs = $lhs; + while ( $exists =~ /^ ?see (.*)/i ) { $redircount--; unless ($redircount) { - &msg($who, "$origlhs has too many levels of redirection."); + &msg( $who, "$origlhs has too many levels of redirection." ); return 1; } - $lhs = $1; + $lhs = $1; $exists = &getFactoid($lhs); - unless( $exists ) { - &msg($who, "$1 is a dangling redirection."); + unless ($exists) { + &msg( $who, "$1 is a dangling redirection." ); + return 1; + } + } + if ( $exists =~ /^ ?see (.*)/i ) { + &TODO("Update.pl: append to linked factoid."); + } + + if ($also_or) { # 'is also ||'. + $rhs = $exists . ' || ' . $rhs; + } + else { + + # if ($exists =~ s/\,\s*$/, /) { + if ( $exists =~ /\,\s*$/ ) { + &DEBUG("current has trailing comma, just append as is"); + &DEBUG("Up: exists => $exists"); + &DEBUG("Up: rhs => $rhs"); + + # $rhs =~ s/^\s+//; + # $rhs = $exists." ".$rhs; # keep comma. + } + + if ( $exists =~ /\.\s*$/ ) { + &DEBUG( + "current has trailing period, just append as is with 2 WS"); + &DEBUG("Up: exists => $exists"); + &DEBUG("Up: rhs => $rhs"); + + # $rhs =~ s/^\s+//; + # use ucfirst();? + # $rhs = $exists." ".$rhs; # keep comma. + } + + if ( $rhs =~ /^[A-Z]/ ) { + if ( $rhs =~ /\w+\s*$/ ) { + &status("auto insert period to factoid."); + $rhs = $exists . ". " . $rhs; + } + else { # '?' or '.' assumed at end. + &status( +"orig factoid already had trailing symbol; not adding period." + ); + $rhs = $exists . " " . $rhs; + } + } + elsif ( $exists =~ /[\,\.\-]\s*$/ ) { + &VERB( +"U: current has trailing symbols; inserting whitespace + new.", + 2 + ); + $rhs = $exists . " " . $rhs; + } + elsif ( $rhs =~ /^\./ ) { + &VERB( "U: new text has ^.; appending directly", 2 ); + $rhs = $exists . $rhs; + } + else { + $rhs = $exists . ', or ' . $rhs; + } + } + + # max length check again. + if ( length $rhs > $param{'maxDataSize'} ) { + if ( length $rhs > length $exists ) { + &performAddressedReply("that's too long"); return 1; } + else { + &status( +"Update: new length is still longer than maxDataSize but less than before, we'll let it go." + ); + } + } + + &performAddressedReply('okay'); + + $count{'Update'}++; + &status("update: <$who> \'$lhs\' =$mhs=> \'$rhs\'; was \'$exists\'"); + &sqlSet( + 'factoids', + { 'factoid_key' => $lhs }, + { + modified_by => $nuh, + modified_time => time(), + factoid_value => $rhs, + } + ); + + if ( !defined $rhs or $rhs eq '' ) { + &ERROR("Update: rhs1 == NULL."); + } + } + else { # not 'also' + + if ( !$correction_plausible ) { # "no, blah is ..." + if ($addressed) { + &performStrictReply( + "...but \002$lhs\002 is already something else..."); + &status("FAILED update: <$who> \'$lhs\' =$mhs=> \'$rhs\'"); + } + return 1; + } + + my $author = &getFactInfo( $lhs, 'created_by' ) || ''; + + if ( IsFlag('m') ne 'm' + && IsFlag('o') ne 'o' + && $author !~ /^\Q$who\E\!/i ) + { + &msg( $who, "you can't change that factoid." ); + return 1; + } + + &performAddressedReply('okay'); + + $count{'Update'}++; + &status("update: <$who> \'$lhs\' =$mhs=> \'$rhs\'; was \'$exists\'"); + + &sqlSet( + 'factoids', + { 'factoid_key' => $lhs }, + { + modified_by => $nuh, + modified_time => time(), + factoid_value => $rhs, + } + ); + + if ( !defined $rhs or $rhs eq '' ) { + &ERROR("Update: rhs1 == NULL."); } - if ($exists =~ /^ ?see (.*)/i) { - &TODO("Update.pl: append to linked factoid."); - } - - if ($also_or) { # 'is also ||'. - $rhs = $exists.' || '.$rhs; - } else { -# if ($exists =~ s/\,\s*$/, /) { - if ($exists =~ /\,\s*$/) { - &DEBUG("current has trailing comma, just append as is"); - &DEBUG("Up: exists => $exists"); - &DEBUG("Up: rhs => $rhs"); - # $rhs =~ s/^\s+//; - # $rhs = $exists." ".$rhs; # keep comma. - } - - if ($exists =~ /\.\s*$/) { - &DEBUG("current has trailing period, just append as is with 2 WS"); - &DEBUG("Up: exists => $exists"); - &DEBUG("Up: rhs => $rhs"); - # $rhs =~ s/^\s+//; - # use ucfirst();? - # $rhs = $exists." ".$rhs; # keep comma. - } - - if ($rhs =~ /^[A-Z]/) { - if ($rhs =~ /\w+\s*$/) { - &status("auto insert period to factoid."); - $rhs = $exists.". ".$rhs; - } else { # '?' or '.' assumed at end. - &status("orig factoid already had trailing symbol; not adding period."); - $rhs = $exists." ".$rhs; - } - } elsif ($exists =~ /[\,\.\-]\s*$/) { - &VERB("U: current has trailing symbols; inserting whitespace + new.",2); - $rhs = $exists." ".$rhs; - } elsif ($rhs =~ /^\./) { - &VERB("U: new text has ^.; appending directly",2); - $rhs = $exists.$rhs; - } else { - $rhs = $exists.', or '.$rhs; - } - } - - # max length check again. - if (length $rhs > $param{'maxDataSize'}) { - if (length $rhs > length $exists) { - &performAddressedReply("that's too long"); - return 1; - } else { - &status("Update: new length is still longer than maxDataSize but less than before, we'll let it go."); - } - } - - &performAddressedReply('okay'); - - $count{'Update'}++; - &status("update: <$who> \'$lhs\' =$mhs=> \'$rhs\'; was \'$exists\'"); - &sqlSet('factoids', {'factoid_key' => $lhs}, { - modified_by => $nuh, - modified_time => time(), - factoid_value => $rhs, - } ); - - if (!defined $rhs or $rhs eq '') { - &ERROR("Update: rhs1 == NULL."); - } - } else { # not 'also' - - if (!$correction_plausible) { # "no, blah is ..." - if ($addressed) { - &performStrictReply("...but \002$lhs\002 is already something else..."); - &status("FAILED update: <$who> \'$lhs\' =$mhs=> \'$rhs\'"); - } - return 1; - } - - my $author = &getFactInfo($lhs, 'created_by') || ''; - - if (IsFlag('m') ne 'm' && IsFlag('o') ne 'o' && - $author !~ /^\Q$who\E\!/i - ) { - &msg($who, "you can't change that factoid."); - return 1; - } - - &performAddressedReply('okay'); - - $count{'Update'}++; - &status("update: <$who> \'$lhs\' =$mhs=> \'$rhs\'; was \'$exists\'"); - - &sqlSet('factoids', {'factoid_key' => $lhs}, { - modified_by => $nuh, - modified_time => time(), - factoid_value => $rhs, - } ); - - if (!defined $rhs or $rhs eq '') { - &ERROR("Update: rhs1 == NULL."); - } } return 1; diff --git a/src/Files.pl b/src/Files.pl index 91610b6..3a294aa 100644 --- a/src/Files.pl +++ b/src/Files.pl @@ -17,33 +17,33 @@ sub loadLang { my $langCount = 0; my $replyName; - if (!open(FILE, $file)) { - &ERROR("Failed reading lang file ($file): $!"); - exit 0; + if ( !open( FILE, $file ) ) { + &ERROR("Failed reading lang file ($file): $!"); + exit 0; } - undef %lang; # for rehash. + undef %lang; # for rehash. while () { - chop; - if ($_ eq '' || /^#/) { - undef $replyName; - next; - } - - if (!/^\s/) { - $replyName = $_; - next; - } - - s/^[\s\t]+//g; - if (!$replyName) { - &status("loadLang: bad line ('$_')"); - next; - } - - $lang{$replyName}{$_} = 1; - $langCount++; + chop; + if ( $_ eq '' || /^#/ ) { + undef $replyName; + next; + } + + if ( !/^\s/ ) { + $replyName = $_; + next; + } + + s/^[\s\t]+//g; + if ( !$replyName ) { + &status("loadLang: bad line ('$_')"); + next; + } + + $lang{$replyName}{$_} = 1; + $langCount++; } close FILE; @@ -53,31 +53,32 @@ sub loadLang { # File: Irc Servers list. sub loadIRCServers { - my ($file) = $bot_config_dir."/infobot.servers"; + my ($file) = $bot_config_dir . '/infobot.servers'; @ircServers = (); - %ircPort = (); + %ircPort = (); - if (!open(FILE, $file)) { - &ERROR("Failed reading server list ($file): $!"); - exit 0; + if ( !open( FILE, $file ) ) { + &ERROR("Failed reading server list ($file): $!"); + exit 0; } while () { - chop; - next if /^\s*$/; - next if /^[\#\[ ]/; - - if (/^\s*(\S+?)(:(\d+))?\s*$/) { - push(@ircServers,$1); - $ircPort{$1} = ($3 || 6667); - } else { - &status("loadIRCServers: invalid line => '$_'."); - } + chop; + next if /^\s*$/; + next if /^[\#\[ ]/; + + if (/^\s*(\S+?)(:(\d+))?\s*$/) { + push( @ircServers, $1 ); + $ircPort{$1} = ( $3 || 6667 ); + } + else { + &status("loadIRCServers: invalid line => '$_'."); + } } close FILE; $file =~ s/^.*\///; - &status("Loaded $file (". scalar(@ircServers) ." servers)"); + &status( "Loaded $file (" . scalar(@ircServers) . ' servers)' ); } 1; diff --git a/src/IRC/Irc.pl b/src/IRC/Irc.pl index c89c0db..e4c43a8 100644 --- a/src/IRC/Irc.pl +++ b/src/IRC/Irc.pl @@ -8,79 +8,81 @@ use strict; no strict 'refs'; -no strict 'subs'; # IN/STDIN +no strict 'subs'; # IN/STDIN use vars qw(%floodjoin %nuh %dcc %cache %conns %channels %param %mask - %chanconf %orig %ircPort %ircstats %last %netsplit); + %chanconf %orig %ircPort %ircstats %last %netsplit); use vars qw($irc $nickserv $conn $msgType $who $talkchannel - $addressed $postprocess); + $addressed $postprocess); use vars qw($notcount $nottime $notsize $msgcount $msgtime $msgsize - $pubcount $pubtime $pubsize); + $pubcount $pubtime $pubsize); use vars qw($b_blue $ob); use vars qw(@ircServers); #use open ':utf8'; #use open ':std'; -$nickserv = 0; +$nickserv = 0; + # It's probably closer to 510, but let's be cautious until we calculate it extensively. -my $maxlinelen = 490; +my $maxlinelen = 490; # Keep track of last time we displayed Chans: to avoid spam in logs my $lastChansTime = 0; sub ircloop { - my $error = 0; + my $error = 0; my $lastrun = 0; -loop:; - while (my $host = shift @ircServers) { - # JUST IN CASE. irq was complaining about this. - if ($lastrun == time()) { - &DEBUG("ircloop: hrm... lastrun == time()"); - $error++; - sleep 10; - next; - } - - if (!defined $host) { - &DEBUG("ircloop: ircServers[x] = NULL."); - $lastrun = time(); - next; - } - next unless (exists $ircPort{$host}); - - my $retval = &irc($host, $ircPort{$host}); - next unless (defined $retval and $retval == 0); - $error++; - - if ($error % 3 == 0 and $error != 0) { - &status("IRC: Could not connect."); - &status("IRC: "); - next; - } - - if ($error >= 3*2) { - &status("IRC: cannot connect to any IRC servers; stopping."); - &shutdown(); - exit 1; - } - } - - &status("IRC: ok, done one cycle of IRC servers; trying again."); + loop:; + while ( my $host = shift @ircServers ) { + + # JUST IN CASE. irq was complaining about this. + if ( $lastrun == time() ) { + &DEBUG('ircloop: hrm... lastrun == time()'); + $error++; + sleep 10; + next; + } + + if ( !defined $host ) { + &DEBUG('ircloop: ircServers[x] = NULL.'); + $lastrun = time(); + next; + } + next unless ( exists $ircPort{$host} ); + + my $retval = &irc( $host, $ircPort{$host} ); + next unless ( defined $retval and $retval == 0 ); + $error++; + + if ( $error % 3 == 0 and $error != 0 ) { + &status('IRC: Could not connect.'); + &status('IRC: '); + next; + } + + if ( $error >= 3 * 2 ) { + &status('IRC: cannot connect to any IRC servers; stopping.'); + &shutdown(); + exit 1; + } + } + + &status('IRC: ok, done one cycle of IRC servers; trying again.'); &loadIRCServers(); goto loop; } sub irc { - my ($server,$port) = @_; + my ( $server, $port ) = @_; $irc = new Net::IRC; # TODO: move all this to an sql table my $iaddr = inet_aton($server); - my $paddr = sockaddr_in($port, $iaddr); + my $paddr = sockaddr_in( $port, $iaddr ); my $proto = getprotobyname('tcp'); # why was this here? @@ -88,102 +90,117 @@ sub irc { # host->ip. my $resolve; - if ($server =~ /\D$/) { - my $packed = scalar(gethostbyname($server)); + if ( $server =~ /\D$/ ) { + my $packed = scalar( gethostbyname($server) ); - if (!defined $packed) { - &status(" cannot resolve $server."); - return 0; - } + if ( !defined $packed ) { + &status(" cannot resolve $server."); + return 0; + } - $resolve = inet_ntoa($packed); - ### warning in Sys/Hostname line 78??? - ### caused inside Net::IRC? + $resolve = inet_ntoa($packed); + ### warning in Sys/Hostname line 78??? + ### caused inside Net::IRC? } my %args = ( - Nick => $param{'ircNick'}, - Server => $server, - Port => $port, - Ircname => $param{'ircName'}, + Nick => $param{'ircNick'}, + Server => $server, + Port => $port, + Ircname => $param{'ircName'}, ); - $args{'LocalAddr'} = $param{'ircHost'} if ($param{'ircHost'}); - $args{'Password'} = $param{'ircPasswd'} if ($param{'ircPasswd'}); - - foreach my $mynick (split ',', $param{'ircNick'}) { - &status("Connecting to port $port of server $server ($resolve) as $mynick ..."); - $args{'Nick'} = $mynick; - $conns{$mynick} = $irc->newconn(%args); - if (!defined $conns{$mynick}) { - &ERROR("IRC: connection failed."); - &ERROR("add \"set ircHost 0.0.0.0\" to your config. If that does not work"); - &ERROR("Please check /etc/hosts to see if you have a localhost line like:"); - &ERROR("127.0.0.1 localhost localhost"); - &ERROR("If this is still a problem, please contact the maintainer."); - } - $conns{$mynick}->maxlinelen($maxlinelen); - # handler stuff. - $conns{$mynick}->add_global_handler('caction', \&on_action); - $conns{$mynick}->add_global_handler('cdcc', \&on_dcc); - $conns{$mynick}->add_global_handler('cping', \&on_ping); - $conns{$mynick}->add_global_handler('crping', \&on_ping_reply); - $conns{$mynick}->add_global_handler('cversion', \&on_version); - $conns{$mynick}->add_global_handler('crversion', \&on_crversion); - $conns{$mynick}->add_global_handler('dcc_open', \&on_dcc_open); - $conns{$mynick}->add_global_handler('dcc_close', \&on_dcc_close); - $conns{$mynick}->add_global_handler('chat', \&on_chat); - $conns{$mynick}->add_global_handler('msg', \&on_msg); - $conns{$mynick}->add_global_handler('public', \&on_public); - $conns{$mynick}->add_global_handler('join', \&on_join); - $conns{$mynick}->add_global_handler('part', \&on_part); - $conns{$mynick}->add_global_handler('topic', \&on_topic); - $conns{$mynick}->add_global_handler('invite', \&on_invite); - $conns{$mynick}->add_global_handler('kick', \&on_kick); - $conns{$mynick}->add_global_handler('mode', \&on_mode); - $conns{$mynick}->add_global_handler('nick', \&on_nick); - $conns{$mynick}->add_global_handler('quit', \&on_quit); - $conns{$mynick}->add_global_handler('notice', \&on_notice); - $conns{$mynick}->add_global_handler('whoischannels', \&on_whoischannels); - $conns{$mynick}->add_global_handler('useronchannel', \&on_useronchannel); - $conns{$mynick}->add_global_handler('whois', \&on_whois); - $conns{$mynick}->add_global_handler('other', \&on_other); - $conns{$mynick}->add_global_handler('disconnect', \&on_disconnect); - $conns{$mynick}->add_global_handler([251,252,253,254,255], \&on_init); -# $conns{$mynick}->add_global_handler(302, \&on_init); # userhost - $conns{$mynick}->add_global_handler(303, \&on_ison); # notify. - $conns{$mynick}->add_global_handler(315, \&on_endofwho); - $conns{$mynick}->add_global_handler(422, \&on_endofwho); # nomotd. - $conns{$mynick}->add_global_handler(324, \&on_modeis); - $conns{$mynick}->add_global_handler(333, \&on_topicinfo); - $conns{$mynick}->add_global_handler(352, \&on_who); - $conns{$mynick}->add_global_handler(353, \&on_names); - $conns{$mynick}->add_global_handler(366, \&on_endofnames); - $conns{$mynick}->add_global_handler(376, \&on_endofmotd); # on_connect. - $conns{$mynick}->add_global_handler(433, \&on_nick_taken); - $conns{$mynick}->add_global_handler(439, \&on_targettoofast); - # for proper joinnextChan behaviour - $conns{$mynick}->add_global_handler(471, \&on_chanfull); - $conns{$mynick}->add_global_handler(473, \&on_inviteonly); - $conns{$mynick}->add_global_handler(474, \&on_banned); - $conns{$mynick}->add_global_handler(475, \&on_badchankey); - $conns{$mynick}->add_global_handler(443, \&on_useronchan); - # end of handler stuff. + $args{'LocalAddr'} = $param{'ircHost'} if ( $param{'ircHost'} ); + $args{'Password'} = $param{'ircPasswd'} if ( $param{'ircPasswd'} ); + + foreach my $mynick ( split ',', $param{'ircNick'} ) { + &status( +"Connecting to port $port of server $server ($resolve) as $mynick ..." + ); + $args{'Nick'} = $mynick; + $conns{$mynick} = $irc->newconn(%args); + if ( !defined $conns{$mynick} ) { + &ERROR('IRC: connection failed.'); + &ERROR( +"add \"set ircHost 0.0.0.0\" to your config. If that does not work" + ); + &ERROR( +'Please check /etc/hosts to see if you have a localhost line like:' + ); + &ERROR('127.0.0.1 localhost localhost'); + &ERROR( + 'If this is still a problem, please contact the maintainer.'); + } + $conns{$mynick}->maxlinelen($maxlinelen); + + # handler stuff. + $conns{$mynick}->add_global_handler( 'caction', \&on_action ); + $conns{$mynick}->add_global_handler( 'cdcc', \&on_dcc ); + $conns{$mynick}->add_global_handler( 'cping', \&on_ping ); + $conns{$mynick}->add_global_handler( 'crping', \&on_ping_reply ); + $conns{$mynick}->add_global_handler( 'cversion', \&on_version ); + $conns{$mynick}->add_global_handler( 'crversion', \&on_crversion ); + $conns{$mynick}->add_global_handler( 'dcc_open', \&on_dcc_open ); + $conns{$mynick}->add_global_handler( 'dcc_close', \&on_dcc_close ); + $conns{$mynick}->add_global_handler( 'chat', \&on_chat ); + $conns{$mynick}->add_global_handler( 'msg', \&on_msg ); + $conns{$mynick}->add_global_handler( 'public', \&on_public ); + $conns{$mynick}->add_global_handler( 'join', \&on_join ); + $conns{$mynick}->add_global_handler( 'part', \&on_part ); + $conns{$mynick}->add_global_handler( 'topic', \&on_topic ); + $conns{$mynick}->add_global_handler( 'invite', \&on_invite ); + $conns{$mynick}->add_global_handler( 'kick', \&on_kick ); + $conns{$mynick}->add_global_handler( 'mode', \&on_mode ); + $conns{$mynick}->add_global_handler( 'nick', \&on_nick ); + $conns{$mynick}->add_global_handler( 'quit', \&on_quit ); + $conns{$mynick}->add_global_handler( 'notice', \&on_notice ); + $conns{$mynick} + ->add_global_handler( 'whoischannels', \&on_whoischannels ); + $conns{$mynick} + ->add_global_handler( 'useronchannel', \&on_useronchannel ); + $conns{$mynick}->add_global_handler( 'whois', \&on_whois ); + $conns{$mynick}->add_global_handler( 'other', \&on_other ); + $conns{$mynick}->add_global_handler( 'disconnect', \&on_disconnect ); + $conns{$mynick} + ->add_global_handler( [ 251, 252, 253, 254, 255 ], \&on_init ); + + # $conns{$mynick}->add_global_handler(302, \&on_init); # userhost + $conns{$mynick}->add_global_handler( 303, \&on_ison ); # notify. + $conns{$mynick}->add_global_handler( 315, \&on_endofwho ); + $conns{$mynick}->add_global_handler( 422, \&on_endofwho ); # nomotd. + $conns{$mynick}->add_global_handler( 324, \&on_modeis ); + $conns{$mynick}->add_global_handler( 333, \&on_topicinfo ); + $conns{$mynick}->add_global_handler( 352, \&on_who ); + $conns{$mynick}->add_global_handler( 353, \&on_names ); + $conns{$mynick}->add_global_handler( 366, \&on_endofnames ); + $conns{$mynick}->add_global_handler( 376, \&on_endofmotd ) + ; # on_connect. + $conns{$mynick}->add_global_handler( 433, \&on_nick_taken ); + $conns{$mynick}->add_global_handler( 439, \&on_targettoofast ); + + # for proper joinnextChan behaviour + $conns{$mynick}->add_global_handler( 471, \&on_chanfull ); + $conns{$mynick}->add_global_handler( 473, \&on_inviteonly ); + $conns{$mynick}->add_global_handler( 474, \&on_banned ); + $conns{$mynick}->add_global_handler( 475, \&on_badchankey ); + $conns{$mynick}->add_global_handler( 443, \&on_useronchan ); + + # end of handler stuff. } &clearIRCVars(); # change internal timeout value for scheduler. - $irc->{_timeout} = 10; # how about 60? - # Net::IRC debugging. - $irc->{_debug} = 1; + $irc->{_timeout} = 10; # how about 60? + # Net::IRC debugging. + $irc->{_debug} = 1; - $ircstats{'Server'} = "$server:$port"; + $ircstats{'Server'} = "$server:$port"; # works? needs to actually do something # should likely listen on a tcp port instead #$irc->addfh(STDIN, \&on_stdin, 'r'); - &status("starting main loop"); + &status('starting main loop'); $irc->start; } @@ -198,11 +215,11 @@ sub rawout { # slow down a bit if traffic is 'high'. # need to take into account time of last message sent. - if ($last{buflen} > 256 and length($buf) > 256) { - sleep 1; + if ( $last{buflen} > 256 and length($buf) > 256 ) { + sleep 1; } - $conn->sl($buf) if (&whatInterface() =~ /IRC/); + $conn->sl($buf) if ( &whatInterface() =~ /IRC/ ); $last{buflen} = length($buf); } @@ -210,171 +227,181 @@ sub rawout { sub say { my ($msg) = @_; my $mynick = $conn->nick(); - if (!defined $msg) { - $msg ||= 'NULL'; - &WARN("say: msg == $msg."); - return; + if ( !defined $msg ) { + $msg ||= 'NULL'; + &WARN("say: msg == $msg."); + return; } - if (&getChanConf('silent', $talkchannel) and not - (&IsFlag("s") and &verifyUser($who,$nuh{lc $who}))) { - &DEBUG("say: silent in $talkchannel, not saying $msg"); - return; + if ( &getChanConf( 'silent', $talkchannel ) + and not( &IsFlag('s') and &verifyUser( $who, $nuh{ lc $who } ) ) ) + { + &DEBUG("say: silent in $talkchannel, not saying $msg"); + return; } - if ( $postprocess ) { - undef $postprocess; - } elsif ($postprocess = &getChanConf('postprocess', $talkchannel)) { - &DEBUG("say: $postprocess $msg"); - &parseCmdHook($postprocess . ' ' . $msg); - undef $postprocess; - return; + if ($postprocess) { + undef $postprocess; + } + elsif ( $postprocess = &getChanConf( 'postprocess', $talkchannel ) ) { + &DEBUG("say: $postprocess $msg"); + &parseCmdHook( $postprocess . ' ' . $msg ); + undef $postprocess; + return; } &status("<$mynick/$talkchannel> $msg"); - return unless (&whatInterface() =~ /IRC/); + return unless ( &whatInterface() =~ /IRC/ ); - $msg = 'zero' if ($msg =~ /^0+$/); + $msg = 'zero' if ( $msg =~ /^0+$/ ); my $t = time(); - if ($t == $pubtime) { - $pubcount++; - $pubsize += length $msg; + if ( $t == $pubtime ) { + $pubcount++; + $pubsize += length $msg; - my $i = &getChanConfDefault('sendPublicLimitLines', 3, $chan); - my $j = &getChanConfDefault('sendPublicLimitBytes', 1000, $chan); + my $i = &getChanConfDefault( 'sendPublicLimitLines', 3, $chan ); + my $j = &getChanConfDefault( 'sendPublicLimitBytes', 1000, $chan ); - if ( ($pubcount % $i) == 0 and $pubcount) { - sleep 1; - } elsif ($pubsize > $j) { - sleep 1; - $pubsize -= $j; - } + if ( ( $pubcount % $i ) == 0 and $pubcount ) { + sleep 1; + } + elsif ( $pubsize > $j ) { + sleep 1; + $pubsize -= $j; + } - } else { - $pubcount = 0; - $pubtime = $t; - $pubsize = length $msg; + } + else { + $pubcount = 0; + $pubtime = $t; + $pubsize = length $msg; } - $conn->privmsg($talkchannel, $msg); + $conn->privmsg( $talkchannel, $msg ); } sub msg { - my ($nick, $msg) = @_; - if (!defined $nick) { - &ERROR("msg: nick == NULL."); - return; + my ( $nick, $msg ) = @_; + if ( !defined $nick ) { + &ERROR('msg: nick == NULL.'); + return; } - if (!defined $msg) { - $msg ||= 'NULL'; - &WARN("msg: msg == $msg."); - return; + if ( !defined $msg ) { + $msg ||= 'NULL'; + &WARN("msg: msg == $msg."); + return; } # some say() end up here (eg +help) - if (&getChanConf('silent', $nick) and not - (&IsFlag("s") and &verifyUser($who,$nuh{lc $who}))) { - &DEBUG("msg: silent in $nick, not saying $msg"); - return; + if ( &getChanConf( 'silent', $nick ) + and not( &IsFlag('s') and &verifyUser( $who, $nuh{ lc $who } ) ) ) + { + &DEBUG("msg: silent in $nick, not saying $msg"); + return; } &status(">$nick< $msg"); - return unless (&whatInterface() =~ /IRC/); + return unless ( &whatInterface() =~ /IRC/ ); my $t = time(); - if ($t == $msgtime) { - $msgcount++; - $msgsize += length $msg; + if ( $t == $msgtime ) { + $msgcount++; + $msgsize += length $msg; - my $i = &getChanConfDefault('sendPrivateLimitLines', 3, $chan); - my $j = &getChanConfDefault('sendPrivateLimitBytes', 1000, $chan); - if ( ($msgcount % $i) == 0 and $msgcount) { - sleep 1; - } elsif ($msgsize > $j) { - sleep 1; - $msgsize -= $j; - } + my $i = &getChanConfDefault( 'sendPrivateLimitLines', 3, $chan ); + my $j = &getChanConfDefault( 'sendPrivateLimitBytes', 1000, $chan ); + if ( ( $msgcount % $i ) == 0 and $msgcount ) { + sleep 1; + } + elsif ( $msgsize > $j ) { + sleep 1; + $msgsize -= $j; + } - } else { - $msgcount = 0; - $msgtime = $t; - $msgsize = length $msg; + } + else { + $msgcount = 0; + $msgtime = $t; + $msgsize = length $msg; } - $conn->privmsg($nick, $msg); + $conn->privmsg( $nick, $msg ); } # Usage: &action(nick || chan, txt); sub action { my $mynick = $conn->nick(); - my ($target, $txt) = @_; - if (!defined $txt) { - &WARN("action: txt == NULL."); - return; + my ( $target, $txt ) = @_; + if ( !defined $txt ) { + &WARN('action: txt == NULL.'); + return; } - if (&getChanConf('silent', $target) and not - (&IsFlag("s") and &verifyUser($who,$nuh{lc $who}))) { - &DEBUG("action: silent in $target, not doing $txt"); - return; + if ( &getChanConf( 'silent', $target ) + and not( &IsFlag('s') and &verifyUser( $who, $nuh{ lc $who } ) ) ) + { + &DEBUG("action: silent in $target, not doing $txt"); + return; } - if (length $txt > 480) { - &status("action: txt too long; truncating."); - chop($txt) while (length $txt > 480); + if ( length $txt > 480 ) { + &status('action: txt too long; truncating.'); + chop($txt) while ( length $txt > 480 ); } &status("* $mynick/$target $txt"); - $conn->me($target, $txt); + $conn->me( $target, $txt ); } # Usage: ¬ice(nick || chan, txt); sub notice { - my ($target, $txt) = @_; - if (!defined $txt) { - &WARN("notice: txt == NULL."); - return; + my ( $target, $txt ) = @_; + if ( !defined $txt ) { + &WARN('notice: txt == NULL.'); + return; } &status("-$target- $txt"); - my $t = time(); + my $t = time(); - if ($t == $nottime) { - $notcount++; - $notsize += length $txt; + if ( $t == $nottime ) { + $notcount++; + $notsize += length $txt; - my $i = &getChanConfDefault('sendNoticeLimitLines', 3, $chan); - my $j = &getChanConfDefault('sendNoticeLimitBytes', 1000, $chan); + my $i = &getChanConfDefault( 'sendNoticeLimitLines', 3, $chan ); + my $j = &getChanConfDefault( 'sendNoticeLimitBytes', 1000, $chan ); - if ( ($notcount % $i) == 0 and $notcount) { - sleep 1; - } elsif ($notsize > $j) { - sleep 1; - $notsize -= $j; - } + if ( ( $notcount % $i ) == 0 and $notcount ) { + sleep 1; + } + elsif ( $notsize > $j ) { + sleep 1; + $notsize -= $j; + } - } else { - $notcount = 0; - $nottime = $t; - $notsize = length $txt; + } + else { + $notcount = 0; + $nottime = $t; + $notsize = length $txt; } - $conn->notice($target, $txt); + $conn->notice( $target, $txt ); } sub DCCBroadcast { - my ($txt,$flag) = @_; + my ( $txt, $flag ) = @_; ### FIXME: flag not supported yet. - foreach (keys %{ $dcc{'CHAT'} }) { - $conn->privmsg($dcc{'CHAT'}{$_}, $txt); + foreach ( keys %{ $dcc{'CHAT'} } ) { + $conn->privmsg( $dcc{'CHAT'}{$_}, $txt ); } } @@ -386,43 +413,47 @@ sub DCCBroadcast { sub performReply { my ($reply) = @_; - if (!defined $reply or $reply =~ /^\s*$/) { - &DEBUG("performReply: reply == NULL."); - return; + if ( !defined $reply or $reply =~ /^\s*$/ ) { + &DEBUG('performReply: reply == NULL.'); + return; } $reply =~ /([\.\?\s]+)$/; # FIXME need real throttling.... - if (length($reply) > $maxlinelen - 30) { - $reply = substr($reply, 0, $maxlinelen - 33); - $reply =~ s/ [^ ]*?$/ .../; + if ( length($reply) > $maxlinelen - 30 ) { + $reply = substr( $reply, 0, $maxlinelen - 33 ); + $reply =~ s/ [^ ]*?$/ .../; } &checkMsgType($reply); - if ($msgType eq 'public') { - if (rand() < 0.5 or $reply =~ /[\.\?]$/) { - $reply = "$orig{who}: ".$reply; - } else { - $reply = "$reply, ".$orig{who}; - } - &say($reply); + if ( $msgType eq 'public' ) { + if ( rand() < 0.5 or $reply =~ /[\.\?]$/ ) { + $reply = "$orig{who}: " . $reply; + } + else { + $reply = "$reply, " . $orig{who}; + } + &say($reply); - } elsif ($msgType eq 'private') { - if (rand() > 0.5) { - $reply = "$reply, ".$orig{who}; - } - &msg($who, $reply); + } + elsif ( $msgType eq 'private' ) { + if ( rand() > 0.5 ) { + $reply = "$reply, " . $orig{who}; + } + &msg( $who, $reply ); - } elsif ($msgType eq 'chat') { - if (!exists $dcc{'CHAT'}{$who}) { - &VERB("pSR: dcc{'CHAT'}{$who} does not exist.",2); - return; - } - $conn->privmsg($dcc{'CHAT'}{$who}, $reply); + } + elsif ( $msgType eq 'chat' ) { + if ( !exists $dcc{'CHAT'}{$who} ) { + &VERB( "pSR: dcc{'CHAT'}{$who} does not exist.", 2 ); + return; + } + $conn->privmsg( $dcc{'CHAT'}{$who}, $reply ); - } else { - &ERROR("PR: msgType invalid? ($msgType)."); + } + else { + &ERROR("PR: msgType invalid? ($msgType)."); } } @@ -437,74 +468,79 @@ sub performStrictReply { my ($reply) = @_; # FIXME need real throttling.... - if (length($reply) > $maxlinelen - 30) { - $reply = substr($reply, 0, $maxlinelen - 33); - $reply =~ s/ [^ ]*?$/ .../; + if ( length($reply) > $maxlinelen - 30 ) { + $reply = substr( $reply, 0, $maxlinelen - 33 ); + $reply =~ s/ [^ ]*?$/ .../; } &checkMsgType($reply); - if ($msgType eq 'private') { - &msg($who, $reply); - } elsif ($msgType eq 'public') { - &say($reply); - } elsif ($msgType eq 'chat') { - &dccsay(lc $who, $reply); - } else { - &ERROR("pSR: msgType invalid? ($msgType)."); + if ( $msgType eq 'private' ) { + &msg( $who, $reply ); + } + elsif ( $msgType eq 'public' ) { + &say($reply); + } + elsif ( $msgType eq 'chat' ) { + &dccsay( lc $who, $reply ); + } + else { + &ERROR("pSR: msgType invalid? ($msgType)."); } } sub dccsay { - my($who, $reply) = @_; + my ( $who, $reply ) = @_; - if (!defined $reply or $reply =~ /^\s*$/) { - &WARN("dccsay: reply == NULL."); - return; + if ( !defined $reply or $reply =~ /^\s*$/ ) { + &WARN('dccsay: reply == NULL.'); + return; } - if (!exists $dcc{'CHAT'}{$who}) { - &VERB("pSR: dcc{'CHAT'}{$who} does not exist. (2)",2); - return; + if ( !exists $dcc{'CHAT'}{$who} ) { + &VERB( "pSR: dcc{'CHAT'}{$who} does not exist. (2)", 2 ); + return; } - &status("=>$who<= $reply"); # dcc chat. - $conn->privmsg($dcc{'CHAT'}{$who}, $reply); + &status("=>$who<= $reply"); # dcc chat. + $conn->privmsg( $dcc{'CHAT'}{$who}, $reply ); } sub dcc_close { - my($who) = @_; + my ($who) = @_; my $type; - foreach $type (keys %dcc) { - &FIXME("dcc_close: $who"); - my @who = grep /^\Q$who\E$/i, keys %{ $dcc{$type} }; - next unless (scalar @who); - $who = $who[0]; - &DEBUG("dcc_close... close $who!"); + foreach $type ( keys %dcc ) { + &FIXME("dcc_close: $who"); + my @who = grep /^\Q$who\E$/i, keys %{ $dcc{$type} }; + next unless ( scalar @who ); + $who = $who[0]; + &DEBUG("dcc_close... close $who!"); } } sub joinchan { - my ($chan, $key) = @_; - $key ||= &getChanConf('chankey', $chan); + my ( $chan, $key ) = @_; + $key ||= &getChanConf( 'chankey', $chan ); $key ||= ''; # forgot for about 2 years to implement channel keys when moving # over to Net::IRC... # hopefully validChan is right. - if (&validChan($chan)) { - &status("join: already on $chan?"); + if ( &validChan($chan) ) { + &status("join: already on $chan?"); } + #} else { - &status("joining $b_blue$chan $key$ob"); + &status("joining $b_blue$chan $key$ob"); - return if ($conn->join($chan, $key)); - return if (&validChan($chan)); + return if ( $conn->join( $chan, $key ) ); + return if ( &validChan($chan) ); + + &DEBUG('joinchan: join failed. trying connect!'); + &clearIRCVars(); + $conn->connect(); - &DEBUG("joinchan: join failed. trying connect!"); - &clearIRCVars(); - $conn->connect(); #} } @@ -512,32 +548,34 @@ sub part { my $chan; foreach $chan (@_) { - next if ($chan eq ''); - $chan =~ tr/A-Z/a-z/; # lowercase. + next if ( $chan eq '' ); + $chan =~ tr/A-Z/a-z/; # lowercase. + + if ( $chan !~ /^$mask{chan}$/ ) { + &WARN("part: chan is invalid ($chan)"); + next; + } - if ($chan !~ /^$mask{chan}$/) { - &WARN("part: chan is invalid ($chan)"); - next; - } + &status("parting $chan"); + if ( !&validChan($chan) ) { + &WARN("part: not on $chan; doing anyway"); - &status("parting $chan"); - if (!&validChan($chan)) { - &WARN("part: not on $chan; doing anyway"); -# next; - } + # next; + } - $conn->part($chan); - # deletion of $channels{chan} is done in &entryEvt(). + $conn->part($chan); + + # deletion of $channels{chan} is done in &entryEvt(). } } sub mode { - my ($chan, @modes) = @_; - my $modes = join(" ", @modes); + my ( $chan, @modes ) = @_; + my $modes = join( ' ', @modes ); - if (&validChan($chan) == 0) { - &ERROR("mode: invalid chan => '$chan'."); - return; + if ( &validChan($chan) == 0 ) { + &ERROR("mode: invalid chan => '$chan'."); + return; } &DEBUG("mode: MODE $chan $modes"); @@ -547,89 +585,89 @@ sub mode { } sub op { - my ($chan, @who) = @_; - my $os = 'o' x scalar(@who); + my ( $chan, @who ) = @_; + my $os = 'o' x scalar(@who); - &mode($chan, "+$os @who"); + &mode( $chan, "+$os @who" ); } sub deop { - my ($chan, @who) = @_; + my ( $chan, @who ) = @_; my $os = 'o' x scalar(@who); - &mode($chan, "-$os ".@who); + &mode( $chan, "-$os " . @who ); } sub kick { - my ($nick,$chan,$msg) = @_; - my (@chans) = ($chan eq '') ? (keys %channels) : lc($chan); + my ( $nick, $chan, $msg ) = @_; + my (@chans) = ( $chan eq '' ) ? ( keys %channels ) : lc($chan); my $mynick = $conn->nick(); - if ($chan ne '' and &validChan($chan) == 0) { - &ERROR("kick: invalid channel $chan."); - return; + if ( $chan ne '' and &validChan($chan) == 0 ) { + &ERROR("kick: invalid channel $chan."); + return; } $nick =~ tr/A-Z/a-z/; foreach $chan (@chans) { - if (!&IsNickInChan($nick,$chan)) { - &status("kick: $nick is not on $chan.") if (scalar @chans == 1); - next; - } - - if (!exists $channels{$chan}{o}{$mynick}) { - &status("kick: do not have ops on $chan :("); - next; - } - - &status("Kicking $nick from $chan."); - $conn->kick($chan, $nick, $msg); + if ( !&IsNickInChan( $nick, $chan ) ) { + &status("kick: $nick is not on $chan.") if ( scalar @chans == 1 ); + next; + } + + if ( !exists $channels{$chan}{o}{$mynick} ) { + &status("kick: do not have ops on $chan :("); + next; + } + + &status("Kicking $nick from $chan."); + $conn->kick( $chan, $nick, $msg ); } } sub ban { - my ($mask,$chan) = @_; - my (@chans) = ($chan =~ /^\*?$/) ? (keys %channels) : lc($chan); + my ( $mask, $chan ) = @_; + my (@chans) = ( $chan =~ /^\*?$/ ) ? ( keys %channels ) : lc($chan); my $mynick = $conn->nick(); - my $ban = 0; + my $ban = 0; - if ($chan !~ /^\*?$/ and &validChan($chan) == 0) { - &ERROR("ban: invalid channel $chan."); - return; + if ( $chan !~ /^\*?$/ and &validChan($chan) == 0 ) { + &ERROR("ban: invalid channel $chan."); + return; } foreach $chan (@chans) { - if (!exists $channels{$chan}{o}{$mynick}) { - &status("ban: do not have ops on $chan :("); - next; - } - - &status("Banning $mask from $chan."); - &rawout("MODE $chan +b $mask"); - $ban++; + if ( !exists $channels{$chan}{o}{$mynick} ) { + &status("ban: do not have ops on $chan :("); + next; + } + + &status("Banning $mask from $chan."); + &rawout("MODE $chan +b $mask"); + $ban++; } return $ban; } sub unban { - my ($mask,$chan) = @_; - my (@chans) = ($chan =~ /^\*?$/) ? (keys %channels) : lc($chan); + my ( $mask, $chan ) = @_; + my (@chans) = ( $chan =~ /^\*?$/ ) ? ( keys %channels ) : lc($chan); my $mynick = $conn->nick(); - my $ban = 0; + my $ban = 0; &DEBUG("unban: mask = $mask, chan = @chans"); foreach $chan (@chans) { - if (!exists $channels{$chan}{o}{$mynick}) { - &status("unBan: do not have ops on $chan :("); - next; - } - - &status("Removed ban $mask from $chan."); - &rawout("MODE $chan -b $mask"); - $ban++; + if ( !exists $channels{$chan}{o}{$mynick} ) { + &status("unBan: do not have ops on $chan :("); + next; + } + + &status("Removed ban $mask from $chan."); + &rawout("MODE $chan -b $mask"); + $ban++; } return $ban; @@ -637,11 +675,12 @@ sub unban { sub quit { my ($quitmsg) = @_; - if (defined $conn) { - &status("QUIT " . $conn->nick() . " has quit IRC ($quitmsg)"); - $conn->quit($quitmsg); - } else { - &WARN("quit: could not quit!"); + if ( defined $conn ) { + &status( 'QUIT ' . $conn->nick() . " has quit IRC ($quitmsg)" ); + $conn->quit($quitmsg); + } + else { + &WARN('quit: could not quit!'); } } @@ -649,41 +688,46 @@ sub nick { my ($newnick) = @_; my $mynick = $conn->nick(); - if (!defined $newnick) { - &ERROR("nick: nick == NULL."); - return; + if ( !defined $newnick ) { + &ERROR('nick: nick == NULL.'); + return; } - if (!defined $mynick) { - &WARN("nick: mynick == NULL."); - return; + if ( !defined $mynick ) { + &WARN('nick: mynick == NULL.'); + return; } my $bad = 0; - $bad++ if (exists $nuh{$newnick}); - $bad++ if (&IsNickInAnyChan($newnick)); + $bad++ if ( exists $nuh{$newnick} ); + $bad++ if ( &IsNickInAnyChan($newnick) ); if ($bad) { - &WARN("Nick: not going to try to change from $mynick to $newnick. [". scalar(gmtime). "]"); - # hrm... over time we lose track of our own nick. - #return; + &WARN( "Nick: not going to try to change from $mynick to $newnick. [" + . scalar(gmtime) + . ']' ); + + # hrm... over time we lose track of our own nick. + #return; } - if ($newnick =~ /^$mask{nick}$/) { - &status("nick: Changing nick from $mynick to $newnick"); - # ->nick() will NOT change cause we are using rawout? - &rawout("NICK $newnick"); - return 1; + if ( $newnick =~ /^$mask{nick}$/ ) { + &status("nick: Changing nick from $mynick to $newnick"); + + # ->nick() will NOT change cause we are using rawout? + &rawout("NICK $newnick"); + return 1; } &DEBUG("nick: failed... why oh why (mynick=$mynick, newnick=$newnick)"); return 0; } sub invite { - my($who, $chan) = @_; + my ( $who, $chan ) = @_; + # TODO: check if $who or $chan are invalid. - $conn->invite($who, $chan); + $conn->invite( $who, $chan ); } ########## @@ -693,37 +737,38 @@ sub invite { # Usage: &joinNextChan(); sub joinNextChan { my $joined = 0; - foreach (sort keys %conns) { - $conn = $conns{$_}; - my $mynick = $conn->nick(); - my @join = getJoinChans(1); - - if (scalar @join) { - my $chan = shift @join; - &joinchan($chan); - - if (my $i = scalar @join) { - &status("joinNextChan: $mynick $i chans to join."); - } - $joined = 1; - } + foreach ( sort keys %conns ) { + $conn = $conns{$_}; + my $mynick = $conn->nick(); + my @join = getJoinChans(1); + + if ( scalar @join ) { + my $chan = shift @join; + &joinchan($chan); + + if ( my $i = scalar @join ) { + &status("joinNextChan: $mynick $i chans to join."); + } + $joined = 1; + } } return if $joined; - if (exists $cache{joinTime}) { - my $delta = time() - $cache{joinTime} - 5; - my $timestr = &Time2String($delta); - # FIXME: @join should be @in instead (hacked to 10) - #my $rate = sprintf("%.1f", $delta / @in); - my $rate = sprintf("%.1f", $delta / 10); - delete $cache{joinTime}; + if ( exists $cache{joinTime} ) { + my $delta = time() - $cache{joinTime} - 5; + my $timestr = &Time2String($delta); - &status("time taken to join all chans: $timestr; rate: $rate sec/join"); + # FIXME: @join should be @in instead (hacked to 10) + #my $rate = sprintf('%.1f', $delta / @in); + my $rate = sprintf( '%.1f', $delta / 10 ); + delete $cache{joinTime}; + + &status("time taken to join all chans: $timestr; rate: $rate sec/join"); } # chanserv check: global channels, in case we missed one. foreach ( &ChanConfList('chanServ_ops') ) { - &chanServCheck($_); + &chanServCheck($_); } } @@ -732,9 +777,9 @@ sub getNickInChans { my ($nick) = @_; my @array; - foreach (keys %channels) { - next unless (grep /^\Q$nick\E$/i, keys %{ $channels{$_}{''} }); - push(@array, $_); + foreach ( keys %channels ) { + next unless ( grep /^\Q$nick\E$/i, keys %{ $channels{$_}{''} } ); + push( @array, $_ ); } return @array; @@ -749,28 +794,29 @@ sub getNicksInChan { } sub IsNickInChan { - my ($nick,$chan) = @_; + my ( $nick, $chan ) = @_; - $chan =~ tr/A-Z/a-z/; # not lowercase unfortunately. + $chan =~ tr/A-Z/a-z/; # not lowercase unfortunately. - if ($chan =~ /^$/) { - &DEBUG("INIC: chan == NULL."); - return 0; + if ( $chan =~ /^$/ ) { + &DEBUG('INIC: chan == NULL.'); + return 0; } - if (&validChan($chan) == 0) { - &ERROR("INIC: invalid channel $chan."); - return 0; + if ( &validChan($chan) == 0 ) { + &ERROR("INIC: invalid channel $chan."); + return 0; } - if (grep /^\Q$nick\E$/i, keys %{ $channels{$chan}{''} }) { - return 1; - } else { - foreach (keys %channels) { - next unless (/[A-Z]/); - &DEBUG("iNIC: hash channels contains mixed cased chan!!!"); - } - return 0; + if ( grep /^\Q$nick\E$/i, keys %{ $channels{$chan}{''} } ) { + return 1; + } + else { + foreach ( keys %channels ) { + next unless (/[A-Z]/); + &DEBUG('iNIC: hash channels contains mixed cased chan!!!'); + } + return 0; } } @@ -778,53 +824,57 @@ sub IsNickInAnyChan { my ($nick) = @_; my $chan; - foreach $chan (keys %channels) { - next unless (grep /^\Q$nick\E$/i, keys %{ $channels{$chan}{''} }); - return 1; + foreach $chan ( keys %channels ) { + next unless ( grep /^\Q$nick\E$/i, keys %{ $channels{$chan}{''} } ); + return 1; } return 0; } # Usage: &validChan($chan); sub validChan { + # TODO: use $c instead? my ($chan) = @_; - if (!defined $chan or $chan =~ /^\s*$/) { - return 0; + if ( !defined $chan or $chan =~ /^\s*$/ ) { + return 0; } - if (lc $chan ne $chan) { - &WARN("validChan: lc chan != chan. ($chan); fixing."); - $chan =~ tr/A-Z/a-z/; + if ( lc $chan ne $chan ) { + &WARN("validChan: lc chan != chan. ($chan); fixing."); + $chan =~ tr/A-Z/a-z/; } # it's possible that this check creates the hash if empty. - if (defined $channels{$chan} or exists $channels{$chan}) { - if ($chan =~ /^_?default$/) { -# &WARN("validC: chan cannot be _default! returning 0!"); - return 0; - } + if ( defined $channels{$chan} or exists $channels{$chan} ) { + if ( $chan =~ /^_?default$/ ) { - return 1; - } else { - return 0; + # &WARN('validC: chan cannot be _default! returning 0!'); + return 0; + } + + return 1; + } + else { + return 0; } } ### # Usage: &delUserInfo($nick,@chans); sub delUserInfo { - my ($nick,@chans) = @_; - my ($mode,$chan); + my ( $nick, @chans ) = @_; + my ( $mode, $chan ); foreach $chan (@chans) { - foreach $mode (keys %{ $channels{$chan} }) { - # use grep here? - next unless (exists $channels{$chan}{$mode}{$nick}); + foreach $mode ( keys %{ $channels{$chan} } ) { + + # use grep here? + next unless ( exists $channels{$chan}{$mode}{$nick} ); - delete $channels{$chan}{$mode}{$nick}; - } + delete $channels{$chan}{$mode}{$nick}; + } } } @@ -838,10 +888,11 @@ sub clearIRCVars { undef %channels; undef %floodjoin; - $cache{joinTime} = time(); + $cache{joinTime} = time(); } sub getJoinChans { + # $show should contain the min number of seconds between display # of the Chans: status line. Use 0 to disable my $show = shift; @@ -850,51 +901,56 @@ sub getJoinChans { my @skip; my @join; - # Display "Chans:" only if more than $show seconds since last display - if (time() - $lastChansTime > $show) { - $lastChansTime = time(); - } else { - $show = 0; # Don't display since < 15min since last + # Display 'Chans:' only if more than $show seconds since last display + if ( time() - $lastChansTime > $show ) { + $lastChansTime = time(); + } + else { + $show = 0; # Don't display since < 15min since last } # can't join any if not connected - return @join if (!$conn); + return @join if ( !$conn ); my $nick = $conn->nick(); - foreach (keys %chanconf) { - next if ($_ eq '_default'); - - my $skip = 0; - my $val = $chanconf{$_}{autojoin}; - - if (defined $val) { - $skip++ if ($val eq '0'); - if ($val eq '1') { - # convert old +autojoin to autojoin - $val = lc $nick; - $chanconf{$_}{autojoin} = $val; - } - $skip++ if (lc $val ne lc $nick); - } else { - $skip++; - } - - if ($skip) { - push(@skip, $_); - } else { - if (defined $channels{$_} or exists $channels{$_}) { - push(@in, $_); - } else { - push(@join, $_); - } - } + foreach ( keys %chanconf ) { + next if ( $_ eq '_default' ); + + my $skip = 0; + my $val = $chanconf{$_}{autojoin}; + + if ( defined $val ) { + $skip++ if ( $val eq '0' ); + if ( $val eq '1' ) { + + # convert old +autojoin to autojoin + $val = lc $nick; + $chanconf{$_}{autojoin} = $val; + } + $skip++ if ( lc $val ne lc $nick ); + } + else { + $skip++; + } + + if ($skip) { + push( @skip, $_ ); + } + else { + if ( defined $channels{$_} or exists $channels{$_} ) { + push( @in, $_ ); + } + else { + push( @join, $_ ); + } + } } my $str; - $str .= ' in:' . join(',', sort @in) if scalar @in; - $str .= ' skip:' . join(',', sort @skip) if scalar @skip; - $str .= ' join:' . join(',', sort @join) if scalar @join; + $str .= ' in:' . join( ',', sort @in ) if scalar @in; + $str .= ' skip:' . join( ',', sort @skip ) if scalar @skip; + $str .= ' join:' . join( ',', sort @join ) if scalar @join; &status("Chans: ($nick)$str") if ($show); @@ -902,91 +958,93 @@ sub getJoinChans { } sub closeDCC { -# &DEBUG("closeDCC called."); - my $type; - foreach $type (keys %dcc) { - next if ($type ne uc($type)); - - my $nick; - foreach $nick (keys %{ $dcc{$type} }) { - next unless (defined $nick); - &status("DCC CHAT: closing DCC $type to $nick."); - next unless (defined $dcc{$type}{$nick}); + # &DEBUG('closeDCC called.'); + my $type; - my $ref = $dcc{$type}{$nick}; - &dccsay($nick, "bye bye, $nick") if ($type =~ /^chat$/i); - $dcc{$type}{$nick}->close(); - delete $dcc{$type}{$nick}; - &DEBUG("after close for $nick"); - } - delete $dcc{$type}; + foreach $type ( keys %dcc ) { + next if ( $type ne uc($type) ); + + my $nick; + foreach $nick ( keys %{ $dcc{$type} } ) { + next unless ( defined $nick ); + &status("DCC CHAT: closing DCC $type to $nick."); + next unless ( defined $dcc{$type}{$nick} ); + + my $ref = $dcc{$type}{$nick}; + &dccsay( $nick, "bye bye, $nick" ) if ( $type =~ /^chat$/i ); + $dcc{$type}{$nick}->close(); + delete $dcc{$type}{$nick}; + &DEBUG("after close for $nick"); + } + delete $dcc{$type}; } } sub joinfloodCheck { - my($who,$chan,$userhost) = @_; + my ( $who, $chan, $userhost ) = @_; - return unless (&IsChanConf('joinfloodCheck') > 0); + return unless ( &IsChanConf('joinfloodCheck') > 0 ); - if (exists $netsplit{lc $who}) { # netsplit join. - &DEBUG("joinfloodCheck: $who was in netsplit; not checking."); + if ( exists $netsplit{ lc $who } ) { # netsplit join. + &DEBUG("joinfloodCheck: $who was in netsplit; not checking."); } - if (exists $floodjoin{$chan}{$who}{Time}) { - &WARN("floodjoin{$chan}{$who} already exists?"); + if ( exists $floodjoin{$chan}{$who}{Time} ) { + &WARN("floodjoin{$chan}{$who} already exists?"); } $floodjoin{$chan}{$who}{Time} = time(); $floodjoin{$chan}{$who}{Host} = $userhost; ### Check... - foreach (keys %floodjoin) { - my $c = $_; - my $count = scalar keys %{ $floodjoin{$c} }; - next unless ($count > 5); - &DEBUG("joinflood: count => $count"); - - my $time; - foreach (keys %{ $floodjoin{$c} }) { - my $t = $floodjoin{$c}{$_}{Time}; - next unless (defined $t); - - $time += $t; - } - &DEBUG("joinflood: time => $time"); - $time /= $count; - - &DEBUG("joinflood: new time => $time"); + foreach ( keys %floodjoin ) { + my $c = $_; + my $count = scalar keys %{ $floodjoin{$c} }; + next unless ( $count > 5 ); + &DEBUG("joinflood: count => $count"); + + my $time; + foreach ( keys %{ $floodjoin{$c} } ) { + my $t = $floodjoin{$c}{$_}{Time}; + next unless ( defined $t ); + + $time += $t; + } + &DEBUG("joinflood: time => $time"); + $time /= $count; + + &DEBUG("joinflood: new time => $time"); } ### Clean it up. my $delete = 0; - my $time = time(); - foreach $chan (keys %floodjoin) { - foreach $who (keys %{ $floodjoin{$chan} }) { - my $t = $floodjoin{$chan}{$who}{Time}; - next unless (defined $t); - - my $delta = $time - $t; - next unless ($delta > 10); - - delete $floodjoin{$chan}{$who}; - $delete++; - } + my $time = time(); + foreach $chan ( keys %floodjoin ) { + foreach $who ( keys %{ $floodjoin{$chan} } ) { + my $t = $floodjoin{$chan}{$who}{Time}; + next unless ( defined $t ); + + my $delta = $time - $t; + next unless ( $delta > 10 ); + + delete $floodjoin{$chan}{$who}; + $delete++; + } } &DEBUG("joinfloodCheck: $delete deleted.") if ($delete); } sub getHostMask { - my($n) = @_; + my ($n) = @_; - if (exists $nuh{$n}) { - return &makeHostMask($nuh{$n}); - } else { - $cache{on_who_Hack} = 1; - $conn->who($n); + if ( exists $nuh{$n} ) { + return &makeHostMask( $nuh{$n} ); + } + else { + $cache{on_who_Hack} = 1; + $conn->who($n); } } diff --git a/src/IRC/IrcHelpers.pl b/src/IRC/IrcHelpers.pl index 4f64ca4..67487a2 100644 --- a/src/IRC/IrcHelpers.pl +++ b/src/IRC/IrcHelpers.pl @@ -21,8 +21,8 @@ sub hookMode { # sign. tmp parity needed to store current state if ( $mode =~ /[-+]/ ) { - $parity = 1 if ( $mode eq "+" ); - $parity = 0 if ( $mode eq "-" ); + $parity = 1 if ( $mode eq '+' ); + $parity = 0 if ( $mode eq '-' ); next; } @@ -33,7 +33,8 @@ sub hookMode { if ($parity) { $chanstats{ lc $chan }{'Op'}++ if ( $mode eq 'o' ); $chanstats{ lc $chan }{'Ban'}++ if ( $mode eq 'b' ); - } else { + } + else { $chanstats{ lc $chan }{'Deop'}++ if ( $mode eq 'o' ); $chanstats{ lc $chan }{'Unban'}++ if ( $mode eq 'b' ); } @@ -46,7 +47,7 @@ sub hookMode { # lets do some custom stuff. if ( $mode =~ /o/ and not $parity ) { if ( $target =~ /^\Q$ident\E$/i ) { - &VERB( "hookmode: someone deopped us!", 2 ); + &VERB( 'hookmode: someone deopped us!', 2 ); &chanServCheck($chan); } @@ -69,235 +70,268 @@ sub hookMode { } sub hookMsg { - ($msgType, $chan, $who, $message) = @_; - my $skipmessage = 0; - $addressed = 0; - $addressedother = 0; - $orig{message} = $message; - $orig{who} = $who; - $addrchar = 0; - - $message =~ s/[\cA-\c_]//ig; # strip control characters - $message =~ s/^\s+//; # initial whitespaces. - $who =~ tr/A-Z/a-z/; # lowercase. + ( $msgType, $chan, $who, $message ) = @_; + my $skipmessage = 0; + $addressed = 0; + $addressedother = 0; + $orig{message} = $message; + $orig{who} = $who; + $addrchar = 0; + + $message =~ s/[\cA-\c_]//ig; # strip control characters + $message =~ s/^\s+//; # initial whitespaces. + $who =~ tr/A-Z/a-z/; # lowercase. my $mynick = $conn->nick(); &showProc(); # addressing. - if ($msgType =~ /private/) { - # private messages. - $addressed = 1; - if (&IsChanConf('addressCharacter') > 0) { - $addressCharacter = getChanConf('addressCharacter'); - if ($message =~ s/^\Q$addressCharacter\E//) { - &msg($who, "The addressCharacter \"$addressCharacter\" is to get my attention in a normal channel. Please leave it off when messaging me directly."); - } - } - } else { - # public messages. - # addressing revamped by the xk. - ### below needs to be fixed... - if (&IsChanConf('addressCharacter') > 0) { - $addressCharacter = getChanConf('addressCharacter'); - if ($message =~ s/^\Q$addressCharacter\E//) { - $addrchar = 1; - $addressed = 1; - } - elsif ($message =~ s/^\Q~\E//){ - @chans = &getNickInChans('apt'); - if (not grep $chan, @chans){ - $addrchar = 1; - $addressed = 1; - } - } - } - - if (!$addressed and $message =~ /^($mask{nick})([\;\:\>\, ]+) */) { - my $newmessage = $'; - if ($1 =~ /^\Q$mynick\E$/i) { - $message = $newmessage; - $addressed = 1; - } else { - # ignore messages addressed to other people or unaddressed. - $skipmessage++ if ($2 ne '' and $2 !~ /^ /); - } - } + if ( $msgType =~ /private/ ) { + + # private messages. + $addressed = 1; + if ( &IsChanConf('addressCharacter') > 0 ) { + $addressCharacter = getChanConf('addressCharacter'); + if ( $message =~ s/^\Q$addressCharacter\E// ) { + &msg( $who, +"The addressCharacter \"$addressCharacter\" is to get my attention in a normal channel. Please leave it off when messaging me directly." + ); + } + } + } + else { + + # public messages. + # addressing revamped by the xk. + ### below needs to be fixed... + if ( &IsChanConf('addressCharacter') > 0 ) { + $addressCharacter = getChanConf('addressCharacter'); + if ( $message =~ s/^\Q$addressCharacter\E// ) { + $addrchar = 1; + $addressed = 1; + } + } + + if ( $message =~ /^($mask{nick})([\;\:\>\, ]+) */ ) { + my $newmessage = $'; + if ( $1 =~ /^\Q$mynick\E$/i ) { + $message = $newmessage; + $addressed = 1; + } + else { + + # ignore messages addressed to other people or unaddressed. + $skipmessage++ if ( $2 ne '' and $2 !~ /^ / ); + } + } } # Determine floodwho. - my $c = '_default'; - if ($msgType =~ /public/i) { - # public. - $floodwho = $c = lc $chan; - } elsif ($msgType =~ /private/i) { - # private. - $floodwho = lc $who; - } else { - # dcc? - &FIXME("floodwho = ???"); + my $c = '_default'; + if ( $msgType =~ /public/i ) { + + # public. + $floodwho = $c = lc $chan; } + elsif ( $msgType =~ /private/i ) { - my $val = &getChanConfDefault('floodRepeat', "2:5", $c); - my ($count, $interval) = split /:/, $val; + # private. + $floodwho = lc $who; + } + else { + + # dcc? + &FIXME('floodwho = ???'); + } + + my $val = &getChanConfDefault( 'floodRepeat', '2:5', $c ); + my ( $count, $interval ) = split /:/, $val; # flood repeat protection. if ($addressed) { - my $time = $flood{$floodwho}{$message} || 0; - - if (!&IsFlag('o') and $msgType eq 'public' and (time() - $time < $interval)) { - ### public != personal who so the below is kind of pointless. - my @who; - foreach (keys %flood) { - next if (/^\Q$floodwho\E$/); - next if (defined $chan and /^\Q$chan\E$/); - - push(@who, grep /^\Q$message\E$/i, keys %{ $flood{$_} }); - } - - return if ($lobotomized); - - if (!scalar @who) { - push(@who,'Someone'); - } - &msg($who,join(' ', @who)." already said that ". (time - $time) ." seconds ago" ); - - ### TODO: delete old floodwarn{} keys. - my $floodwarn = 0; - if (!exists $floodwarn{$floodwho}) { - $floodwarn++; - } else { - $floodwarn++ if (time() - $floodwarn{$floodwho} > $interval); - } - - if ($floodwarn) { - &status("FLOOD repetition detected from $floodwho."); - $floodwarn{$floodwho} = time(); - } - - return; - } - - if ($addrchar) { - &status("$b_cyan$who$ob is short-addressing $mynick"); - } elsif ($msgType eq 'private') { # private. - &status("$b_cyan$who$ob is /msg'ing $mynick"); - } else { # public? - &status("$b_cyan$who$ob is addressing $mynick"); - } - - $flood{$floodwho}{$message} = time(); - } elsif ($msgType eq 'public' and &IsChanConf('kickOnRepeat') > 0) { - # unaddressed, public only. - - ### TODO: use a separate "short-time" hash. - my @data; - @data = keys %{ $flood{$floodwho} } if (exists $flood{$floodwho}); + my $time = $flood{$floodwho}{$message} || 0; + + if ( !&IsFlag('o') + and $msgType eq 'public' + and ( time() - $time < $interval ) ) + { + ### public != personal who so the below is kind of pointless. + my @who; + foreach ( keys %flood ) { + next if (/^\Q$floodwho\E$/); + next if ( defined $chan and /^\Q$chan\E$/ ); + + push( @who, grep /^\Q$message\E$/i, keys %{ $flood{$_} } ); + } + + return if ($lobotomized); + + if ( !scalar @who ) { + push( @who, 'Someone' ); + } + &msg( $who, + join( ' ', @who ) + . ' already said that ' + . ( time - $time ) + . ' seconds ago' ); + + ### TODO: delete old floodwarn{} keys. + my $floodwarn = 0; + if ( !exists $floodwarn{$floodwho} ) { + $floodwarn++; + } + else { + $floodwarn++ if ( time() - $floodwarn{$floodwho} > $interval ); + } + + if ($floodwarn) { + &status("FLOOD repetition detected from $floodwho."); + $floodwarn{$floodwho} = time(); + } + + return; + } + + if ($addrchar) { + &status("$b_cyan$who$ob is short-addressing $mynick"); + } + elsif ( $msgType eq 'private' ) { # private. + &status("$b_cyan$who$ob is /msg'ing $mynick"); + } + else { # public? + &status("$b_cyan$who$ob is addressing $mynick"); + } + + $flood{$floodwho}{$message} = time(); + } + elsif ( $msgType eq 'public' and &IsChanConf('kickOnRepeat') > 0 ) { + + # unaddressed, public only. + + ### TODO: use a separate 'short-time' hash. + my @data; + @data = keys %{ $flood{$floodwho} } if ( exists $flood{$floodwho} ); } - $val = &getChanConfDefault('floodMessages', "5:30", $c); - ($count, $interval) = split /:/, $val; + $val = &getChanConfDefault( 'floodMessages', '5:30', $c ); + ( $count, $interval ) = split /:/, $val; # flood overflow protection. if ($addressed) { - foreach (keys %{ $flood{$floodwho} }) { - next unless (time() - $flood{$floodwho}{$_} > $interval); - delete $flood{$floodwho}{$_}; - } + foreach ( keys %{ $flood{$floodwho} } ) { + next unless ( time() - $flood{$floodwho}{$_} > $interval ); + delete $flood{$floodwho}{$_}; + } - my $i = scalar keys %{ $flood{$floodwho} }; - if ($i > $count) { - my $expire = $param{'ignoreAutoExpire'} || 5; + my $i = scalar keys %{ $flood{$floodwho} }; + if ( $i > $count ) { + my $expire = $param{'ignoreAutoExpire'} || 5; -# &msg($who,"overflow of messages ($i > $count)"); - &msg($who,"Too many queries from you, ignoring for $expire minutes."); - &status("FLOOD overflow detected from $floodwho; ignoring"); + # &msg($who,"overflow of messages ($i > $count)"); + &msg( $who, + "Too many queries from you, ignoring for $expire minutes." ); + &status("FLOOD overflow detected from $floodwho; ignoring"); - &ignoreAdd("*!$uh", $chan, $expire, "flood overflow auto-detected."); - return; - } + &ignoreAdd( "*!$uh", $chan, $expire, + 'flood overflow auto-detected.' ); + return; + } - $flood{$floodwho}{$message} = time(); + $flood{$floodwho}{$message} = time(); } my @ignore; - if ($msgType =~ /public/i) { # public. - $talkchannel = $chan; - &status("<$orig{who}/$chan> $orig{message}"); - push(@ignore, keys %{ $ignore{$chan} }) if (exists $ignore{$chan}); - } elsif ($msgType =~ /private/i) { # private. - &status("[$orig{who}] $orig{message}"); - $talkchannel = undef; - $chan = '_default'; - } else { - &DEBUG("unknown msgType => $msgType."); + if ( $msgType =~ /public/i ) { # public. + $talkchannel = $chan; + &status("<$orig{who}/$chan> $orig{message}"); + push( @ignore, keys %{ $ignore{$chan} } ) if ( exists $ignore{$chan} ); } - push(@ignore, keys %{ $ignore{'*'} }) if (exists $ignore{'*'}); - - if ((!$skipmessage or &IsChanConf('seenStoreAll') > 0) and - &IsChanConf('sed') > 0 and &IsChanConf('seen') > 0 and - $msgType =~ /public/ and - $orig{message} =~ /^s\/([^;\/]*)\/([^;\/]*)\/([g]*)$/) { - my $sedmsg = $seencache{$who}{'msg'}; - eval "\$sedmsg =~ s/\Q$1\E/\Q$2\E/$3;"; - $sedmsg =~ s/^(.{255}).*$/$1.../; # 255 char max to prevent flood - - if ($sedmsg ne $seencache{$who}{'msg'}) { - &DEBUG("sed \"" . $orig{message} . "\" \"" . - $seencache{$who}{'msg'} . "\" \"" . $sedmsg. "\""); - &msg($talkchannel, "$orig{who} meant: $sedmsg"); - } - } elsif ((!$skipmessage or &IsChanConf('seenStoreAll') > 0) and - &IsChanConf('seen') > 0 and $msgType =~ /public/) { - $seencache{$who}{'time'} = time(); - $seencache{$who}{'nick'} = $orig{who}; - $seencache{$who}{'host'} = $uh; - $seencache{$who}{'chan'} = $talkchannel; - $seencache{$who}{'msg'} = $orig{message}; - $seencache{$who}{'msgcount'}++; + elsif ( $msgType =~ /private/i ) { # private. + &status("[$orig{who}] $orig{message}"); + $talkchannel = undef; + $chan = '_default'; } - if (&IsChanConf('minVolunteerLength') > 0) { - # FIXME hack to treat unaddressed as if using addrchar - $addrchar = 1; + else { + &DEBUG("unknown msgType => $msgType."); + } + push( @ignore, keys %{ $ignore{'*'} } ) if ( exists $ignore{'*'} ); + + if ( ( !$skipmessage or &IsChanConf('seenStoreAll') > 0 ) + and &IsChanConf('sed') > 0 + and &IsChanConf('seen') > 0 + and $msgType =~ /public/ + and $orig{message} =~ /^s\/([^;\/]*)\/([^;\/]*)\/([g]*)$/ ) + { + my $sedmsg = $seencache{$who}{'msg'}; + eval "\$sedmsg =~ s/\Q$1\E/\Q$2\E/$3;"; + $sedmsg =~ s/^(.{255}).*$/$1.../; # 255 char max to prevent flood + + if ( $sedmsg ne $seencache{$who}{'msg'} ) { + &DEBUG( "sed \"" + . $orig{message} . "\" \"" + . $seencache{$who}{'msg'} . "\" \"" + . $sedmsg + . "\"" ); + &msg( $talkchannel, "$orig{who} meant: $sedmsg" ); + } + } + elsif ( ( !$skipmessage or &IsChanConf('seenStoreAll') > 0 ) + and &IsChanConf('seen') > 0 + and $msgType =~ /public/ ) + { + $seencache{$who}{'time'} = time(); + $seencache{$who}{'nick'} = $orig{who}; + $seencache{$who}{'host'} = $uh; + $seencache{$who}{'chan'} = $talkchannel; + $seencache{$who}{'msg'} = $orig{message}; + $seencache{$who}{'msgcount'}++; + } + if ( &IsChanConf('minVolunteerLength') > 0 ) { + + # FIXME hack to treat unaddressed as if using addrchar + $addrchar = 1; } return if ($skipmessage); - return unless ($addrchar or $addressed); + return unless ( $addrchar or $addressed ); foreach (@ignore) { - s/\*/\\S*/g; + s/\*/\\S*/g; - next unless (eval { $nuh =~ /^$_$/i } ); + next unless ( eval { $nuh =~ /^$_$/i } ); - # better to ignore an extra message than to allow one to get - # through, although it would be better to go through ignore - # checking again. - if (time() - ($cache{ignoreCheckTime} || 0) > 60) { - &ignoreCheck(); - } + # better to ignore an extra message than to allow one to get + # through, although it would be better to go through ignore + # checking again. + if ( time() - ( $cache{ignoreCheckTime} || 0 ) > 60 ) { + &ignoreCheck(); + } - &status("IGNORE <$who> $message"); - return; + &status("IGNORE <$who> $message"); + return; } - if (defined $nuh) { - if (!defined $userHandle) { - &DEBUG("line 1074: need verifyUser?"); - &verifyUser($who, $nuh); - } - } else { - &DEBUG("hookMsg: 'nuh' not defined?"); + if ( defined $nuh ) { + if ( !defined $userHandle ) { + &DEBUG('line 1074: need verifyUser?'); + &verifyUser( $who, $nuh ); + } + } + else { + &DEBUG("hookMsg: 'nuh' not defined?"); } ### For extra debugging purposes... - if ($_ = &process()) { -# &DEBUG("IrcHooks: process returned '$_'."); + if ( $_ = &process() ) { + + # &DEBUG("IrcHooks: process returned '$_'."); } # hack to remove +o from ppl with +O flag. - if (exists $users{$userHandle} && exists $users{$userHandle}{FLAGS} && - $users{$userHandle}{FLAGS} =~ /O/ - ) { - $users{$userHandle}{FLAGS} =~ s/o//g; + if ( exists $users{$userHandle} + && exists $users{$userHandle}{FLAGS} + && $users{$userHandle}{FLAGS} =~ /O/ ) + { + $users{$userHandle}{FLAGS} =~ s/o//g; } return; @@ -305,78 +339,83 @@ sub hookMsg { # this is basically run on on_join or on_quit sub chanLimitVerify { - my($c) = @_; - $chan = $c; - my $l = $channels{$chan}{'l'}; + my ($c) = @_; + $chan = $c; + my $l = $channels{$chan}{'l'}; - return unless (&IsChanConf('chanlimitcheck') > 0); + return unless ( &IsChanConf('chanlimitcheck') > 0 ); - if (scalar keys %netsplit) { - &WARN("clV: netsplit active (1, chan = $chan); skipping."); - return; + if ( scalar keys %netsplit ) { + &WARN("clV: netsplit active (1, chan = $chan); skipping."); + return; } - if (!defined $l) { - &DEBUG("$chan: running chanlimitCheck from chanLimitVerify."); - &chanlimitCheck(); - return; + if ( !defined $l ) { + &DEBUG("$chan: running chanlimitCheck from chanLimitVerify."); + &chanlimitCheck(); + return; } # only change it if it's not set. - my $plus = &getChanConfDefault('chanlimitcheckPlus', 5, $chan); - my $count = scalar(keys %{ $channels{$chan}{''} }); - my $int = &getChanConfDefault('chanlimitcheckInterval', 10, $chan); + my $plus = &getChanConfDefault( 'chanlimitcheckPlus', 5, $chan ); + my $count = scalar( keys %{ $channels{$chan}{''} } ); + my $int = &getChanConfDefault( 'chanlimitcheckInterval', 10, $chan ); my $delta = $count + $plus - $l; -# $delta =~ s/^\-//; - if ($plus <= 3) { - &WARN("clc: stupid to have plus at $plus, fix it!"); + # $delta =~ s/^\-//; + + if ( $plus <= 3 ) { + &WARN("clc: stupid to have plus at $plus, fix it!"); } - if (exists $cache{chanlimitChange}{$chan}) { - if (time() - $cache{chanlimitChange}{$chan} < $int*60) { - return; - } + if ( exists $cache{chanlimitChange}{$chan} ) { + if ( time() - $cache{chanlimitChange}{$chan} < $int * 60 ) { + return; + } } &chanServCheck($chan); ### TODO: unify code with chanlimitcheck() - return if ($delta > 5); + return if ( $delta > 5 ); - &status("clc: big change in limit for $chan ($delta);". - "going for it. (was: $l; now: ".($count+$plus).")"); + &status("clc: big change in limit for $chan ($delta);" + . "going for it. (was: $l; now: " + . ( $count + $plus ) + . ')' ); - $conn->mode($chan, "+l", $count+$plus); + $conn->mode( $chan, '+l', $count + $plus ); $cache{chanlimitChange}{$chan} = time(); } sub chanServCheck { ($chan) = @_; - if (!defined $chan or $chan =~ /^\s*$/) { - &WARN("chanServCheck: chan == NULL."); - return 0; + if ( !defined $chan or $chan =~ /^\s*$/ ) { + &WARN('chanServCheck: chan == NULL.'); + return 0; } - return unless (&IsChanConf('chanServCheck') > 0); + return unless ( &IsChanConf('chanServCheck') > 0 ); - &VERB("chanServCheck($chan) called.",2); + &VERB( "chanServCheck($chan) called.", 2 ); - if ( &IsParam('nickServ_pass') and !$nickserv) { - $conn->who('NickServ'); - return 0; + if ( &IsParam('nickServ_pass') and !$nickserv ) { + $conn->who('NickServ'); + return 0; } # check for first hash then for next hash. # TODO: a function for &ischanop()? &isvoice()? - if (exists $channels{lc $chan} and exists $channels{lc $chan}{'o'}{$ident}) { - return 0; + if ( exists $channels{ lc $chan } + and exists $channels{ lc $chan }{'o'}{$ident} ) + { + return 0; } &status("ChanServ ==> Requesting ops for $chan. (chanServCheck)"); - &msg('ChanServ', "OP $chan"); + &msg( 'ChanServ', "OP $chan" ); return 1; } diff --git a/src/IRC/IrcHooks.pl b/src/IRC/IrcHooks.pl index 07adbb2..af96470 100644 --- a/src/IRC/IrcHooks.pl +++ b/src/IRC/IrcHooks.pl @@ -10,124 +10,130 @@ use vars qw(%chanconf); sub on_generic { $conn = shift(@_); my ($event) = @_; - my $nick = $event->nick(); - my $chan = ($event->to)[0]; + my $nick = $event->nick(); + my $chan = ( $event->to )[0]; &DEBUG("on_generic: nick => '$nick'."); &DEBUG("on_generic: chan => '$chan'."); - foreach ($event->args) { - &DEBUG("on_generic: args => '$_'."); + foreach ( $event->args ) { + &DEBUG("on_generic: args => '$_'."); } } sub on_action { $conn = shift(@_); my ($event) = @_; - my ($nick, $args) = ($event->nick, $event->args); - my $chan = ($event->to)[0]; + my ( $nick, $args ) = ( $event->nick, $event->args ); + my $chan = ( $event->to )[0]; - if ($chan eq $ident) { - &status("* [$nick] $args"); - } else { - &status("* $nick/$chan $args"); + if ( $chan eq $ident ) { + &status("* [$nick] $args"); + } + else { + &status("* $nick/$chan $args"); } } sub on_chat { $conn = shift(@_); my ($event) = @_; - my $msg = ($event->args)[0]; - my $sock = ($event->to)[0]; - my $nick = lc $event->nick(); + my $msg = ( $event->args )[0]; + my $sock = ( $event->to )[0]; + my $nick = lc $event->nick(); - if (!exists $nuh{$nick}) { - &DEBUG("chat: nuh{$nick} doesn't exist; trying WHOIS ."); - $conn->whois($nick); - return; + if ( !exists $nuh{$nick} ) { + &DEBUG("chat: nuh{$nick} doesn't exist; trying WHOIS ."); + $conn->whois($nick); + return; } ### set vars that would have been set in hookMsg. - $userHandle = ''; # reset. - $who = lc $nick; - $message = $msg; - $orig{who} = $nick; - $orig{message} = $msg; - $nuh = $nuh{$who}; - $uh = (split /\!/, $nuh)[1]; - $h = (split /\@/, $uh)[1]; - $addressed = 1; - $msgType = 'chat'; - - if (!exists $dcc{'CHATvrfy'}{$nick}) { - $userHandle = &verifyUser($who, $nuh); - my $crypto = $users{$userHandle}{PASS}; - my $success = 0; - - if ($userHandle eq '_default') { - &WARN("DCC CHAT: _default/guest not allowed."); - return; - } - - ### TODO: prevent users without CRYPT chatting. - if (!defined $crypto) { - &TODO("dcc close chat"); - &msg($who, "nope, no guest logins allowed..."); - return; - } - - if (&ckpasswd($msg, $crypto)) { - # stolen from eggdrop. - $conn->privmsg($sock, "Connected to $ident"); - $conn->privmsg($sock, "Commands start with '.' (like '.quit' or '.help')"); - $conn->privmsg($sock, "Everything else goes out to the party line."); - - &dccStatus(2) unless (exists $sched{'dccStatus'}{RUNNING}); - - $success++; - - } else { - &status("DCC CHAT: incorrect pass; closing connection."); - &DEBUG("chat: sock => '$sock'."); + $userHandle = ''; # reset. + $who = lc $nick; + $message = $msg; + $orig{who} = $nick; + $orig{message} = $msg; + $nuh = $nuh{$who}; + $uh = ( split /\!/, $nuh )[1]; + $h = ( split /\@/, $uh )[1]; + $addressed = 1; + $msgType = 'chat'; + + if ( !exists $dcc{'CHATvrfy'}{$nick} ) { + $userHandle = &verifyUser( $who, $nuh ); + my $crypto = $users{$userHandle}{PASS}; + my $success = 0; + + if ( $userHandle eq '_default' ) { + &WARN('DCC CHAT: _default/guest not allowed.'); + return; + } + + ### TODO: prevent users without CRYPT chatting. + if ( !defined $crypto ) { + &TODO('dcc close chat'); + &msg( $who, 'nope, no guest logins allowed...' ); + return; + } + + if ( &ckpasswd( $msg, $crypto ) ) { + + # stolen from eggdrop. + $conn->privmsg( $sock, "Connected to $ident" ); + $conn->privmsg( $sock, + 'Commands start with "." (like ".quit" or ".help")' ); + $conn->privmsg( $sock, + 'Everything else goes out to the party line.' ); + + &dccStatus(2) unless ( exists $sched{'dccStatus'}{RUNNING} ); + + $success++; + + } + else { + &status('DCC CHAT: incorrect pass; closing connection.'); + &DEBUG("chat: sock => '$sock'."); ### $sock->close(); - delete $dcc{'CHAT'}{$nick}; - &FIXME("chat: after closing sock."); - ### BUG: close seizes bot. why? - } + delete $dcc{'CHAT'}{$nick}; + &FIXME('chat: after closing sock.'); + ### BUG: close seizes bot. why? + } - if ($success) { - &status("DCC CHAT: user $nick is here!"); - &DCCBroadcast("*** $nick ($uh) joined the party line."); + if ($success) { + &status("DCC CHAT: user $nick is here!"); + &DCCBroadcast("*** $nick ($uh) joined the party line."); - $dcc{'CHATvrfy'}{$nick} = $userHandle; + $dcc{'CHATvrfy'}{$nick} = $userHandle; - return if ($userHandle eq '_default'); + return if ( $userHandle eq '_default' ); - &dccsay($nick,"Flags: $users{$userHandle}{FLAGS}"); - } + &dccsay( $nick, "Flags: $users{$userHandle}{FLAGS}" ); + } - return; + return; } &status("$b_red=$b_cyan$who$b_red=$ob $message"); - if ($message =~ s/^\.//) { # dcc chat commands. - ### TODO: make use of &Forker(); here? - &loadMyModule('UserDCC'); + if ( $message =~ s/^\.// ) { # dcc chat commands. + ### TODO: make use of &Forker(); here? + &loadMyModule('UserDCC'); - &DCCBroadcast("#$who# $message",'m'); + &DCCBroadcast( "#$who# $message", 'm' ); - my $retval = &userDCC(); - return unless (defined $retval); - return if ($retval eq $noreply); + my $retval = &userDCC(); + return unless ( defined $retval ); + return if ( $retval eq $noreply ); - $conn->privmsg($dcc{'CHAT'}{$who}, "Invalid command."); + $conn->privmsg( $dcc{'CHAT'}{$who}, 'Invalid command.' ); - } else { # dcc chat arena. + } + else { # dcc chat arena. - foreach (keys %{ $dcc{'CHAT'} }) { - $conn->privmsg($dcc{'CHAT'}{$_}, "<$who> $orig{message}"); - } + foreach ( keys %{ $dcc{'CHAT'} } ) { + $conn->privmsg( $dcc{'CHAT'}{$_}, "<$who> $orig{message}" ); + } } return 'DCC CHAT MESSAGE'; @@ -137,8 +143,8 @@ sub on_chat { sub on_ison { $conn = shift(@_); my ($event) = @_; - my $x1 = ($event->args)[0]; - my $x2 = ($event->args)[1]; + my $x1 = ( $event->args )[0]; + my $x2 = ( $event->args )[1]; $x2 =~ s/\s$//; &DEBUG("on_ison: x1 = '$x1', x2 => '$x2'"); @@ -149,297 +155,327 @@ sub on_endofmotd { # update IRCStats. $ident = $conn->nick(); - $ircstats{'ConnectTime'} = time(); + $ircstats{'ConnectTime'} = time(); $ircstats{'ConnectCount'}++; - if (defined $ircstats{'DisconnectTime'}) { - $ircstats{'OffTime'} += time() - $ircstats{'DisconnectTime'}; + if ( defined $ircstats{'DisconnectTime'} ) { + $ircstats{'OffTime'} += time() - $ircstats{'DisconnectTime'}; } # first time run. - if (!exists $users{_default}) { - &status("!!! First time run... adding _default user."); - $users{_default}{FLAGS} = 'amrt'; - $users{_default}{HOSTS}{"*!*@*"} = 1; + if ( !exists $users{_default} ) { + &status('!!! First time run... adding _default user.'); + $users{_default}{FLAGS} = 'amrt'; + $users{_default}{HOSTS}{'*!*@*'} = 1; } - if (scalar keys %users < 2) { - &status("!"x40); - &status("!!! Ok. Now type '/msg $ident PASS ' to get master access through DCC CHAT."); - &status("!"x40); + if ( scalar keys %users < 2 ) { + &status( '!' x 40 ); + &status( +"!!! Ok. Now type '/msg $ident PASS ' to get master access through DCC CHAT." + ); + &status( '!' x 40 ); } + # end of first time run. - if (&IsChanConf('Wingate') > 0) { - my $file = "$bot_base_dir/$param{'ircUser'}.wingate"; - open(IN, $file); - while () { - chop; - next unless (/^(\S+)\*$/); - push(@wingateBad, $_); - } - close IN; + if ( &IsChanConf('Wingate') > 0 ) { + my $file = "$bot_base_dir/$param{'ircUser'}.wingate"; + open( IN, $file ); + while () { + chop; + next unless (/^(\S+)\*$/); + push( @wingateBad, $_ ); + } + close IN; } if ($firsttime) { - &ScheduleThis(1, 'setupSchedulers'); - $firsttime = 0; + &ScheduleThis( 1, 'setupSchedulers' ); + $firsttime = 0; } - if (&IsParam('ircUMode')) { - &VERB("Attempting change of user modes to $param{'ircUMode'}.", 2); - if ($param{'ircUMode'} !~ /^[-+]/) { - &WARN("ircUMode had no +- prefix; adding +"); - $param{'ircUMode'} = "+".$param{'ircUMode'}; - } + if ( &IsParam('ircUMode') ) { + &VERB( "Attempting change of user modes to $param{'ircUMode'}.", 2 ); + if ( $param{'ircUMode'} !~ /^[-+]/ ) { + &WARN('ircUMode had no +- prefix; adding +'); + $param{'ircUMode'} = '+' . $param{'ircUMode'}; + } - &rawout("MODE $ident $param{'ircUMode'}"); + &rawout("MODE $ident $param{'ircUMode'}"); } # ok, we're free to do whatever we want now. go for it! $running = 1; # add ourself to notify. - $conn->ison($conn->nick()); + $conn->ison( $conn->nick() ); # Q, as on quakenet.org. - if (&IsParam('Q_pass')) { - &status("Authing to Q..."); - &rawout("PRIVMSG Q\@CServe.quakenet.org :AUTH $param{'Q_user'} $param{'Q_pass'}"); + if ( &IsParam('Q_pass') ) { + &status('Authing to Q...'); + &rawout( +"PRIVMSG Q\@CServe.quakenet.org :AUTH $param{'Q_user'} $param{'Q_pass'}" + ); } - &status("End of motd. Now lets join some channels..."); + &status('End of motd. Now lets join some channels...'); + #&joinNextChan(); } sub on_endofwho { $conn = shift(@_); my ($event) = @_; -# &DEBUG("endofwho: chan => $chan"); - $chan ||= ($event->args)[1]; -# &DEBUG("endofwho: chan => $chan"); - if (exists $cache{countryStats}) { - &do_countrystats(); + # &DEBUG("endofwho: chan => $chan"); + $chan ||= ( $event->args )[1]; + + # &DEBUG("endofwho: chan => $chan"); + + if ( exists $cache{countryStats} ) { + &do_countrystats(); } } sub on_dcc { $conn = shift(@_); my ($event) = @_; - my $type = uc( ($event->args)[1] ); + my $type = uc( ( $event->args )[1] ); my $nick = lc $event->nick(); &status("on_dcc type=$type nick=$nick sock=$sock"); # pity Net::IRC doesn't store nuh. Here's a hack :) - if (!exists $nuh{lc $nick}) { - $conn->whois($nick); - $nuh{$nick} = "GETTING-NOW"; # trying. - } - $type ||= "???"; - - if ($type eq 'SEND') { # GET for us. - # incoming DCC SEND. we're receiving a file. - my $get = ($event->args)[2]; - &status("DCC: not Initializing GET from $nick to '$param{tempDir}/$get'"); - # FIXME: do we want to get anything? - return; - #open(DCCGET,">$param{tempDir}/$get"); - #$conn->new_get($event, \*DCCGET); - - } elsif ($type eq 'GET') { # SEND for us? - &status("DCC: not Initializing SEND for $nick."); - # FIXME: do we want to do anything? - return; - $conn->new_send($event->args); - - } elsif ($type eq 'CHAT') { - &status("DCC: Initializing CHAT for $nick."); - $conn->new_chat($event); -# $conn->new_chat(1, $nick, $event->host); - - } else { - &WARN("${b_green}DCC $type$ob (1)"); + if ( !exists $nuh{ lc $nick } ) { + $conn->whois($nick); + $nuh{$nick} = 'GETTING-NOW'; # trying. + } + $type ||= '???'; + + if ( $type eq 'SEND' ) { # GET for us. + # incoming DCC SEND. we're receiving a file. + my $get = ( $event->args )[2]; + &status( + "DCC: not Initializing GET from $nick to '$param{tempDir}/$get'"); + + # FIXME: do we want to get anything? + return; + + #open(DCCGET,">$param{tempDir}/$get"); + #$conn->new_get($event, \*DCCGET); + + } + elsif ( $type eq 'GET' ) { # SEND for us? + &status("DCC: not Initializing SEND for $nick."); + + # FIXME: do we want to do anything? + return; + $conn->new_send( $event->args ); + + } + elsif ( $type eq 'CHAT' ) { + &status("DCC: Initializing CHAT for $nick."); + $conn->new_chat($event); + + # $conn->new_chat(1, $nick, $event->host); + + } + else { + &WARN("${b_green}DCC $type$ob (1)"); } } sub on_dcc_close { $conn = shift(@_); my ($event) = @_; - my $nick = $event->nick(); - my $sock = ($event->to)[0]; + my $nick = $event->nick(); + my $sock = ( $event->to )[0]; # DCC CHAT close on fork exit workaround. - if ($bot_pid != $$) { - &WARN("run-away fork; exiting."); - &delForked($forker); + if ( $bot_pid != $$ ) { + &WARN('run-away fork; exiting.'); + &delForked($forker); } - if (exists $dcc{'SEND'}{$nick} and -f "$param{tempDir}/$nick.txt") { - &status("${b_green}DCC SEND$ob close from $b_cyan$nick$ob"); + if ( exists $dcc{'SEND'}{$nick} and -f "$param{tempDir}/$nick.txt" ) { + &status("${b_green}DCC SEND$ob close from $b_cyan$nick$ob"); - &status("dcc_close: purging DCC send $nick.txt"); - unlink "$param{tempDir}/$nick.txt"; + &status("dcc_close: purging DCC send $nick.txt"); + unlink "$param{tempDir}/$nick.txt"; - delete $dcc{'SEND'}{$nick}; - } elsif (exists $dcc{'CHAT'}{$nick} and $dcc{'CHAT'}{$nick} eq $sock) { - &status("${b_green}DCC CHAT$ob close from $b_cyan$nick$ob"); - delete $dcc{'CHAT'}{$nick}; - delete $dcc{'CHATvrfy'}{$nick}; - } else { - &status("${b_green}DCC$ob UNKNOWN close from $b_cyan$nick$ob (2)"); + delete $dcc{'SEND'}{$nick}; + } + elsif ( exists $dcc{'CHAT'}{$nick} and $dcc{'CHAT'}{$nick} eq $sock ) { + &status("${b_green}DCC CHAT$ob close from $b_cyan$nick$ob"); + delete $dcc{'CHAT'}{$nick}; + delete $dcc{'CHATvrfy'}{$nick}; + } + else { + &status("${b_green}DCC$ob UNKNOWN close from $b_cyan$nick$ob (2)"); } } sub on_dcc_open { $conn = shift(@_); my ($event) = @_; - my $type = uc( ($event->args)[0] ); + my $type = uc( ( $event->args )[0] ); my $nick = lc $event->nick(); - my $sock = ($event->to)[0]; + my $sock = ( $event->to )[0]; &status("on_dcc_open type=$type nick=$nick sock=$sock"); $msgType = 'chat'; - $type ||= "???"; + $type ||= '???'; ### BUG: who is set to bot's nick? # lets do it. - if ($type eq 'SEND') { - &status("${b_green}DCC lGET$ob established with $b_cyan$nick$ob"); - - } elsif ($type eq 'CHAT') { - # very cheap hack. - ### TODO: run ScheduleThis inside on_dcc_open_chat recursively - ### 1,3,5,10 seconds then fail. - if ($nuh{$nick} eq "GETTING-NOW") { - &ScheduleThis(3/60, 'on_dcc_open_chat', $nick, $sock); - } else { - on_dcc_open_chat(undef, $nick, $sock); - } - - } elsif ($type eq 'SEND') { - &status("Starting DCC receive."); - foreach ($event->args) { - &status(" => '$_'."); - } - - } else { - &WARN("${b_green}DCC $type$ob (3)"); + if ( $type eq 'SEND' ) { + &status("${b_green}DCC lGET$ob established with $b_cyan$nick$ob"); + + } + elsif ( $type eq 'CHAT' ) { + + # very cheap hack. + ### TODO: run ScheduleThis inside on_dcc_open_chat recursively + ### 1,3,5,10 seconds then fail. + if ( $nuh{$nick} eq 'GETTING-NOW' ) { + &ScheduleThis( 3 / 60, 'on_dcc_open_chat', $nick, $sock ); + } + else { + on_dcc_open_chat( undef, $nick, $sock ); + } + + } + elsif ( $type eq 'SEND' ) { + &status('Starting DCC receive.'); + foreach ( $event->args ) { + &status(" => '$_'."); + } + + } + else { + &WARN("${b_green}DCC $type$ob (3)"); } } # really custom sub to get NUH since Net::IRC doesn't appear to support # it. sub on_dcc_open_chat { - my(undef, $nick, $sock) = @_; + my ( undef, $nick, $sock ) = @_; - if ($nuh{$nick} eq "GETTING-NOW") { - &FIXME("getting nuh for $nick failed."); - return; + if ( $nuh{$nick} eq 'GETTING-NOW' ) { + &FIXME("getting nuh for $nick failed."); + return; } - &status("${b_green}DCC CHAT$ob established with $b_cyan$nick$ob $b_yellow($ob$nuh{$nick}$b_yellow)$ob"); + &status( +"${b_green}DCC CHAT$ob established with $b_cyan$nick$ob $b_yellow($ob$nuh{$nick}$b_yellow)$ob" + ); - &verifyUser($nick, $nuh{lc $nick}); + &verifyUser( $nick, $nuh{ lc $nick } ); - if (!exists $users{$userHandle}{HOSTS}) { - &performStrictReply("you have no hosts defined in my user file; rejecting."); - $sock->close(); - return; + if ( !exists $users{$userHandle}{HOSTS} ) { + &performStrictReply( + 'you have no hosts defined in my user file; rejecting.'); + $sock->close(); + return; } - my $crypto = $users{$userHandle}{PASS}; + my $crypto = $users{$userHandle}{PASS}; $dcc{'CHAT'}{$nick} = $sock; # TODO: don't make DCC CHAT established in the first place. - if ($userHandle eq '_default') { - &dccsay($nick, "_default/guest not allowed"); - $sock->close(); - return; + if ( $userHandle eq '_default' ) { + &dccsay( $nick, '_default/guest not allowed' ); + $sock->close(); + return; } - if (defined $crypto) { - &status("DCC CHAT: going to use ".$nick."'s crypt."); - &dccsay($nick,"Enter your password."); - } else { -# &dccsay($nick,"Welcome to infobot DCC CHAT interface, $userHandle."); + if ( defined $crypto ) { + &status( "DCC CHAT: going to use $nick\'s crypt." ); + &dccsay( $nick, 'Enter your password.' ); + } + else { + + # &dccsay($nick,"Welcome to infobot DCC CHAT interface, $userHandle."); } } sub on_disconnect { $conn = shift(@_); my ($event) = @_; - my $from = $event->from(); - my $what = ($event->args)[0]; - my $mynick=$conn->nick(); + my $from = $event->from(); + my $what = ( $event->args )[0]; + my $mynick = $conn->nick(); &status("$mynick disconnect from $from ($what)."); - $ircstats{'DisconnectTime'} = time(); - $ircstats{'DisconnectReason'} = $what; + $ircstats{'DisconnectTime'} = time(); + $ircstats{'DisconnectReason'} = $what; $ircstats{'DisconnectCount'}++; - $ircstats{'TotalTime'} += time() - $ircstats{'ConnectTime'} - if ($ircstats{'ConnectTime'}); + $ircstats{'TotalTime'} += time() - $ircstats{'ConnectTime'} + if ( $ircstats{'ConnectTime'} ); # clear any variables on reconnection. $nickserv = 0; &clearIRCVars(); - if (!defined $conn) { - &WARN("on_disconnect: self is undefined! WTF"); - &DEBUG("running function irc... lets hope this works."); - &irc(); - return; + if ( !defined $conn ) { + &WARN('on_disconnect: self is undefined! WTF'); + &DEBUG('running function irc... lets hope this works.'); + &irc(); + return; } - &WARN("scheduling call ircCheck() in 60s"); + &WARN('scheduling call ircCheck() in 60s'); &clearIRCVars(); - &ScheduleThis(1, 'ircCheck'); + &ScheduleThis( 1, 'ircCheck' ); } sub on_endofnames { $conn = shift(@_); my ($event) = @_; - my $chan = ($event->args)[1]; + my $chan = ( $event->args )[1]; # sync time should be done in on_endofwho like in BitchX - if (exists $cache{jointime}{$chan}) { - my $delta_time = sprintf("%.03f", &timedelta($cache{jointime}{$chan}) ); - $delta_time = 0 if ($delta_time <= 0); - if ($delta_time > 100) { - &WARN("endofnames: delta_time > 100 ($delta_time)"); - } + if ( exists $cache{jointime}{$chan} ) { + my $delta_time = + sprintf( '%.03f', &timedelta( $cache{jointime}{$chan} ) ); + $delta_time = 0 if ( $delta_time <= 0 ); + if ( $delta_time > 100 ) { + &WARN("endofnames: delta_time > 100 ($delta_time)"); + } - &status("$b_blue$chan$ob: sync in ${delta_time}s."); + &status("$b_blue$chan$ob: sync in ${delta_time}s."); } $conn->mode($chan); my $txt; my @array; - foreach ('o','v','') { - my $count = scalar(keys %{ $channels{$chan}{$_} }); - next unless ($count); + foreach ( 'o', 'v', '' ) { + my $count = scalar( keys %{ $channels{$chan}{$_} } ); + next unless ($count); - $txt = 'total' if ($_ eq ''); - $txt = 'voice' if ($_ eq 'v'); - $txt = 'ops' if ($_ eq 'o'); + $txt = 'total' if ( $_ eq '' ); + $txt = 'voice' if ( $_ eq 'v' ); + $txt = 'ops' if ( $_ eq 'o' ); - push(@array, "$count $txt"); + push( @array, "$count $txt" ); } - my $chanstats = join(' || ', @array); + my $chanstats = join( ' || ', @array ); &status("$b_blue$chan$ob: [$chanstats]"); &chanServCheck($chan); - # schedule used to solve ircu (OPN) "target too fast" problems. - $conn->schedule(5, sub { &joinNextChan(); } ); + + # schedule used to solve ircu (OPN) 'target too fast' problems. + $conn->schedule( 5, sub { &joinNextChan(); } ); } sub on_init { $conn = shift(@_); my ($event) = @_; - my (@args) = ($event->args); + my (@args) = ( $event->args ); shift @args; &status("@args"); @@ -448,155 +484,165 @@ sub on_init { sub on_invite { $conn = shift(@_); my ($event) = @_; - my $chan = lc( ($event->args)[0] ); + my $chan = lc( ( $event->args )[0] ); my $nick = $event->nick; - if ($nick =~ /^\Q$ident\E$/) { - &DEBUG("on_invite: self invite."); - return; + if ( $nick =~ /^\Q$ident\E$/ ) { + &DEBUG('on_invite: self invite.'); + return; } ### TODO: join key. - if (exists $chanconf{$chan}) { - # it's still buggy :/ - if (&validChan($chan)) { - &msg($who, "i'm already in \002$chan\002."); -# return; - } + if ( exists $chanconf{$chan} ) { - &status("invited to $b_blue$chan$ob by $b_cyan$nick$ob"); - &joinchan($chan); + # it's still buggy :/ + if ( &validChan($chan) ) { + &msg( $who, "i'm already in \002$chan\002." ); + + # return; + } + + &status("invited to $b_blue$chan$ob by $b_cyan$nick$ob"); + &joinchan($chan); } } sub on_join { $conn = shift(@_); - my ($event) = @_; - my ($user,$host) = split(/\@/, $event->userhost); - $chan = lc( ($event->to)[0] ); # CASING!!!! - $who = $event->nick(); - $msgType = 'public'; - my $i = scalar(keys %{ $channels{$chan} }); - my $j = $cache{maxpeeps}{$chan} || 0; + my ($event) = @_; + my ( $user, $host ) = split( /\@/, $event->userhost ); + $chan = lc( ( $event->to )[0] ); # CASING!!!! + $who = $event->nick(); + $msgType = 'public'; + my $i = scalar( keys %{ $channels{$chan} } ); + my $j = $cache{maxpeeps}{$chan} || 0; - if (!&IsParam('noSHM') && time() > ($sched{shmFlush}{TIME} || time()) + 3600) { - &DEBUG("looks like schedulers died somewhere... restarting..."); - &setupSchedulers(); + if ( !&IsParam('noSHM') + && time() > ( $sched{shmFlush}{TIME} || time() ) + 3600 ) + { + &DEBUG('looks like schedulers died somewhere... restarting...'); + &setupSchedulers(); } $chanstats{$chan}{'Join'}++; - $userstats{lc $who}{'Join'} = time() if (&IsChanConf('seenStats') > 0); - $cache{maxpeeps}{$chan} = $i if ($i > $j); + $userstats{ lc $who }{'Join'} = time() if ( &IsChanConf('seenStats') > 0 ); + $cache{maxpeeps}{$chan} = $i if ( $i > $j ); - &joinfloodCheck($who, $chan, $event->userhost); + &joinfloodCheck( $who, $chan, $event->userhost ); # netjoin detection. my $netsplit = 0; - if (exists $netsplit{lc $who}) { - delete $netsplit{lc $who}; - $netsplit = 1; + if ( exists $netsplit{ lc $who } ) { + delete $netsplit{ lc $who }; + $netsplit = 1; - if (!scalar keys %netsplit) { - &DEBUG("on_join: netsplit hash is now empty!"); - undef %netsplitservers; - &netsplitCheck(); # any point in running this? - &chanlimitCheck(); - } + if ( !scalar keys %netsplit ) { + &DEBUG('on_join: netsplit hash is now empty!'); + undef %netsplitservers; + &netsplitCheck(); # any point in running this? + &chanlimitCheck(); + } } - if ($netsplit and !exists $cache{netsplit}) { - &VERB("on_join: ok.... re-running chanlimitCheck in 60.",2); - $conn->schedule(60, sub { - &chanlimitCheck(); - delete $cache{netsplit}; - } ); + if ( $netsplit and !exists $cache{netsplit} ) { + &VERB('on_join: ok.... re-running chanlimitCheck in 60.', 2); + $conn->schedule( + 60, + sub { + &chanlimitCheck(); + delete $cache{netsplit}; + } + ); - $cache{netsplit} = time(); + $cache{netsplit} = time(); } # how to tell if there's a netjoin??? my $netsplitstr = ''; - $netsplitstr = " $b_yellow\[${ob}NETSPLIT VICTIM$b_yellow]$ob" if ($netsplit); - &status(">>> join/$b_blue$chan$ob $b_cyan$who$ob $b_yellow($ob$user\@$host$b_yellow)$ob$netsplitstr"); + $netsplitstr = " $b_yellow\[${ob}NETSPLIT VICTIM$b_yellow]$ob" + if ($netsplit); + &status( +">>> join/$b_blue$chan$ob $b_cyan$who$ob $b_yellow($ob$user\@$host$b_yellow)$ob$netsplitstr" + ); $channels{$chan}{''}{$who}++; - $nuh = $who."!".$user."\@".$host; - $nuh{lc $who} = $nuh unless (exists $nuh{lc $who}); + $nuh = $who . '!' . $user . '@' . $host; + $nuh{ lc $who } = $nuh unless ( exists $nuh{ lc $who } ); ### on-join bans. my @bans; - push(@bans, keys %{ $bans{$chan} }) if (exists $bans{$chan}); - push(@bans, keys %{ $bans{'*'} }) if (exists $bans{'*'}); + push( @bans, keys %{ $bans{$chan} } ) if ( exists $bans{$chan} ); + push( @bans, keys %{ $bans{'*'} } ) if ( exists $bans{'*'} ); foreach (@bans) { - my $ban = $_; - s/\?/./g; - s/\*/\\S*/g; - my $mask = $_; - next unless ($nuh =~ /^$mask$/i); + my $ban = $_; + s/\?/./g; + s/\*/\\S*/g; + my $mask = $_; + next unless ( $nuh =~ /^$mask$/i ); - ### TODO: check $channels{$chan}{'b'} if ban already exists. - foreach (keys %{ $channels{$chan}{'b'} }) { - &DEBUG(" bans_on_chan($chan) => $_"); - } + ### TODO: check $channels{$chan}{'b'} if ban already exists. + foreach ( keys %{ $channels{$chan}{'b'} } ) { + &DEBUG(" bans_on_chan($chan) => $_"); + } - my $reason = "no reason"; - foreach ($chan, '*') { - next unless (exists $bans{$_}); - next unless (exists $bans{$_}{$ban}); + my $reason = 'no reason'; + foreach ( $chan, '*' ) { + next unless ( exists $bans{$_} ); + next unless ( exists $bans{$_}{$ban} ); - my @array = @{ $bans{$_}{$ban} }; + my @array = @{ $bans{$_}{$ban} }; - $reason = $array[4] if ($array[4]); - last; - } + $reason = $array[4] if ( $array[4] ); + last; + } - &ban($ban, $chan); - &kick($who, $chan, $reason); + &ban( $ban, $chan ); + &kick( $who, $chan, $reason ); - last; + last; } # no need to go further. return if ($netsplit); # who == bot. - if ($who =~ /^\Q$ident\E$/i) { - if (defined( my $whojoin = $cache{join}{$chan} )) { - &msg($chan, "Okay, I'm here. (courtesy of $whojoin)"); - delete $cache{join}{$chan}; - &joinNextChan(); # hack. - } + if ( $who =~ /^\Q$ident\E$/i ) { + if ( defined( my $whojoin = $cache{join}{$chan} ) ) { + &msg( $chan, "Okay, I'm here. (courtesy of $whojoin)" ); + delete $cache{join}{$chan}; + &joinNextChan(); # hack. + } - ### TODO: move this to &joinchan()? - $cache{jointime}{$chan} = &timeget(); - $conn->who($chan); + ### TODO: move this to &joinchan()? + $cache{jointime}{$chan} = &timeget(); + $conn->who($chan); - return; + return; } ### ROOTWARN: - &rootWarn($who,$user,$host,$chan) if ( - &IsChanConf('RootWarn') > 0 && - $user =~ /^~?r(oo|ew|00)t$/i - ); + &rootWarn( $who, $user, $host, $chan ) + if ( &IsChanConf('RootWarn') > 0 + && $user =~ /^~?r(oo|ew|00)t$/i ); ### emit a message based on who just joined - &onjoin($who,$user,$host,$chan) if (&IsChanConf('OnJoin') > 0); + &onjoin( $who, $user, $host, $chan ) if ( &IsChanConf('OnJoin') > 0 ); ### NEWS: - if (&IsChanConf('News') > 0 && &IsChanConf('newsKeepRead') > 0) { - if (!&loadMyModule('News')) { # just in case. - &DEBUG('could not load news.'); - } else { - &News::latest($chan); - } + if ( &IsChanConf('News') > 0 && &IsChanConf('newsKeepRead') > 0 ) { + if ( !&loadMyModule('News') ) { # just in case. + &DEBUG('could not load news.'); + } + else { + &News::latest($chan); + } } ### botmail: - if (&IsChanConf('botmail') > 0) { - &botmail::check(lc $who); + if ( &IsChanConf('botmail') > 0 ) { + &botmail::check( lc $who ); } ### wingate: @@ -606,136 +652,148 @@ sub on_join { sub on_kick { $conn = shift(@_); my ($event) = @_; - my ($chan,$reason) = $event->args; - my $kicker = $event->nick; - my $kickee = ($event->to)[0]; - my $uh = $event->userhost(); + my ( $chan, $reason ) = $event->args; + my $kicker = $event->nick; + my $kickee = ( $event->to )[0]; + my $uh = $event->userhost(); - &status(">>> kick/$b_blue$chan$ob [$b$kickee!$uh$ob] by $b_cyan$kicker$ob $b_yellow($ob$reason$b_yellow)$ob"); + &status( +">>> kick/$b_blue$chan$ob [$b$kickee!$uh$ob] by $b_cyan$kicker$ob $b_yellow($ob$reason$b_yellow)$ob" + ); - $chan = lc $chan; # forgot about this, found by xsdg, 20001229. + $chan = lc $chan; # forgot about this, found by xsdg, 20001229. $chanstats{$chan}{'Kick'}++; - if ($kickee eq $ident) { - &clearChanVars($chan); + if ( $kickee eq $ident ) { + &clearChanVars($chan); - &status("SELF attempting to rejoin lost channel $chan"); - &joinchan($chan); - } else { - &delUserInfo($kickee,$chan); + &status("SELF attempting to rejoin lost channel $chan"); + &joinchan($chan); + } + else { + &delUserInfo( $kickee, $chan ); } } sub on_mode { $conn = shift(@_); - my ($event) = @_; - my ($user, $host) = split(/\@/, $event->userhost); - my @args = $event->args(); - my $nick = $event->nick(); - $chan = ($event->to)[0]; + my ($event) = @_; + my ( $user, $host ) = split( /\@/, $event->userhost ); + my @args = $event->args(); + my $nick = $event->nick(); + $chan = ( $event->to )[0]; # last element is empty... so nuke it. - pop @args while ($args[$#args] eq ''); + pop @args while ( $args[$#args] eq '' ); - if ($nick eq $chan) { # UMODE - &status(">>> mode $b_yellow\[$ob$b@args$b_yellow\]$ob by $b_cyan$nick$ob"); - } else { # MODE - &status(">>> mode/$b_blue$chan$ob $b_yellow\[$ob$b@args$b_yellow\]$ob by $b_cyan$nick$ob"); - &hookMode($nick, @args); + if ( $nick eq $chan ) { # UMODE + &status( + ">>> mode $b_yellow\[$ob$b@args$b_yellow\]$ob by $b_cyan$nick$ob"); + } + else { # MODE + &status( +">>> mode/$b_blue$chan$ob $b_yellow\[$ob$b@args$b_yellow\]$ob by $b_cyan$nick$ob" + ); + &hookMode( $nick, @args ); } } sub on_modeis { $conn = shift(@_); my ($event) = @_; - my ($myself, undef,@args) = $event->args(); - my $nick = $event->nick(); - $chan = ($event->args())[1]; + my ( $myself, undef, @args ) = $event->args(); + my $nick = $event->nick(); + $chan = ( $event->args() )[1]; - &hookMode($nick, @args); + &hookMode( $nick, @args ); } sub on_msg { $conn = shift(@_); my ($event) = @_; - my $nick = $event->nick; - my $msg = ($event->args)[0]; - - ($user,$host) = split(/\@/, $event->userhost); - $uh = $event->userhost(); - $nuh = $nick."!".$uh; - $msgtime = time(); - $h = $host; - - if ($nick eq $ident) { # hopefully ourselves. - if ($msg eq 'TEST') { - &status("IRCTEST: Yes, we're alive."); - delete $cache{connect}; - return; - } - } - - &hookMsg('private', undef, $nick, $msg); - $who = ''; - $chan = ''; - $msgType = ''; + my $nick = $event->nick; + my $msg = ( $event->args )[0]; + + ( $user, $host ) = split( /\@/, $event->userhost ); + $uh = $event->userhost(); + $nuh = $nick . '!' . $uh; + $msgtime = time(); + $h = $host; + + if ( $nick eq $ident ) { # hopefully ourselves. + if ( $msg eq 'TEST' ) { + &status("IRCTEST: Yes, we're alive."); + delete $cache{connect}; + return; + } + } + + &hookMsg( 'private', undef, $nick, $msg ); + $who = ''; + $chan = ''; + $msgType = ''; } sub on_names { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; - my $chan = lc $args[2]; # CASING, the last of them! + my @args = $event->args; + my $chan = lc $args[2]; # CASING, the last of them! - foreach (split / /, @args[3..$#args]) { - $channels{$chan}{'o'}{$_}++ if s/\@//; - $channels{$chan}{'v'}{$_}++ if s/\+//; - $channels{$chan}{''}{$_}++; + foreach ( split / /, @args[ 3 .. $#args ] ) { + $channels{$chan}{'o'}{$_}++ if s/\@//; + $channels{$chan}{'v'}{$_}++ if s/\+//; + $channels{$chan}{''}{$_}++; } } sub on_nick { $conn = shift(@_); my ($event) = @_; - my $nick = $event->nick(); - my $newnick = ($event->args)[0]; + my $nick = $event->nick(); + my $newnick = ( $event->args )[0]; - if (exists $netsplit{lc $newnick}) { - &status("Netsplit: $newnick/$nick came back from netsplit and changed to original nick! removing from hash."); - delete $netsplit{lc $newnick}; - &netsplitCheck() if (time() != $sched{netsplitCheck}{TIME}); + if ( exists $netsplit{ lc $newnick } ) { + &status( +"Netsplit: $newnick/$nick came back from netsplit and changed to original nick! removing from hash." + ); + delete $netsplit{ lc $newnick }; + &netsplitCheck() if ( time() != $sched{netsplitCheck}{TIME} ); } - my ($chan,$mode); - foreach $chan (keys %channels) { - foreach $mode (keys %{ $channels{$chan} }) { - next unless (exists $channels{$chan}{$mode}{$nick}); + my ( $chan, $mode ); + foreach $chan ( keys %channels ) { + foreach $mode ( keys %{ $channels{$chan} } ) { + next unless ( exists $channels{$chan}{$mode}{$nick} ); - $channels{$chan}{$mode}{$newnick} = $channels{$chan}{$mode}{$nick}; - } + $channels{$chan}{$mode}{$newnick} = $channels{$chan}{$mode}{$nick}; + } } + # TODO: do %flood* aswell. - &delUserInfo($nick, keys %channels); - $nuh{lc $newnick} = $nuh{lc $nick}; - delete $nuh{lc $nick}; - - if ($nick eq $conn->nick()) { - &status(">>> I materialized into $b_green$newnick$ob from $nick"); - $ident = $newnick; - $conn->nick($newnick); - } else { - &status(">>> $b_cyan$nick$ob materializes into $b_green$newnick$ob"); - my $mynick=$conn->nick(); - if ($nick =~ /^\Q$mynick\E$/i) { - &getNickInUse(); - } + &delUserInfo( $nick, keys %channels ); + $nuh{ lc $newnick } = $nuh{ lc $nick }; + delete $nuh{ lc $nick }; + + if ( $nick eq $conn->nick() ) { + &status(">>> I materialized into $b_green$newnick$ob from $nick"); + $ident = $newnick; + $conn->nick($newnick); + } + else { + &status(">>> $b_cyan$nick$ob materializes into $b_green$newnick$ob"); + my $mynick = $conn->nick(); + if ( $nick =~ /^\Q$mynick\E$/i ) { + &getNickInUse(); + } } } sub on_nick_taken { $conn = shift(@_); - my $nick = $conn->nick(); + my $nick = $conn->nick(); + #my $newnick = $nick . int(rand 10); my $newnick = $nick . '_'; @@ -744,105 +802,114 @@ sub on_nick_taken { &status("nick taken ($nick); preparing nick change."); $conn->whois($nick); + #$conn->schedule(5, sub { - &status("nick taken; changing to temporary nick ($nick -> $newnick)."); - &nick($newnick); + &status("nick taken; changing to temporary nick ($nick -> $newnick)."); + &nick($newnick); + #} ); } sub on_notice { $conn = shift(@_); my ($event) = @_; - my $nick = $event->nick(); - my $chan = ($event->to)[0]; - my $args = ($event->args)[0]; - - if ($nick =~ /^NickServ$/i) { # nickserv. - &status("NickServ: <== '$args'"); - - my $check = 0; - $check++ if ($args =~ /^This nickname is registered/i); - $check++ if ($args =~ /nickname.*owned/i); - - if ($check) { - &status("nickserv told us to register; doing it."); - - if (&IsParam('nickServ_pass')) { - &status("NickServ: ==> Identifying."); - &rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}"); - return; - } else { - &status("We can't tell nickserv a passwd ;("); - } - } - - # password accepted. - if ($args =~ /^Password a/i) { - my $done = 0; - - foreach ( &ChanConfList('chanServ_ops') ) { - next unless &chanServCheck($_); - next if ($done); - &DEBUG("nickserv activated or restarted; doing chanserv check."); - $done++; - } - - $nickserv++; - } - - } elsif ($nick =~ /^ChanServ$/i) { # chanserv. - &status("ChanServ: <== '$args'."); - - } else { - if ($chan =~ /^$mask{chan}$/) { # channel notice. - &status("-$nick/$chan- $args"); - } else { - $server = $nick unless (defined $server); - &status("-$nick- $args"); # private or server notice. - } + my $nick = $event->nick(); + my $chan = ( $event->to )[0]; + my $args = ( $event->args )[0]; + + if ( $nick =~ /^NickServ$/i ) { # nickserv. + &status("NickServ: <== '$args'"); + + my $check = 0; + $check++ if ( $args =~ /^This nickname is registered/i ); + $check++ if ( $args =~ /nickname.*owned/i ); + + if ($check) { + &status('nickserv told us to register; doing it.'); + + if ( &IsParam('nickServ_pass') ) { + &status('NickServ: ==> Identifying.'); + &rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}"); + return; + } + else { + &status("We can't tell nickserv a passwd ;("); + } + } + + # password accepted. + if ( $args =~ /^Password a/i ) { + my $done = 0; + + foreach ( &ChanConfList('chanServ_ops') ) { + next unless &chanServCheck($_); + next if ($done); + &DEBUG( + 'nickserv activated or restarted; doing chanserv check.'); + $done++; + } + + $nickserv++; + } + + } + elsif ( $nick =~ /^ChanServ$/i ) { # chanserv. + &status("ChanServ: <== '$args'."); + + } + else { + if ( $chan =~ /^$mask{chan}$/ ) { # channel notice. + &status("-$nick/$chan- $args"); + } + else { + $server = $nick unless ( defined $server ); + &status("-$nick- $args"); # private or server notice. + } } } sub on_other { $conn = shift(@_); my ($event) = @_; - my $chan = ($event->to)[0]; - my $nick = $event->nick; + my $chan = ( $event->to )[0]; + my $nick = $event->nick; - &status("!!! other called."); + &status('!!! other called.'); &status("!!! $event->args"); } sub on_part { $conn = shift(@_); my ($event) = @_; - $chan = lc( ($event->to)[0] ); # CASING!!! - my $mynick = $conn->nick(); - my $nick = $event->nick; + $chan = lc( ( $event->to )[0] ); # CASING!!! + my $mynick = $conn->nick(); + my $nick = $event->nick; my $userhost = $event->userhost; - $who = $nick; - $msgType = 'public'; + $who = $nick; + $msgType = 'public'; - if (!exists $channels{$chan}) { - &DEBUG("on_part: found out $mynick is on $chan!"); - $channels{$chan} = 1; + if ( !exists $channels{$chan} ) { + &DEBUG("on_part: found out $mynick is on $chan!"); + $channels{$chan} = 1; } - if (exists $floodjoin{$chan}{$nick}{Time}) { - delete $floodjoin{$chan}{$nick}; + if ( exists $floodjoin{$chan}{$nick}{Time} ) { + delete $floodjoin{$chan}{$nick}; } $chanstats{$chan}{'Part'}++; - &delUserInfo($nick,$chan); - if ($nick eq $ident) { - &clearChanVars($chan); + &delUserInfo( $nick, $chan ); + if ( $nick eq $ident ) { + &clearChanVars($chan); } - if (!&IsNickInAnyChan($nick) and &IsChanConf('seenStats') > 0) { - delete $userstats{lc $nick}; + if ( !&IsNickInAnyChan($nick) and &IsChanConf('seenStats') > 0 ) { + delete $userstats{ lc $nick }; } - &status(">>> part/$b_blue$chan$ob $b_cyan$nick$ob $b_yellow($ob$userhost$b_yellow)$ob"); + &status( +">>> part/$b_blue$chan$ob $b_cyan$nick$ob $b_yellow($ob$userhost$b_yellow)$ob" + ); } sub on_ping { @@ -850,18 +917,19 @@ sub on_ping { my ($event) = @_; my $nick = $event->nick; - $conn->ctcp_reply($nick, join(' ', ($event->args))); - &status(">>> ${b_green}CTCP PING$ob request from $b_cyan$nick$ob received."); + $conn->ctcp_reply( $nick, join( ' ', ( $event->args ) ) ); + &status( + ">>> ${b_green}CTCP PING$ob request from $b_cyan$nick$ob received."); } sub on_ping_reply { $conn = shift(@_); my ($event) = @_; - my $nick = $event->nick; - my $t = ($event->args)[1]; - if (!defined $t) { - &WARN("on_ping_reply: t == undefined."); - return; + my $nick = $event->nick; + my $t = ( $event->args )[1]; + if ( !defined $t ) { + &WARN('on_ping_reply: t == undefined.'); + return; } my $lag = time() - $t; @@ -872,141 +940,159 @@ sub on_ping_reply { sub on_public { $conn = shift(@_); my ($event) = @_; - my $msg = ($event->args)[0]; - $chan = lc( ($event->to)[0] ); # CASING. - my $nick = $event->nick; - $who = $nick; - $uh = $event->userhost(); - $nuh = $nick."!".$uh; - $msgType = 'public'; + my $msg = ( $event->args )[0]; + $chan = lc( ( $event->to )[0] ); # CASING. + my $nick = $event->nick; + $who = $nick; + $uh = $event->userhost(); + $nuh = $nick . '!' . $uh; + $msgType = 'public'; + # TODO: move this out of hookMsg to here? - ($user,$host) = split(/\@/, $uh); - $h = $host; + ( $user, $host ) = split( /\@/, $uh ); + $h = $host; # rare case should this happen - catch it just in case. - if ($bot_pid != $$) { - &ERROR("run-away fork; exiting."); - &delForked($forker); + if ( $bot_pid != $$ ) { + &ERROR('run-away fork; exiting.'); + &delForked($forker); } - $msgtime = time(); - $lastWho{$chan} = $nick; + $msgtime = time(); + $lastWho{$chan} = $nick; ### TODO: use $nick or lc $nick? - if (&IsChanConf('seenStats') > 0) { - $userstats{lc $nick}{'Count'}++; - $userstats{lc $nick}{'Time'} = time(); + if ( &IsChanConf('seenStats') > 0 ) { + $userstats{ lc $nick }{'Count'}++; + $userstats{ lc $nick }{'Time'} = time(); } # cache it. - my $time = time(); - if (!$cache{ircTextCounters}) { - &DEBUG("caching ircTextCounters for first time."); - my @str = split(/\s+/, &getChanConf('ircTextCounters')); - for (@str) { $_ = quotemeta($_); } - $cache{ircTextCounters} = join('|', @str); + my $time = time(); + if ( !$cache{ircTextCounters} ) { + &DEBUG('caching ircTextCounters for first time.'); + my @str = split( /\s+/, &getChanConf('ircTextCounters') ); + for (@str) { $_ = quotemeta($_); } + $cache{ircTextCounters} = join( '|', @str ); } my $str = $cache{ircTextCounters}; - if ($str && $msg =~ /^($str)[\s!\.]?$/i) { - my $x = $1; - - &VERB("textcounters: $x matched for $who",2); - my $c = $chan || 'PRIVATE'; - - # better to do "counter=counter+1". - # but that will avoid time check. - my ($v,$t) = &sqlSelect('stats', "counter,time", { - nick => $who, - type => $x, - channel => $c, - } ); - $v++; - - # don't allow ppl to cheat the stats :-) - if ((defined $t && $time - $t > 60) or (!defined $t)) { - &sqlSet('stats', {'nick' => $who}, { - type => $x, - channel => $c, - time => $time, - counter => $v, - } ); - } - } - - &hookMsg('public', $chan, $nick, $msg); + if ( $str && $msg =~ /^($str)[\s!\.]?$/i ) { + my $x = $1; + + &VERB( "textcounters: $x matched for $who", 2 ); + my $c = $chan || 'PRIVATE'; + + # better to do 'counter=counter+1'. + # but that will avoid time check. + my ( $v, $t ) = &sqlSelect( + 'stats', + 'counter,time', + { + nick => $who, + type => $x, + channel => $c, + } + ); + $v++; + + # don't allow ppl to cheat the stats :-) + if ( ( defined $t && $time - $t > 60 ) or ( !defined $t ) ) { + &sqlSet( + 'stats', + { + 'nick' => $who, + 'type' => $x, + 'channel' => $c, + }, + { + time => $time, + counter => $v, + } + ); + } + } + + &hookMsg( 'public', $chan, $nick, $msg ); $chanstats{$chan}{'PublicMsg'}++; - $who = ''; - $chan = ''; - $msgType = ''; + $who = ''; + $chan = ''; + $msgType = ''; } sub on_quit { $conn = shift(@_); my ($event) = @_; - my $nick = $event->nick(); - my $reason = ($event->args)[0]; + my $nick = $event->nick(); + my $reason = ( $event->args )[0]; # hack for ICC. - $msgType = 'public'; - $who = $nick; + $msgType = 'public'; + $who = $nick; ### $chan = $reason; # no. - my $count = 0; - foreach (grep !/^_default$/, keys %channels) { - # fixes inconsistent chanstats bug #1. - if (!&IsNickInChan($nick,$_)) { - $count++; - next; - } - $chanstats{$_}{'SignOff'}++; - } + my $count = 0; + foreach ( grep !/^_default$/, keys %channels ) { - if ($count == scalar keys %channels) { - &DEBUG("on_quit: nick $nick was not found in any chan."); + # fixes inconsistent chanstats bug #1. + if ( !&IsNickInChan( $nick, $_ ) ) { + $count++; + next; + } + $chanstats{$_}{'SignOff'}++; } - # should fix chanstats inconsistencies bug #2. - if ($reason =~ /^($mask{host})\s($mask{host})$/) { # netsplit. - $reason = "NETSPLIT: $1 <=> $2"; - - # chanlimit code. - foreach $chan ( &getNickInChans($nick) ) { - next unless ( &IsChanConf('chanlimitcheck') > 0); - next unless ( exists $channels{$_}{'l'} ); - - &DEBUG("on_quit: netsplit detected on $_; disabling chan limit."); - $conn->mode($_, "-l"); - } - - $netsplit{lc $nick} = time(); - if (!exists $netsplitservers{$1}{$2}) { - &status("netsplit detected between $1 and $2 at [".scalar(gmtime)."]"); - $netsplitservers{$1}{$2} = time(); - } + if ( $count == scalar keys %channels ) { + &DEBUG("on_quit: nick $nick was not found in any chan."); } - my $chans = join(' ', &getNickInChans($nick) ); - &status(">>> $b_cyan$nick$ob has signed off IRC $b_red($ob$reason$b_red)$ob [$chans]"); + # should fix chanstats inconsistencies bug #2. + if ( $reason =~ /^($mask{host})\s($mask{host})$/ ) { # netsplit. + $reason = "NETSPLIT: $1 <=> $2"; + + # chanlimit code. + foreach $chan ( &getNickInChans($nick) ) { + next unless ( &IsChanConf('chanlimitcheck') > 0 ); + next unless ( exists $channels{$_}{'l'} ); + + &DEBUG("on_quit: netsplit detected on $_; disabling chan limit."); + $conn->mode( $_, '-l' ); + } + + $netsplit{ lc $nick } = time(); + if ( !exists $netsplitservers{$1}{$2} ) { + &status("netsplit detected between $1 and $2 at [" + . scalar(gmtime) + . ']' ); + $netsplitservers{$1}{$2} = time(); + } + } + + my $chans = join( ' ', &getNickInChans($nick) ); + &status( +">>> $b_cyan$nick$ob has signed off IRC $b_red($ob$reason$b_red)$ob [$chans]" + ); ### ### ok... lets clear out the cache ### - &delUserInfo($nick, keys %channels); - if (exists $nuh{lc $nick}) { - delete $nuh{lc $nick}; - } else { - # well.. it's good but weird that this has happened - lets just - # be quiet about it. - } - delete $userstats{lc $nick} if (&IsChanConf('seenStats') > 0); - delete $chanstats{lc $nick}; + &delUserInfo( $nick, keys %channels ); + if ( exists $nuh{ lc $nick } ) { + delete $nuh{ lc $nick }; + } + else { + + # well.. it's good but weird that this has happened - lets just + # be quiet about it. + } + delete $userstats{ lc $nick } if ( &IsChanConf('seenStats') > 0 ); + delete $chanstats{ lc $nick }; ### # if we have a temp nick, and whoever is camping on our main nick leaves # revert to main nick. Note that Net::IRC only knows our main nick - if ($nick eq $conn->nick()) { - &status("nickchange: own nick \"$nick\" became free; changing."); - &nick($mynick); + if ( $nick eq $conn->nick() ) { + &status("nickchange: own nick \"$nick\" became free; changing."); + &nick($mynick); } } @@ -1014,32 +1100,33 @@ sub on_targettoofast { $conn = shift(@_); my ($event) = @_; my $nick = $event->nick(); - my($me,$chan,$why) = $event->args(); + my ( $me, $chan, $why ) = $event->args(); ### TODO: incomplete. - if ($why =~ /.* wait (\d+) second/) { - my $sleep = $1; - my $max = 10; + if ( $why =~ /.* wait (\d+) second/ ) { + my $sleep = $1; + my $max = 10; - if ($sleep > $max) { - &status("targettoofast: going to sleep for $max ($sleep)..."); - $sleep = $max; - } else { - &status("targettoofast: going to sleep for $sleep"); - } + if ( $sleep > $max ) { + &status("targettoofast: going to sleep for $max ($sleep)..."); + $sleep = $max; + } + else { + &status("targettoofast: going to sleep for $sleep"); + } - my $delta = time() - ($cache{sleepTime} || 0); - if ($delta > $max+2) { - sleep $sleep; - $cache{sleepTime} = time(); - } + my $delta = time() - ( $cache{sleepTime} || 0 ); + if ( $delta > $max + 2 ) { + sleep $sleep; + $cache{sleepTime} = time(); + } - return; + return; } - if (!exists $cache{TargetTooFast}) { - &DEBUG("on_ttf: failed: $why"); - $cache{TargetTooFast}++; + if ( !exists $cache{TargetTooFast} ) { + &DEBUG("on_ttf: failed: $why"); + $cache{TargetTooFast}++; } } @@ -1047,46 +1134,48 @@ sub on_topic { $conn = shift(@_); my ($event) = @_; - if (scalar($event->args) == 1) { # change. - my $topic = ($event->args)[0]; - my $chan = ($event->to)[0]; - my $nick = $event->nick(); - - ### - # WARNING: - # race condition here. To fix, change '1' to '0'. - # This will keep track of topics set by bot only. - ### - # UPDATE: - # this may be fixed at a later date with topic queueing. - ### - - $topic{$chan}{'Current'} = $topic if (1); - $chanstats{$chan}{'Topic'}++; - - &status(">>> topic/$b_blue$chan$ob by $b_cyan$nick$ob -> $topic"); - } else { # join. - my ($nick, $chan, $topic) = $event->args; - if (&IsChanConf('Topic') > 0) { - $topic{$chan}{'Current'} = $topic; - &topicAddHistory($chan,$topic); - } - - $topic = &fixString($topic, 1); - &status(">>> topic/$b_blue$chan$ob is $topic"); + if ( scalar( $event->args ) == 1 ) { # change. + my $topic = ( $event->args )[0]; + my $chan = ( $event->to )[0]; + my $nick = $event->nick(); + + ### + # WARNING: + # race condition here. To fix, change '1' to '0'. + # This will keep track of topics set by bot only. + ### + # UPDATE: + # this may be fixed at a later date with topic queueing. + ### + + $topic{$chan}{'Current'} = $topic if (1); + $chanstats{$chan}{'Topic'}++; + + &status(">>> topic/$b_blue$chan$ob by $b_cyan$nick$ob -> $topic"); + } + else { # join. + my ( $nick, $chan, $topic ) = $event->args; + if ( &IsChanConf('Topic') > 0 ) { + $topic{$chan}{'Current'} = $topic; + &topicAddHistory( $chan, $topic ); + } + + $topic = &fixString( $topic, 1 ); + &status(">>> topic/$b_blue$chan$ob is $topic"); } } sub on_topicinfo { $conn = shift(@_); my ($event) = @_; - my ($myself,$chan,$setby,$time) = $event->args(); + my ( $myself, $chan, $setby, $time ) = $event->args(); my $timestr; - if (time() - $time > 60*60*24) { - $timestr = "at ". gmtime $time; - } else { - $timestr = &Time2String(time() - $time) ." ago"; + if ( time() - $time > 60 * 60 * 24 ) { + $timestr = 'at ' . gmtime $time; + } + else { + $timestr = &Time2String( time() - $time ) . ' ago'; } &status(">>> set by $b_cyan$setby$ob $timestr"); @@ -1095,66 +1184,81 @@ sub on_topicinfo { sub on_crversion { $conn = shift(@_); my ($event) = @_; - my $nick = $event->nick(); + my $nick = $event->nick(); my $ver; - if (scalar $event->args() != 1) { # old. - $ver = join ' ', $event->args(); - $ver =~ s/^VERSION //; - } else { # new. - $ver = ($event->args())[0]; + if ( scalar $event->args() != 1 ) { # old. + $ver = join ' ', $event->args(); + $ver =~ s/^VERSION //; + } + else { # new. + $ver = ( $event->args() )[0]; } - if (grep /^\Q$nick\E$/i, @vernick) { - &WARN("nick $nick found in vernick ($ver); skipping."); - return; + if ( grep /^\Q$nick\E$/i, @vernick ) { + &WARN("nick $nick found in vernick ($ver); skipping."); + return; } - push(@vernick, $nick); + push( @vernick, $nick ); - if ($ver =~ /bitchx/i) { - $ver{bitchx}{$nick} = $ver; + if ( $ver =~ /bitchx/i ) { + $ver{bitchx}{$nick} = $ver; - } elsif ($ver =~ /xc\!|xchat/i) { - $ver{xchat}{$nick} = $ver; + } + elsif ( $ver =~ /xc\!|xchat/i ) { + $ver{xchat}{$nick} = $ver; + + } + elsif ( $ver =~ /irssi/i ) { + $ver{irssi}{$nick} = $ver; - } elsif ($ver =~ /irssi/i) { - $ver{irssi}{$nick} = $ver; + } + elsif ( $ver =~ /epic|(Third Eye)/i ) { + $ver{epic}{$nick} = $ver; - } elsif ($ver =~ /epic|(Third Eye)/i) { - $ver{epic}{$nick} = $ver; + } + elsif ( $ver =~ /ircII|PhoEniX/i ) { + $ver{ircII}{$nick} = $ver; - } elsif ($ver =~ /ircII|PhoEniX/i) { - $ver{ircII}{$nick} = $ver; + } + elsif ( $ver =~ /mirc/i ) { - } elsif ($ver =~ /mirc/i) { -# &DEBUG("verstats: mirc: $nick => '$ver'."); - $ver{mirc}{$nick} = $ver; + # &DEBUG("verstats: mirc: $nick => '$ver'."); + $ver{mirc}{$nick} = $ver; -# ok... then we get to the lesser known/used clients. - } elsif ($ver =~ /ircle/i) { - $ver{ircle}{$nick} = $ver; + # ok... then we get to the lesser known/used clients. + } + elsif ( $ver =~ /ircle/i ) { + $ver{ircle}{$nick} = $ver; - } elsif ($ver =~ /chatzilla/i) { - $ver{chatzilla}{$nick} = $ver; + } + elsif ( $ver =~ /chatzilla/i ) { + $ver{chatzilla}{$nick} = $ver; - } elsif ($ver =~ /pirch/i) { - $ver{pirch}{$nick} = $ver; + } + elsif ( $ver =~ /pirch/i ) { + $ver{pirch}{$nick} = $ver; - } elsif ($ver =~ /sirc /i) { - $ver{sirc}{$nick} = $ver; + } + elsif ( $ver =~ /sirc /i ) { + $ver{sirc}{$nick} = $ver; - } elsif ($ver =~ /kvirc/i) { - $ver{kvirc}{$nick} = $ver; + } + elsif ( $ver =~ /kvirc/i ) { + $ver{kvirc}{$nick} = $ver; - } elsif ($ver =~ /eggdrop/i) { - $ver{eggdrop}{$nick} = $ver; + } + elsif ( $ver =~ /eggdrop/i ) { + $ver{eggdrop}{$nick} = $ver; - } elsif ($ver =~ /xircon/i) { - $ver{xircon}{$nick} = $ver; + } + elsif ( $ver =~ /xircon/i ) { + $ver{xircon}{$nick} = $ver; - } else { - &DEBUG("verstats: other: $nick => '$ver'."); - $ver{other}{$nick} = $ver; + } + else { + &DEBUG("verstats: other: $nick => '$ver'."); + $ver{other}{$nick} = $ver; } } @@ -1164,43 +1268,43 @@ sub on_version { my $nick = $event->nick; &status(">>> ${b_green}CTCP VERSION$ob request from $b_cyan$nick$ob"); - $conn->ctcp_reply($nick, "VERSION $bot_version"); + $conn->ctcp_reply( $nick, "VERSION $bot_version" ); } sub on_who { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; - my $str = $args[5]."!".$args[2]."\@".$args[3]; + my @args = $event->args; + my $str = $args[5] . '!' . $args[2] . '@' . $args[3]; - if ($cache{on_who_Hack}) { - $cache{nuhInfo}{lc $args[5]}{Nick} = $args[5]; - $cache{nuhInfo}{lc $args[5]}{User} = $args[2]; - $cache{nuhInfo}{lc $args[5]}{Host} = $args[3]; - $cache{nuhInfo}{lc $args[5]}{NUH} = "$args[5]!$args[2]\@$args[3]"; - return; + if ( $cache{on_who_Hack} ) { + $cache{nuhInfo}{ lc $args[5] }{Nick} = $args[5]; + $cache{nuhInfo}{ lc $args[5] }{User} = $args[2]; + $cache{nuhInfo}{ lc $args[5] }{Host} = $args[3]; + $cache{nuhInfo}{ lc $args[5] }{NUH} = "$args[5]!$args[2]\@$args[3]"; + return; } - if ($args[5] =~ /^nickserv$/i and !$nickserv) { - &DEBUG("ok... we did a who for nickserv."); - &rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}"); + if ( $args[5] =~ /^nickserv$/i and !$nickserv ) { + &DEBUG('ok... we did a who for nickserv.'); + &rawout("PRIVMSG NickServ :IDENTIFY $param{'nickServ_pass'}"); } - $nuh{lc $args[5]} = $args[5]."!".$args[2]."\@".$args[3]; + $nuh{ lc $args[5] } = $args[5] . '!' . $args[2] . '@' . $args[3]; } sub on_whois { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; + my @args = $event->args; - $nuh{lc $args[1]} = $args[1]."!".$args[2]."\@".$args[3]; + $nuh{ lc $args[1] } = $args[1] . '!' . $args[2] . '@' . $args[3]; } sub on_whoischannels { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; + my @args = $event->args; &DEBUG("on_whoischannels: @args"); } @@ -1208,7 +1312,7 @@ sub on_whoischannels { sub on_useronchannel { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; + my @args = $event->args; &DEBUG("on_useronchannel: @args"); &joinNextChan(); @@ -1221,7 +1325,7 @@ sub on_useronchannel { sub on_chanfull { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; + my @args = $event->args; &status(">>> chanfull/$b_blue$args[1]$ob"); @@ -1231,7 +1335,7 @@ sub on_chanfull { sub on_inviteonly { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; + my @args = $event->args; &status(">>> inviteonly/$b_cyan$args[1]$ob"); @@ -1241,10 +1345,12 @@ sub on_inviteonly { sub on_banned { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; - my $chan = $args[1]; + my @args = $event->args; + my $chan = $args[1]; - &status(">>> banned/$b_blue$chan$ob $b_cyan$args[0]$ob, removing autojoin for $chan"); + &status( +">>> banned/$b_blue$chan$ob $b_cyan$args[0]$ob, removing autojoin for $chan" + ); delete $chanconf{$chan}{autojoin}; &joinNextChan(); } @@ -1252,8 +1358,8 @@ sub on_banned { sub on_badchankey { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; - my $chan = $args[1]; + my @args = $event->args; + my $chan = $args[1]; &DEBUG("on_badchankey: args => @args, removing autojoin for $chan"); delete $chanconf{$chan}{autojoin}; @@ -1263,7 +1369,7 @@ sub on_badchankey { sub on_useronchan { $conn = shift(@_); my ($event) = @_; - my @args = $event->args; + my @args = $event->args; &DEBUG("on_useronchan: args => @args"); &joinNextChan(); diff --git a/src/IRC/Schedulers.pl b/src/IRC/Schedulers.pl index 18c649d..925ce1e 100644 --- a/src/IRC/Schedulers.pl +++ b/src/IRC/Schedulers.pl @@ -51,7 +51,7 @@ sub queueTask { } sub setupSchedulers { - &VERB("Starting schedulers...",2); + &VERB( 'Starting schedulers...', 2 ); # ONCE OFF. @@ -60,15 +60,16 @@ sub setupSchedulers { &randomQuote(2); &randomFactoid(2); &seenFlush(2); - &leakCheck(2); # mandatory + &leakCheck(2); # mandatory &seenFlushOld(2); - &miscCheck2(2); # mandatory + &miscCheck2(2); # mandatory &slashdotLoop(2); &plugLoop(2); &kernelLoop(2); &wingateWriteFile(2); - &factoidCheck(2); # takes a couple of seconds on a 486. defer it -# TODO: convert to new format... or nuke altogether. + &factoidCheck(2); # takes a couple of seconds on a 486. defer it + + # TODO: convert to new format... or nuke altogether. &newsFlush(2); &rssFeeds(2); @@ -76,22 +77,22 @@ sub setupSchedulers { &uptimeLoop(1); &logLoop(1); &chanlimitCheck(1); - &netsplitCheck(1); # mandatory - &floodLoop(1); # mandatory - &ignoreCheck(1); # mandatory - &miscCheck(1); # mandatory - &shmFlush(1); # mandatory + &netsplitCheck(1); # mandatory + &floodLoop(1); # mandatory + &ignoreCheck(1); # mandatory + &miscCheck(1); # mandatory + &shmFlush(1); # mandatory sleep 1; - &ircCheck(1); # mandatory + &ircCheck(1); # mandatory # TODO: squeeze this into a one-liner. -# my $count = map { exists $sched{$_}{TIME} } keys %sched; - my $count = 0; - foreach (keys %sched) { - my $time = $sched{$_}{TIME}; - next unless (defined $time and $time > time()); + # my $count = map { exists $sched{$_}{TIME} } keys %sched; + my $count = 0; + foreach ( keys %sched ) { + my $time = $sched{$_}{TIME}; + next unless ( defined $time and $time > time() ); - $count++; + $count++; } &status("Schedulers: $count will be running."); @@ -99,27 +100,36 @@ sub setupSchedulers { } sub ScheduleThis { - my ($interval, $codename, @args) = @_; - # Set to supllied value plus a random 0-60 seconds to avoid simultaneous runs - my $waittime = &getRandomInt("$interval-" . ($interval+&getRandomInt(60) ) ); + my ( $interval, $codename, @args ) = @_; - if (!defined $waittime) { - &WARN("interval == waittime == UNDEF for $codename."); - return; - } + # Set to supllied value plus a random 0-60 seconds to avoid simultaneous runs + my $waittime = + &getRandomInt( "$interval-" . ( $interval + &getRandomInt(60) ) ); - my $time = $sched{$codename}{TIME}; - if (defined $time and $time > time()) { - &WARN("Sched for $codename already exists in " . &Time2String(time() - $time) . "."); - return; + if ( !defined $waittime ) { + &WARN("interval == waittime == UNDEF for $codename."); + return; } - &DEBUG("Scheduling \&$codename() " . \&$codename . " for " . &Time2String($waittime),3); - - my $retval = $conn->schedule($waittime, \&$codename, @args); - $sched{$codename}{LABEL} = $retval; - $sched{$codename}{TIME} = time()+$waittime; - $sched{$codename}{LOOP} = 1; + my $time = $sched{$codename}{TIME}; + if ( defined $time and $time > time() ) { + &WARN( "Sched for $codename already exists in " + . &Time2String( time() - $time ) + . '.' ); + return; + } + + &DEBUG( + "Scheduling \&$codename() " + . \&$codename . ' for ' + . &Time2String($waittime), + 3 + ); + + my $retval = $conn->schedule( $waittime, \&$codename, @args ); + $sched{$codename}{LABEL} = $retval; + $sched{$codename}{TIME} = time() + $waittime; + $sched{$codename}{LOOP} = 1; } #### @@ -127,139 +137,145 @@ sub ScheduleThis { #### sub rssFeeds { - my $interval = $param{'rssFeedTime'} || 30; - if (@_) { - &ScheduleThis( $interval*60, 'rssFeeds' ); # minutes - return if ( $_[0] eq '2' ); # defer. - } - &Forker( - 'RSSFeeds', - sub { - my $line = &RSSFeeds::RSS(); - return unless ( defined $line ); - - } - ); + my $interval = $param{'rssFeedTime'} || 30; + if (@_) { + &ScheduleThis( $interval * 60, 'rssFeeds' ); # minutes + return if ( $_[0] eq '2' ); # defer. + } + &Forker( + 'RSSFeeds', + sub { + my $line = &RSSFeeds::RSS(); + return unless ( defined $line ); + + } + ); } sub randomQuote { - my $interval = &getChanConfDefault('randomQuoteInterval', 60, $chan); + my $interval = &getChanConfDefault( 'randomQuoteInterval', 60, $chan ); if (@_) { - &ScheduleThis($interval*60, 'randomQuote'); # every hour - return if ($_[0] eq '2'); # defer. + &ScheduleThis( $interval * 60, 'randomQuote' ); # every hour + return if ( $_[0] eq '2' ); # defer. } foreach ( &ChanConfList('randomQuote') ) { - next unless (&validChan($_)); + next unless ( &validChan($_) ); - my $line = &getRandomLineFromFile($bot_data_dir. "/infobot.randtext"); - if (!defined $line) { - &ERROR("random Quote: weird error?"); - return; - } + my $line = + &getRandomLineFromFile( $bot_data_dir . '/infobot.randtext' ); + if ( !defined $line ) { + &ERROR('random Quote: weird error?'); + return; + } - &status("sending random Quote to $_."); - &action($_, "Ponders: ".$line); + &status("sending random Quote to $_."); + &action( $_, 'Ponders: ' . $line ); } ### TODO: if there were no channels, don't reschedule until channel ### configuration is modified. } sub randomFactoid { - my ($key,$val); + my ( $key, $val ); my $error = 0; - my $interval = &getChanConfDefault('randomFactoidInterval', 60, $chan); + my $interval = &getChanConfDefault( 'randomFactoidInterval', 60, $chan ); if (@_) { - &ScheduleThis($interval*60, 'randomFactoid'); # minutes - return if ($_[0] eq '2'); # defer. + &ScheduleThis( $interval * 60, 'randomFactoid' ); # minutes + return if ( $_[0] eq '2' ); # defer. } foreach ( &ChanConfList('randomFactoid') ) { - next unless (&validChan($_)); + next unless ( &validChan($_) ); - &status("sending random Factoid to $_."); - while (1) { - ($key,$val) = &randKey('factoids',"factoid_key,factoid_value"); - &DEBUG("rF: $key, $val"); + &status("sending random Factoid to $_."); + while (1) { + ( $key, $val ) = + &randKey( 'factoids', 'factoid_key,factoid_value' ); + &DEBUG("rF: $key, $val"); ### $val =~ tr/^[A-Z]/[a-z]/; # blah is Good => blah is good. - last if ((defined $val) and ($val !~ /^ $param{'maxLogSize'}) { - my $date = sprintf("%04d%02d%02d", (gmtime)[5,4,3]); - $file{log} = $param{'logfile'} ."-". $date; - &status("cycling log file."); - - if ( -e $file{log}) { - my $i = 1; - my $newlog; - while () { - $newlog = $file{log}."-".$i; - last if (! -e $newlog); - $i++; - } - $file{log} = $newlog; - } - - &closeLog(); - CORE::system("/bin/mv '$param{'logfile'}' '$file{log}'"); - &compress($file{log}); - &openLog(); - &status("cycling log file."); + if ( -s $file{log} > $param{'maxLogSize'} ) { + my $date = sprintf( '%04d%02d%02d', (gmtime)[ 5, 4, 3 ] ); + $file{log} = $param{'logfile'} . '-' . $date; + &status('cycling log file.'); + + if ( -e $file{log} ) { + my $i = 1; + my $newlog; + while () { + $newlog = $file{log} . '-' . $i; + last if ( !-e $newlog ); + $i++; + } + $file{log} = $newlog; + } + + &closeLog(); + CORE::system("/bin/mv '$param{'logfile'}' '$file{log}'"); + &compress( $file{log} ); + &openLog(); + &status('cycling log file.'); } ### check if all the logs exceed size. - if (!opendir(LOGS, $bot_log_dir)) { - &WARN("logLoop: could not open dir '$bot_log_dir'"); - return; + if ( !opendir( LOGS, $bot_log_dir ) ) { + &WARN("logLoop: could not open dir '$bot_log_dir'"); + return; } - my $tsize = 0; - my (%age, %size); - while (defined($_ = readdir LOGS)) { - my $logfile = "$bot_log_dir/$_"; + my $tsize = 0; + my ( %age, %size ); + while ( defined( $_ = readdir LOGS ) ) { + my $logfile = "$bot_log_dir/$_"; - next unless ( -f $logfile); + next unless ( -f $logfile ); - my $size = -s $logfile; - my $age = (stat $logfile)[9]; - $age{$age} = $logfile; - $size{$logfile} = $size; - $tsize += $size; + my $size = -s $logfile; + my $age = ( stat $logfile )[9]; + $age{$age} = $logfile; + $size{$logfile} = $size; + $tsize += $size; } closedir LOGS; - my $delete = 0; - while ($tsize > $param{'maxLogSize'}) { - &status("LOG: current size > max ($tsize > $param{'maxLogSize'})"); - my $oldest = (sort {$a <=> $b} keys %age)[0]; - &status("LOG: unlinking $age{$oldest}."); - unlink $age{$oldest}; - $tsize -= $oldest; - $delete++; + my $delete = 0; + while ( $tsize > $param{'maxLogSize'} ) { + &status("LOG: current size > max ($tsize > $param{'maxLogSize'})"); + my $oldest = ( sort { $a <=> $b } keys %age )[0]; + &status("LOG: unlinking $age{$oldest}."); + unlink $age{$oldest}; + $tsize -= $oldest; + $delete++; } ### TODO: add how many b,kb,mb removed? @@ -268,518 +284,564 @@ sub logLoop { sub seenFlushOld { if (@_) { - &ScheduleThis(86400, 'seenFlushOld'); # 1 day - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 86400, 'seenFlushOld' ); # 1 day + return if ( $_[0] eq '2' ); # defer. } # is this global-only? - return unless (&IsChanConf('seen') > 0); - return unless (&IsChanConf('seenFlushInterval') > 0); + return unless ( &IsChanConf('seen') > 0 ); + return unless ( &IsChanConf('seenFlushInterval') > 0 ); # global setting. does not make sense for per-channel. - my $max_time = &getChanConfDefault('seenMaxDays', 30, $chan) *60*60*24; - my $delete = 0; - - if ($param{'DBType'} =~ /^(pgsql|mysql|sqlite(2)?)$/i) { - my $query; - - if ($param{'DBType'} =~ /^(mysql|sqlite(2)?)$/i) { - $query = "SELECT nick,time FROM seen GROUP BY nick HAVING ". - "UNIX_TIMESTAMP() - time > $max_time"; - } else { # pgsql. - $query = "SELECT nick,time FROM seen WHERE ". - "extract(epoch from timestamp 'now') - time > $max_time"; - } - - my $sth = $dbh->prepare($query); - if ($sth->execute) { - while (my @row = $sth->fetchrow_array) { - my ($nick,$time) = @row; - - &sqlDelete('seen', { nick => $nick } ); - $delete++; - } - $sth->finish; - } - } else { - &FIXME("seenFlushOld: for bad DBType:" . $param{'DBType'} . "."); - } - &VERB("SEEN deleted $delete seen entries.",2); + my $max_time = + &getChanConfDefault( 'seenMaxDays', 30, $chan ) * 60 * 60 * 24; + my $delete = 0; + + if ( $param{'DBType'} =~ /^(pgsql|mysql|sqlite(2)?)$/i ) { + my $query; + + if ( $param{'DBType'} =~ /^mysql$/i ) { + $query = + 'SELECT nick,time FROM seen GROUP BY nick HAVING ' + . "UNIX_TIMESTAMP() - time > $max_time"; + } + elsif ( $param{'DBType'} =~ /^sqlite(2)?$/i ) { + $query = + 'SELECT nick,time FROM seen GROUP BY nick HAVING ' + . "strftime('%s','now','localtime') - time > $max_time"; + } + else { # pgsql. + $query = + 'SELECT nick,time FROM seen WHERE ' + . "extract(epoch from timestamp 'now') - time > $max_time"; + } + + my $sth = $dbh->prepare($query); + if ( $sth->execute ) { + while ( my @row = $sth->fetchrow_array ) { + my ( $nick, $time ) = @row; + + &sqlDelete( 'seen', { nick => $nick } ); + $delete++; + } + $sth->finish; + } + } + else { + &FIXME( 'seenFlushOld: for bad DBType:' . $param{'DBType'} . '.' ); + } + &VERB( "SEEN deleted $delete seen entries.", 2 ); } sub newsFlush { if (@_) { - &ScheduleThis(3600, 'newsFlush'); # 1 hour - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 3600, 'newsFlush' ); # 1 hour + return if ( $_[0] eq '2' ); # defer. } - if (!&ChanConfList('News')) { - &DEBUG("newsFlush: news disabled? (chan => $chan)"); - return; + if ( !&ChanConfList('News') ) { + &DEBUG("newsFlush: news disabled? (chan => $chan)"); + return; } - my $delete = 0; - my $oldest = time(); + my $delete = 0; + my $oldest = time(); my %none; - foreach $chan (keys %::news) { - my $i = 0; - my $total = scalar(keys %{ $::news{$chan} }); - - if (!$total) { - delete $::news{$chan}; - next; - } - - foreach $item (keys %{ $::news{$chan} }) { - my $t = $::news{$chan}{$item}{Expire}; - - my $tadd = $::news{$chan}{$item}{Time}; - $oldest = $tadd if ($oldest > $tadd); - - next if ($t == 0 or $t == -1); - if ($t < 1000) { - &status("newsFlush: Fixed Expire time for $chan/$item, should not happen anyway."); - $::news{$chan}{$item}{Expire} = time() + $t*60*60*24; - next; - } + foreach $chan ( keys %::news ) { + my $i = 0; + my $total = scalar( keys %{ $::news{$chan} } ); + + if ( !$total ) { + delete $::news{$chan}; + next; + } + + foreach $item ( keys %{ $::news{$chan} } ) { + my $t = $::news{$chan}{$item}{Expire}; + + my $tadd = $::news{$chan}{$item}{Time}; + $oldest = $tadd if ( $oldest > $tadd ); + + next if ( $t == 0 or $t == -1 ); + if ( $t < 1000 ) { + &status( +"newsFlush: Fixed Expire time for $chan/$item, should not happen anyway." + ); + $::news{$chan}{$item}{Expire} = time() + $t * 60 * 60 * 24; + next; + } - my $delta = $t - time(); + my $delta = $t - time(); - next unless (time() > $t); + next unless ( time() > $t ); - # TODO: show how old it was. - delete $::news{$chan}{$item}; - &status("NEWS: (newsflush) deleted '$item'"); - $delete++; - $i++; - } + # TODO: show how old it was. + delete $::news{$chan}{$item}; + &status("NEWS: (newsflush) deleted '$item'"); + $delete++; + $i++; + } - &status("NEWS (newsflush) {$chan}: deleted [$i/$total] news entries.") if ($i); - $none{$chan} = 1 if ($total == $i); + &status("NEWS (newsflush) {$chan}: deleted [$i/$total] news entries.") + if ($i); + $none{$chan} = 1 if ( $total == $i ); } # TODO: flush users aswell. - my $duser = 0; - foreach $chan (keys %::newsuser) { - next if (exists $none{$chan}); - - foreach (keys %{ $::newsuser{$chan} }) { - my $t = $::newsuser{$chan}{$_}; - if (!defined $t or ($t > 2 and $t < 1000)) { - &DEBUG("something wrong with newsuser{$chan}{$_} => $t"); - next; - } + my $duser = 0; + foreach $chan ( keys %::newsuser ) { + next if ( exists $none{$chan} ); + + foreach ( keys %{ $::newsuser{$chan} } ) { + my $t = $::newsuser{$chan}{$_}; + if ( !defined $t or ( $t > 2 and $t < 1000 ) ) { + &DEBUG("something wrong with newsuser{$chan}{$_} => $t"); + next; + } - next unless ($oldest > $t); + next unless ( $oldest > $t ); - delete $::newsuser{$chan}{$_}; - $duser++; - } + delete $::newsuser{$chan}{$_}; + $duser++; + } - my $i = scalar(keys %{ $::newsuser{$chan} }); - delete $::newsuser{$chan} unless ($i); + my $i = scalar( keys %{ $::newsuser{$chan} } ); + delete $::newsuser{$chan} unless ($i); } - if ($delete or $duser) { - &status("NewsFlush: deleted: $delete news entries; $duser user cache."); + if ( $delete or $duser ) { + &status("NewsFlush: deleted: $delete news entries; $duser user cache."); } } sub chanlimitCheck { - my $interval = &getChanConfDefault('chanlimitcheckInterval', 10, $chan); - my $mynick=$conn->nick(); + my $interval = &getChanConfDefault( 'chanlimitcheckInterval', 10, $chan ); + my $mynick = $conn->nick(); if (@_) { - &ScheduleThis($interval*60, 'chanlimitCheck'); # default 10 minutes - return if ($_[0] eq '2'); + &ScheduleThis( $interval * 60, 'chanlimitCheck' ); # default 10 minutes + return if ( $_[0] eq '2' ); } - my $str = join(' ', &ChanConfList('chanlimitcheck') ); + my $str = join( ' ', &ChanConfList('chanlimitcheck') ); foreach $chan ( &ChanConfList('chanlimitcheck') ) { - next unless (&validChan($chan)); - - if ($chan eq '_default') { - &WARN("chanlimit: we're doing $chan!! HELP ME!"); - next; - } - - my $limitplus = &getChanConfDefault('chanlimitcheckPlus', 5, $chan); - my $newlimit = scalar(keys %{ $channels{$chan}{''} }) + $limitplus; - my $limit = $channels{$chan}{'l'}; - - if (scalar keys %netsplitservers) { - if (defined $limit) { - &status("chanlimit: netsplit; removing it for $chan."); - $conn->mode($chan, "-l"); - $cache{chanlimitChange}{$chan} = time(); - &status("chanlimit: netsplit; removed."); - } - - next; - } - - if (defined $limit and scalar keys %{ $channels{$chan}{''} } > $limit) { - &FIXME("LIMIT: set too low!!!"); - ### run NAMES again and flush it. - } - - if (defined $limit and $limit == $newlimit) { - $cache{chanlimitChange}{$chan} = time(); - next; - } - - if (!exists $channels{$chan}{'o'}{$mynick}) { - &status("chanlimit: dont have ops on $chan.") unless (exists $cache{warn}{chanlimit}{$chan}); - $cache{warn}{chanlimit}{$chan} = 1; - &chanServCheck($chan); - next; - } - delete $cache{warn}{chanlimit}{$chan}; - - if (!defined $limit) { - &status("chanlimit: $chan: setting for first time or from netsplit."); - } - - if (exists $cache{chanlimitChange}{$chan}) { - my $delta = time() - $cache{chanlimitChange}{$chan}; - if ($delta < $interval*60) { - &DEBUG("chanlimit: not going to change chanlimit! ($delta<$interval*60)"); - return; - } - } - - $conn->mode($chan, "+l", $newlimit); - $cache{chanlimitChange}{$chan} = time(); + next unless ( &validChan($chan) ); + + if ( $chan eq '_default' ) { + &WARN("chanlimit: we're doing $chan!! HELP ME!"); + next; + } + + my $limitplus = &getChanConfDefault( 'chanlimitcheckPlus', 5, $chan ); + my $newlimit = scalar( keys %{ $channels{$chan}{''} } ) + $limitplus; + my $limit = $channels{$chan}{'l'}; + + if ( scalar keys %netsplitservers ) { + if ( defined $limit ) { + &status("chanlimit: netsplit; removing it for $chan."); + $conn->mode( $chan, '-l' ); + $cache{chanlimitChange}{$chan} = time(); + &status('chanlimit: netsplit; removed.'); + } + + next; + } + + if ( defined $limit and scalar keys %{ $channels{$chan}{''} } > $limit ) + { + &FIXME('LIMIT: set too low!!!'); + ### run NAMES again and flush it. + } + + if ( defined $limit and $limit == $newlimit ) { + $cache{chanlimitChange}{$chan} = time(); + next; + } + + if ( !exists $channels{$chan}{'o'}{$mynick} ) { + &status("chanlimit: dont have ops on $chan.") + unless ( exists $cache{warn}{chanlimit}{$chan} ); + $cache{warn}{chanlimit}{$chan} = 1; + &chanServCheck($chan); + next; + } + delete $cache{warn}{chanlimit}{$chan}; + + if ( !defined $limit ) { + &status( + "chanlimit: $chan: setting for first time or from netsplit."); + } + + if ( exists $cache{chanlimitChange}{$chan} ) { + my $delta = time() - $cache{chanlimitChange}{$chan}; + if ( $delta < $interval * 60 ) { + &DEBUG( +"chanlimit: not going to change chanlimit! ($delta<$interval*60)" + ); + return; + } + } + + $conn->mode( $chan, '+l', $newlimit ); + $cache{chanlimitChange}{$chan} = time(); } } sub netsplitCheck { - my ($s1,$s2); + my ( $s1, $s2 ); if (@_) { - &ScheduleThis(300, 'netsplitCheck'); # every 5 minutes - return if ($_[0] eq '2'); + &ScheduleThis( 300, 'netsplitCheck' ); # every 5 minutes + return if ( $_[0] eq '2' ); } $cache{'netsplitCache'}++; -# &DEBUG("running netsplitCheck... $cache{netsplitCache}"); - if (!scalar %netsplit and scalar %netsplitservers) { - &DEBUG("nsC: !hash netsplit but hash netsplitservers <- removing!"); - undef %netsplitservers; - return; + # &DEBUG("running netsplitCheck... $cache{netsplitCache}"); + + if ( !scalar %netsplit and scalar %netsplitservers ) { + &DEBUG('nsC: !hash netsplit but hash netsplitservers <- removing!'); + undef %netsplitservers; + return; } # well... this shouldn't happen since %netsplit code does it anyway. - foreach $s1 (keys %netsplitservers) { + foreach $s1 ( keys %netsplitservers ) { - foreach $s2 (keys %{ $netsplitservers{$s1} }) { - my $delta = time() - $netsplitservers{$s1}{$s2}; + foreach $s2 ( keys %{ $netsplitservers{$s1} } ) { + my $delta = time() - $netsplitservers{$s1}{$s2}; - if ($delta > 60*30) { - &status("netsplit between $s1 and $s2 appears to be stale."); - delete $netsplitservers{$s1}{$s2}; - &chanlimitCheck(); - } - } + if ( $delta > 60 * 30 ) { + &status("netsplit between $s1 and $s2 appears to be stale."); + delete $netsplitservers{$s1}{$s2}; + &chanlimitCheck(); + } + } - my $i = scalar(keys %{ $netsplitservers{$s1} }); - delete $netsplitservers{$s1} unless ($i); + my $i = scalar( keys %{ $netsplitservers{$s1} } ); + delete $netsplitservers{$s1} unless ($i); } # %netsplit hash checker. - my $count = scalar keys %netsplit; - my $delete = 0; - foreach (keys %netsplit) { - if (&IsNickInAnyChan($_)) { # why would this happen? -# &DEBUG("nsC: $_ is in some chan; removing from netsplit list."); - delete $netsplit{$_}; - $delete++; - next; - } + my $count = scalar keys %netsplit; + my $delete = 0; + foreach ( keys %netsplit ) { + if ( &IsNickInAnyChan($_) ) { # why would this happen? - next unless (time() - $netsplit{$_} > 60*15); + # &DEBUG("nsC: $_ is in some chan; removing from netsplit list."); + delete $netsplit{$_}; + $delete++; + next; + } - $delete++; - delete $netsplit{$_}; + next unless ( time() - $netsplit{$_} > 60 * 15 ); + + $delete++; + delete $netsplit{$_}; } - # yet another hack. - # FIXED: $ch should be used rather than $chan since it creates NULL channels in the hash - foreach my $ch (keys %channels) { - my $i = $cache{maxpeeps}{$ch} || 0; - my $j = scalar(keys %{ $channels{$ch} }); - next unless ($i > 10 and 0.25*$i > $j); +# yet another hack. +# FIXED: $ch should be used rather than $chan since it creates NULL channels in the hash + foreach my $ch ( keys %channels ) { + my $i = $cache{maxpeeps}{$ch} || 0; + my $j = scalar( keys %{ $channels{$ch} } ); + next unless ( $i > 10 and 0.25 * $i > $j ); - &DEBUG("netsplit: 0.25*max($i) > current($j); possible netsplit?"); + &DEBUG("netsplit: 0.25*max($i) > current($j); possible netsplit?"); } if ($delete) { - my $j = scalar(keys %netsplit); - &status("nsC: removed from netsplit list: (before: $count; after: $j)"); + my $j = scalar( keys %netsplit ); + &status("nsC: removed from netsplit list: (before: $count; after: $j)"); } - if (!scalar %netsplit and scalar %netsplitservers) { - &DEBUG("nsC: ok hash netsplit is NULL; purging hash netsplitservers"); - undef %netsplitservers; + if ( !scalar %netsplit and scalar %netsplitservers ) { + &DEBUG('nsC: ok hash netsplit is NULL; purging hash netsplitservers'); + undef %netsplitservers; } - if ($count and !scalar keys %netsplit) { - &DEBUG("nsC: netsplit is hopefully gone. reinstating chanlimit check."); - &chanlimitCheck(); + if ( $count and !scalar keys %netsplit ) { + &DEBUG('nsC: netsplit is hopefully gone. reinstating chanlimit check.'); + &chanlimitCheck(); } } sub floodLoop { - my $delete = 0; + my $delete = 0; my $who; if (@_) { - &ScheduleThis(60, 'floodLoop'); # 1 minute - return if ($_[0] eq '2'); + &ScheduleThis( 60, 'floodLoop' ); # 1 minute + return if ( $_[0] eq '2' ); } - my $time = time(); - my $interval = &getChanConfDefault('floodCycle',60, $chan); + my $time = time(); + my $interval = &getChanConfDefault( 'floodCycle', 60, $chan ); - foreach $who (keys %flood) { - foreach (keys %{ $flood{$who} }) { - if (!exists $flood{$who}{$_}) { - &WARN("flood{$who}{$_} undefined?"); - next; - } + foreach $who ( keys %flood ) { + foreach ( keys %{ $flood{$who} } ) { + if ( !exists $flood{$who}{$_} ) { + &WARN("flood{$who}{$_} undefined?"); + next; + } - if ($time - $flood{$who}{$_} > $interval) { - delete $flood{$who}{$_}; - $delete++; - } - } + if ( $time - $flood{$who}{$_} > $interval ) { + delete $flood{$who}{$_}; + $delete++; + } + } } - &VERB("floodLoop: deleted $delete items.",2); + &VERB( "floodLoop: deleted $delete items.", 2 ); } sub seenFlush { if (@_) { - my $interval = &getChanConfDefault('seenFlushInterval', 60, $chan); - &ScheduleThis($interval*60, 'seenFlush'); # minutes - return if ($_[0] eq '2'); + my $interval = &getChanConfDefault( 'seenFlushInterval', 60, $chan ); + &ScheduleThis( $interval * 60, 'seenFlush' ); # minutes + return if ( $_[0] eq '2' ); } my %stats; my $nick; my $flushed = 0; $stats{'count_old'} = &countKeys('seen') || 0; - $stats{'new'} = 0; - $stats{'old'} = 0; - - if ($param{'DBType'} =~ /^(mysql|pgsql|sqlite(2)?)$/i) { - foreach $nick (keys %seencache) { - my $retval = &sqlSet('seen', {'nick' => lc $seencache{$nick}{'nick'}}, { - time => $seencache{$nick}{'time'}, - host => $seencache{$nick}{'host'}, - channel => $seencache{$nick}{'chan'}, - message => $seencache{$nick}{'msg'}, - } ); - - delete $seencache{$nick}; - $flushed++; - } - } else { - &DEBUG("seenFlush: NO VALID FACTOID SUPPORT?"); - } - - &status("Seen: Flushed $flushed entries.") if ($flushed); - &VERB(sprintf(" new seen: %03.01f%% (%d/%d)", - $stats{'new'}*100/($stats{'count_old'} || 1), - $stats{'new'}, ( $stats{'count_old'} || 1) ), 2) if ($stats{'new'}); - &VERB(sprintf(" now seen: %3.1f%% (%d/%d)", - $stats{'old'}*100 / ( &countKeys('seen') || 1), - $stats{'old'}, &countKeys('seen') ), 2) if ($stats{'old'}); - - &WARN("scalar keys seenflush != 0!") if (scalar keys %seenflush); + $stats{'new'} = 0; + $stats{'old'} = 0; + + if ( $param{'DBType'} =~ /^(mysql|pgsql|sqlite(2)?)$/i ) { + foreach $nick ( keys %seencache ) { + my $retval = &sqlSet( + 'seen', + { 'nick' => lc $seencache{$nick}{'nick'} }, + { + time => $seencache{$nick}{'time'}, + host => $seencache{$nick}{'host'}, + channel => $seencache{$nick}{'chan'}, + message => $seencache{$nick}{'msg'}, + } + ); + + delete $seencache{$nick}; + $flushed++; + } + } + else { + &DEBUG('seenFlush: NO VALID FACTOID SUPPORT?'); + } + + &status("Seen: Flushed $flushed entries.") if ($flushed); + &VERB( + sprintf( + ' new seen: %03.01f%% (%d/%d)', + $stats{'new'} * 100 / ( $stats{'count_old'} || 1 ), + $stats{'new'}, + ( $stats{'count_old'} || 1 ) + ), + 2 + ) if ( $stats{'new'} ); + &VERB( + sprintf( + ' now seen: %3.1f%% (%d/%d)', + $stats{'old'} * 100 / ( &countKeys('seen') || 1 ), $stats{'old'}, + &countKeys('seen') + ), + 2 + ) if ( $stats{'old'} ); + + &WARN('scalar keys seenflush != 0!') if ( scalar keys %seenflush ); } sub leakCheck { - my ($blah1,$blah2); + my ( $blah1, $blah2 ); my $count = 0; if (@_) { - &ScheduleThis(14400, 'leakCheck'); # every 4 hours - return if ($_[0] eq '2'); + &ScheduleThis( 14400, 'leakCheck' ); # every 4 hours + return if ( $_[0] eq '2' ); } # flood. this is dealt with in floodLoop() - foreach $blah1 (keys %flood) { - foreach $blah2 (keys %{ $flood{$blah1} }) { - $count += scalar(keys %{ $flood{$blah1}{$blah2} }); - } + foreach $blah1 ( keys %flood ) { + foreach $blah2 ( keys %{ $flood{$blah1} } ) { + $count += scalar( keys %{ $flood{$blah1}{$blah2} } ); + } } - &VERB("leak: hash flood has $count total keys.",2); + &VERB( "leak: hash flood has $count total keys.", 2 ); # floodjoin. $count = 0; - foreach $blah1 (keys %floodjoin) { - foreach $blah2 (keys %{ $floodjoin{$blah1} }) { - $count += scalar(keys %{ $floodjoin{$blah1}{$blah2} }); - } + foreach $blah1 ( keys %floodjoin ) { + foreach $blah2 ( keys %{ $floodjoin{$blah1} } ) { + $count += scalar( keys %{ $floodjoin{$blah1}{$blah2} } ); + } } - &VERB("leak: hash floodjoin has $count total keys.",2); + &VERB( "leak: hash floodjoin has $count total keys.", 2 ); # floodwarn. - $count = scalar(keys %floodwarn); - &VERB("leak: hash floodwarn has $count total keys.",2); + $count = scalar( keys %floodwarn ); + &VERB( "leak: hash floodwarn has $count total keys.", 2 ); my $chan; - foreach $chan (grep /[A-Z]/, keys %channels) { - &DEBUG("leak: chan => '$chan'."); - my ($i,$j); - foreach $i (keys %{ $channels{$chan} }) { - foreach (keys %{ $channels{$chan}{$i} }) { - &DEBUG("leak: \$channels{$chan}{$i}{$_} ..."); - } - } + foreach $chan ( grep /[A-Z]/, keys %channels ) { + &DEBUG("leak: chan => '$chan'."); + my ( $i, $j ); + foreach $i ( keys %{ $channels{$chan} } ) { + foreach ( keys %{ $channels{$chan}{$i} } ) { + &DEBUG("leak: \$channels{$chan}{$i}{$_} ..."); + } + } } # chanstats - $count = scalar(keys %chanstats); - &VERB("leak: hash chanstats has $count total keys.",2); + $count = scalar( keys %chanstats ); + &VERB( "leak: hash chanstats has $count total keys.", 2 ); # nuh. - my $delete = 0; - foreach (keys %nuh) { - next if (&IsNickInAnyChan($_)); - next if (exists $dcc{CHAT}{$_}); + my $delete = 0; + foreach ( keys %nuh ) { + next if ( &IsNickInAnyChan($_) ); + next if ( exists $dcc{CHAT}{$_} ); - delete $nuh{$_}; - $delete++; + delete $nuh{$_}; + $delete++; } - &status("leak: $delete nuh{} items deleted; now have ". - scalar(keys %nuh) ) if ($delete); + &status( + "leak: $delete nuh{} items deleted; now have " . scalar( keys %nuh ) ) + if ($delete); } sub ignoreCheck { if (@_) { - &ScheduleThis(60, 'ignoreCheck'); # once every minute - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 60, 'ignoreCheck' ); # once every minute + return if ( $_[0] eq '2' ); # defer. } - my $time = time(); - my $count = 0; + my $time = time(); + my $count = 0; - foreach (keys %ignore) { - my $chan = $_; + foreach ( keys %ignore ) { + my $chan = $_; - foreach (keys %{ $ignore{$chan} }) { - my @array = @{ $ignore{$chan}{$_} }; + foreach ( keys %{ $ignore{$chan} } ) { + my @array = @{ $ignore{$chan}{$_} }; - next unless ($array[0] and $time > $array[0]); + next unless ( $array[0] and $time > $array[0] ); - delete $ignore{$chan}{$_}; - &status("ignore: $_/$chan has expired."); - $count++; - } + delete $ignore{$chan}{$_}; + &status("ignore: $_/$chan has expired."); + $count++; + } } $cache{ignoreCheckTime} = time(); - &VERB("ignore: $count items deleted.",2); + &VERB( "ignore: $count items deleted.", 2 ); } sub ircCheck { if (@_) { - &ScheduleThis(300, 'ircCheck'); # every 5 minutes - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 300, 'ircCheck' ); # every 5 minutes + return if ( $_[0] eq '2' ); # defer. } $cache{statusSafe} = 1; - foreach (sort keys %conns) { - $conn=$conns{$_}; - my $mynick=$conn->nick(); - &DEBUG("ircCheck for $_"); - my @join = &getJoinChans(900); # Display with min of 900sec delay between redisplay - if (scalar @join) { - &FIXME('ircCheck: found channels to join! ' . join(',',@join)); - &joinNextChan(); - } - - # TODO: fix on_disconnect() - - if (time() - $msgtime > 3600) { - # TODO: shouldn't we use cache{connect} somewhere? - if (exists $cache{connect}) { - &WARN("ircCheck: no msg for 3600 and disco'd! reconnecting!"); - $msgtime = time(); # just in case. - &ircloop(); - delete $cache{connect}; - } else { - &status('ircCheck: possible lost in space; checking.'. - scalar(gmtime) ); - &msg($mynick, 'TEST'); - $cache{connect} = time(); - } - } - } - - if (grep /^\s*$/, keys %channels) { - &WARN('ircCheck: we have a NULL chan in hash channels? removing!'); - if (!exists $channels{''}) { - &DEBUG('ircCheck: this should never happen!'); + foreach ( sort keys %conns ) { + $conn = $conns{$_}; + my $mynick = $conn->nick(); + &DEBUG("ircCheck for $_"); + my @join = + &getJoinChans(900) + ; # Display with min of 900sec delay between redisplay + if ( scalar @join ) { + &FIXME( 'ircCheck: found channels to join! ' . join( ',', @join ) ); + &joinNextChan(); + } + + # TODO: fix on_disconnect() + + if ( time() - $msgtime > 3600 ) { + + # TODO: shouldn't we use cache{connect} somewhere? + if ( exists $cache{connect} ) { + &WARN("ircCheck: no msg for 3600 and disco'd! reconnecting!"); + $msgtime = time(); # just in case. + &ircloop(); + delete $cache{connect}; + } + else { + &status( 'ircCheck: possible lost in space; checking.' + . scalar(gmtime) ); + &msg( $mynick, 'TEST' ); + $cache{connect} = time(); } - } - if ($ident !~ /^\Q$param{ircNick}\E$/) { - # this does not work unfortunately. - &WARN("ircCheck: ident($ident) != param{ircNick}($param{ircNick})."); + } + } + + if ( grep /^\s*$/, keys %channels ) { + &WARN('ircCheck: we have a NULL chan in hash channels? removing!'); + if ( !exists $channels{''} ) { + &DEBUG('ircCheck: this should never happen!'); + } + } + if ( $ident !~ /^\Q$param{ircNick}\E$/ ) { + + # this does not work unfortunately. + &WARN("ircCheck: ident($ident) != param{ircNick}($param{ircNick})."); - # this check is misleading... perhaps we should do a notify. - if (! &IsNickInAnyChan( $param{ircNick} ) ) { - &DEBUG("$param{ircNick} not in use... changing!"); - &nick( $param{ircNick} ); - } else { - &WARN("$param{ircNick} is still in use..."); - } + # this check is misleading... perhaps we should do a notify. + if ( !&IsNickInAnyChan( $param{ircNick} ) ) { + &DEBUG("$param{ircNick} not in use... changing!"); + &nick( $param{ircNick} ); + } + else { + &WARN("$param{ircNick} is still in use..."); + } } $cache{statusSafe} = 0; ### USER FILE. - if ($utime_userfile > $wtime_userfile and time() - $wtime_userfile > 3600) { - &writeUserFile(); - $wtime_userfile = time(); + if ( $utime_userfile > $wtime_userfile and time() - $wtime_userfile > 3600 ) + { + &writeUserFile(); + $wtime_userfile = time(); } ### CHAN FILE. - if ($utime_chanfile > $wtime_chanfile and time() - $wtime_chanfile > 3600) { - &writeChanFile(); - $wtime_chanfile = time(); + if ( $utime_chanfile > $wtime_chanfile and time() - $wtime_chanfile > 3600 ) + { + &writeChanFile(); + $wtime_chanfile = time(); } } sub miscCheck { if (@_) { - &ScheduleThis(7200, 'miscCheck'); # every 2 hours - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 7200, 'miscCheck' ); # every 2 hours + return if ( $_[0] eq '2' ); # defer. } # SHM check. my @ipcs; - if ( -x "/usr/bin/ipcs") { - @ipcs = `/usr/bin/ipcs`; - } else { - &WARN("ircCheck: no 'ipcs' binary."); - return; + if ( -x '/usr/bin/ipcs' ) { + @ipcs = `/usr/bin/ipcs`; + } + else { + &WARN("ircCheck: no 'ipcs' binary."); + return; } # make backup of important files. - &mkBackup( $bot_state_dir."/infobot.chan", 60*60*24*3); - &mkBackup( $bot_state_dir."/infobot.users", 60*60*24*3); - &mkBackup( $bot_base_dir."/infobot-news.txt", 60*60*24*1); + &mkBackup( $bot_state_dir . '/infobot.chan', 60 * 60 * 24 * 3 ); + &mkBackup( $bot_state_dir . '/infobot.users', 60 * 60 * 24 * 3 ); + &mkBackup( $bot_base_dir . '/infobot-news.txt', 60 * 60 * 24 * 1 ); # flush cache{lobotomy} - foreach (keys %{ $cache{lobotomy} }) { - next unless (time() - $cache{lobotomy}{$_} > 60*60); - delete $cache{lobotomy}{$_}; + foreach ( keys %{ $cache{lobotomy} } ) { + next unless ( time() - $cache{lobotomy}{$_} > 60 * 60 ); + delete $cache{lobotomy}{$_}; } ### check modules if they've been modified. might be evil. @@ -787,95 +849,100 @@ sub miscCheck { # shmid stale remove. foreach (@ipcs) { - chop; - - # key, shmid, owner, perms, bytes, nattch - next unless (/^(0x\d+) (\d+)\s+(\S+)\s+(\d+)\s+(\d+)\s+/); - - my ($shmid, $size) = ($2,$5); - next unless ($shmid != $shm and $size == 2000); - my $z = &shmRead($shmid); - if ($z =~ /^(\S+):(\d+):(\d+): /) { - my $n = $1; - my $pid = $2; - my $time = $3; - next if (time() - $time < 60*60); - # FIXME remove not-pid shm if parent process dead - next if ($pid == $bot_pid); - # don't touch other bots, if they're running. - next unless ($param{ircUser} =~ /^\Q$n\E$/); - } else { - &DEBUG("shm: $shmid is not ours or old infobot => ($z)"); - next; - } - - &status("SHM: nuking shmid $shmid"); - CORE::system("/usr/bin/ipcrm shm $shmid >/dev/null"); + chop; + + # key, shmid, owner, perms, bytes, nattch + next unless (/^(0x\d+) (\d+)\s+(\S+)\s+(\d+)\s+(\d+)\s+/); + + my ( $shmid, $size ) = ( $2, $5 ); + next unless ( $shmid != $shm and $size == 2000 ); + my $z = &shmRead($shmid); + if ( $z =~ /^(\S+):(\d+):(\d+): / ) { + my $n = $1; + my $pid = $2; + my $time = $3; + next if ( time() - $time < 60 * 60 ); + + # FIXME remove not-pid shm if parent process dead + next if ( $pid == $bot_pid ); + + # don't touch other bots, if they're running. + next unless ( $param{ircUser} =~ /^\Q$n\E$/ ); + } + else { + &DEBUG("shm: $shmid is not ours or old infobot => ($z)"); + next; + } + + &status("SHM: nuking shmid $shmid"); + CORE::system("/usr/bin/ipcrm shm $shmid >/dev/null"); } } sub miscCheck2 { if (@_) { - &ScheduleThis(14400, 'miscCheck2'); # every 4 hours - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 14400, 'miscCheck2' ); # every 4 hours + return if ( $_[0] eq '2' ); # defer. } # debian check. - opendir(DEBIAN, "$bot_state_dir/debian"); + opendir( DEBIAN, "$bot_state_dir/debian" ); foreach ( grep /gz$/, readdir(DEBIAN) ) { - my $exit = CORE::system("gzip -t $bot_state_dir/debian/$_"); - next unless ($exit); + my $exit = CORE::system("gzip -t $bot_state_dir/debian/$_"); + next unless ($exit); - &status("debian: unlinking file => $_"); - unlink "$bot_state_dir/debian/$_"; + &status("debian: unlinking file => $_"); + unlink "$bot_state_dir/debian/$_"; } closedir DEBIAN; # compress logs that should have been compressed. # TODO: use strftime? - my ($day,$month,$year) = (gmtime(time()))[3,4,5]; - my $date = sprintf("%04d%02d%02d",$year+1900,$month+1,$day); + my ( $day, $month, $year ) = ( gmtime( time() ) )[ 3, 4, 5 ]; + my $date = sprintf( '%04d%02d%02d', $year + 1900, $month + 1, $day ); - if (!opendir(DIR,"$bot_log_dir")) { - &ERROR("misccheck2: log dir $bot_log_dir does not exist."); - closedir DIR; - return -1; + if ( !opendir( DIR, "$bot_log_dir" ) ) { + &ERROR("misccheck2: log dir $bot_log_dir does not exist."); + closedir DIR; + return -1; } - while (my $f = readdir(DIR)) { - next unless ( -f "$bot_log_dir/$f"); - next if ($f =~ /gz|bz2/); - next unless ($f =~ /(\d{8})/); - next if ($date eq $1); + while ( my $f = readdir(DIR) ) { + next unless ( -f "$bot_log_dir/$f" ); + next if ( $f =~ /gz|bz2/ ); + next unless ( $f =~ /(\d{8})/ ); + next if ( $date eq $1 ); - &compress("$bot_log_dir/$f"); + &compress("$bot_log_dir/$f"); } closedir DIR; } ### this is semi-scheduled sub getNickInUse { -# FIXME: broken for multiple connects -# if ($ident eq $param{'ircNick'}) { -# &status("okay, got my nick back."); -# return; -# } -# -# if (@_) { -# &ScheduleThis(30, 'getNickInUse'); -# return if ($_[0] eq '2'); # defer. -# } -# -# &nick( $param{'ircNick'} ); + + # FIXME: broken for multiple connects + # if ($ident eq $param{'ircNick'}) { + # &status('okay, got my nick back.'); + # return; + # } + # + # if (@_) { + # &ScheduleThis(30, 'getNickInUse'); + # return if ($_[0] eq '2'); # defer. + # } + # + # &nick( $param{'ircNick'} ); } sub uptimeLoop { - return if (!defined &uptimeWriteFile); -# return unless &IsParam('Uptime'); + return if ( !defined &uptimeWriteFile ); + + # return unless &IsParam('Uptime'); if (@_) { - &ScheduleThis(3600, 'uptimeLoop'); # once per hour - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 3600, 'uptimeLoop' ); # once per hour + return if ( $_[0] eq '2' ); # defer. } &uptimeWriteFile(); @@ -884,204 +951,220 @@ sub uptimeLoop { sub slashdotLoop { if (@_) { - &ScheduleThis(3600, 'slashdotLoop'); # once per hour - return if ($_[0] eq '2'); + &ScheduleThis( 3600, 'slashdotLoop' ); # once per hour + return if ( $_[0] eq '2' ); } my @chans = &ChanConfList('slashdotAnnounce'); - return unless (scalar @chans); + return unless ( scalar @chans ); - &Forker('slashdot', sub { - my $line = &Slashdot::slashdotAnnounce(); - return unless (defined $line); + &Forker( + 'slashdot', + sub { + my $line = &Slashdot::slashdotAnnounce(); + return unless ( defined $line ); - foreach (@chans) { - next unless (&::validChan($_)); + foreach (@chans) { + next unless ( &::validChan($_) ); - &::status("sending slashdot update to $_."); - ¬ice($_, "Slashdot: $line"); - } - } ); + &::status("sending slashdot update to $_."); + ¬ice( $_, "Slashdot: $line" ); + } + } + ); } sub plugLoop { if (@_) { - &ScheduleThis(3600, 'plugLoop'); # once per hour - return if ($_[0] eq '2'); + &ScheduleThis( 3600, 'plugLoop' ); # once per hour + return if ( $_[0] eq '2' ); } my @chans = &ChanConfList('plugAnnounce'); - return unless (scalar @chans); + return unless ( scalar @chans ); - &Forker('Plug', sub { - my $line = &Plug::plugAnnounce(); - return unless (defined $line); + &Forker( + 'Plug', + sub { + my $line = &Plug::plugAnnounce(); + return unless ( defined $line ); - foreach (@chans) { - next unless (&::validChan($_)); + foreach (@chans) { + next unless ( &::validChan($_) ); - &::status("sending plug update to $_."); - ¬ice($_, "Plug: $line"); - } - } ); + &::status("sending plug update to $_."); + ¬ice( $_, "Plug: $line" ); + } + } + ); } sub kernelLoop { if (@_) { - &ScheduleThis(14400, 'kernelLoop'); # once every 4 hours - return if ($_[0] eq '2'); + &ScheduleThis( 14400, 'kernelLoop' ); # once every 4 hours + return if ( $_[0] eq '2' ); } my @chans = &ChanConfList('kernelAnnounce'); - return unless (scalar @chans); + return unless ( scalar @chans ); - &Forker('Kernel', sub { - my @data = &Kernel::kernelAnnounce(); + &Forker( + 'Kernel', + sub { + my @data = &Kernel::kernelAnnounce(); - foreach (@chans) { - next unless (&::validChan($_)); + foreach (@chans) { + next unless ( &::validChan($_) ); - &::status("sending kernel update to $_."); - my $c = $_; - foreach (@data) { - ¬ice($c, "Kernel: $_"); - } - } - } ); + &::status("sending kernel update to $_."); + my $c = $_; + foreach (@data) { + ¬ice( $c, "Kernel: $_" ); + } + } + } + ); } sub wingateCheck { return unless &IsChanConf('Wingate') > 0; ### FILE CACHE OF OFFENDING WINGATES. - foreach (grep /^$host$/, @wingateBad) { - &status("Wingate: RUNNING ON $host BY $who"); - &ban("*!*\@$host", '') if &IsChanConf('wingateBan') > 0; + foreach ( grep /^$host$/, @wingateBad ) { + &status("Wingate: RUNNING ON $host BY $who"); + &ban( "*!*\@$host", '' ) if &IsChanConf('wingateBan') > 0; - my $reason = &getChanConf('wingateKick'); + my $reason = &getChanConf('wingateKick'); - next unless ($reason); - &kick($who, '', $reason) + next unless ($reason); + &kick( $who, '', $reason ); } ### RUN CACHE OF TRIED WINGATES. - if (grep /^$host$/, @wingateCache) { - push(@wingateNow, $host); # per run. - push(@wingateCache, $host); # cache per run. - } else { - &DEBUG("Already scanned $host. good."); + if ( grep /^$host$/, @wingateCache ) { + push( @wingateNow, $host ); # per run. + push( @wingateCache, $host ); # cache per run. + } + else { + &DEBUG("Already scanned $host. good."); } - my $interval = &getChanConfDefault('wingateInterval', 60, $chan); # seconds. - return if (defined $forked{'Wingate'}); - return if (time() - $wingaterun <= $interval); - return unless (scalar(keys %wingateToDo)); + my $interval = + &getChanConfDefault( 'wingateInterval', 60, $chan ); # seconds. + return if ( defined $forked{'Wingate'} ); + return if ( time() - $wingaterun <= $interval ); + return unless ( scalar( keys %wingateToDo ) ); $wingaterun = time(); - &Forker('Wingate', sub { &Wingate::Wingates(keys %wingateToDo); } ); + &Forker( 'Wingate', sub { &Wingate::Wingates( keys %wingateToDo ); } ); undef @wingateNow; } ### TODO: ?? sub wingateWriteFile { if (@_) { - &ScheduleThis(3600, 'wingateWriteFile'); # once per hour - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 3600, 'wingateWriteFile' ); # once per hour + return if ( $_[0] eq '2' ); # defer. } - return unless (scalar @wingateCache); + return unless ( scalar @wingateCache ); my $file = "$bot_base_dir/$param{'ircUser'}.wingate"; - if ($bot_pid != $$) { - &DEBUG('wingateWriteFile: Reorganising!'); + if ( $bot_pid != $$ ) { + &DEBUG('wingateWriteFile: Reorganising!'); - open(IN, $file); - while () { - chop; - push(@wingateNow, $_); - } - close IN; + open( IN, $file ); + while () { + chop; + push( @wingateNow, $_ ); + } + close IN; - # very lame hack. - my %hash = map { $_ => 1 } @wingateNow; - @wingateNow = sort keys %hash; + # very lame hack. + my %hash = map { $_ => 1 } @wingateNow; + @wingateNow = sort keys %hash; } &DEBUG('wingateWF: writing...'); - open(OUT, ">$file"); + open( OUT, ">$file" ); foreach (@wingateNow) { - print OUT "$_\n"; + print OUT "$_\n"; } close OUT; } sub factoidCheck { if (@_) { - &ScheduleThis(43200, 'factoidCheck'); # ever 12 hours - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 43200, 'factoidCheck' ); # ever 12 hours + return if ( $_[0] eq '2' ); # defer. } - my @list = &searchTable('factoids', 'factoid_key', 'factoid_key', " #DEL#"); - my $stale = &getChanConfDefault('factoidDeleteDelay', 14, $chan) *60*60*24; - if ($stale < 1) { - # disable it since it's 'illegal'. - return; + my @list = + &searchTable( 'factoids', 'factoid_key', 'factoid_key', ' #DEL#' ); + my $stale = + &getChanConfDefault( 'factoidDeleteDelay', 14, $chan ) * 60 * 60 * 24; + if ( $stale < 1 ) { + + # disable it since it's 'illegal'. + return; } - my $time = time(); + my $time = time(); foreach (@list) { - my $age = &getFactInfo($_, 'modified_time'); - - if (!defined $age or $age !~ /^\d+$/) { - if (scalar @list > 50) { - if (!$cache{warnDel}) { - &WARN("list is over 50 (".scalar(@list)."... giving it a miss."); - $cache{warnDel} = 1; - last; - } - } + my $age = &getFactInfo( $_, 'modified_time' ); + + if ( !defined $age or $age !~ /^\d+$/ ) { + if ( scalar @list > 50 ) { + if ( !$cache{warnDel} ) { + &WARN( 'list is over 50 (' + . scalar(@list) + . '... giving it a miss.' ); + $cache{warnDel} = 1; + last; + } + } - &WARN("del factoid: old cruft (no time): $_"); - &delFactoid($_); - next; - } + &WARN("del factoid: old cruft (no time): $_"); + &delFactoid($_); + next; + } - next unless ($time - $age > $stale); + next unless ( $time - $age > $stale ); - my $fix = $_; - $fix =~ s/ #DEL#$//g; - my $agestr = &Time2String($time - $age); - &status("safedel: Removing '$_' for good. [$agestr old]"); + my $fix = $_; + $fix =~ s/ #DEL#$//g; + my $agestr = &Time2String( $time - $age ); + &status("safedel: Removing '$_' for good. [$agestr old]"); - &delFactoid($_); + &delFactoid($_); } } sub dccStatus { - return unless (scalar keys %{ $dcc{CHAT} }); + return unless ( scalar keys %{ $dcc{CHAT} } ); if (@_) { - &ScheduleThis(600, 'dccStatus'); # every 10 minutes - return if ($_[0] eq '2'); # defer. + &ScheduleThis( 600, 'dccStatus' ); # every 10 minutes + return if ( $_[0] eq '2' ); # defer. } - my $time = strftime("%H:%M", gmtime(time()) ); + my $time = strftime( '%H:%M', gmtime( time() ) ); my $c; - foreach (keys %channels) { - my $c = $_; - my $users = keys %{ $channels{$c}{''} }; - my $chops = keys %{ $channels{$c}{o} }; - my $bans = keys %{ $channels{$c}{b} }; - - my $txt = "[$time] $c: $users members ($chops chops), $bans bans"; - foreach (keys %{ $dcc{'CHAT'} }) { - next unless (exists $channels{$c}{''}{lc $_}); - $conn->privmsg($dcc{'CHAT'}{$_}, $txt); - } + foreach ( keys %channels ) { + my $c = $_; + my $users = keys %{ $channels{$c}{''} }; + my $chops = keys %{ $channels{$c}{o} }; + my $bans = keys %{ $channels{$c}{b} }; + + my $txt = "[$time] $c: $users members ($chops chops), $bans bans"; + foreach ( keys %{ $dcc{'CHAT'} } ) { + next unless ( exists $channels{$c}{''}{ lc $_ } ); + $conn->privmsg( $dcc{'CHAT'}{$_}, $txt ); + } } } @@ -1092,47 +1175,49 @@ sub scheduleList { # b - weird time. ### - my $reply = "sched:"; - foreach (keys %{ $irc->{_queue}}) { - my $q = $_; - my $coderef = $irc->{_queue}->{$q}->[1]; - my $sched; - foreach (keys %sched) { - my $schedname = $_; - next unless defined(\&$schedname); - next unless ($coderef eq \&$schedname); - $sched = $schedname; - last; - } - - my $time = $irc->{_queue}->{$q}->[0] - time(); - - if (defined $sched) { - $reply = "$reply, $sched($q):" . &Time2String($time); - } else { - $reply = "$reply, NULL($q):" . &Time2String($time); - } + my $reply = 'sched:'; + foreach ( keys %{ $irc->{_queue} } ) { + my $q = $_; + my $coderef = $irc->{_queue}->{$q}->[1]; + my $sched; + foreach ( keys %sched ) { + my $schedname = $_; + next unless defined( \&$schedname ); + next unless ( $coderef eq \&$schedname ); + $sched = $schedname; + last; + } + + my $time = $irc->{_queue}->{$q}->[0] - time(); + + if ( defined $sched ) { + $reply = "$reply, $sched($q):" . &Time2String($time); + } + else { + $reply = "$reply, NULL($q):" . &Time2String($time); + } } &DEBUG("$reply"); } sub mkBackup { - my($file, $time) = @_; - my $backup = 0; + my ( $file, $time ) = @_; + my $backup = 0; - if (! -f $file) { - &VERB("mkB: file '$file' does not exist.",2); - return; + if ( !-f $file ) { + &VERB( "mkB: file '$file' does not exist.", 2 ); + return; } - my $age = 'New'; + my $age = 'New'; if ( -e "$file~" ) { - $backup++ if ((stat $file)[9] - (stat "$file~")[9] > $time); - my $delta = time() - (stat "$file~")[9]; - $age = &Time2String($delta); - } else { - $backup++; + $backup++ if ( ( stat $file )[9] - ( stat "$file~" )[9] > $time ); + my $delta = time() - ( stat "$file~" )[9]; + $age = &Time2String($delta); + } + else { + $backup++; } return unless ($backup); diff --git a/src/Misc.pl b/src/Misc.pl index db0c523..e999a2f 100644 --- a/src/Misc.pl +++ b/src/Misc.pl @@ -9,71 +9,73 @@ use strict; use vars qw(%file %mask %param %cmdstats %myModules); use vars qw($msgType $who $bot_pid $nuh $shm $force_public_reply - $no_timehires $bot_data_dir $addrchar); + $no_timehires $bot_data_dir $addrchar); sub help { my $topic = shift; - my $file = $bot_data_dir."/infobot.help"; + my $file = $bot_data_dir . '/infobot.help'; my %help = (); # crude hack for performStrictReply() to work as expected. - $msgType = 'private' if ($msgType eq 'public'); + $msgType = 'private' if ( $msgType eq 'public' ); - if (!open(FILE, $file)) { - &ERROR("Failed reading help file ($file): $!"); - return; + if ( !open( FILE, $file ) ) { + &ERROR("Failed reading help file ($file): $!"); + return; } - while (defined(my $help = )) { - $help =~ s/^[\# ].*//; - chomp $help; - next unless $help; - my ($key, $val) = split(/:/, $help, 2); + while ( defined( my $help = ) ) { + $help =~ s/^[\# ].*//; + chomp $help; + next unless $help; + my ( $key, $val ) = split( /:/, $help, 2 ); - $val =~ s/^\s+//; - $val =~ s/^D:/\002 Desc\002:/; - $val =~ s/^E:/\002Example\002:/; - $val =~ s/^N:/\002 NOTE\002:/; - $val =~ s/^U:/\002 Usage\002:/; - $val =~ s/##/$key/; - $val =~ s/__/\037/g; - $val =~ s/==/ /; + $val =~ s/^\s+//; + $val =~ s/^D:/\002 Desc\002:/; + $val =~ s/^E:/\002Example\002:/; + $val =~ s/^N:/\002 NOTE\002:/; + $val =~ s/^U:/\002 Usage\002:/; + $val =~ s/##/$key/; + $val =~ s/__/\037/g; + $val =~ s/==/ /; - $help{$key} = '' if (!exists $help{$key}); - $help{$key} .= $val."\n"; + $help{$key} = '' if ( !exists $help{$key} ); + $help{$key} .= $val . "\n"; } close FILE; - if (!defined $topic or $topic eq '') { - &msg($who, $help{'main'}); + if ( !defined $topic or $topic eq '' ) { + &msg( $who, $help{'main'} ); - my $i = 0; - my @array; - my $count = scalar(keys %help); - my $reply; - foreach (sort keys %help) { - push(@array,$_); - $reply = scalar(@array) ." topics: ". - join("\002,\002 ", @array); - $i++; + my $i = 0; + my @array; + my $count = scalar( keys %help ); + my $reply; + foreach ( sort keys %help ) { + push( @array, $_ ); + $reply = + scalar(@array) . ' topics: ' . join( "\002,\002 ", @array ); + $i++; - if (length $reply > 400 or $count == $i) { - &msg($who,$reply); - undef @array; - } - } + if ( length $reply > 400 or $count == $i ) { + &msg( $who, $reply ); + undef @array; + } + } - return ''; + return ''; } - $topic = &fixString(lc $topic); + $topic = &fixString( lc $topic ); - if (exists $help{$topic}) { - foreach (split /\n/, $help{$topic}) { - &performStrictReply($_); - } - } else { - &performStrictReply("no help on $topic. Use 'help' without arguments."); + if ( exists $help{$topic} ) { + foreach ( split /\n/, $help{$topic} ) { + &performStrictReply($_); + } + } + else { + &performStrictReply( + "no help on $topic. Use 'help' without arguments."); } return ''; @@ -83,28 +85,31 @@ sub getPath { my ($pathnfile) = @_; ### TODO: gotta hate an if statement. - if ($pathnfile =~ /(.*)\/(.*?)$/) { - return $1; - } else { - return "."; + if ( $pathnfile =~ /(.*)\/(.*?)$/ ) { + return $1; + } + else { + return '.'; } } sub timeget { - if ($no_timehires) { # fallback. - return time(); - } else { # the real thing. - return [gettimeofday()]; + if ($no_timehires) { # fallback. + return time(); + } + else { # the real thing. + return [ gettimeofday() ]; } } sub timedelta { - my($start_time) = shift; + my ($start_time) = shift; - if ($no_timehires) { # fallback. - return time() - $start_time; - } else { # the real thing. - return tv_interval ($start_time); + if ($no_timehires) { # fallback. + return time() - $start_time; + } + else { # the real thing. + return tv_interval($start_time); } } @@ -115,47 +120,49 @@ sub timedelta { ### # Usage; &formListReply($rand, $prefix, @list); sub formListReply { - my($rand, $prefix, @list) = @_; - my $total = scalar @list; - my $maxshow = &getChanConfDefault('maxListReplyCount', 15, $chan); - my $maxlen = &getChanConfDefault('maxListReplyLength', 400, $chan); + my ( $rand, $prefix, @list ) = @_; + my $total = scalar @list; + my $maxshow = &getChanConfDefault( 'maxListReplyCount', 15, $chan ); + my $maxlen = &getChanConfDefault( 'maxListReplyLength', 400, $chan ); my $reply; # remove irc overhead $maxlen -= 30; # no results. - return $prefix ."returned no results." unless ($total); + return $prefix . 'returned no results.' unless ($total); # random. if ($rand) { - my @rand; - foreach (&makeRandom($total)) { - push(@rand, $list[$_]); - last if (scalar @rand == $maxshow); - } - if ($total > $maxshow) { - @list = sort @rand; - } else { - @list = @rand; - } - } elsif ($total > $maxshow) { - &status("formListReply: truncating list."); - - @list = @list[0..$maxshow-1]; + my @rand; + foreach ( &makeRandom($total) ) { + push( @rand, $list[$_] ); + last if ( scalar @rand == $maxshow ); + } + if ( $total > $maxshow ) { + @list = sort @rand; + } + else { + @list = @rand; + } + } + elsif ( $total > $maxshow ) { + &status('formListReply: truncating list.'); + + @list = @list[ 0 .. $maxshow - 1 ]; } # form the reply. # FIXME: should grow and exit when full, not discard any that are oversize while () { - $reply = $prefix ."(\002". scalar(@list). "\002"; - $reply .= " of \002$total\002" if ($total != scalar @list); - $reply .= "): " . join(" \002;;\002 ", @list) ."."; + $reply = $prefix . "(\002" . scalar(@list) . "\002"; + $reply .= " of \002$total\002" if ( $total != scalar @list ); + $reply .= '): ' . join( " \002;;\002 ", @list ) . '.'; - last if (length($reply) < $maxlen and scalar(@list) <= $maxshow); - last if (scalar(@list) == 1); + last if ( length($reply) < $maxlen and scalar(@list) <= $maxshow ); + last if ( scalar(@list) == 1 ); - pop @list; + pop @list; } return $reply; @@ -164,12 +171,14 @@ sub formListReply { ### Intelligence joining of arrays. # Usage: &IJoin(@array); sub IJoin { - if (!scalar @_) { - return 'NULL'; - } elsif (scalar @_ == 1) { - return $_[0]; - } else { - return join(', ',@{_}[0..$#_-1]) . " and $_[$#_]"; + if ( !scalar @_ ) { + return 'NULL'; + } + elsif ( scalar @_ == 1 ) { + return $_[0]; + } + else { + return join( ', ', @{_}[ 0 .. $#_ - 1 ] ) . " and $_[$#_]"; } } @@ -178,27 +187,27 @@ sub IJoin { sub Time2String { my ($time) = @_; my $prefix = ''; - my (@s, @t); + my ( @s, @t ); - return 'NULL' if (!defined $time); - return $time if ($time !~ /\d+/); + return 'NULL' if ( !defined $time ); + return $time if ( $time !~ /\d+/ ); - if ($time < 0) { - $time = - $time; - $prefix = "- "; + if ( $time < 0 ) { + $time = -$time; + $prefix = '- '; } $t[0] = int($time) % 60; - $t[1] = int($time / 60) % 60; - $t[2] = int($time / 3600) % 24; - $t[3] = int($time / 86400); + $t[1] = int( $time / 60 ) % 60; + $t[2] = int( $time / 3600 ) % 24; + $t[3] = int( $time / 86400 ); - push(@s, "$t[3]d") if ($t[3] != 0); - push(@s, "$t[2]h") if ($t[2] != 0); - push(@s, "$t[1]m") if ($t[1] != 0); - push(@s, "$t[0]s") if ($t[0] != 0 or !@s); + push( @s, "$t[3]d" ) if ( $t[3] != 0 ); + push( @s, "$t[2]h" ) if ( $t[2] != 0 ); + push( @s, "$t[1]m" ) if ( $t[1] != 0 ); + push( @s, "$t[0]s" ) if ( $t[0] != 0 or !@s ); - my $retval = $prefix.join(' ', @s); + my $retval = $prefix . join( ' ', @s ); $retval =~ s/(\d+)/\002$1\002/g; return $retval; } @@ -214,30 +223,31 @@ sub fixFileList { # generate a hash list. foreach (@files) { - next unless /^(.*\/)(.*?)$/; + next unless /^(.*\/)(.*?)$/; - $files{$1}{$2} = 1; + $files{$1}{$2} = 1; } - @files = (); # reuse the array. + @files = (); # reuse the array. # sort the hash list appropriately. - foreach (sort keys %files) { - my $file = $_; - my @keys = sort keys %{ $files{$file} }; - my $i = scalar(@keys); + foreach ( sort keys %files ) { + my $file = $_; + my @keys = sort keys %{ $files{$file} }; + my $i = scalar(@keys); - if (scalar @keys > 3) { - pop @keys while (scalar @keys > 3); - push(@keys, "..."); - } + if ( scalar @keys > 3 ) { + pop @keys while ( scalar @keys > 3 ); + push( @keys, '...' ); + } - if ($i > 1) { - $file .= "\002{\002". join("\002|\002", @keys) ."\002}\002"; - } else { - $file .= $keys[0]; - } + if ( $i > 1 ) { + $file .= "\002{\002" . join( "\002|\002", @keys ) . "\002}\002"; + } + else { + $file .= $keys[0]; + } - push(@files,$file); + push( @files, $file ); } return @files; @@ -245,21 +255,21 @@ sub fixFileList { # Usage: &fixString($str); sub fixString { - my ($str, $level) = @_; - if (!defined $str) { - &WARN("fixString: str == NULL."); - return ''; + my ( $str, $level ) = @_; + if ( !defined $str ) { + &WARN('fixString: str == NULL.'); + return ''; } for ($str) { - s/^\s+//; # remove start whitespaces. - s/\s+$//; # remove end whitespaces. - s/\s+/ /g; # remove excessive whitespaces. + s/^\s+//; # remove start whitespaces. + s/\s+$//; # remove end whitespaces. + s/\s+/ /g; # remove excessive whitespaces. - next unless (defined $level); - if (s/[\cA-\c_]//ig) { # remove control characters. - &DEBUG("stripped control chars"); - } + next unless ( defined $level ); + if (s/[\cA-\c_]//ig) { # remove control characters. + &DEBUG('stripped control chars'); + } } return $str; @@ -267,36 +277,42 @@ sub fixString { # Usage: &fixPlural($str,$int); sub fixPlural { - my ($str,$int) = @_; - - if (!defined $str) { - &WARN("fixPlural: str == NULL."); - return; - } - - if (!defined $int or $int =~ /^\D+$/) { - &WARN("fixPlural: int != defined or int"); - return $str; - } - - if ($str eq 'has') { - $str = 'have' if ($int > 1); - } elsif ($str eq 'is') { - $str = 'are' if ($int > 1); - } elsif ($str eq 'was') { - $str = 'were' if ($int > 1); - } elsif ($str eq 'this') { - $str = 'these' if ($int > 1); - } elsif ($str =~ /y$/) { - if ($int > 1) { - if ($str =~ /ey$/) { - $str .= 's'; # eg: 'money' => 'moneys'. - } else { - $str =~ s/y$/ies/; - } - } - } else { - $str .= 's' if ($int != 1); + my ( $str, $int ) = @_; + + if ( !defined $str ) { + &WARN('fixPlural: str == NULL.'); + return; + } + + if ( !defined $int or $int =~ /^\D+$/ ) { + &WARN('fixPlural: int != defined or int'); + return $str; + } + + if ( $str eq 'has' ) { + $str = 'have' if ( $int > 1 ); + } + elsif ( $str eq 'is' ) { + $str = 'are' if ( $int > 1 ); + } + elsif ( $str eq 'was' ) { + $str = 'were' if ( $int > 1 ); + } + elsif ( $str eq 'this' ) { + $str = 'these' if ( $int > 1 ); + } + elsif ( $str =~ /y$/ ) { + if ( $int > 1 ) { + if ( $str =~ /ey$/ ) { + $str .= 's'; # eg: 'money' => 'moneys'. + } + else { + $str =~ s/y$/ies/; + } + } + } + else { + $str .= 's' if ( $int != 1 ); } return $str; @@ -307,55 +323,56 @@ sub fixPlural { ### sub getRandomLineFromFile { - my($file) = @_; + my ($file) = @_; - if (!open(IN, $file)) { - &WARN("gRLfF: could not open ($file): $!"); - return; + if ( !open( IN, $file ) ) { + &WARN("gRLfF: could not open ($file): $!"); + return; } my @lines = ; close IN; - if (!scalar @lines) { - &ERROR("GRLF: nothing loaded?"); - return; + if ( !scalar @lines ) { + &ERROR('GRLF: nothing loaded?'); + return; } # could we use the filehandler instead and put it through getRandom? - while (my $line = &getRandom(@lines)) { - chop $line; + while ( my $line = &getRandom(@lines) ) { + chop $line; - next if ($line =~ /^\#/); - next if ($line =~ /^\s*$/); + next if ( $line =~ /^\#/ ); + next if ( $line =~ /^\s*$/ ); - return $line; + return $line; } } sub getLineFromFile { - my($file,$lineno) = @_; + my ( $file, $lineno ) = @_; - if (! -f $file) { - &ERROR("getLineFromFile: file '$file' does not exist."); - return 0; + if ( !-f $file ) { + &ERROR("getLineFromFile: file '$file' does not exist."); + return 0; } - if (open(IN,$file)) { - my @lines = ; - close IN; + if ( open( IN, $file ) ) { + my @lines = ; + close IN; - if ($lineno > scalar @lines) { - &ERROR("getLineFromFile: lineno exceeds line count from file."); - return 0; - } + if ( $lineno > scalar @lines ) { + &ERROR('getLineFromFile: lineno exceeds line count from file.'); + return 0; + } - my $line = $lines[$lineno-1]; - chop $line; - return $line; - } else { - &ERROR("gLFF: Could not open file ($file): $!"); - return 0; + my $line = $lines[ $lineno - 1 ]; + chop $line; + return $line; + } + else { + &ERROR("gLFF: Could not open file ($file): $!"); + return 0; } } @@ -364,31 +381,33 @@ sub getRandom { my @array = @_; srand(); - return $array[int(rand(scalar @array))]; + return $array[ int( rand( scalar @array ) ) ]; } -# Usage: &getRandomInt("30-60"); &getRandomInt(5); -# Desc : Returns a randomn integer between "X-Y" or 1 and the value passed +# Usage: &getRandomInt('30-60'); &getRandomInt(5); +# Desc : Returns a randomn integer between 'X-Y' or 1 and the value passed sub getRandomInt { - my $str = shift; - - if ( !defined $str ) { - &WARN("getRandomInt: str == NULL."); - return undef; - } - - if ( $str =~ /^(\d+(\.\d+)?)$/ ) { - return int( rand $str ) + 1; - } elsif ( $str =~ /^(\d+)-(\d+)$/ ) { - return $1 if $1 == $2; - my $min = $1 < $2 ? $1 : $2; # Swap is backwords - my $max = $2 > $1 ? $2 : $1; - return int( rand( $max - $min + 1 ) ) + $min; - } else { - - # &ERROR("getRandomInt: invalid arg '$str'."); - return undef; - } + my $str = shift; + + if ( !defined $str ) { + &WARN('getRandomInt: str == NULL.'); + return undef; + } + + if ( $str =~ /^(\d+(\.\d+)?)$/ ) { + return int( rand $str ) + 1; + } + elsif ( $str =~ /^(\d+)-(\d+)$/ ) { + return $1 if $1 == $2; + my $min = $1 < $2 ? $1 : $2; # Swap is backwords + my $max = $2 > $1 ? $2 : $1; + return int( rand( $max - $min + 1 ) ) + $min; + } + else { + + # &ERROR("getRandomInt: invalid arg '$str'."); + return undef; + } } ########## @@ -396,10 +415,10 @@ sub getRandomInt { ### sub iseq { - my ($left,$right) = @_; + my ( $left, $right ) = @_; return 0 unless defined $right; return 0 unless defined $left; - return 1 if ($left =~ /^\Q$right$/i); + return 1 if ( $left =~ /^\Q$right$/i ); } sub isne { @@ -411,33 +430,35 @@ sub isne { # Usage: &IsHostMatch($nuh); sub IsHostMatch { my ($thisnuh) = @_; - my (%this,%local); + my ( %this, %local ); - if ($nuh =~ /^(\S+)!(\S+)@(\S+)/) { - $local{'nick'} = lc $1; - $local{'user'} = lc $2; - $local{'host'} = &makeHostMask(lc $3); + if ( $nuh =~ /^(\S+)!(\S+)@(\S+)/ ) { + $local{'nick'} = lc $1; + $local{'user'} = lc $2; + $local{'host'} = &makeHostMask( lc $3 ); } - if (!defined $thisnuh) { - &WARN("IHM: thisnuh == NULL."); - return 0; - } elsif ($thisnuh =~ /^(\S+)!(\S+)@(\S+)/) { - $this{'nick'} = lc $1; - $this{'user'} = lc $2; - $this{'host'} = &makeHostMask(lc $3); - } else { - &WARN("IHM: thisnuh is invalid '$thisnuh'."); - return 1 if ($thisnuh eq ''); - return 0; + if ( !defined $thisnuh ) { + &WARN('IHM: thisnuh == NULL.'); + return 0; + } + elsif ( $thisnuh =~ /^(\S+)!(\S+)@(\S+)/ ) { + $this{'nick'} = lc $1; + $this{'user'} = lc $2; + $this{'host'} = &makeHostMask( lc $3 ); + } + else { + &WARN("IHM: thisnuh is invalid '$thisnuh'."); + return 1 if ( $thisnuh eq '' ); + return 0; } # auth if 1) user and host match 2) user and nick match. # this may change in the future. - if ($this{'user'} =~ /^\Q$local{'user'}\E$/i) { - return 2 if ($this{'host'} eq $local{'host'}); - return 1 if ($this{'nick'} eq $local{'nick'}); + if ( $this{'user'} =~ /^\Q$local{'user'}\E$/i ) { + return 2 if ( $this{'host'} eq $local{'host'} ); + return 1 if ( $this{'nick'} eq $local{'nick'} ); } return 0; } @@ -445,44 +466,45 @@ sub IsHostMatch { #### # Usage: &isStale($file, $age); sub isStale { - my ($file, $age) = @_; + my ( $file, $age ) = @_; - if (!defined $age) { - &WARN("isStale: age == NULL."); - return 1; + if ( !defined $age ) { + &WARN('isStale: age == NULL.'); + return 1; } - if (!defined $file) { - &WARN("isStale: file == NULL."); - return 1; + if ( !defined $file ) { + &WARN('isStale: file == NULL.'); + return 1; } - &DEBUG("!exist $file") if (! -f $file); + &DEBUG("!exist $file") if ( !-f $file ); - return 1 unless ( -f $file); - if ($file =~ /idx/) { - my $age2 = time() - (stat($file))[9]; - &VERB("stale: $age2. (". &Time2String($age2) .")",2); + return 1 unless ( -f $file ); + if ( $file =~ /idx/ ) { + my $age2 = time() - ( stat($file) )[9]; + &VERB( "stale: $age2. (" . &Time2String($age2) . ')', 2 ); } - $age *= 60*60*24 if ($age >= 0 and $age < 30); + $age *= 60 * 60 * 24 if ( $age >= 0 and $age < 30 ); - return 1 if (time() - (stat($file))[9] > $age); + return 1 if ( time() - ( stat($file) )[9] > $age ); return 0; } sub isFileUpdated { - my ($file, $time) = @_; + my ( $file, $time ) = @_; - if (! -f $file) { - return 1; + if ( !-f $file ) { + return 1; } - my $time_file = (stat $file)[9]; + my $time_file = ( stat $file )[9]; - if ($time <= $time_file) { - return 0; - } else { - return 1; + if ( $time <= $time_file ) { + return 0; + } + else { + return 1; } } @@ -492,22 +514,22 @@ sub isFileUpdated { # Usage: &makeHostMask($host); sub makeHostMask { - my ($host) = @_; - my $nu = ''; + my ($host) = @_; + my $nu = ''; - if ($host =~ s/^(\S+!\S+\@)//) { - &DEBUG("mHM: detected nick!user\@ for host arg; fixing"); - &DEBUG("nu => $nu"); - $nu = $1; + if ( $host =~ s/^(\S+!\S+\@)// ) { + &DEBUG("mHM: detected nick!user\@ for host arg; fixing"); + &DEBUG("nu => $nu"); + $nu = $1; } - if ($host =~ /^$mask{ip}$/) { - return $nu."$1.$2.$3.*"; + if ( $host =~ /^$mask{ip}$/ ) { + return $nu . "$1.$2.$3.*"; } - my @array = split(/\./, $host); - return $nu.$host if (scalar @array <= 3); - return $nu."*.".join('.',@{array}[1..$#array]); + my @array = split( /\./, $host ); + return $nu . $host if ( scalar @array <= 3 ); + return $nu . '*.' . join( '.', @{array}[ 1 .. $#array ] ); } # Usage: &makeRandom(int); @@ -516,23 +538,23 @@ sub makeRandom { my @retval; my %done; - if ($max =~ /^\D+$/) { - &ERROR("makeRandom: arg ($max) is not integer."); - return 0; + if ( $max =~ /^\D+$/ ) { + &ERROR("makeRandom: arg ($max) is not integer."); + return 0; } - if ($max < 1) { - &ERROR("makeRandom: arg ($max) is not positive."); - return 0; + if ( $max < 1 ) { + &ERROR("makeRandom: arg ($max) is not positive."); + return 0; } srand(); - while (scalar keys %done < $max) { - my $rand = int(rand $max); - next if (exists $done{$rand}); + while ( scalar keys %done < $max ) { + my $rand = int( rand $max ); + next if ( exists $done{$rand} ); - push(@retval,$rand); - $done{$rand} = 1; + push( @retval, $rand ); + $done{$rand} = 1; } return @retval; @@ -540,12 +562,14 @@ sub makeRandom { sub checkMsgType { my ($reply) = @_; - return unless (&IsParam('minLengthBeforePrivate')); + return unless ( &IsParam('minLengthBeforePrivate') ); return if ($force_public_reply); - if (length $reply > $param{'minLengthBeforePrivate'}) { - &status("Reply: len reply > minLBP ($param{'minLengthBeforePrivate'}); msgType now private."); - $msgType = 'private'; + if ( length $reply > $param{'minLengthBeforePrivate'} ) { + &status( +"Reply: len reply > minLBP ($param{'minLengthBeforePrivate'}); msgType now private." + ); + $msgType = 'private'; } } @@ -557,10 +581,11 @@ sub checkMsgType { sub validExec { my ($str) = @_; - if ($str =~ /[\`\'\"\|]/) { # invalid. - return 0; - } else { # valid. - return 1; + if ( $str =~ /[\`\'\"\|]/ ) { # invalid. + return 0; + } + else { # valid. + return 1; } } @@ -569,14 +594,14 @@ sub hasProfanity { my ($string) = @_; my $profanity = 1; - for (lc $string) { - /fuck/ and last; - /dick|dildo/ and last; - /shit/ and last; - /pussy|[ck]unt/ and last; - /wh[0o]re|bitch|slut/ and last; + for ( lc $string ) { + /fuck/ and last; + /dick|dildo/ and last; + /shit/ and last; + /pussy|[ck]unt/ and last; + /wh[0o]re|bitch|slut/ and last; - $profanity = 0; + $profanity = 0; } return $profanity; @@ -585,87 +610,102 @@ sub hasProfanity { sub IsChanConfOrWarn { my ($param) = @_; - if (&IsChanConf($param) > 0) { - return 1; - } else { - ### TODO: specific reason why it failed. - &msg($who, "unfortunately, \002$param\002 is disabled in my configuration") unless ($addrchar); - return 0; + if ( &IsChanConf($param) > 0 ) { + return 1; + } + else { + ### TODO: specific reason why it failed. + &msg( $who, + "unfortunately, \002$param\002 is disabled in my configuration" ) + unless ($addrchar); + return 0; } } sub Forker { - my ($label, $code) = @_; + my ( $label, $code ) = @_; my $pid; &shmFlush(); - &VERB("double fork detected; not forking.",2) if ($$ != $bot_pid); + &VERB( 'double fork detected; not forking.', 2 ) if ( $$ != $bot_pid ); + + if ( &IsParam('forking') and $$ == $bot_pid ) { + return unless &addForked($label); - if (&IsParam('forking') and $$ == $bot_pid) { - return unless &addForked($label); + $SIG{CHLD} = 'IGNORE'; + $pid = eval { fork() }; + return if $pid; # parent does nothing - $SIG{CHLD} = 'IGNORE'; - $pid = eval { fork() }; - return if $pid; # parent does nothing + select( undef, undef, undef, 0.2 ); - select(undef, undef, undef, 0.2); -# &status("fork starting for '$label', PID == $$."); - &status("--- fork starting for '$label', PID == $$, bot_pid == $bot_pid ---"); - &shmWrite($shm,"SET FORKPID $label $$"); + # &status("fork starting for '$label', PID == $$."); + &status( + "--- fork starting for '$label', PID == $$, bot_pid == $bot_pid ---" + ); + &shmWrite( $shm, "SET FORKPID $label $$" ); - sleep 1; + sleep 1; } ### TODO: use AUTOLOAD ### very lame hack. - if ($label !~ /-/ and !&loadMyModule($label)) { - &DEBUG("Forker: failed?"); - &delForked($label); + if ( $label !~ /-/ and !&loadMyModule($label) ) { + &DEBUG('Forker: failed?'); + &delForked($label); } - if (defined $code) { - $code->(); # weird, hey? - } else { - &WARN("Forker: code not defined!"); + if ( defined $code ) { + $code->(); # weird, hey? + } + else { + &WARN('Forker: code not defined!'); } &delForked($label); } sub closePID { - return 1 unless (exists $file{PID}); - return 1 unless ( -f $file{PID}); - return 1 if (unlink $file{PID}); - return 0 if ( -f $file{PID}); + return 1 unless ( exists $file{PID} ); + return 1 unless ( -f $file{PID} ); + return 1 if ( unlink $file{PID} ); + return 0 if ( -f $file{PID} ); } sub mkcrypt { - my($str) = @_; - my $salt = join '',('.','/',0..9,'A'..'Z','a'..'z')[rand 64, rand 64]; + my ($str) = @_; + my $salt = join '', + ( '.', '/', 0 .. 9, 'A' .. 'Z', 'a' .. 'z' )[ rand 64, rand 64 ]; - return crypt($str, $salt); + return crypt( $str, $salt ); } sub closeStats { - return unless (&getChanConfList('ircTextCounters')); - - foreach (keys %cmdstats) { - my $type = $_; - my $i = &sqlSelect('stats', 'counter', { - nick => $type, - type => 'cmdstats', - } ); - my $z = 0; - $z++ unless ($i); - - $i += $cmdstats{$type}; - - - &sqlSet('stats', {'nick' => $type}, { - type => 'cmdstats', - 'time' => time(), - counter => $i, - } ); + return unless ( &getChanConfList('ircTextCounters') ); + + foreach ( keys %cmdstats ) { + my $type = $_; + my $i = &sqlSelect( + 'stats', + 'counter', + { + nick => $type, + type => 'cmdstats', + } + ); + my $z = 0; + $z++ unless ($i); + + $i += $cmdstats{$type}; + + &sqlSet( + 'stats', + { 'nick' => $type }, + { + type => 'cmdstats', + 'time' => time(), + counter => $i, + } + ); } } diff --git a/src/Modules/BZFlag.pl b/src/Modules/BZFlag.pl index ef988c4..73b156c 100755 --- a/src/Modules/BZFlag.pl +++ b/src/Modules/BZFlag.pl @@ -18,342 +18,398 @@ use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); my $no_BZFlag; BEGIN { - $no_BZFlag = 0; - eval "use Socket"; - eval "use LWP::UserAgent"; - $no_BZFlag++ if ($@); + $no_BZFlag = 0; + eval "use Socket"; + eval "use LWP::UserAgent"; + $no_BZFlag++ if ($@); } sub BZFlag { - my ($message) = @_; - my ($retval); - if ($no_BZFlag) { - &::status("BZFlag module requires Socket."); - return 'BZFlag module not active'; - } - if ($message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi) { - $retval = &query($1,$2); - } elsif ($message =~ /^bzflist$/xi) { - $retval = &list(); - } else { - $retval = "BZFlag: unhandled command \"$message\""; - } - &::performStrictReply($retval); + my ($message) = @_; + my ($retval); + if ($no_BZFlag) { + &::status("BZFlag module requires Socket."); + return 'BZFlag module not active'; + } + if ( $message =~ /^bzfquery\s+([^:]*)(?::([0-9]*))?$/xi ) { + $retval = &query( $1, $2 ); + } + elsif ( $message =~ /^bzflist$/xi ) { + $retval = &list(); + } + else { + $retval = "BZFlag: unhandled command \"$message\""; + } + &::performStrictReply($retval); } sub list { - my ($response); - my $ua = new LWP::UserAgent; - $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy')); - - $ua->timeout(5); - - my $req = HTTP::Request->new('GET', 'http://db.bzflag.org/db/?action=LIST'); - my $res = $ua->request($req); - my %servers; - my $totalServers = 0; - for my $line (split("\n",$res->content)) { - my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5); - # not "(A4)18" to handle old dumb perl - my ($style, $maxShots, $shakeWins, $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime, - $maxPlayers, $rogueSize, $rogueMax, $redSize, $redMax, $greenSize, $greenMax, - $blueSize, $blueMax, $purpleSize, $purpleMax, $observerSize, $observerMax) = - unpack('A4A4A4A4A4A4A4A2A2A2A2A2A2A2A2A2A2A2A2A2', $flags); - my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize) - + hex($blueSize) + hex($purpleSize) + hex($observerSize); - $servers{$serverport} = $playerSize; - $servers{$version} += $playerSize; - $servers{'PLAYERS'} += $playerSize; - $totalServers += 1; - } - $response .= "s=$totalServers"; - foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) { - if ($servers{$key} > 0) { - $response .= " $key($servers{$key})"; - } - } - &::performStrictReply($response); - return; + my ($response); + my $ua = new LWP::UserAgent; + $ua->proxy( 'http', $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') ); + + $ua->timeout(5); + + my $req = + HTTP::Request->new( 'GET', 'http://db.bzflag.org/db/?action=LIST' ); + my $res = $ua->request($req); + my %servers; + my $totalServers = 0; + for my $line ( split( "\n", $res->content ) ) { + my ( $serverport, $version, $flags, $ip, $comments ) = + split( " ", $line, 5 ); + + # not "(A4)18" to handle old dumb perl + my ( + $style, $maxShots, $shakeWins, $shakeTimeout, + $maxPlayerScore, $maxTeamScore, $maxTime, $maxPlayers, + $rogueSize, $rogueMax, $redSize, $redMax, + $greenSize, $greenMax, $blueSize, $blueMax, + $purpleSize, $purpleMax, $observerSize, $observerMax + ) = unpack( 'A4A4A4A4A4A4A4A2A2A2A2A2A2A2A2A2A2A2A2A2', $flags ); + my $playerSize = + hex($rogueSize) + hex($redSize) + hex($greenSize) + hex($blueSize) + + hex($purpleSize) + hex($observerSize); + $servers{$serverport} = $playerSize; + $servers{$version} += $playerSize; + $servers{'PLAYERS'} += $playerSize; + $totalServers += 1; + } + $response .= "s=$totalServers"; + foreach + my $key ( sort { $servers{$b} <=> $servers{$a} } ( keys(%servers) ) ) + { + if ( $servers{$key} > 0 ) { + $response .= " $key($servers{$key})"; + } + } + &::performStrictReply($response); + return; } sub list17 { - my ($response); - my $ua = new LWP::UserAgent; - $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy')); - - $ua->timeout(5); - - my $req = HTTP::Request->new('GET', 'http://list.bzflag.org:5156/'); - my $res = $ua->request($req); - my %servers; - my $totalServers = 0; - my $totalPlayers = 0; - for my $line (split("\n",$res->content)) { - my ($serverport, $version, $flags, $ip, $comments) = split(" ",$line,5); - # not "(A4)18" to handle old dumb perl - my ($style,$maxPlayers,$maxShots, - $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize, - $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax, - $shakeWins,$shakeTimeout, - $maxPlayerScore,$maxTeamScore,$maxTime) = - unpack('A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4', $flags); - my $playerSize = hex($rogueSize) + hex($redSize) + hex($greenSize) - + hex($blueSize) + hex($purpleSize); - $servers{$serverport} = $playerSize; - $totalServers += 1; - $totalPlayers += $playerSize; - } - $response .= "s=$totalServers p=$totalPlayers"; - foreach my $key (sort {$servers{$b} <=> $servers{$a}} (keys(%servers))) { - if ($servers{$key} > 0) { - $response .= " $key($servers{$key})"; - } - } - &::performStrictReply($response); - return; + my ($response); + my $ua = new LWP::UserAgent; + $ua->proxy( 'http', $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') ); + + $ua->timeout(5); + + my $req = HTTP::Request->new( 'GET', 'http://list.bzflag.org:5156/' ); + my $res = $ua->request($req); + my %servers; + my $totalServers = 0; + my $totalPlayers = 0; + for my $line ( split( "\n", $res->content ) ) { + my ( $serverport, $version, $flags, $ip, $comments ) = + split( " ", $line, 5 ); + + # not "(A4)18" to handle old dumb perl + my ( + $style, $maxPlayers, $maxShots, $rogueSize, + $redSize, $greenSize, $blueSize, $purpleSize, + $rogueMax, $redMax, $greenMax, $blueMax, + $purpleMax, $shakeWins, $shakeTimeout, $maxPlayerScore, + $maxTeamScore, $maxTime + ) = unpack( 'A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4A4', $flags ); + my $playerSize = + hex($rogueSize) + hex($redSize) + hex($greenSize) + hex($blueSize) + + hex($purpleSize); + $servers{$serverport} = $playerSize; + $totalServers += 1; + $totalPlayers += $playerSize; + } + $response .= "s=$totalServers p=$totalPlayers"; + foreach + my $key ( sort { $servers{$b} <=> $servers{$a} } ( keys(%servers) ) ) + { + if ( $servers{$key} > 0 ) { + $response .= " $key($servers{$key})"; + } + } + &::performStrictReply($response); + return; } sub querytext { - my ($servernameport) = @_; - my ($servername,$port) = split(":",$servernameport); - if ($no_BZFlag) { - &::status("BZFlag module requires Socket."); - return 'BZFlag module not active'; - } - #my @teamName = ('Rogue', 'Red', 'Green', 'Blue', 'Purple', 'Observer', 'Rabbit'); - my @teamName = ('X', 'R', 'G', 'B', 'P', 'O', 'K'); - my ($message, $server, $response); - $port = 5154 unless $port; - - # socket define - my $sockaddr = 'S n a4 x8'; - - # port to port number - my ($name,$aliases,$proto) = getprotobyname('tcp'); - ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/; - - # get server address - my ($type,$len,$serveraddr); - ($name,$aliases,$type,$len,$serveraddr) = gethostbyname($servername); - $server = pack($sockaddr, AF_INET, $port, $serveraddr); - - # connect - # TODO wrap this with a 5 second alarm() - return 'socket() error' unless socket(S1, AF_INET, SOCK_STREAM, $proto); - return "could not connect to $servername:$port" unless connect(S1, $server); - - # don't buffer - select(S1); $| = 1; select(STDOUT); - - # get hello - my $buffer; - return 'read error' unless read(S1, $buffer, 8) == 8; - - # parse reply - my ($magic,$major,$minor,$something,$revision) = unpack("a4 a1 a1 a1 a1", $buffer); - my ($version) = $magic . $major . $minor . $something . $revision; - - # quit if version isn't valid - return 'not a bzflag server' if ($magic ne 'BZFS'); - $response .= "$major$minor$something$revision "; - # check version - if ($version eq 'BZFS0026') { - # 1.11.x handled here - return 'read error' unless read(S1, $buffer, 1) == 1; - my ($id) = unpack('C', $buffer); - return "rejected by server" if ($id == 255); - - # send game request - print S1 pack('n2', 0, 0x7167); - - # get reply - my $nbytes = read(S1, $buffer, 4); - my ($infolen, $infocode) = unpack('n2', $buffer); - if ($infocode == 0x6774) { - # read and ignore MsgGameTime from new servers - $nbytes = read(S1, $buffer, 8); - $nbytes = read(S1, $buffer, 4); - ($infolen, $infocode) = unpack('n2', $buffer); - } - $nbytes = read(S1, $buffer, 42); - if ($nbytes != 42) { - return "Error: read $nbytes bytes, expecting 46: $^E\n"; - } - - my ($style,$maxPlayers,$maxShots, - $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize,$observerSize, - $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax,$observerMax, - $shakeWins,$shakeTimeout, - $maxPlayerScore,$maxTeamScore,$maxTime,$timeElapsed) = unpack('n23', $buffer); - return "bad server data $infocode" unless $infocode == 0x7167; - - # send players request - print S1 pack('n2', 0, 0x7170); - - # get number of teams and players we'll be receiving - return 'count read error' unless read(S1, $buffer, 8) == 8; - my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer); - - # get the teams - return 'bad count data' unless $countcode == 0x7170; - return 'count read error' unless read(S1, $buffer, 5) == 5; - ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer); - for (1..$numTeams) { - return 'team read error' unless read(S1, $buffer, 8) == 8; - my ($team,$size,$won,$lost) = unpack('n4', $buffer); - if ($size > 0) { - my $score = $won - $lost; - $response .= "$teamName[$team]:$score($won-$lost) "; - } - } - - # get the players - for (1..$numPlayers) { - last unless read(S1, $buffer, 175) == 175; - my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) = - unpack('n2Cn5A32A128', $buffer); - #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) = - # unpack("n2Nn2 n4A32A128", $buffer); - return 'bad player data' unless $playercode == 0x6170; - my $score = $won - $lost; - $response .= " $sign($teamName[$team]"; - $response .= ":$email" if ($email); - $response .= ")$score($won-$lost)"; - } - $response .= "No Players" if ($numPlayers < 1); - - # close socket - } elsif ($major == 1 && $minor == 9) { - # 1.10.x handled here - $revision = $something * 10 + $revision; - return 'read error' unless read(S1, $buffer, 1) == 1; - my ($id) = unpack('C', $buffer); - - # send game request - print S1 pack('n2', 0, 0x7167); - - # FIXME the packets are wrong from here down - # get reply - return 'server read error' unless read(S1, $buffer, 40) == 40; - my ($infolen,$infocode,$style,$maxPlayers,$maxShots, - $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize, - $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax, - $shakeWins,$shakeTimeout, - $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer); - return 'bad server data' unless $infocode == 0x7167; - - # send players request - print S1 pack('n2', 0, 0x7170); - - # get number of teams and players we'll be receiving - return 'count read error' unless read(S1, $buffer, 8) == 8; - my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer); - - # get the teams - return 'bad count data' unless $countcode == 0x7170; - return 'count read error' unless read(S1, $buffer, 5) == 5; - ($countlen,$countcode,$numTeams) = unpack("n n C", $buffer); - for (1..$numTeams) { - return 'team read error' unless read(S1, $buffer, 8) == 8; - my ($team,$size,$won,$lost) = unpack('n4', $buffer); - if ($size > 0) { - my $score = $won - $lost; - $response .= "$teamName[$team]:$score($won-$lost) "; - } - } - - # get the players - for (1..$numPlayers) { - last unless read(S1, $buffer, 175) == 175; - my ($playerlen,$playercode,$pID,$type,$team,$won,$lost,$tks,$sign,$email) = - unpack('n2Cn5A32A128', $buffer); - #my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) = - # unpack("n2Nn2 n4A32A128", $buffer); - return 'bad player data' unless $playercode == 0x6170; - my $score = $won - $lost; - $response .= " $sign($teamName[$team]"; - $response .= ":$email" if ($email); - $response .= ")$score($won-$lost)"; - } - $response .= "No Players" if ($numPlayers < 1); - - # close socket - close(S1); - } elsif ($major == 1 && $minor == 0 && $something == 7) { - # 1.7* versions handled here - # old servers send a reconnect port number - return 'read error' unless read(S1, $buffer, 2) == 2; - my ($reconnect) = unpack('n', $buffer); - $minor = $minor * 10 + $something; - # quit if rejected - return 'rejected by server' if ($reconnect == 0); - - # reconnect on new port - $server = pack($sockaddr, AF_INET, $reconnect, $serveraddr); - return 'socket() error on reconnect' unless socket(S, AF_INET, SOCK_STREAM, $proto); - return "could not reconnect to $servername:$reconnect" unless connect(S, $server); - select(S); $| = 1; select(STDOUT); - - # close first socket - close(S1); - - # send game request - print S pack('n2', 0, 0x7167); - - # get reply - return 'server read error' unless read(S, $buffer, 40) == 40; - my ($infolen,$infocode,$style,$maxPlayers,$maxShots, - $rogueSize,$redSize,$greenSize,$blueSize,$purpleSize, - $rogueMax,$redMax,$greenMax,$blueMax,$purpleMax, - $shakeWins,$shakeTimeout, - $maxPlayerScore,$maxTeamScore,$maxTime) = unpack('n20', $buffer); - return 'bad server data' unless $infocode == 0x7167; - - # send players request - print S pack('n2', 0, 0x7170); - - # get number of teams and players we'll be receiving - return 'count read error' unless read(S, $buffer, 8) == 8; - my ($countlen,$countcode,$numTeams,$numPlayers) = unpack('n4', $buffer); - return 'bad count data' unless $countcode == 0x7170; - - # get the teams - for (1..$numTeams) { - return 'team read error' unless read(S, $buffer, 14) == 14; - my ($teamlen,$teamcode,$team,$size,$aSize,$won,$lost) = unpack('n7', $buffer); - return 'bad team data' unless $teamcode == 0x7475; - if ($size > 0) { - my $score = $won - $lost; - $response .= "$teamName[$team]:$score($won-$lost) "; - } - } - - # get the players - for (1..$numPlayers) { - last unless read(S, $buffer, 180) == 180; - my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) = - unpack("n2Nn2 n4A32A128", $buffer); - return 'bad player data' unless $playercode == 0x6170; - my $score = $won - $lost; - $response .= " $sign($teamName[$team]"; - $response .= ":$email" if ($email); - $response .= ")$score($won-$lost)"; - } - $response .= "No Players" if ($numPlayers <= 1); - - # close socket - close(S); - } else { - $response = "incompatible version: $version"; - } - - return $response; + my ($servernameport) = @_; + my ( $servername, $port ) = split( ":", $servernameport ); + if ($no_BZFlag) { + &::status("BZFlag module requires Socket."); + return 'BZFlag module not active'; + } + +#my @teamName = ('Rogue', 'Red', 'Green', 'Blue', 'Purple', 'Observer', 'Rabbit'); + my @teamName = ( 'X', 'R', 'G', 'B', 'P', 'O', 'K' ); + my ( $message, $server, $response ); + $port = 5154 unless $port; + + # socket define + my $sockaddr = 'S n a4 x8'; + + # port to port number + my ( $name, $aliases, $proto ) = getprotobyname('tcp'); + ( $name, $aliases, $port ) = getservbyname( $port, 'tcp' ) + unless $port =~ /^\d+$/; + + # get server address + my ( $type, $len, $serveraddr ); + ( $name, $aliases, $type, $len, $serveraddr ) = gethostbyname($servername); + $server = pack( $sockaddr, AF_INET, $port, $serveraddr ); + + # connect + # TODO wrap this with a 5 second alarm() + return 'socket() error' unless socket( S1, AF_INET, SOCK_STREAM, $proto ); + return "could not connect to $servername:$port" + unless connect( S1, $server ); + + # don't buffer + select(S1); + $| = 1; + select(STDOUT); + + # get hello + my $buffer; + return 'read error' unless read( S1, $buffer, 8 ) == 8; + + # parse reply + my ( $magic, $major, $minor, $something, $revision ) = + unpack( "a4 a1 a1 a1 a1", $buffer ); + my ($version) = $magic . $major . $minor . $something . $revision; + + # quit if version isn't valid + return 'not a bzflag server' if ( $magic ne 'BZFS' ); + $response .= "$major$minor$something$revision "; + + # check version + if ( $version eq 'BZFS0026' ) { + + # 1.11.x handled here + return 'read error' unless read( S1, $buffer, 1 ) == 1; + my ($id) = unpack( 'C', $buffer ); + return "rejected by server" if ( $id == 255 ); + + # send game request + print S1 pack( 'n2', 0, 0x7167 ); + + # get reply + my $nbytes = read( S1, $buffer, 4 ); + my ( $infolen, $infocode ) = unpack( 'n2', $buffer ); + if ( $infocode == 0x6774 ) { + + # read and ignore MsgGameTime from new servers + $nbytes = read( S1, $buffer, 8 ); + $nbytes = read( S1, $buffer, 4 ); + ( $infolen, $infocode ) = unpack( 'n2', $buffer ); + } + $nbytes = read( S1, $buffer, 42 ); + if ( $nbytes != 42 ) { + return "Error: read $nbytes bytes, expecting 46: $^E\n"; + } + + my ( + $style, $maxPlayers, $maxShots, $rogueSize, + $redSize, $greenSize, $blueSize, $purpleSize, + $observerSize, $rogueMax, $redMax, $greenMax, + $blueMax, $purpleMax, $observerMax, $shakeWins, + $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime, + $timeElapsed + ) = unpack( 'n23', $buffer ); + return "bad server data $infocode" unless $infocode == 0x7167; + + # send players request + print S1 pack( 'n2', 0, 0x7170 ); + + # get number of teams and players we'll be receiving + return 'count read error' unless read( S1, $buffer, 8 ) == 8; + my ( $countlen, $countcode, $numTeams, $numPlayers ) = + unpack( 'n4', $buffer ); + + # get the teams + return 'bad count data' unless $countcode == 0x7170; + return 'count read error' unless read( S1, $buffer, 5 ) == 5; + ( $countlen, $countcode, $numTeams ) = unpack( "n n C", $buffer ); + for ( 1 .. $numTeams ) { + return 'team read error' unless read( S1, $buffer, 8 ) == 8; + my ( $team, $size, $won, $lost ) = unpack( 'n4', $buffer ); + if ( $size > 0 ) { + my $score = $won - $lost; + $response .= "$teamName[$team]:$score($won-$lost) "; + } + } + + # get the players + for ( 1 .. $numPlayers ) { + last unless read( S1, $buffer, 175 ) == 175; + my ( + $playerlen, $playercode, $pID, $type, $team, + $won, $lost, $tks, $sign, $email + ) = unpack( 'n2Cn5A32A128', $buffer ); + +#my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) = +# unpack("n2Nn2 n4A32A128", $buffer); + return 'bad player data' unless $playercode == 0x6170; + my $score = $won - $lost; + $response .= " $sign($teamName[$team]"; + $response .= ":$email" if ($email); + $response .= ")$score($won-$lost)"; + } + $response .= "No Players" if ( $numPlayers < 1 ); + + # close socket + } + elsif ( $major == 1 && $minor == 9 ) { + + # 1.10.x handled here + $revision = $something * 10 + $revision; + return 'read error' unless read( S1, $buffer, 1 ) == 1; + my ($id) = unpack( 'C', $buffer ); + + # send game request + print S1 pack( 'n2', 0, 0x7167 ); + + # FIXME the packets are wrong from here down + # get reply + return 'server read error' unless read( S1, $buffer, 40 ) == 40; + my ( + $infolen, $infocode, $style, $maxPlayers, + $maxShots, $rogueSize, $redSize, $greenSize, + $blueSize, $purpleSize, $rogueMax, $redMax, + $greenMax, $blueMax, $purpleMax, $shakeWins, + $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime + ) = unpack( 'n20', $buffer ); + return 'bad server data' unless $infocode == 0x7167; + + # send players request + print S1 pack( 'n2', 0, 0x7170 ); + + # get number of teams and players we'll be receiving + return 'count read error' unless read( S1, $buffer, 8 ) == 8; + my ( $countlen, $countcode, $numTeams, $numPlayers ) = + unpack( 'n4', $buffer ); + + # get the teams + return 'bad count data' unless $countcode == 0x7170; + return 'count read error' unless read( S1, $buffer, 5 ) == 5; + ( $countlen, $countcode, $numTeams ) = unpack( "n n C", $buffer ); + for ( 1 .. $numTeams ) { + return 'team read error' unless read( S1, $buffer, 8 ) == 8; + my ( $team, $size, $won, $lost ) = unpack( 'n4', $buffer ); + if ( $size > 0 ) { + my $score = $won - $lost; + $response .= "$teamName[$team]:$score($won-$lost) "; + } + } + + # get the players + for ( 1 .. $numPlayers ) { + last unless read( S1, $buffer, 175 ) == 175; + my ( + $playerlen, $playercode, $pID, $type, $team, + $won, $lost, $tks, $sign, $email + ) = unpack( 'n2Cn5A32A128', $buffer ); + +#my ($playerlen,$playercode,$pAddr,$pPort,$pNum,$type,$team,$won,$lost,$sign,$email) = +# unpack("n2Nn2 n4A32A128", $buffer); + return 'bad player data' unless $playercode == 0x6170; + my $score = $won - $lost; + $response .= " $sign($teamName[$team]"; + $response .= ":$email" if ($email); + $response .= ")$score($won-$lost)"; + } + $response .= "No Players" if ( $numPlayers < 1 ); + + # close socket + close(S1); + } + elsif ( $major == 1 && $minor == 0 && $something == 7 ) { + + # 1.7* versions handled here + # old servers send a reconnect port number + return 'read error' unless read( S1, $buffer, 2 ) == 2; + my ($reconnect) = unpack( 'n', $buffer ); + $minor = $minor * 10 + $something; + + # quit if rejected + return 'rejected by server' if ( $reconnect == 0 ); + + # reconnect on new port + $server = pack( $sockaddr, AF_INET, $reconnect, $serveraddr ); + return 'socket() error on reconnect' + unless socket( S, AF_INET, SOCK_STREAM, $proto ); + return "could not reconnect to $servername:$reconnect" + unless connect( S, $server ); + select(S); + $| = 1; + select(STDOUT); + + # close first socket + close(S1); + + # send game request + print S pack( 'n2', 0, 0x7167 ); + + # get reply + return 'server read error' unless read( S, $buffer, 40 ) == 40; + my ( + $infolen, $infocode, $style, $maxPlayers, + $maxShots, $rogueSize, $redSize, $greenSize, + $blueSize, $purpleSize, $rogueMax, $redMax, + $greenMax, $blueMax, $purpleMax, $shakeWins, + $shakeTimeout, $maxPlayerScore, $maxTeamScore, $maxTime + ) = unpack( 'n20', $buffer ); + return 'bad server data' unless $infocode == 0x7167; + + # send players request + print S pack( 'n2', 0, 0x7170 ); + + # get number of teams and players we'll be receiving + return 'count read error' unless read( S, $buffer, 8 ) == 8; + my ( $countlen, $countcode, $numTeams, $numPlayers ) = + unpack( 'n4', $buffer ); + return 'bad count data' unless $countcode == 0x7170; + + # get the teams + for ( 1 .. $numTeams ) { + return 'team read error' unless read( S, $buffer, 14 ) == 14; + my ( $teamlen, $teamcode, $team, $size, $aSize, $won, $lost ) = + unpack( 'n7', $buffer ); + return 'bad team data' unless $teamcode == 0x7475; + if ( $size > 0 ) { + my $score = $won - $lost; + $response .= "$teamName[$team]:$score($won-$lost) "; + } + } + + # get the players + for ( 1 .. $numPlayers ) { + last unless read( S, $buffer, 180 ) == 180; + my ( + $playerlen, $playercode, $pAddr, $pPort, + $pNum, $type, $team, $won, + $lost, $sign, $email + ) = unpack( "n2Nn2 n4A32A128", $buffer ); + return 'bad player data' unless $playercode == 0x6170; + my $score = $won - $lost; + $response .= " $sign($teamName[$team]"; + $response .= ":$email" if ($email); + $response .= ")$score($won-$lost)"; + } + $response .= "No Players" if ( $numPlayers <= 1 ); + + # close socket + close(S); + } + else { + $response = "incompatible version: $version"; + } + + return $response; } sub query { - my ($servernameport) = @_; - &::performStrictReply(&querytext($servernameport)); - return; + my ($servernameport) = @_; + &::performStrictReply( &querytext($servernameport) ); + return; } 1; diff --git a/src/Modules/Debian.pl b/src/Modules/Debian.pl index 8ec592b..b4bd5b4 100644 --- a/src/Modules/Debian.pl +++ b/src/Modules/Debian.pl @@ -11,26 +11,28 @@ package Debian; use strict; -no strict 'refs'; # FIXME: dstats aborts if set - -my $announce = 0; -my $defaultdist = 'sid'; -my $refresh = &::getChanConfDefault('debianRefreshInterval', 7, $::chan) * 60 * 60 * 24; -my $debug = 0; -my $debian_dir = $::bot_state_dir . '/debian'; -my $country = 'nl'; # well .config it yourself then. ;-) -my $protocol = 'http'; +no strict 'refs'; # FIXME: dstats aborts if set + +my $announce = 0; +my $defaultdist = 'sid'; +my $refresh = + &::getChanConfDefault( 'debianRefreshInterval', 7, $::chan ) * 60 * 60 * 24; +my $debug = 0; +my $debian_dir = $::bot_state_dir . '/debian'; +my $country = 'nl'; # well .config it yourself then. ;-) +my $protocol = 'http'; + # EDIT THIS (i386, amd64, powerpc, [etc.]): my $arch = "i386"; # format: "alias=real". -my %dists = ( - 'unstable' => 'sid', - 'testing' => 'lenny', - 'stable' => 'etch', - 'experimental' => 'experimental', - 'oldstable' => 'sarge', - 'incoming' => 'incoming', +my %dists = ( + 'unstable' => 'sid', + 'testing' => 'lenny', + 'stable' => 'etch', + 'experimental' => 'experimental', + 'oldstable' => 'sarge', + 'incoming' => 'incoming', ); my %archived_dists = ( @@ -43,11 +45,10 @@ my %archived_dists = ( slink => 'slink', ); -my %archiveurlcontents = ( - "Contents-##DIST-$arch.gz" => - "$protocol://debian.crosslink.net/debian-archive". - "/dists/##DIST/Contents-$arch.gz", -); +my %archiveurlcontents = + ( "Contents-##DIST-$arch.gz" => + "$protocol://debian.crosslink.net/debian-archive" + . "/dists/##DIST/Contents-$arch.gz", ); my %archiveurlpackages = ( "Packages-##DIST-main-$arch.gz" => @@ -61,26 +62,20 @@ my %archiveurlpackages = ( "/dists/##DIST/non-free/binary-$arch/Packages.gz", ); - my %urlcontents = ( - "Contents-##DIST-$arch.gz" => - "$protocol://ftp.$country.debian.org". - "/debian/dists/##DIST/Contents-$arch.gz", - "Contents-##DIST-$arch-non-US.gz" => - "$protocol://non-us.debian.org". - "/debian-non-US/dists/##DIST/non-US/Contents-$arch.gz", + "Contents-##DIST-$arch.gz" => "$protocol://ftp.$country.debian.org" + . "/debian/dists/##DIST/Contents-$arch.gz", + "Contents-##DIST-$arch-non-US.gz" => "$protocol://non-us.debian.org" + . "/debian-non-US/dists/##DIST/non-US/Contents-$arch.gz", ); my %urlpackages = ( - "Packages-##DIST-main-$arch.gz" => - "$protocol://ftp.$country.debian.org". - "/debian/dists/##DIST/main/binary-$arch/Packages.gz", - "Packages-##DIST-contrib-$arch.gz" => - "$protocol://ftp.$country.debian.org". - "/debian/dists/##DIST/contrib/binary-$arch/Packages.gz", - "Packages-##DIST-non-free-$arch.gz" => - "$protocol://ftp.$country.debian.org". - "/debian/dists/##DIST/non-free/binary-$arch/Packages.gz", + "Packages-##DIST-main-$arch.gz" => "$protocol://ftp.$country.debian.org" + . "/debian/dists/##DIST/main/binary-$arch/Packages.gz", + "Packages-##DIST-contrib-$arch.gz" => "$protocol://ftp.$country.debian.org" + . "/debian/dists/##DIST/contrib/binary-$arch/Packages.gz", + "Packages-##DIST-non-free-$arch.gz" => "$protocol://ftp.$country.debian.org" + . "/debian/dists/##DIST/non-free/binary-$arch/Packages.gz", ); ##################### @@ -90,96 +85,101 @@ my %urlpackages = ( #### # Usage: &DebianDownload($dist, %hash); sub DebianDownload { - my ($dist, %urls) = @_; - my $bad = 0; - my $good = 0; + my ( $dist, %urls ) = @_; + my $bad = 0; + my $good = 0; - if (! -d $debian_dir) { - &::status("Debian: creating debian dir."); - mkdir($debian_dir, 0755); + if ( !-d $debian_dir ) { + &::status("Debian: creating debian dir."); + mkdir( $debian_dir, 0755 ); } # fe dists. # Download the files. my $file; - foreach $file (keys %urls) { - my $url = $urls{$file}; - $url =~ s/##DIST/$dist/g; - $file =~ s/##DIST/$dist/g; - my $update = 0; - - if ( -f $file ) { - my $last_refresh = (stat $file)[9]; - $update++ if (time() - $last_refresh > $refresh); - } else { - $update++; - } - - next unless ($update); - - &::DEBUG("announce == $announce.") if ($debug); - if ($good + $bad == 0 and !$announce) { - &::status("Debian: Downloading files for '$dist'."); - &::msg($::who, "Updating debian files... please wait."); - $announce++; - } - - if (exists $::debian{$url}) { - &::DEBUG("2: ".(time - $::debian{$url})." <= $refresh") if ($debug); - next if (time() - $::debian{$url} <= $refresh); - &::DEBUG("stale for url $url; updating!") if ($debug); - } - - if ($url =~ /^ftp:\/\/(.*?)\/(\S+)\/(\S+)$/) { - my ($host,$path,$thisfile) = ($1,$2,$3); - - if (!&::ftpGet($host,$path,$thisfile,$file)) { - &::WARN("deb: down: $file == BAD."); - $bad++; - next; - } - - } elsif ($url =~ /^http:\/\/\S+\/\S+$/) { - - if (!&::getURLAsFile($url,$file)) { - &::WARN("deb: down: http: $file == BAD."); - $bad++; - next; - } - - } else { - &::ERROR("Debian: invalid format of url => ($url)."); - $bad++; - next; - } - - if (! -f $file) { - &::WARN("deb: down: http: !file"); - $bad++; - next; - } - -# my $exit = system("/bin/gzip -t $file"); -# if ($exit) { -# &::WARN("deb: $file is corrupted ($exit) :/"); -# unlink $file; -# next; -# } - - &::DEBUG("deb: download: good.") if ($debug); - $good++; + foreach $file ( keys %urls ) { + my $url = $urls{$file}; + $url =~ s/##DIST/$dist/g; + $file =~ s/##DIST/$dist/g; + my $update = 0; + + if ( -f $file ) { + my $last_refresh = ( stat $file )[9]; + $update++ if ( time() - $last_refresh > $refresh ); + } + else { + $update++; + } + + next unless ($update); + + &::DEBUG("announce == $announce.") if ($debug); + if ( $good + $bad == 0 and !$announce ) { + &::status("Debian: Downloading files for '$dist'."); + &::msg( $::who, "Updating debian files... please wait." ); + $announce++; + } + + if ( exists $::debian{$url} ) { + &::DEBUG( "2: " . ( time - $::debian{$url} ) . " <= $refresh" ) + if ($debug); + next if ( time() - $::debian{$url} <= $refresh ); + &::DEBUG("stale for url $url; updating!") if ($debug); + } + + if ( $url =~ /^ftp:\/\/(.*?)\/(\S+)\/(\S+)$/ ) { + my ( $host, $path, $thisfile ) = ( $1, $2, $3 ); + + if ( !&::ftpGet( $host, $path, $thisfile, $file ) ) { + &::WARN("deb: down: $file == BAD."); + $bad++; + next; + } + + } + elsif ( $url =~ /^http:\/\/\S+\/\S+$/ ) { + + if ( !&::getURLAsFile( $url, $file ) ) { + &::WARN("deb: down: http: $file == BAD."); + $bad++; + next; + } + + } + else { + &::ERROR("Debian: invalid format of url => ($url)."); + $bad++; + next; + } + + if ( !-f $file ) { + &::WARN("deb: down: http: !file"); + $bad++; + next; + } + + # my $exit = system("/bin/gzip -t $file"); + # if ($exit) { + # &::WARN("deb: $file is corrupted ($exit) :/"); + # unlink $file; + # next; + # } + + &::DEBUG("deb: download: good.") if ($debug); + $good++; } # ok... lets just run this. - &::miscCheck() if (&::whatInterface() =~ /IRC/); + &::miscCheck() if ( &::whatInterface() =~ /IRC/ ); if ($good) { - &generateIndex($dist); - return 1; - } else { - return -1 unless ($bad); # no download. - &::DEBUG("DD: !good and bad($bad). :("); - return 0; + &generateIndex($dist); + return 1; + } + else { + return -1 unless ($bad); # no download. + &::DEBUG("DD: !good and bad($bad). :("); + return 0; } } @@ -190,95 +190,101 @@ sub DebianDownload { #### # Usage: &searchContents($query); sub searchContents { - my ($dist, $query) = &getDistroFromStr($_[0]); + my ( $dist, $query ) = &getDistroFromStr( $_[0] ); &::status("Debian: Contents search for '$query' in '$dist'."); - my $dccsend = 0; + my $dccsend = 0; - $dccsend++ if ($query =~ s/^dcc\s+//i); + $dccsend++ if ( $query =~ s/^dcc\s+//i ); - $query =~ s/\\([\^\$])/$1/g; # hrm? + $query =~ s/\\([\^\$])/$1/g; # hrm? $query =~ s/^\s+|\s+$//g; - if (!&::validExec($query)) { - &::msg($::who, 'search string looks fuzzy.'); - return; + if ( !&::validExec($query) ) { + &::msg( $::who, 'search string looks fuzzy.' ); + return; } - my %urls = fixDist($dist,'contents'); - if ($dist eq 'incoming') { # nothing yet. - &::DEBUG('sC: dist = "incoming". no contents yet.'); - return; - } else { - # download contents file. - &::DEBUG('deb: download 1.') if ($debug); - if (!&DebianDownload($dist, %urls)) { - &::WARN('Debian: could not download files.'); - } + my %urls = fixDist( $dist, 'contents' ); + if ( $dist eq 'incoming' ) { # nothing yet. + &::DEBUG('sC: dist = "incoming". no contents yet.'); + return; + } + else { + + # download contents file. + &::DEBUG('deb: download 1.') if ($debug); + if ( !&DebianDownload( $dist, %urls ) ) { + &::WARN('Debian: could not download files.'); + } } # start of search. my $start_time = &::timeget(); - my $found = 0; - my $front = 0; + my $found = 0; + my $front = 0; my %contents; my $grepRE; ### TODO: search properly if /usr/bin/blah is done. - if ($query =~ s/\$$//) { - &::DEBUG("deb: search-regex found.") if ($debug); - $grepRE = "$query\[ \t]"; - } elsif ($query =~ s/^\^//) { - &::DEBUG("deb: front marker regex found.") if ($debug); - $front = 1; - $grepRE = $query; - } else { - $grepRE = "$query*\[ \t]"; + if ( $query =~ s/\$$// ) { + &::DEBUG("deb: search-regex found.") if ($debug); + $grepRE = "$query\[ \t]"; + } + elsif ( $query =~ s/^\^// ) { + &::DEBUG("deb: front marker regex found.") if ($debug); + $front = 1; + $grepRE = $query; + } + else { + $grepRE = "$query*\[ \t]"; } # fix up grepRE for "*". $grepRE =~ s/\*/.*/g; my @files; - foreach (keys %urls) { - next unless ( -f $_ ); - push(@files, $_); + foreach ( keys %urls ) { + next unless ( -f $_ ); + push( @files, $_ ); } - if (!scalar @files) { - &::ERROR("sC: no files?"); - &::msg($::who, "failed."); - return; + if ( !scalar @files ) { + &::ERROR("sC: no files?"); + &::msg( $::who, "failed." ); + return; } - my $files = join(' ', @files); + my $files = join( ' ', @files ); + + my $regex = $query; + $regex =~ s/\./\\./g; + $regex =~ s/\*/\\S*/g; + $regex =~ s/\?/./g; - my $regex = $query; - $regex =~ s/\./\\./g; - $regex =~ s/\*/\\S*/g; - $regex =~ s/\?/./g; + open( IN, "zegrep -h '$grepRE' $files |" ); - open(IN,"zegrep -h '$grepRE' $files |"); # wonderful abuse of if, last, next, return, and, unless ;) while () { - last if ($found > 100); - - next unless (/^\.?\/?(.*?)[\t\s]+(\S+)\n$/); - my ($file,$package) = ("/".$1,$2); - - if ($query =~ /[\/\*\\]/) { - next unless (eval { $file =~ /$regex/ }); - return unless &checkEval($@); - } else { - my ($basename) = $file =~ /^.*\/(.*)$/; - next unless (eval { $basename =~ /$regex/ }); - return unless &checkEval($@); - } - next if ($query !~ /\.\d\.gz/ and $file =~ /\/man\//); - next if ($front and eval { $file !~ /^\/$query/ }); - return unless &checkEval($@); - - $contents{$package}{$file} = 1; - $found++; + last if ( $found > 100 ); + + next unless (/^\.?\/?(.*?)[\t\s]+(\S+)\n$/); + my ( $file, $package ) = ( "/" . $1, $2 ); + + if ( $query =~ /[\/\*\\]/ ) { + next unless ( eval { $file =~ /$regex/ } ); + return unless &checkEval($@); + } + else { + my ($basename) = $file =~ /^.*\/(.*)$/; + next unless ( eval { $basename =~ /$regex/ } ); + return unless &checkEval($@); + } + next if ( $query !~ /\.\d\.gz/ and $file =~ /\/man\// ); + next if ( $front and eval { $file !~ /^\/$query/ } ); + return unless &checkEval($@); + + $contents{$package}{$file} = 1; + $found++; } close IN; @@ -286,182 +292,193 @@ sub searchContents { ### send results with dcc. if ($dccsend) { - if (exists $::dcc{'SEND'}{$::who}) { - &::msg($::who, "DCC already active!"); - return; - } - - if (!scalar %contents) { - &::msg($::who,"search returned no results."); - return; - } - - my $file = "$::param{tempDir}/$::who.txt"; - if (!open OUT, ">$file") { - &::ERROR("Debian: cannot write file for dcc send."); - return; - } - - foreach $pkg (keys %contents) { - foreach (keys %{ $contents{$pkg} }) { - # TODO: correct padding. - print OUT "$_\t\t\t$pkg\n"; - } - } - close OUT; - - &::shmWrite($::shm, "DCC SEND $::who $file"); - - return; + if ( exists $::dcc{'SEND'}{$::who} ) { + &::msg( $::who, "DCC already active!" ); + return; + } + + if ( !scalar %contents ) { + &::msg( $::who, "search returned no results." ); + return; + } + + my $file = "$::param{tempDir}/$::who.txt"; + if ( !open OUT, ">$file" ) { + &::ERROR("Debian: cannot write file for dcc send."); + return; + } + + foreach $pkg ( keys %contents ) { + foreach ( keys %{ $contents{$pkg} } ) { + + # TODO: correct padding. + print OUT "$_\t\t\t$pkg\n"; + } + } + close OUT; + + &::shmWrite( $::shm, "DCC SEND $::who $file" ); + + return; } &::status("Debian: $found contents results found."); my @list; - foreach $pkg (keys %contents) { - my @tmplist = &::fixFileList(keys %{ $contents{$pkg} }); - my @sublist = sort { length $a <=> length $b } @tmplist; + foreach $pkg ( keys %contents ) { + my @tmplist = &::fixFileList( keys %{ $contents{$pkg} } ); + my @sublist = sort { length $a <=> length $b } @tmplist; - pop @sublist while (scalar @sublist > 3); + pop @sublist while ( scalar @sublist > 3 ); - $pkg =~ s/\,/\037\,\037/g; # underline ','. - push(@list, "(". join(', ',@sublist) .") in $pkg"); + $pkg =~ s/\,/\037\,\037/g; # underline ','. + push( @list, "(" . join( ', ', @sublist ) . ") in $pkg" ); } + # sort the total list from shortest to longest... @list = sort { length $a <=> length $b } @list; # show how long it took. my $delta_time = &::timedelta($start_time); - &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0); + &::status( sprintf( "Debian: %.02f sec to complete query.", $delta_time ) ) + if ( $delta_time > 0 ); my $prefix = "Debian Search of '$query' "; - if (scalar @list) { # @list. - &::performStrictReply( &::formListReply(0, $prefix, @list) ); - return; + if ( scalar @list ) { # @list. + &::performStrictReply( &::formListReply( 0, $prefix, @list ) ); + return; } # !@list. &::DEBUG("deb: ok, !\@list, searching desc for '$query'.") if ($debug); @list = &searchDesc($query); - if (!scalar @list) { - my $prefix = "Debian Package/File/Desc Search of '$query' "; - &::performStrictReply( &::formListReply(0, $prefix, ) ); + if ( !scalar @list ) { + my $prefix = "Debian Package/File/Desc Search of '$query' "; + &::performStrictReply( &::formListReply( 0, $prefix, ) ); - } elsif (scalar @list == 1) { # list = 1. - &::DEBUG("deb: list == 1; showing package info of '$list[0]'."); - &infoPackages("info", $list[0]); + } + elsif ( scalar @list == 1 ) { # list = 1. + &::DEBUG("deb: list == 1; showing package info of '$list[0]'."); + &infoPackages( "info", $list[0] ); - } else { # list > 1. - my $prefix = "Debian Desc Search of '$query' "; - &::performStrictReply( &::formListReply(0, $prefix, @list) ); + } + else { # list > 1. + my $prefix = "Debian Desc Search of '$query' "; + &::performStrictReply( &::formListReply( 0, $prefix, @list ) ); } } #### # Usage: &searchAuthor($query); sub searchAuthor { - my ($dist, $query) = &getDistroFromStr($_[0]); - &::DEBUG("deb: searchAuthor: dist => '$dist', query => '$query'.") if ($debug); + my ( $dist, $query ) = &getDistroFromStr( $_[0] ); + &::DEBUG("deb: searchAuthor: dist => '$dist', query => '$query'.") + if ($debug); $query =~ s/^\s+|\s+$//g; # start of search. my $start_time = &::timeget(); &::status("Debian: starting author search."); - my %urls = fixDist($dist,'packages'); + my %urls = fixDist( $dist, 'packages' ); my $files; - my ($bad,$good) = (0,0); - foreach (keys %urls) { - if (! -f $_ ) { - $bad++; - next; - } - - $good++; - $files .= " ".$_; + my ( $bad, $good ) = ( 0, 0 ); + foreach ( keys %urls ) { + if ( !-f $_ ) { + $bad++; + next; + } + + $good++; + $files .= " " . $_; } &::DEBUG("deb: good = $good, bad = $bad...") if ($debug); - if ($good == 0 and $bad != 0) { + if ( $good == 0 and $bad != 0 ) { &::DEBUG("deb: download 2."); - if (!&DebianDownload($dist, %urls)) { - &::ERROR("Debian(sA): could not download files."); - return; - } + if ( !&DebianDownload( $dist, %urls ) ) { + &::ERROR("Debian(sA): could not download files."); + return; + } } - my (%maint, %pkg, $package); - open(IN,"zegrep -h '^Package|^Maintainer' $files |"); + my ( %maint, %pkg, $package ); + open( IN, "zegrep -h '^Package|^Maintainer' $files |" ); while () { - if (/^Package: (\S+)$/) { - $package = $1; - - } elsif (/^Maintainer: (.*) \<(\S+)\>$/) { - my($name,$email) = ($1,$2); - if ($package eq "") { - &::DEBUG("deb: sA: package == NULL."); - next; - } - $maint{$name}{$email} = 1; - $pkg{$name}{$package} = 1; - $package = ""; - - } else { - chop; - &::WARN("debian: invalid line: '$_' (1)."); - } + if (/^Package: (\S+)$/) { + $package = $1; + + } + elsif (/^Maintainer: (.*) \<(\S+)\>$/) { + my ( $name, $email ) = ( $1, $2 ); + if ( $package eq "" ) { + &::DEBUG("deb: sA: package == NULL."); + next; + } + $maint{$name}{$email} = 1; + $pkg{$name}{$package} = 1; + $package = ""; + + } + else { + chop; + &::WARN("debian: invalid line: '$_' (1)."); + } } close IN; my %hash; + # TODO: can we use 'map' here? - foreach (grep /\Q$query\E/i, keys %maint) { - $hash{$_} = 1; + foreach ( grep /\Q$query\E/i, keys %maint ) { + $hash{$_} = 1; } # TODO: should we only search email if '@' is used? - if (scalar keys %hash < 15) { - my $name; - - foreach $name (keys %maint) { - my $email; - - foreach $email (keys %{ $maint{$name} }) { - next unless ($email =~ /\Q$query\E/i); - next if (exists $hash{$name}); - $hash{$name} = 1; - } - } + if ( scalar keys %hash < 15 ) { + my $name; + + foreach $name ( keys %maint ) { + my $email; + + foreach $email ( keys %{ $maint{$name} } ) { + next unless ( $email =~ /\Q$query\E/i ); + next if ( exists $hash{$name} ); + $hash{$name} = 1; + } + } } my @list = keys %hash; - if (scalar @list != 1) { - my $prefix = "Debian Author Search of '$query' "; - &::performStrictReply( &::formListReply(0, $prefix, @list) ); - return 1; + if ( scalar @list != 1 ) { + my $prefix = "Debian Author Search of '$query' "; + &::performStrictReply( &::formListReply( 0, $prefix, @list ) ); + return 1; } &::DEBUG("deb: showing all packages by '$list[0]'...") if ($debug); - my @pkg = sort keys %{ $pkg{$list[0]} }; + my @pkg = sort keys %{ $pkg{ $list[0] } }; # show how long it took. my $delta_time = &::timedelta($start_time); - &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0); + &::status( sprintf( "Debian: %.02f sec to complete query.", $delta_time ) ) + if ( $delta_time > 0 ); - my $email = join(', ', keys %{ $maint{$list[0]} }); - my $prefix = "Debian Packages by $list[0] \002<\002$email\002>\002 "; - &::performStrictReply( &::formListReply(0, $prefix, @pkg) ); + my $email = join( ', ', keys %{ $maint{ $list[0] } } ); + my $prefix = "Debian Packages by $list[0] \002<\002$email\002>\002 "; + &::performStrictReply( &::formListReply( 0, $prefix, @pkg ) ); } #### # Usage: &searchDesc($query); sub searchDesc { - my ($dist, $query) = &getDistroFromStr($_[0]); - &::DEBUG("deb: searchDesc: dist => '$dist', query => '$query'.") if ($debug); + my ( $dist, $query ) = &getDistroFromStr( $_[0] ); + &::DEBUG("deb: searchDesc: dist => '$dist', query => '$query'.") + if ($debug); $query =~ s/^\s+|\s+$//g; # start of search. @@ -469,64 +486,67 @@ sub searchDesc { &::status("Debian: starting desc search."); my $files; - my ($bad,$good) = (0,0); - my %urls = fixDist($dist,'packages'); + my ( $bad, $good ) = ( 0, 0 ); + my %urls = fixDist( $dist, 'packages' ); # XXX This should be abstracted elsewhere. - foreach (keys %urls) { - if (! -f $_ ) { - $bad++; - next; - } - - $good++; - $files .= " $_"; + foreach ( keys %urls ) { + if ( !-f $_ ) { + $bad++; + next; + } + + $good++; + $files .= " $_"; } &::DEBUG("deb(2): good = $good, bad = $bad...") if ($debug); - if ($good == 0 and $bad != 0) { - &::DEBUG("deb: download 2c.") if ($debug); + if ( $good == 0 and $bad != 0 ) { + &::DEBUG("deb: download 2c.") if ($debug); - if (!&DebianDownload($dist, %urls)) { - &::ERROR("deb: sD: could not download files."); - return; - } + if ( !&DebianDownload( $dist, %urls ) ) { + &::ERROR("deb: sD: could not download files."); + return; + } } - my $regex = $query; - $regex =~ s/\./\\./g; - $regex =~ s/\*/\\S*/g; - $regex =~ s/\?/./g; + my $regex = $query; + $regex =~ s/\./\\./g; + $regex =~ s/\*/\\S*/g; + $regex =~ s/\?/./g; - my (%desc, $package); - open(IN,"zegrep -h '^Package|^Description' $files |"); + my ( %desc, $package ); + open( IN, "zegrep -h '^Package|^Description' $files |" ); while () { - if (/^Package: (\S+)$/) { - $package = $1; - } elsif (/^Description: (.*)$/) { - my $desc = $1; - next unless (eval { $desc =~ /$regex/i }); - return unless &checkEval($@); - - if ($package eq "") { - &::WARN("sD: package == NULL?"); - next; - } - - $desc{$package} = $desc; - $package = ""; - - } else { - chop; - &::WARN("debian: invalid line: '$_'. (2)"); - } + if (/^Package: (\S+)$/) { + $package = $1; + } + elsif (/^Description: (.*)$/) { + my $desc = $1; + next unless ( eval { $desc =~ /$regex/i } ); + return unless &checkEval($@); + + if ( $package eq "" ) { + &::WARN("sD: package == NULL?"); + next; + } + + $desc{$package} = $desc; + $package = ""; + + } + else { + chop; + &::WARN("debian: invalid line: '$_'. (2)"); + } } close IN; # show how long it took. my $delta_time = &::timedelta($start_time); - &::status(sprintf("Debian: %.02f sec to complete query.", $delta_time)) if ($delta_time > 0); + &::status( sprintf( "Debian: %.02f sec to complete query.", $delta_time ) ) + if ( $delta_time > 0 ); return keys %desc; } @@ -534,45 +554,45 @@ sub searchDesc { #### # Usage: &generateIncoming(); sub generateIncoming { - my $pkgfile = $debian_dir."/Packages-incoming"; - my $idxfile = $pkgfile.".idx"; - my $stale = 0; - $stale++ if (&::isStale($pkgfile.".gz", $refresh)); - $stale++ if (&::isStale($idxfile, $refresh)); + my $pkgfile = $debian_dir . "/Packages-incoming"; + my $idxfile = $pkgfile . ".idx"; + my $stale = 0; + $stale++ if ( &::isStale( $pkgfile . ".gz", $refresh ) ); + $stale++ if ( &::isStale( $idxfile, $refresh ) ); &::DEBUG("deb: gI: stale => '$stale'.") if ($debug); return 0 unless ($stale); ### STATIC URL. - my %ftp = &::ftpList("llug.sep.bnl.gov", "/pub/debian/Incoming/"); + my %ftp = &::ftpList( "llug.sep.bnl.gov", "/pub/debian/Incoming/" ); - if (!open PKG, ">$pkgfile") { - &::ERROR("cannot write to pkg $pkgfile."); - return 0; + if ( !open PKG, ">$pkgfile" ) { + &::ERROR("cannot write to pkg $pkgfile."); + return 0; } - if (!open IDX, ">$idxfile") { - &::ERROR("cannot write to idx $idxfile."); - return 0; + if ( !open IDX, ">$idxfile" ) { + &::ERROR("cannot write to idx $idxfile."); + return 0; } print IDX "*$pkgfile.gz\n"; my $file; - foreach $file (sort keys %ftp) { - next unless ($file =~ /deb$/); - - if ($file =~ /^(\S+)\_(\S+)\_(\S+)\.deb$/) { - print IDX "$1\n"; - print PKG "Package: $1\n"; - print PKG "Version: $2\n"; - print PKG "Architecture: ", (defined $4) ? $4 : "all", "\n"; - } - print PKG "Filename: $file\n"; - print PKG "Size: $ftp{$file}\n"; - print PKG "\n"; + foreach $file ( sort keys %ftp ) { + next unless ( $file =~ /deb$/ ); + + if ( $file =~ /^(\S+)\_(\S+)\_(\S+)\.deb$/ ) { + print IDX "$1\n"; + print PKG "Package: $1\n"; + print PKG "Version: $2\n"; + print PKG "Architecture: ", ( defined $4 ) ? $4 : "all", "\n"; + } + print PKG "Filename: $file\n"; + print PKG "Size: $ftp{$file}\n"; + print PKG "\n"; } close IDX; close PKG; - system("gzip -9fv $pkgfile"); # lame fix. + system("gzip -9fv $pkgfile"); # lame fix. &::status("Debian: generateIncoming() complete."); } @@ -584,81 +604,94 @@ sub generateIncoming { # Usage: &getPackageInfo($query,$file); sub getPackageInfo { - my ($package, $file) = @_; + my ( $package, $file ) = @_; - if (! -f $file) { - &::status("gPI: file $file does not exist?"); - return 'NULL'; + if ( !-f $file ) { + &::status("gPI: file $file does not exist?"); + return 'NULL'; } my $found = 0; - my (%pkg, $pkg); + my ( %pkg, $pkg ); - open(IN, "/bin/zcat $file 2>&1 |"); + open( IN, "/bin/zcat $file 2>&1 |" ); my $done = 0; - while (!eof IN) { - $_ = ; - - next if (/^ \S+/); # package long description. - - # package line. - if (/^Package: (.*)\n$/) { - $pkg = $1; - if ($pkg =~ /^\Q$package\E$/i) { - $found++; # we can use pkg{'package'} instead. - $pkg{'package'} = $pkg; - } - - next; - } - - if ($found) { - chop; - - if (/^Version: (.*)$/) { - $pkg{'version'} = $1; - } elsif (/^Priority: (.*)$/) { - $pkg{'priority'} = $1; - } elsif (/^Section: (.*)$/) { - $pkg{'section'} = $1; - } elsif (/^Size: (.*)$/) { - $pkg{'size'} = $1; - } elsif (/^Installed-Size: (.*)$/i) { - $pkg{'installed'} = $1; - } elsif (/^Description: (.*)$/) { - $pkg{'desc'} = $1; - } elsif (/^Filename: (.*)$/) { - $pkg{'find'} = $1; - } elsif (/^Pre-Depends: (.*)$/) { - $pkg{'depends'} = "pre-depends on $1"; - } elsif (/^Depends: (.*)$/) { - if (exists $pkg{'depends'}) { - $pkg{'depends'} .= "; depends on $1"; - } else { - $pkg{'depends'} = "depends on $1"; - } - } elsif (/^Maintainer: (.*)$/) { - $pkg{'maint'} = $1; - } elsif (/^Provides: (.*)$/) { - $pkg{'provides'} = $1; - } elsif (/^Suggests: (.*)$/) { - $pkg{'suggests'} = $1; - } elsif (/^Conflicts: (.*)$/) { - $pkg{'conflicts'} = $1; - } + while ( !eof IN ) { + $_ = ; + + next if (/^ \S+/); # package long description. + + # package line. + if (/^Package: (.*)\n$/) { + $pkg = $1; + if ( $pkg =~ /^\Q$package\E$/i ) { + $found++; # we can use pkg{'package'} instead. + $pkg{'package'} = $pkg; + } + + next; + } + + if ($found) { + chop; + + if (/^Version: (.*)$/) { + $pkg{'version'} = $1; + } + elsif (/^Priority: (.*)$/) { + $pkg{'priority'} = $1; + } + elsif (/^Section: (.*)$/) { + $pkg{'section'} = $1; + } + elsif (/^Size: (.*)$/) { + $pkg{'size'} = $1; + } + elsif (/^Installed-Size: (.*)$/i) { + $pkg{'installed'} = $1; + } + elsif (/^Description: (.*)$/) { + $pkg{'desc'} = $1; + } + elsif (/^Filename: (.*)$/) { + $pkg{'find'} = $1; + } + elsif (/^Pre-Depends: (.*)$/) { + $pkg{'depends'} = "pre-depends on $1"; + } + elsif (/^Depends: (.*)$/) { + if ( exists $pkg{'depends'} ) { + $pkg{'depends'} .= "; depends on $1"; + } + else { + $pkg{'depends'} = "depends on $1"; + } + } + elsif (/^Maintainer: (.*)$/) { + $pkg{'maint'} = $1; + } + elsif (/^Provides: (.*)$/) { + $pkg{'provides'} = $1; + } + elsif (/^Suggests: (.*)$/) { + $pkg{'suggests'} = $1; + } + elsif (/^Conflicts: (.*)$/) { + $pkg{'conflicts'} = $1; + } ### &::DEBUG("=> '$_'."); - } + } - # blank line. - if (/^$/) { - undef $pkg; - last if ($found); - next; - } + # blank line. + if (/^$/) { + undef $pkg; + last if ($found); + next; + } - next if (defined $pkg); + next if ( defined $pkg ); } close IN; @@ -668,115 +701,131 @@ sub getPackageInfo { # Usage: &infoPackages($query,$package); sub infoPackages { - my ($query,$dist,$package) = ($_[0], &getDistroFromStr($_[1])); + my ( $query, $dist, $package ) = ( $_[0], &getDistroFromStr( $_[1] ) ); &::status("Debian: Searching for package '$package' in '$dist'."); # download packages file. # hrm... - my %urls = &fixDist($dist,'packages'); - if ($dist ne "incoming") { - &::DEBUG("deb: download 3.") if ($debug); + my %urls = &fixDist( $dist, 'packages' ); + if ( $dist ne "incoming" ) { + &::DEBUG("deb: download 3.") if ($debug); - if (!&DebianDownload($dist, %urls)) { # no good download. - &::WARN("Debian(iP): could not download ANY files."); - } + if ( !&DebianDownload( $dist, %urls ) ) { # no good download. + &::WARN("Debian(iP): could not download ANY files."); + } } # check if the package is valid. my $incoming = 0; - my @files = &validPackage($package, $dist); - if (!scalar @files) { - &::status("Debian: no valid package found; checking incoming."); - @files = &validPackage($package, "incoming"); - - if (scalar @files) { - &::status("Debian: cool, it exists in incoming."); - $incoming++; - } else { - &::msg($::who, "Package '$package' does not exist."); - return 0; - } + my @files = &validPackage( $package, $dist ); + if ( !scalar @files ) { + &::status("Debian: no valid package found; checking incoming."); + @files = &validPackage( $package, "incoming" ); + + if ( scalar @files ) { + &::status("Debian: cool, it exists in incoming."); + $incoming++; + } + else { + &::msg( $::who, "Package '$package' does not exist." ); + return 0; + } } - if (scalar @files > 1) { - &::WARN("same package in more than one file; random."); - &::DEBUG("THIS SHOULD BE FIXED SOMEHOW!!!"); - $files[0] = &::getRandom(@files); + if ( scalar @files > 1 ) { + &::WARN("same package in more than one file; random."); + &::DEBUG("THIS SHOULD BE FIXED SOMEHOW!!!"); + $files[0] = &::getRandom(@files); } - if (! -f $files[0]) { - &::WARN("files[0] ($files[0]) doesn't exist."); - &::msg($::who, "FIXME: $files[0] does not exist?"); - return 'NULL'; + if ( !-f $files[0] ) { + &::WARN("files[0] ($files[0]) doesn't exist."); + &::msg( $::who, "FIXME: $files[0] does not exist?" ); + return 'NULL'; } ### TODO: if specific package is requested, note down that a version ### exists in incoming. my $found = 0; - my $file = $files[0]; + my $file = $files[0]; my ($pkg); ### TODO: use fe, dump to a hash. if only one version of the package ### exists. do as normal otherwise list all versions. - if (! -f $file) { - &::ERROR("D:iP: file '$file' DOES NOT EXIST!!! should never happen."); - return 0; + if ( !-f $file ) { + &::ERROR("D:iP: file '$file' DOES NOT EXIST!!! should never happen."); + return 0; } - my %pkg = &getPackageInfo($package, $file); + my %pkg = &getPackageInfo( $package, $file ); - $query = "info" if ($query eq "dinfo"); + $query = "info" if ( $query eq "dinfo" ); # 'fm'-like output. - if ($query eq "info") { - if (scalar keys %pkg <= 5) { - &::DEBUG("deb: running debianCheck() due to problems (".scalar(keys %pkg).")."); - &debianCheck(); - &::DEBUG("deb: end of debianCheck()"); - - &::msg($::who,"Debian: Package appears to exist but I could not retrieve info about it..."); - return; - } - - $pkg{'info'} = "\002(\002". $pkg{'desc'} ."\002)\002"; - $pkg{'info'} .= ", section ".$pkg{'section'}; - $pkg{'info'} .= ", is ".$pkg{'priority'}; -# $pkg{'info'} .= ". Version: \002$pkg{'version'}\002"; - $pkg{'info'} .= ". Version: \002$pkg{'version'}\002 ($dist)"; - $pkg{'info'} .= ", Packaged size: \002". int($pkg{'size'}/1024) ."\002 kB"; - $pkg{'info'} .= ", Installed size: \002$pkg{'installed'}\002 kB"; - - if ($incoming) { - &::status("iP: info requested and pkg is in incoming, too."); - my %incpkg = &getPackageInfo($query, $debian_dir ."/Packages-incoming"); - - if (scalar keys %incpkg) { - $pkg{'info'} .= ". Is in incoming ($incpkg{'file'})."; - } else { - &::ERROR("iP: pkg $query is in incoming but we couldn't get any info?"); - } - } - } - - if ($dist eq "incoming") { - $pkg{'info'} .= "Version: \002$pkg{'version'}\002"; - $pkg{'info'} .= ", Packaged size: \002". int($pkg{'size'}/1024) ."\002 kB"; - $pkg{'info'} .= ", is in incoming!!!"; - } - - if (!exists $pkg{$query}) { - if ($query eq "suggests") { - $pkg{$query} = "has no suggestions"; - } elsif ($query eq "conflicts") { - $pkg{$query} = "does not conflict with any other package"; - } elsif ($query eq "depends") { - $pkg{$query} = "does not depend on anything"; - } elsif ($query eq "maint") { - $pkg{$query} = "has no maintainer"; - } else { - $pkg{$query} = "has nothing about $query"; - } + if ( $query eq "info" ) { + if ( scalar keys %pkg <= 5 ) { + &::DEBUG( "deb: running debianCheck() due to problems (" + . scalar( keys %pkg ) + . ")." ); + &debianCheck(); + &::DEBUG("deb: end of debianCheck()"); + + &::msg( $::who, +"Debian: Package appears to exist but I could not retrieve info about it..." + ); + return; + } + + $pkg{'info'} = "\002(\002" . $pkg{'desc'} . "\002)\002"; + $pkg{'info'} .= ", section " . $pkg{'section'}; + $pkg{'info'} .= ", is " . $pkg{'priority'}; + + # $pkg{'info'} .= ". Version: \002$pkg{'version'}\002"; + $pkg{'info'} .= ". Version: \002$pkg{'version'}\002 ($dist)"; + $pkg{'info'} .= + ", Packaged size: \002" . int( $pkg{'size'} / 1024 ) . "\002 kB"; + $pkg{'info'} .= ", Installed size: \002$pkg{'installed'}\002 kB"; + + if ($incoming) { + &::status("iP: info requested and pkg is in incoming, too."); + my %incpkg = + &getPackageInfo( $query, $debian_dir . "/Packages-incoming" ); + + if ( scalar keys %incpkg ) { + $pkg{'info'} .= ". Is in incoming ($incpkg{'file'})."; + } + else { + &::ERROR( +"iP: pkg $query is in incoming but we couldn't get any info?" + ); + } + } + } + + if ( $dist eq "incoming" ) { + $pkg{'info'} .= "Version: \002$pkg{'version'}\002"; + $pkg{'info'} .= + ", Packaged size: \002" . int( $pkg{'size'} / 1024 ) . "\002 kB"; + $pkg{'info'} .= ", is in incoming!!!"; + } + + if ( !exists $pkg{$query} ) { + if ( $query eq "suggests" ) { + $pkg{$query} = "has no suggestions"; + } + elsif ( $query eq "conflicts" ) { + $pkg{$query} = "does not conflict with any other package"; + } + elsif ( $query eq "depends" ) { + $pkg{$query} = "does not depend on anything"; + } + elsif ( $query eq "maint" ) { + $pkg{$query} = "has no maintainer"; + } + else { + $pkg{$query} = "has nothing about $query"; + } } &::performStrictReply("$package: $pkg{$query}"); @@ -784,78 +833,82 @@ sub infoPackages { # Usage: &infoStats($dist); sub infoStats { - my ($dist) = @_; - $dist = &getDistro($dist); - return unless (defined $dist); + my ($dist) = @_; + $dist = &getDistro($dist); + return unless ( defined $dist ); &::DEBUG("deb: infoS: dist => '$dist'."); # download packages file if needed. - my %urls = &fixDist($dist,'packages'); + my %urls = &fixDist( $dist, 'packages' ); &::DEBUG("deb: download 4."); - if (!&DebianDownload($dist, %urls)) { - &::WARN("Debian(iS): could not download ANY files."); - &::msg($::who, "Debian(iS): internal error."); - return; + if ( !&DebianDownload( $dist, %urls ) ) { + &::WARN("Debian(iS): could not download ANY files."); + &::msg( $::who, "Debian(iS): internal error." ); + return; } my %stats; - my %total = (count => 0, maint => 0, isize => 0, csize => 0); + my %total = ( count => 0, maint => 0, isize => 0, csize => 0 ); my $file; - foreach $file (keys %urls) { - &::DEBUG("deb: file => '$file'."); - if (exists $stats{$file}{'count'}) { - &::DEBUG("deb: hrm... duplicate open with $file???"); - next; - } - - open(IN, "zcat $file 2>&1 |"); - - if (! -e "$file") { - &::DEBUG("deb: iS: $file does not exist."); - next; - } - - while (!eof IN) { - $_ = ; - - next if (/^ \S+/); # package long description. - - if (/^Package: (.*)\n$/) { # counter. - $stats{$file}{'count'}++; - $total{'count'}++; - } elsif (/^Maintainer: .* <(\S+)>$/) { - $stats{$file}{'maint'}{$1}++; - $total{'maint'}{$1}++; - } elsif (/^Size: (.*)$/) { # compressed size. - $stats{$file}{'csize'} += $1; - $total{'csize'} += $1; - } elsif (/^i.*size: (.*)$/i) { # installed size. - $stats{$file}{'isize'} += $1; - $total{'isize'} += $1; - } + foreach $file ( keys %urls ) { + &::DEBUG("deb: file => '$file'."); + if ( exists $stats{$file}{'count'} ) { + &::DEBUG("deb: hrm... duplicate open with $file???"); + next; + } + + open( IN, "zcat $file 2>&1 |" ); + + if ( !-e "$file" ) { + &::DEBUG("deb: iS: $file does not exist."); + next; + } + + while ( !eof IN ) { + $_ = ; + + next if (/^ \S+/); # package long description. + + if (/^Package: (.*)\n$/) { # counter. + $stats{$file}{'count'}++; + $total{'count'}++; + } + elsif (/^Maintainer: .* <(\S+)>$/) { + $stats{$file}{'maint'}{$1}++; + $total{'maint'}{$1}++; + } + elsif (/^Size: (.*)$/) { # compressed size. + $stats{$file}{'csize'} += $1; + $total{'csize'} += $1; + } + elsif (/^i.*size: (.*)$/i) { # installed size. + $stats{$file}{'isize'} += $1; + $total{'isize'} += $1; + } ### &::DEBUG("=> '$_'."); - } - close IN; + } + close IN; } ### TODO: don't count ppl with multiple email addresses. - &::performStrictReply( - "Debian Distro Stats on $dist... ". - "\002$total{'count'}\002 packages, ". - "\002".scalar(keys %{ $total{'maint'} })."\002 maintainers, ". - "\002". int($total{'isize'}/1024)."\002 MB installed size, ". - "\002". int($total{'csize'}/1024/1024)."\002 MB compressed size." - ); + &::performStrictReply( "Debian Distro Stats on $dist... " + . "\002$total{'count'}\002 packages, " . "\002" + . scalar( keys %{ $total{'maint'} } ) + . "\002 maintainers, " . "\002" + . int( $total{'isize'} / 1024 ) + . "\002 MB installed size, " . "\002" + . int( $total{'csize'} / 1024 / 1024 ) + . "\002 MB compressed size." ); ### TODO: do individual stats? if so, we need _another_ arg. -# foreach $file (keys %stats) { -# foreach (keys %{ $stats{$file} }) { -# &::DEBUG(" '$file' '$_' '$stats{$file}{$_}'."); -# } -# } + # foreach $file (keys %stats) { + # foreach (keys %{ $stats{$file} }) { + # &::DEBUG(" '$file' '$_' '$stats{$file}{$_}'."); + # } + # } return; } @@ -866,61 +919,62 @@ sub infoStats { # Usage: &generateIndex(); sub generateIndex { - my (@dists) = @_; - &::DEBUG("D: generateIndex($dists[0]) called! ".join(':',caller(),)); - if (!scalar @dists or $dists[0] eq '') { - &::ERROR("gI: no dists to generate index."); - return 1; + my (@dists) = @_; + &::DEBUG( "D: generateIndex($dists[0]) called! " . join( ':', caller(), ) ); + if ( !scalar @dists or $dists[0] eq '' ) { + &::ERROR("gI: no dists to generate index."); + return 1; } foreach (@dists) { - my $dist = &getDistro($_); # incase the alias is returned, possible? - my $idx = $debian_dir."/Packages-$dist.idx"; - my %urls = fixDist($_,'packages'); - - # TODO: check if any of the Packages file have been updated then - # regenerate it, even if it's not stale. - # TODO: also, regenerate the index if the packages file is newer - # than the index. - next unless (&::isStale($idx, $refresh)); - - if (/^incoming$/i) { - &::DEBUG("deb: gIndex: calling generateIncoming()!"); - &generateIncoming(); - next; - } - -# if (/^sarge$/i) { -# &::DEBUG("deb: Copying old index of sarge to -old"); -# system("cp $idx $idx-old"); -# } - - &::DEBUG("deb: gIndex: calling DebianDownload($dist, ...).") if ($debug); - &DebianDownload($dist, &fixDist($dist,'packages') ); - - &::status("Debian: generating index for '$dist'."); - if (!open OUT, ">$idx") { - &::ERROR("cannot write to $idx."); - return 0; - } - - my $packages; - foreach $packages (keys %urls) { - if (! -e $packages) { - &::ERROR("gIndex: '$packages' does not exist?"); - next; - } - - print OUT "*$packages\n"; - open(IN,"zcat $packages |"); - - while () { - next unless (/^Package: (.*)\n$/); - print OUT $1."\n"; - } - close IN; - } - close OUT; + my $dist = &getDistro($_); # incase the alias is returned, possible? + my $idx = $debian_dir . "/Packages-$dist.idx"; + my %urls = fixDist( $_, 'packages' ); + + # TODO: check if any of the Packages file have been updated then + # regenerate it, even if it's not stale. + # TODO: also, regenerate the index if the packages file is newer + # than the index. + next unless ( &::isStale( $idx, $refresh ) ); + + if (/^incoming$/i) { + &::DEBUG("deb: gIndex: calling generateIncoming()!"); + &generateIncoming(); + next; + } + + # if (/^sarge$/i) { + # &::DEBUG("deb: Copying old index of sarge to -old"); + # system("cp $idx $idx-old"); + # } + + &::DEBUG("deb: gIndex: calling DebianDownload($dist, ...).") + if ($debug); + &DebianDownload( $dist, &fixDist( $dist, 'packages' ) ); + + &::status("Debian: generating index for '$dist'."); + if ( !open OUT, ">$idx" ) { + &::ERROR("cannot write to $idx."); + return 0; + } + + my $packages; + foreach $packages ( keys %urls ) { + if ( !-e $packages ) { + &::ERROR("gIndex: '$packages' does not exist?"); + next; + } + + print OUT "*$packages\n"; + open( IN, "zcat $packages |" ); + + while () { + next unless (/^Package: (.*)\n$/); + print OUT $1 . "\n"; + } + close IN; + } + close OUT; } return 1; @@ -928,99 +982,100 @@ sub generateIndex { # Usage: &validPackage($package, $dist); sub validPackage { - my ($package,$dist) = @_; + my ( $package, $dist ) = @_; my @files; my $file; ### this majorly sucks, we need some standard in place. # why is this needed... need to investigate later. - my $olddist = $dist; + my $olddist = $dist; $dist = &getDistro($dist); &::DEBUG("deb: validPackage($package, $dist) called.") if ($debug); my $error = 0; - while (!open IN, $debian_dir."/Packages-$dist.idx") { - if ($error) { - &::ERROR("Packages-$dist.idx does not exist (#1)."); - return; - } + while ( !open IN, $debian_dir . "/Packages-$dist.idx" ) { + if ($error) { + &::ERROR("Packages-$dist.idx does not exist (#1)."); + return; + } - &generateIndex($dist); + &generateIndex($dist); - $error++; + $error++; } my $count = 0; while () { - if (/^\*(.*)\n$/) { - $file = $1; - next; - } - - if (/^\Q$package\E\n$/) { - push(@files,$file); - } - $count++; + if (/^\*(.*)\n$/) { + $file = $1; + next; + } + + if (/^\Q$package\E\n$/) { + push( @files, $file ); + } + $count++; } close IN; - &::VERB("vP: scanned $count items in index.",2); + &::VERB( "vP: scanned $count items in index.", 2 ); return @files; } sub searchPackage { - my ($dist, $query) = &getDistroFromStr($_[0]); - my $file = $debian_dir."/Packages-$dist.idx"; - my $warn = ($query =~ tr/A-Z/a-z/) ? 1 : 0; - my $error = 0; + my ( $dist, $query ) = &getDistroFromStr( $_[0] ); + my $file = $debian_dir . "/Packages-$dist.idx"; + my $warn = ( $query =~ tr/A-Z/a-z/ ) ? 1 : 0; + my $error = 0; my @files; &::status("Debian: Search package matching '$query' in '$dist'."); unlink $file if ( -z $file ); - while (!open IN, $file) { - if ($dist eq "incoming") { - &::DEBUG("deb: sP: dist == incoming; calling gI()."); - &generateIncoming(); - } + while ( !open IN, $file ) { + if ( $dist eq "incoming" ) { + &::DEBUG("deb: sP: dist == incoming; calling gI()."); + &generateIncoming(); + } - if ($error) { - &::ERROR("could not generate index ($file)!"); - return; - } + if ($error) { + &::ERROR("could not generate index ($file)!"); + return; + } - $error++; - &::DEBUG("deb: should we be doing this?"); - &generateIndex(($dist)); + $error++; + &::DEBUG("deb: should we be doing this?"); + &generateIndex( ($dist) ); } while () { - chop; + chop; - if (/^\*(.*)$/) { - $file = $1; + if (/^\*(.*)$/) { + $file = $1; - if (&::isStale($file, $refresh)) { - &::DEBUG("deb: STALE $file! regen.") if ($debug); - &generateIndex(($dist)); + if ( &::isStale( $file, $refresh ) ) { + &::DEBUG("deb: STALE $file! regen.") if ($debug); + &generateIndex( ($dist) ); ### @files = searchPackage("$query $dist"); - &::DEBUG("deb: EVIL HACK HACK HACK.") if ($debug); - last; - } + &::DEBUG("deb: EVIL HACK HACK HACK.") if ($debug); + last; + } - next; - } + next; + } - if (/\Q$query\E/) { - push(@files,$_); - } + if (/\Q$query\E/) { + push( @files, $_ ); + } } close IN; - if (scalar @files and $warn) { - &::msg($::who, "searching for package name should be fully lowercase!"); + if ( scalar @files and $warn ) { + &::msg( $::who, + "searching for package name should be fully lowercase!" ); } return @files; @@ -1029,158 +1084,173 @@ sub searchPackage { sub getDistro { my $dist = $_[0]; - if (!defined $dist or $dist eq "") { - &::DEBUG("deb: gD: dist == NULL; dist = defaultdist."); - $dist = $defaultdist; + if ( !defined $dist or $dist eq "" ) { + &::DEBUG("deb: gD: dist == NULL; dist = defaultdist."); + $dist = $defaultdist; } - if (exists $dists{$dist}) { - &::VERB("gD: returning dists{$dist} ($dists{$dist})",2); - return $dists{$dist}; + if ( exists $dists{$dist} ) { + &::VERB( "gD: returning dists{$dist} ($dists{$dist})", 2 ); + return $dists{$dist}; } - elsif (exists $archived_dists{$dist}){ - &::VERB("gD: returning archivedists{$dist} ($archived_dists{$dist})",2); - return $archived_dists{$dist}; + elsif ( exists $archived_dists{$dist} ) { + &::VERB( "gD: returning archivedists{$dist} ($archived_dists{$dist})", + 2 ); + return $archived_dists{$dist}; } else { - if (!grep(/^\Q$dist\E$/i, %dists) and !grep(/^\Q$dist\E$/i, %archived_dists)) { - &::msg($::who, "invalid dist '$dist'."); - return; - } - - &::VERB("gD: returning $dist (no change or conversion)",2); - return $dist; + if ( !grep( /^\Q$dist\E$/i, %dists ) + and !grep( /^\Q$dist\E$/i, %archived_dists ) ) + { + &::msg( $::who, "invalid dist '$dist'." ); + return; + } + + &::VERB( "gD: returning $dist (no change or conversion)", 2 ); + return $dist; } } sub getDistroFromStr { my ($str) = @_; - my $dists = join '|', %dists, %archived_dists; - my $dist = $defaultdist; + my $dists = join '|', %dists, %archived_dists; + my $dist = $defaultdist; - if ($str =~ s/\s+($dists)$//i) { - $dist = &getDistro(lc $1); - $str =~ s/\\+$//; + if ( $str =~ s/\s+($dists)$//i ) { + $dist = &getDistro( lc $1 ); + $str =~ s/\\+$//; } $str =~ s/\\([\$\^])/$1/g; - return($dist,$str); + return ( $dist, $str ); } sub fixDist { - my ($dist, $type) = @_; + my ( $dist, $type ) = @_; my %new; - my ($key,$val); + my ( $key, $val ); my %dist_urls; - if (exists $archived_dists{$dist}){ - if ($type eq 'contents'){ - %dist_urls = %archiveurlcontents; - } - else { - %dist_urls = %archiveurlpackages; - } + if ( exists $archived_dists{$dist} ) { + if ( $type eq 'contents' ) { + %dist_urls = %archiveurlcontents; + } + else { + %dist_urls = %archiveurlpackages; + } } else { - if ($type eq 'contents'){ - %dist_urls = %urlcontents; - } - else { - %dist_urls = %urlpackages; - } + if ( $type eq 'contents' ) { + %dist_urls = %urlcontents; + } + else { + %dist_urls = %urlpackages; + } } - while (($key,$val) = each %dist_urls) { - $key =~ s/##DIST/$dist/; - $val =~ s/##DIST/$dist/; - ### TODO: what should we do if the sar wasn't done. - $new{$debian_dir."/".$key} = $val; + while ( ( $key, $val ) = each %dist_urls ) { + $key =~ s/##DIST/$dist/; + $val =~ s/##DIST/$dist/; + ### TODO: what should we do if the sar wasn't done. + $new{ $debian_dir . "/" . $key } = $val; } return %new; } sub DebianFind { + # HACK! HACK! HACK! my ($str) = @_; - my ($dist, $query) = &getDistroFromStr($str); + my ( $dist, $query ) = &getDistroFromStr($str); my @results = sort &searchPackage($str); - if (!scalar @results) { - &::Forker("Debian", sub { &searchContents($str); } ); - } elsif (scalar @results == 1) { - &::status("searchPackage returned one result; getting info of package instead!"); - &::Forker("Debian", sub { &infoPackages("info", "$results[0] $dist"); } ); - } else { - my $prefix = "Debian Package Listing of '$query' "; - &::performStrictReply( &::formListReply(0, $prefix, @results) ); + if ( !scalar @results ) { + &::Forker( "Debian", sub { &searchContents($str); } ); + } + elsif ( scalar @results == 1 ) { + &::status( +"searchPackage returned one result; getting info of package instead!" + ); + &::Forker( "Debian", + sub { &infoPackages( "info", "$results[0] $dist" ); } ); + } + else { + my $prefix = "Debian Package Listing of '$query' "; + &::performStrictReply( &::formListReply( 0, $prefix, @results ) ); } } sub debianCheck { - my $error = 0; + my $error = 0; &::status("debianCheck() called."); ### TODO: remove the following loop (check if dir exists before) while (1) { - last if (opendir(DEBIAN, $debian_dir)); + last if ( opendir( DEBIAN, $debian_dir ) ); - if ($error) { - &::ERROR("dC: cannot opendir debian."); - return; - } + if ($error) { + &::ERROR("dC: cannot opendir debian."); + return; + } - mkdir $debian_dir, 0755; - $error++; + mkdir $debian_dir, 0755; + $error++; } my $retval = 0; my $file; - while (defined($file = readdir DEBIAN)) { - next unless ($file =~ /(gz|bz2)$/); - - # TODO: add bzip2 support (debian doesn't do .bz2 anyway) - my $exit = system("/bin/gzip -t '$debian_dir/$file'"); - next unless ($exit); - &::DEBUG("deb: hmr... => ".(time() - (stat($debian_dir/$file))[8])."'."); - next unless (time() - (stat($file))[8] > 3600); - - #&::DEBUG("deb: dC: exit => '$exit'."); - &::WARN("dC: '$debian_dir/$file' corrupted? deleting!"); - unlink $debian_dir."/".$file; - $retval++; + while ( defined( $file = readdir DEBIAN ) ) { + next unless ( $file =~ /(gz|bz2)$/ ); + + # TODO: add bzip2 support (debian doesn't do .bz2 anyway) + my $exit = system("/bin/gzip -t '$debian_dir/$file'"); + next unless ($exit); + &::DEBUG( "deb: hmr... => " + . ( time() - ( stat( $debian_dir / $file ) )[8] ) + . "'." ); + next unless ( time() - ( stat($file) )[8] > 3600 ); + + #&::DEBUG("deb: dC: exit => '$exit'."); + &::WARN("dC: '$debian_dir/$file' corrupted? deleting!"); + unlink $debian_dir . "/" . $file; + $retval++; } return $retval; } sub checkEval { - my($str) = @_; + my ($str) = @_; if ($str) { - &::WARN("cE: $str"); - return 0; - } else { - return 1; + &::WARN("cE: $str"); + return 0; + } + else { + return 1; } } sub searchDescFE { -# &::DEBUG("deb: FE called for searchDesc"); - my ($query) = @_; + + # &::DEBUG("deb: FE called for searchDesc"); + my ($query) = @_; my @list = &searchDesc($query); - if (!scalar @list) { - my $prefix = "Debian Desc Search of '$query' "; - &::performStrictReply( &::formListReply(0, $prefix, ) ); - } elsif (scalar @list == 1) { # list = 1. - &::DEBUG("deb: list == 1; showing package info of '$list[0]'."); - &infoPackages("info", $list[0]); - } else { # list > 1. - my $prefix = "Debian Desc Search of '$query' "; - &::performStrictReply( &::formListReply(0, $prefix, @list) ); + if ( !scalar @list ) { + my $prefix = "Debian Desc Search of '$query' "; + &::performStrictReply( &::formListReply( 0, $prefix, ) ); + } + elsif ( scalar @list == 1 ) { # list = 1. + &::DEBUG("deb: list == 1; showing package info of '$list[0]'."); + &infoPackages( "info", $list[0] ); + } + else { # list > 1. + my $prefix = "Debian Desc Search of '$query' "; + &::performStrictReply( &::formListReply( 0, $prefix, @list ) ); } } diff --git a/src/Modules/DebianBugs.pm b/src/Modules/DebianBugs.pm index 42a9948..eccefd7 100644 --- a/src/Modules/DebianBugs.pm +++ b/src/Modules/DebianBugs.pm @@ -17,103 +17,122 @@ use LWP::UserAgent; $VERSION = q($Rev: $); $DEBUG ||= 0; -sub get_url($){ - my $url = shift; - - my $ua = LWP::UserAgent->new; - $ua->agent("blootbug_debbugs/$VERSION"); - - # Create a request - my $req = HTTP::Request->new(GET => $url); - # Pass request to the user agent and get a response back - my $res = $ua->request($req); - # Check the outcome of the response - if ($res->is_success) { - return $res->content; - } else { - return undef; - } +sub get_url($) { + my $url = shift; + + my $ua = LWP::UserAgent->new; + $ua->agent("blootbug_debbugs/$VERSION"); + + # Create a request + my $req = HTTP::Request->new( GET => $url ); + + # Pass request to the user agent and get a response back + my $res = $ua->request($req); + + # Check the outcome of the response + if ( $res->is_success ) { + return $res->content; + } + else { + return undef; + } } -sub bug_info($;$){ - my $bug_num = shift; - my $options = shift || {}; - - if (not $bug_num =~ /^\#?\d+$/) { - warn "Bug is not a number!" and return undef if not $options->{return_warnings}; - return "Bug is not a number!"; - } - $bug_num =~ s/^\#//; - my $report = get_url("http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=$bug_num"); - - # strip down report to relevant header information. - $report =~ /(.+?)
/s; - $report = $1; - my $bug = {}; - ($bug->{num},$bug->{title}) = $report =~ m#\#(\d+)\<\/A\>\(.+?)\<\/H1\>#is; - if ($DEBUG) { - print "Bugnum: $bug->{num}\nTitle: $bug->{title}\nReport: $report\n"; - } - $bug->{title} =~ s/</\{title} =~ s/>/\>/g; - $bug->{title} =~ s/"/\"/g; - $bug->{severity} = 'n'; #Default severity is normal - my @bug_flags = split /(?{severity}) = $bug_flag =~ /(wishlist|minor|normal|important|serious|grave)/i; - # Just leave the leter instead of the whole thing. - $bug->{severity} =~ s/^(.).+$/$1/; - } - elsif ($bug_flag =~ /Package:/) { - ($bug->{package}) = $bug_flag =~ /\"\>\s*([^\<\>\"]+?)\s*\<\/a\>/; - } - elsif ($bug_flag =~ /Reported by:/) { - ($bug->{reporter}) = $bug_flag =~ /\"\>\s*(.+?)\s*\<\/a\>/; - # strip < and > - $bug->{reporter} =~ s/</\{reporter} =~ s/>/\>/g; - } - elsif ($bug_flag =~ /Date:/) { - ($bug->{date}) = $bug_flag =~ /Date:\s*(\w.+?)\s*$/; - #ditch extra whitespace - $bug->{date} =~ s/\s{2,}/\ /; - } - elsif ($bug_flag =~ /Tags:/) { - ($bug->{tags}) = $bug_flag =~ /strong\>\s*(.+?)\s*\<\/strong\>/; - } - elsif ($bug_flag =~ /merged with /) { - $bug_flag =~ s/merged with\s*//; - $bug_flag =~ s/\<[^\>]+\>//g; - $bug_flag =~ s/\s//sg; - $bug->{merged_with} = $bug_flag; - - } - elsif ($bug_flag =~ /\>Done:\{done} = 1; - } - elsif ($bug_flag =~ /\>Fixed\{done} = 1; - } - } - # report bug - - $report = ''; - $report .= 'DONE:' if defined $bug->{done} and $bug->{done}; - $report .= '#'.$bug->{num}.':'.uc($bug->{severity}).'['.$bug->{package}.'] '.$bug->{title}; - $report .= ' ('.$bug->{tags}.')' if defined $bug->{tags}; - $report .= '; ' . $bug->{date}; - # Avoid reporting so many merged bugs. - $report .= ' ['.join(',',splice(@{[split(/,/,$bug->{merged_with})]},0,3)).']' if defined $bug->{merged_with}; - if ($DEBUG) { - use Data::Dumper; - print STDERR Dumper($bug); - } - return $report; +sub bug_info($;$) { + my $bug_num = shift; + my $options = shift || {}; + + if ( not $bug_num =~ /^\#?\d+$/ ) { + warn "Bug is not a number!" and return undef + if not $options->{return_warnings}; + return "Bug is not a number!"; + } + $bug_num =~ s/^\#//; + my $report = + get_url("http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=$bug_num"); + + # strip down report to relevant header information. + $report =~ /(.+?)
/s; + $report = $1; + my $bug = {}; + ( $bug->{num}, $bug->{title} ) = + $report =~ m#\#(\d+)\<\/A\>\(.+?)\<\/H1\>#is; + if ($DEBUG) { + print "Bugnum: $bug->{num}\nTitle: $bug->{title}\nReport: $report\n"; + } + $bug->{title} =~ s/</\{title} =~ s/>/\>/g; + $bug->{title} =~ s/"/\"/g; + $bug->{severity} = 'n'; #Default severity is normal + my @bug_flags = split /(?{severity} ) = + $bug_flag =~ /(wishlist|minor|normal|important|serious|grave)/i; + + # Just leave the leter instead of the whole thing. + $bug->{severity} =~ s/^(.).+$/$1/; + } + elsif ( $bug_flag =~ /Package:/ ) { + ( $bug->{package} ) = $bug_flag =~ /\"\>\s*([^\<\>\"]+?)\s*\<\/a\>/; + } + elsif ( $bug_flag =~ /Reported by:/ ) { + ( $bug->{reporter} ) = $bug_flag =~ /\"\>\s*(.+?)\s*\<\/a\>/; + + # strip < and > + $bug->{reporter} =~ s/</\{reporter} =~ s/>/\>/g; + } + elsif ( $bug_flag =~ /Date:/ ) { + ( $bug->{date} ) = $bug_flag =~ /Date:\s*(\w.+?)\s*$/; + + #ditch extra whitespace + $bug->{date} =~ s/\s{2,}/\ /; + } + elsif ( $bug_flag =~ /Tags:/ ) { + ( $bug->{tags} ) = $bug_flag =~ /strong\>\s*(.+?)\s*\<\/strong\>/; + } + elsif ( $bug_flag =~ /merged with / ) { + $bug_flag =~ s/merged with\s*//; + $bug_flag =~ s/\<[^\>]+\>//g; + $bug_flag =~ s/\s//sg; + $bug->{merged_with} = $bug_flag; + + } + elsif ( $bug_flag =~ /\>Done:\{done} = 1; + } + elsif ( $bug_flag =~ /\>Fixed\{done} = 1; + } + } + + # report bug + + $report = ''; + $report .= 'DONE:' if defined $bug->{done} and $bug->{done}; + $report .= '#' + . $bug->{num} . ':' + . uc( $bug->{severity} ) . '[' + . $bug->{package} . '] ' + . $bug->{title}; + $report .= ' (' . $bug->{tags} . ')' if defined $bug->{tags}; + $report .= '; ' . $bug->{date}; + + # Avoid reporting so many merged bugs. + $report .= ' [' + . join( ',', splice( @{ [ split( /,/, $bug->{merged_with} ) ] }, 0, 3 ) ) + . ']' + if defined $bug->{merged_with}; + if ($DEBUG) { + use Data::Dumper; + print STDERR Dumper($bug); + } + return $report; } -sub package_bugs($){ +sub package_bugs($) { } diff --git a/src/Modules/DebianExtra.pl b/src/Modules/DebianExtra.pl index 6645596..8df9343 100644 --- a/src/Modules/DebianExtra.pl +++ b/src/Modules/DebianExtra.pl @@ -10,142 +10,165 @@ use strict; package DebianExtra; sub Parse { - my($args) = @_; - my($msg) = ''; + my ($args) = @_; + my ($msg) = ''; #&::DEBUG("DebianExtra: $args\n"); - if (!defined $args or $args =~ /^$/) { - &debianBugs(); + if ( !defined $args or $args =~ /^$/ ) { + &debianBugs(); } - if ($args =~ /^\#?(\d+)$/) { - # package number: - $msg = &do_id($args); - } elsif ($args =~ /^(\S+\@\S+)$/) { - # package email maintainer. - $msg = &do_email($args); - } elsif ($args =~ /^(\S+)$/) { - # package name. - $msg = &do_pkg($args); - } else { - # invalid. - $msg = "error: could not parse $args"; + if ( $args =~ /^\#?(\d+)$/ ) { + + # package number: + $msg = &do_id($args); + } + elsif ( $args =~ /^(\S+\@\S+)$/ ) { + + # package email maintainer. + $msg = &do_email($args); + } + elsif ( $args =~ /^(\S+)$/ ) { + + # package name. + $msg = &do_pkg($args); + } + else { + + # invalid. + $msg = "error: could not parse $args"; } &::performStrictReply($msg); } sub debianBugs { my @results = &::getURL("http://master.debian.org/~wakkerma/bugs"); - my ($date, $rcbugs, $remove); - my ($bugs_closed, $bugs_opened) = (0,0); - - if (scalar @results) { - foreach (@results) { - s/<.*?>//g; - $date = $1 if (/status at (.*)\s*$/); - $rcbugs = $1 if (/bugs: (\d+)/); - $remove = $1 if (/REMOVE\S+ (\d+)\s*$/); - if (/^(\d+) r\S+ b\S+ w\S+ c\S+ a\S+ (\d+)/) { - $bugs_closed = $1; - $bugs_opened = $2; - } - } - my $xtxt = ($bugs_closed >=$bugs_opened) ? - "It's good to see " : - "Oh no, the bug count is rising -- "; - - &::performStrictReply( - "Debian bugs statistics, last updated on $date... ". - "There are \002$rcbugs\002 release-critical bugs; $xtxt". - "\002$bugs_closed\002 bugs closed, opening \002$bugs_opened\002 bugs. ". - "About \002$remove\002 packages will be removed." - ); - } else { - &::msg($::who, "Couldn't retrieve data for debian bug stats."); + my ( $date, $rcbugs, $remove ); + my ( $bugs_closed, $bugs_opened ) = ( 0, 0 ); + + if ( scalar @results ) { + foreach (@results) { + s/<.*?>//g; + $date = $1 if (/status at (.*)\s*$/); + $rcbugs = $1 if (/bugs: (\d+)/); + $remove = $1 if (/REMOVE\S+ (\d+)\s*$/); + if (/^(\d+) r\S+ b\S+ w\S+ c\S+ a\S+ (\d+)/) { + $bugs_closed = $1; + $bugs_opened = $2; + } + } + my $xtxt = + ( $bugs_closed >= $bugs_opened ) + ? "It's good to see " + : "Oh no, the bug count is rising -- "; + + &::performStrictReply( + "Debian bugs statistics, last updated on $date... " + . "There are \002$rcbugs\002 release-critical bugs; $xtxt" + . "\002$bugs_closed\002 bugs closed, opening \002$bugs_opened\002 bugs. " + . "About \002$remove\002 packages will be removed." ); + } + else { + &::msg( $::who, "Couldn't retrieve data for debian bug stats." ); } } -sub do_id($){ +sub do_id($) { my ($bug_num) = shift; - if (not $bug_num =~ /^\#?\d+$/) { - return "Bug is not a number!"; + if ( not $bug_num =~ /^\#?\d+$/ ) { + return "Bug is not a number!"; } $bug_num =~ s/^\#//; - my @results = &::getURL("http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=$bug_num"); - my $report = join("\n", @results); + my @results = + &::getURL("http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=$bug_num"); + my $report = join( "\n", @results ); # strip down report to relevant header information. -# $report =~ s/\r//sig; + # $report =~ s/\r//sig; $report =~ /]*>(.+?)
/si; $report = $1; my $bug = {}; - ($bug->{num},$bug->{title}) = $report =~ m#\#(\d+)\<\/A\>\(.+?)\<\/H1\>#is; + ( $bug->{num}, $bug->{title} ) = + $report =~ m#\#(\d+)\<\/A\>\(.+?)\<\/H1\>#is; &::DEBUG("Bugnum: $bug->{num}\n"); $bug->{title} =~ s/</\{title} =~ s/>/\>/g; $bug->{title} =~ s/"/\"/g; &::DEBUG("Title: $bug->{title}\n"); - $bug->{severity} = 'n'; #Default severity is normal + $bug->{severity} = 'n'; #Default severity is normal my @bug_flags = split /(?{severity}) = $bug_flag =~ /(wishlist|minor|normal|important|serious|grave)/i; - # Just leave the leter instead of the whole thing. - $bug->{severity} =~ s/^(.).+$/$1/; - } - elsif ($bug_flag =~ /Package:/) { - ($bug->{package}) = $bug_flag =~ /\"\>\s*([^\<\>\"]+?)\s*\<\/a\>/; - } - elsif ($bug_flag =~ /Reported by:/) { - ($bug->{reporter}) = $bug_flag =~ /\"\>\s*(.+?)\s*\<\/a\>/; - # strip < and > - $bug->{reporter} =~ s/</\{reporter} =~ s/>/\>/g; - } - elsif ($bug_flag =~ /Date:/) { - ($bug->{date}) = $bug_flag =~ /Date:\s*(\w.+?)\s*$/; - #ditch extra whitespace - $bug->{date} =~ s/\s{2,}/\ /; - } - elsif ($bug_flag =~ /Tags:/) { - ($bug->{tags}) = $bug_flag =~ /strong\>\s*(.+?)\s*\<\/strong\>/; - } - elsif ($bug_flag =~ /merged with /) { - $bug_flag =~ s/merged with\s*//; - $bug_flag =~ s/\<[^\>]+\>//g; - $bug_flag =~ s/\s//sg; - $bug->{merged_with} = $bug_flag; - - } - elsif ($bug_flag =~ /\>Done:\{done} = 1; - } - elsif ($bug_flag =~ /\>Fixed\{done} = 1; - } + $bug_flag =~ s/\n//g; + &::DEBUG("Bug_flag: $bug_flag\n"); + if ( $bug_flag =~ /Severity:/i ) { + ( $bug->{severity} ) = + $bug_flag =~ /(wishlist|minor|normal|important|serious|grave)/i; + + # Just leave the leter instead of the whole thing. + $bug->{severity} =~ s/^(.).+$/$1/; + } + elsif ( $bug_flag =~ /Package:/ ) { + ( $bug->{package} ) = $bug_flag =~ /\"\>\s*([^\<\>\"]+?)\s*\<\/a\>/; + } + elsif ( $bug_flag =~ /Reported by:/ ) { + ( $bug->{reporter} ) = $bug_flag =~ /\"\>\s*(.+?)\s*\<\/a\>/; + + # strip < and > + $bug->{reporter} =~ s/</\{reporter} =~ s/>/\>/g; + } + elsif ( $bug_flag =~ /Date:/ ) { + ( $bug->{date} ) = $bug_flag =~ /Date:\s*(\w.+?)\s*$/; + + #ditch extra whitespace + $bug->{date} =~ s/\s{2,}/\ /; + } + elsif ( $bug_flag =~ /Tags:/ ) { + ( $bug->{tags} ) = $bug_flag =~ /strong\>\s*(.+?)\s*\<\/strong\>/; + } + elsif ( $bug_flag =~ /merged with / ) { + $bug_flag =~ s/merged with\s*//; + $bug_flag =~ s/\<[^\>]+\>//g; + $bug_flag =~ s/\s//sg; + $bug->{merged_with} = $bug_flag; + + } + elsif ( $bug_flag =~ /\>Done:\{done} = 1; + } + elsif ( $bug_flag =~ /\>Fixed\{done} = 1; + } } # report bug $report = ''; $report .= 'DONE:' if defined $bug->{done} and $bug->{done}; - $report .= '#'.$bug->{num}.':'.uc($bug->{severity}).'['.$bug->{package}.'] '.$bug->{title}; - $report .= ' ('.$bug->{tags}.')' if defined $bug->{tags}; + $report .= '#' + . $bug->{num} . ':' + . uc( $bug->{severity} ) . '[' + . $bug->{package} . '] ' + . $bug->{title}; + $report .= ' (' . $bug->{tags} . ')' if defined $bug->{tags}; $report .= '; ' . $bug->{date}; + # Avoid reporting so many merged bugs. - $report .= ' ['.join(',',splice(@{[split(/,/,$bug->{merged_with})]},0,3)).']' if defined $bug->{merged_with}; + $report .= ' [' + . join( ',', splice( @{ [ split( /,/, $bug->{merged_with} ) ] }, 0, 3 ) ) + . ']' + if defined $bug->{merged_with}; if ($::DEBUG) { - use Data::Dumper; - &::DEBUG(Dumper($bug)); + use Data::Dumper; + &::DEBUG( Dumper($bug) ); } return $report; } sub old_do_id { - my($num) = @_; + my ($num) = @_; my $url = "http://bugs.debian.org/$num"; # FIXME @@ -153,7 +176,7 @@ sub old_do_id { } sub do_email { - my($email) = @_; + my ($email) = @_; my $url = "http://bugs.debian.org/$email"; # FIXME @@ -161,12 +184,12 @@ sub do_email { my @results = &::getURL($url); foreach (@results) { - &::DEBUG("do_email: $_"); + &::DEBUG("do_email: $_"); } } sub do_pkg { - my($pkg) = @_; + my ($pkg) = @_; my $url = "http://bugs.debian.org/$pkg"; # FIXME @@ -174,7 +197,7 @@ sub do_pkg { my @results = &::getURL($url); foreach (@results) { - &::DEBUG("do_pkg: $_"); + &::DEBUG("do_pkg: $_"); } } diff --git a/src/Modules/Dict.pl b/src/Modules/Dict.pl index 2522a1c..333b477 100644 --- a/src/Modules/Dict.pl +++ b/src/Modules/Dict.pl @@ -16,167 +16,198 @@ use strict; #use vars qw(PF_INET); # need a specific host||ip. -my $server = "dict.org"; +my $server = "dict.org"; sub Dict { my ($query) = @_; -# return unless &::loadPerlModule("IO::Socket"); - my $port = 2628; - my $proto = getprotobyname('tcp'); + + # return unless &::loadPerlModule("IO::Socket"); + my $port = 2628; + my $proto = getprotobyname('tcp'); my @results; my $retval; for ($query) { - s/^[\s\t]+//; - s/[\s\t]+$//; - s/[\s\t]+/ /; + s/^[\s\t]+//; + s/[\s\t]+$//; + s/[\s\t]+/ /; } # connect. # TODO: make strict-safe constants... so we can defer IO::Socket load. - my $socket = new IO::Socket; - socket($socket, PF_INET, SOCK_STREAM, $proto) or return "error: socket: $!"; + my $socket = new IO::Socket; + socket( $socket, PF_INET, SOCK_STREAM, $proto ) + or return "error: socket: $!"; eval { - local $SIG{ALRM} = sub { die 'alarm' }; - alarm 10; - connect($socket, sockaddr_in($port, inet_aton($server))) or die "error: connect: $!"; - alarm 0; + local $SIG{ALRM} = sub { die 'alarm' }; + alarm 10; + connect( $socket, sockaddr_in( $port, inet_aton($server) ) ) + or die "error: connect: $!"; + alarm 0; }; if ($@) { - # failure. - $retval = "i could not get info from $server '$@'"; - } else { # success. - $socket->autoflush(1); # required. - - my $num; - if ($query =~ s/^(\d+)\s+//) { - $num = $1; - } - my $dict = '*'; - if ($query =~ s/\/(\S+)$//) { - $dict = $1; - } - - # body. - push(@results, &Define($socket,$query,$dict)); - #push(@results, &Define($socket,$query,'foldoc')); - #push(@results, &Define($socket,$query,'web1913')); - # end. - - print $socket "QUIT\n"; - close $socket; - - my $count=0; - foreach (@results) { - $count++; - &::DEBUG("$count: $_"); - } - my $total = scalar @results; - - if ($total == 0) { - $num = undef; - } - - if (defined $num and ($num > $total or $num < 1)) { - &::msg($::who, "error: choice in definition is out of range."); - return; - } - - # parse the results. - if ($total > 1) { - if (defined $num) { - $retval = sprintf("[%d/%d] %s", $num, $total, $results[$num-1]); - } else { - # suggested by larne and others. - my $prefix = "Dictionary '$query' "; - $retval = &::formListReply(1, $prefix, @results); - } - } elsif ($total == 1) { - $retval = "Dictionary '$query' ".$results[0]; - } else { - $retval = "could not find definition for \002$query\002"; - $retval .= " in $dict" if ($dict ne '*'); - } + + # failure. + $retval = "i could not get info from $server '$@'"; + } + else { # success. + $socket->autoflush(1); # required. + + my $num; + if ( $query =~ s/^(\d+)\s+// ) { + $num = $1; + } + my $dict = '*'; + if ( $query =~ s/\/(\S+)$// ) { + $dict = $1; + } + + # body. + push( @results, &Define( $socket, $query, $dict ) ); + + #push(@results, &Define($socket,$query,'foldoc')); + #push(@results, &Define($socket,$query,'web1913')); + # end. + + print $socket "QUIT\n"; + close $socket; + + my $count = 0; + foreach (@results) { + $count++; + &::DEBUG("$count: $_"); + } + my $total = scalar @results; + + if ( $total == 0 ) { + $num = undef; + } + + if ( defined $num and ( $num > $total or $num < 1 ) ) { + &::msg( $::who, "error: choice in definition is out of range." ); + return; + } + + # parse the results. + if ( $total > 1 ) { + if ( defined $num ) { + $retval = + sprintf( "[%d/%d] %s", $num, $total, $results[ $num - 1 ] ); + } + else { + + # suggested by larne and others. + my $prefix = "Dictionary '$query' "; + $retval = &::formListReply( 1, $prefix, @results ); + } + } + elsif ( $total == 1 ) { + $retval = "Dictionary '$query' " . $results[0]; + } + else { + $retval = "could not find definition for \002$query\002"; + $retval .= " in $dict" if ( $dict ne '*' ); + } } &::performStrictReply($retval); } sub Define { - my ($socket, $query, $dict) = @_; + my ( $socket, $query, $dict ) = @_; my @results; &::DEBUG("Dict: asking $dict."); print $socket "DEFINE $dict \"$query\"\n"; - my $def = ''; + my $def = ''; my $term = $query; while (<$socket>) { - chop; # remove \n - chop; # remove \r - - &::DEBUG("$term/$dict '$_'"); - if (/^552 /) { - # no match. - return; - } elsif (/^250 /) { + chop; # remove \n + chop; # remove \r + + &::DEBUG("$term/$dict '$_'"); + if (/^552 /) { + + # no match. + return; + } + elsif (/^250 /) { + # end w/ optional stats - last; - } elsif (/^151 "([^"]*)" (\S+) .*/) { + last; + } + elsif (/^151 "([^"]*)" (\S+) .*/) { + # 151 "Good Thing" jargon "Jargon File (4.3.0, 30 APR 2001)" - $term=$1; - $dict=$2; - $def = ''; + $term = $1; + $dict = $2; + $def = ''; &::DEBUG("term=$term dict=$dict"); - } else { - my $line = $_; - # some dicts put part of the definition on the same line ie: jargon - $line =~ s/^$term//i; - $line =~ s/^\s+/ /; - if ($dict eq 'wn') { - # special processing for sub defs in wordnet - if ($line eq '.') { - # end of def. - $def =~ s/\s+$//; - $def =~ s/\[[^\]]*\]//g; - push(@results, $def); - } elsif ($line =~ m/^\s+(\S+ )?(\d+)?: (.*)/) { - # start of sub def. - my $text = $3; - $def =~ s/\s+$//; - #&::DEBUG("def => '$def'."); - $def =~ s/\[[^\]]*\]//g; - push(@results, $def) if ($def ne ''); - $def = $text; - } elsif (/^\s+(.*)/) { - $def .= $line; - } else { - &::DEBUG("ignored '$line'"); - } - } else { - # would be nice to divide other dicts - # but many are not always in a parsable format - if ($line eq '.') { - # end of def. - next if ($def eq ''); - push(@results, $def); - $def = ''; - } elsif ($line =~ m/^\s+(\S.*\S)\s*$/) { - #&::DEBUG("got '$1'"); - $def .= ' ' if ($def ne ''); - $def .= $1; - } else { - &::DEBUG("ignored '$line'"); - } - } - } + } + else { + my $line = $_; + + # some dicts put part of the definition on the same line ie: jargon + $line =~ s/^$term//i; + $line =~ s/^\s+/ /; + if ( $dict eq 'wn' ) { + + # special processing for sub defs in wordnet + if ( $line eq '.' ) { + + # end of def. + $def =~ s/\s+$//; + $def =~ s/\[[^\]]*\]//g; + push( @results, $def ); + } + elsif ( $line =~ m/^\s+(\S+ )?(\d+)?: (.*)/ ) { + + # start of sub def. + my $text = $3; + $def =~ s/\s+$//; + + #&::DEBUG("def => '$def'."); + $def =~ s/\[[^\]]*\]//g; + push( @results, $def ) if ( $def ne '' ); + $def = $text; + } + elsif (/^\s+(.*)/) { + $def .= $line; + } + else { + &::DEBUG("ignored '$line'"); + } + } + else { + + # would be nice to divide other dicts + # but many are not always in a parsable format + if ( $line eq '.' ) { + + # end of def. + next if ( $def eq '' ); + push( @results, $def ); + $def = ''; + } + elsif ( $line =~ m/^\s+(\S.*\S)\s*$/ ) { + + #&::DEBUG("got '$1'"); + $def .= ' ' if ( $def ne '' ); + $def .= $1; + } + else { + &::DEBUG("ignored '$line'"); + } + } + } } - &::DEBUG("Dict: $dict: found ". scalar(@results) ." defs."); + &::DEBUG( "Dict: $dict: found " . scalar(@results) . " defs." ); - return if (!scalar @results); + return if ( !scalar @results ); return @results; } diff --git a/src/Modules/DumpVars.pl b/src/Modules/DumpVars.pl index 5b36b22..3ca982d 100644 --- a/src/Modules/DumpVars.pl +++ b/src/Modules/DumpVars.pl @@ -15,118 +15,123 @@ my $countlines = 0; sub dumpvarslog { my ($line) = @_; - if (&IsParam('dumpvarsLogFile')) { - print DUMPVARS $line."\n"; - } else { - &status("DV: ".$line); + if ( &IsParam('dumpvarsLogFile') ) { + print DUMPVARS $line . "\n"; + } + else { + &status( "DV: " . $line ); } } sub DumpNames(\%$) { - my ($package,$packname) = @_; + my ( $package, $packname ) = @_; my $symname = 0; my $line; - if ($packname eq 'main::') { - &dumpvarslog('Packages'); + if ( $packname eq 'main::' ) { + &dumpvarslog('Packages'); - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined %sym); - next unless ($symname =~/::/); - &dumpvarslog(" $symname"); - $countlines++; - } + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined %sym ); + next unless ( $symname =~ /::/ ); + &dumpvarslog(" $symname"); + $countlines++; + } } # Scalars. - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined $sym); - - my $line; - if (length($sym) > 512) { - &dumpvarslog("Scalar '$packname' $symname too long."); - } else { - &dumpvarslog("Scalar '$packname' \$ $symname => '$sym'"); - } - $countlines++; + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined $sym ); + + my $line; + if ( length($sym) > 512 ) { + &dumpvarslog("Scalar '$packname' $symname too long."); + } + else { + &dumpvarslog("Scalar '$packname' \$ $symname => '$sym'"); + } + $countlines++; } # Functions. - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined &sym); + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined &sym ); - &dumpvarslog("Function '$packname' $symname()"); - $countlines++; + &dumpvarslog("Function '$packname' $symname()"); + $countlines++; } # Lists. - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined @sym); - - &dumpvarslog("List '$packname' \@$symname (". scalar(@{$symname}) .")"); - $countlines++; - - next unless ($packname eq 'main::'); - foreach (@{$symname}) { - if (defined $_) { - &dumpvarslog(" => '$_'."); - } else { - &dumpvarslog(" => ."); - } - } + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined @sym ); + + &dumpvarslog( + "List '$packname' \@$symname (" . scalar( @{$symname} ) . ")" ); + $countlines++; + + next unless ( $packname eq 'main::' ); + foreach ( @{$symname} ) { + if ( defined $_ ) { + &dumpvarslog(" => '$_'."); + } + else { + &dumpvarslog(" => ."); + } + } } # Hashes. - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined %sym); - next if ($symname =~/::/); - - &dumpvarslog("Hash '$packname' \%$symname"); - $countlines++; - - next unless ($packname eq 'main::'); - foreach (keys %{$symname}) { - my $val = ${$symname}{$_}; - if (defined $val) { - &dumpvarslog(" $_ => '$val'."); - } else { - &dumpvarslog(" $_ => ."); - } - } + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined %sym ); + next if ( $symname =~ /::/ ); + + &dumpvarslog("Hash '$packname' \%$symname"); + $countlines++; + + next unless ( $packname eq 'main::' ); + foreach ( keys %{$symname} ) { + my $val = ${$symname}{$_}; + if ( defined $val ) { + &dumpvarslog(" $_ => '$val'."); + } + else { + &dumpvarslog(" $_ => ."); + } + } } - return unless ($packname eq 'main::'); + return unless ( $packname eq 'main::' ); - foreach $symname (sort keys %$package) { - local *sym = $$package{$symname}; - next unless (defined %sym); - next unless ($symname =~/::/); - next if ($symname eq 'main::'); + foreach $symname ( sort keys %$package ) { + local *sym = $$package{$symname}; + next unless ( defined %sym ); + next unless ( $symname =~ /::/ ); + next if ( $symname eq 'main::' ); - DumpNames(\%sym,$symname) + DumpNames( \%sym, $symname ); } } sub dumpallvars { - if (&IsParam('dumpvarsLogFile')) { - my $file = $param{'dumpvarsLogFile'}; - &status("opening fh to dumpvars ($file)"); - if (!open(DUMPVARS,">$file")) { - &ERROR("cannot open dumpvars."); - return; - } + if ( &IsParam('dumpvarsLogFile') ) { + my $file = $param{'dumpvarsLogFile'}; + &status("opening fh to dumpvars ($file)"); + if ( !open( DUMPVARS, ">$file" ) ) { + &ERROR("cannot open dumpvars."); + return; + } } - DumpNames(%main::,'main::'); + DumpNames( %main::, 'main::' ); - if (&IsParam('dumpvarsLogFile')) { - &status("closing fh to dumpvars"); - close DUMPVARS; + if ( &IsParam('dumpvarsLogFile') ) { + &status("closing fh to dumpvars"); + close DUMPVARS; } &status("DV: count == $countlines"); diff --git a/src/Modules/DumpVars2.pl b/src/Modules/DumpVars2.pl index a6e70e5..968f5b8 100644 --- a/src/Modules/DumpVars2.pl +++ b/src/Modules/DumpVars2.pl @@ -12,10 +12,11 @@ use Devel::Symdump; sub symdumplog { my ($line) = @_; - if (fileno SYMDUMP) { - print SYMDUMP $line."\n"; - } else { - &status("SD: ".$line); + if ( fileno SYMDUMP ) { + print SYMDUMP $line . "\n"; + } + else { + &status( "SD: " . $line ); } } @@ -23,41 +24,43 @@ sub symdumpAll { my $o = Devel::Symdump->rnew(); # scalars. - foreach ($o->scalars) { -# &symdumpRecur($_); - symdumplog(" scalar($_)"); + foreach ( $o->scalars ) { + + # &symdumpRecur($_); + symdumplog(" scalar($_)"); } } sub symdumpRecur { my $x = shift; - if (ref $x eq 'HASH') { - foreach (keys %$x) { - &symdumpRecur($_); - } - } else { - symdumplog("unknown: $x"); + if ( ref $x eq 'HASH' ) { + foreach ( keys %$x ) { + &symdumpRecur($_); + } + } + else { + symdumplog("unknown: $x"); } } sub symdumpAllFile { &DEBUG('before open'); - if (&IsParam('symdumpLogFile')) { - my $file = $param{'symdumpLogFile'}; - &status("opening fh to symdump ($file)"); - if (!open(SYMDUMP,">$file")) { - &ERROR('cannot open dumpvars.'); - return; - } + if ( &IsParam('symdumpLogFile') ) { + my $file = $param{'symdumpLogFile'}; + &status("opening fh to symdump ($file)"); + if ( !open( SYMDUMP, ">$file" ) ) { + &ERROR('cannot open dumpvars.'); + return; + } } &DEBUG('after open'); symdumpAll(); - if (fileno SYMDUMP) { - &status('closing fh to symdump'); - close SYMDUMP; + if ( fileno SYMDUMP ) { + &status('closing fh to symdump'); + close SYMDUMP; } &status("SD: count == $countlines"); diff --git a/src/Modules/Exchange.pl b/src/Modules/Exchange.pl index 9c9e320..bf4c71b 100644 --- a/src/Modules/Exchange.pl +++ b/src/Modules/Exchange.pl @@ -21,255 +21,255 @@ BEGIN { } sub GetAbb { - my($LookFor,%Hash) = @_; + my ( $LookFor, %Hash ) = @_; - my $Found = (grep /$LookFor/i, keys %Hash)[0]; + my $Found = ( grep /$LookFor/i, keys %Hash )[0]; $Found =~ m/\((\w\w\w)\)/; return $1; } sub GetTlds { my %Hash = ( - 'AF', 'AFGHANISTAN', - 'AL', 'ALBANIA', - 'DZ', 'ALGERIA', - 'AS', 'AMERICAN SAMOA', - 'AD', 'ANDORRA', - 'AO', 'ANGOLA', - 'AI', 'ANGUILLA', - 'AQ', 'ANTARCTICA', - 'AG', 'ANTIGUA AND BARBUDA', - 'AR', 'ARGENTINA', - 'AM', 'ARMENIA', - 'AW', 'ARUBA', - 'AU', 'AUSTRALIA', - 'AT', 'AUSTRIA', - 'AZ', 'AZERBAIJAN', - 'BS', 'BAHAMAS', - 'BH', 'BAHRAIN', - 'BD', 'BANGLADESH', - 'BB', 'BARBADOS', - 'BY', 'BELARUS', - 'BE', 'BELGIUM', - 'BZ', 'BELIZE', - 'BJ', 'BENIN', - 'BM', 'BERMUDA', - 'BT', 'BHUTAN', - 'BO', 'BOLIVIA', - 'BA', 'BOSNIA AND HERZEGOWINA', - 'BW', 'BOTSWANA', - 'BV', 'BOUVET ISLAND', - 'BR', 'BRAZIL', - 'IO', 'BRITISH INDIAN OCEAN TERRITORY', - 'BN', 'BRUNEI DARUSSALAM', - 'BG', 'BULGARIA', - 'BF', 'BURKINA FASO', - 'BI', 'BURUNDI', - 'KH', 'CAMBODIA', - 'CM', 'CAMEROON', - 'CA', 'CANADA', - 'CV', 'CAPE VERDE', - 'KY', 'CAYMAN ISLANDS', - 'CF', 'CENTRAL AFRICAN REPUBLIC', - 'TD', 'CHAD', - 'CL', 'CHILE', - 'CN', 'CHINA', - 'CX', 'CHRISTMAS ISLAND', - 'CC', 'COCOS (KEELING) ISLANDS', - 'CO', 'COLOMBIA', - 'KM', 'COMOROS', - 'CG', 'CONGO', - 'CD', 'CONGO, THE DEMOCRATIC REPUBLIC OF THE', - 'CK', 'COOK ISLANDS', - 'CR', 'COSTA RICA', - 'CI', "COTE D'IVOIRE", - 'HR', 'CROATIA (local name: Hrvatska)', - 'CU', 'CUBA', - 'CY', 'CYPRUS', - 'CZ', 'CZECH REPUBLIC', - 'DK', 'DENMARK', - 'DJ', 'DJIBOUTI', - 'DM', 'DOMINICA', - 'DO', 'DOMINICAN REPUBLIC', - 'TP', 'EAST TIMOR', - 'EC', 'ECUADOR', - 'EG', 'EGYPT', - 'SV', 'EL SALVADOR', - 'GQ', 'EQUATORIAL GUINEA', - 'ER', 'ERITREA', - 'EE', 'ESTONIA', - 'ET', 'ETHIOPIA', - 'FK', 'FALKLAND ISLANDS (MALVINAS)', - 'FO', 'FAROE ISLANDS', - 'FJ', 'FIJI', - 'FI', 'FINLAND', - 'FR', 'FRANCE', - 'FX', 'FRANCE, METROPOLITAN', - 'GF', 'FRENCH GUIANA', - 'PF', 'FRENCH POLYNESIA', - 'TF', 'FRENCH SOUTHERN TERRITORIES', - 'GA', 'GABON', - 'GM', 'GAMBIA', - 'GE', 'GEORGIA', - 'DE', 'GERMANY', - 'GH', 'GHANA', - 'GI', 'GIBRALTAR', - 'GR', 'GREECE', - 'GL', 'GREENLAND', - 'GD', 'GRENADA', - 'GP', 'GUADELOUPE', - 'GU', 'GUAM', - 'GT', 'GUATEMALA', - 'GN', 'GUINEA', - 'GW', 'GUINEA-BISSAU', - 'GY', 'GUYANA', - 'HT', 'HAITI', - 'HM', 'HEARD AND MC DONALD ISLANDS', - 'VA', 'HOLY SEE (VATICAN CITY STATE)', - 'HN', 'HONDURAS', - 'HK', 'HONG KONG', - 'HU', 'HUNGARY', - 'IS', 'ICELAND', - 'IN', 'INDIA', - 'ID', 'INDONESIA', - 'IR', 'IRAN (ISLAMIC REPUBLIC OF)', - 'IQ', 'IRAQ', - 'IE', 'IRELAND', - 'IL', 'ISRAEL', - 'IT', 'ITALY', - 'JM', 'JAMAICA', - 'JP', 'JAPAN', - 'JO', 'JORDAN', - 'KZ', 'KAZAKHSTAN', - 'KE', 'KENYA', - 'KI', 'KIRIBATI', - 'KP', "KOREA, DEMOCRATIC PEOPLE'S REPUBLIC OF", - 'KR', 'KOREA, REPUBLIC OF', - 'KW', 'KUWAIT', - 'KG', 'KYRGYZSTAN', - 'LA', "LAO PEOPLE'S DEMOCRATIC REPUBLIC", - 'LV', 'LATVIA', - 'LB', 'LEBANON', - 'LS', 'LESOTHO', - 'LR', 'LIBERIA', - 'LY', 'LIBYAN ARAB JAMAHIRIYA', - 'LI', 'LIECHTENSTEIN', - 'LT', 'LITHUANIA', - 'LU', 'LUXEMBOURG', - 'MO', 'MACAU', - 'MK', 'MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF', - 'MG', 'MADAGASCAR', - 'MW', 'MALAWI', - 'MY', 'MALAYSIA', - 'MV', 'MALDIVES', - 'ML', 'MALI', - 'MT', 'MALTA', - 'MH', 'MARSHALL ISLANDS', - 'MQ', 'MARTINIQUE', - 'MR', 'MAURITANIA', - 'MU', 'MAURITIUS', - 'YT', 'MAYOTTE', - 'MX', 'MEXICO', - 'FM', 'MICRONESIA, FEDERATED STATES OF', - 'MD', 'MOLDOVA, REPUBLIC OF', - 'MC', 'MONACO', - 'MN', 'MONGOLIA', - 'MS', 'MONTSERRAT', - 'MA', 'MOROCCO', - 'MZ', 'MOZAMBIQUE', - 'MM', 'MYANMAR', - 'NA', 'NAMIBIA', - 'NR', 'NAURU', - 'NP', 'NEPAL', - 'NL', 'NETHERLANDS', - 'AN', 'NETHERLANDS ANTILLES', - 'NC', 'NEW CALEDONIA', - 'NZ', 'NEW ZEALAND', - 'NI', 'NICARAGUA', - 'NE', 'NIGER', - 'NG', 'NIGERIA', - 'NU', 'NIUE', - 'NF', 'NORFOLK ISLAND', - 'MP', 'NORTHERN MARIANA ISLANDS', - 'NO', 'NORWAY', - 'OM', 'OMAN', - 'PK', 'PAKISTAN', - 'PW', 'PALAU', - 'PA', 'PANAMA', - 'PG', 'PAPUA NEW GUINEA', - 'PY', 'PARAGUAY', - 'PE', 'PERU', - 'PH', 'PHILIPPINES', - 'PN', 'PITCAIRN', - 'PL', 'POLAND', - 'PT', 'PORTUGAL', - 'PR', 'PUERTO RICO', - 'QA', 'QATAR', - 'RE', 'REUNION', - 'RO', 'ROMANIA', - 'RU', 'RUSSIAN FEDERATION', - 'RW', 'RWANDA', - 'KN', 'SAINT KITTS AND NEVIS', - 'LC', 'SAINT LUCIA', - 'VC', 'SAINT VINCENT AND THE GRENADINES', - 'WS', 'SAMOA', - 'SM', 'SAN MARINO', - 'ST', 'SAO TOME AND PRINCIPE', - 'SA', 'SAUDI ARABIA', - 'SN', 'SENEGAL', - 'SC', 'SEYCHELLES', - 'SL', 'SIERRA LEONE', - 'SG', 'SINGAPORE', - 'SK', 'SLOVAKIA (Slovak Republic)', - 'SI', 'SLOVENIA', - 'SB', 'SOLOMON ISLANDS', - 'SO', 'SOMALIA', - 'ZA', 'SOUTH AFRICA', - 'GS', 'SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS', - 'ES', 'SPAIN', - 'LK', 'SRI LANKA', - 'SH', 'ST. HELENA', - 'PM', 'ST. PIERRE AND MIQUELON', - 'SD', 'SUDAN', - 'SR', 'SURINAME', - 'SJ', 'SVALBARD AND JAN MAYEN ISLANDS', - 'SZ', 'SWAZILAND', - 'SE', 'SWEDEN', - 'CH', 'SWITZERLAND', - 'SY', 'SYRIAN ARAB REPUBLIC', - 'TW', 'TAIWAN, PROVINCE OF CHINA', - 'TJ', 'TAJIKISTAN', - 'TZ', 'TANZANIA, UNITED REPUBLIC OF', - 'TH', 'THAILAND', - 'TG', 'TOGO', - 'TK', 'TOKELAU', - 'TO', 'TONGA', - 'TT', 'TRINIDAD AND TOBAGO', - 'TN', 'TUNISIA', - 'TR', 'TURKEY', - 'TM', 'TURKMENISTAN', - 'TC', 'TURKS AND CAICOS ISLANDS', - 'TV', 'TUVALU', - 'UG', 'UGANDA', - 'UA', 'UKRAINE', - 'AE', 'UNITED ARAB EMIRATES', - 'GB', 'UNITED KINGDOM', - 'US', 'UNITED STATES', - 'UM', 'UNITED STATES MINOR OUTLYING ISLANDS', - 'UY', 'URUGUAY', - 'UZ', 'UZBEKISTAN', - 'VU', 'VANUATU', - 'VE', 'VENEZUELA', - 'VN', 'VIET NAM', - 'VG', 'VIRGIN ISLANDS (BRITISH)', - 'VI', 'VIRGIN ISLANDS (U.S.)', - 'WF', 'WALLIS AND FUTUNA ISLANDS', - 'EH', 'WESTERN SAHARA', - 'YE', 'YEMEN', - 'YU', 'YUGOSLAVIA', - 'ZM', 'ZAMBIA', - 'ZW', 'ZIMBABWE', - ); + 'AF', 'AFGHANISTAN', + 'AL', 'ALBANIA', + 'DZ', 'ALGERIA', + 'AS', 'AMERICAN SAMOA', + 'AD', 'ANDORRA', + 'AO', 'ANGOLA', + 'AI', 'ANGUILLA', + 'AQ', 'ANTARCTICA', + 'AG', 'ANTIGUA AND BARBUDA', + 'AR', 'ARGENTINA', + 'AM', 'ARMENIA', + 'AW', 'ARUBA', + 'AU', 'AUSTRALIA', + 'AT', 'AUSTRIA', + 'AZ', 'AZERBAIJAN', + 'BS', 'BAHAMAS', + 'BH', 'BAHRAIN', + 'BD', 'BANGLADESH', + 'BB', 'BARBADOS', + 'BY', 'BELARUS', + 'BE', 'BELGIUM', + 'BZ', 'BELIZE', + 'BJ', 'BENIN', + 'BM', 'BERMUDA', + 'BT', 'BHUTAN', + 'BO', 'BOLIVIA', + 'BA', 'BOSNIA AND HERZEGOWINA', + 'BW', 'BOTSWANA', + 'BV', 'BOUVET ISLAND', + 'BR', 'BRAZIL', + 'IO', 'BRITISH INDIAN OCEAN TERRITORY', + 'BN', 'BRUNEI DARUSSALAM', + 'BG', 'BULGARIA', + 'BF', 'BURKINA FASO', + 'BI', 'BURUNDI', + 'KH', 'CAMBODIA', + 'CM', 'CAMEROON', + 'CA', 'CANADA', + 'CV', 'CAPE VERDE', + 'KY', 'CAYMAN ISLANDS', + 'CF', 'CENTRAL AFRICAN REPUBLIC', + 'TD', 'CHAD', + 'CL', 'CHILE', + 'CN', 'CHINA', + 'CX', 'CHRISTMAS ISLAND', + 'CC', 'COCOS (KEELING) ISLANDS', + 'CO', 'COLOMBIA', + 'KM', 'COMOROS', + 'CG', 'CONGO', + 'CD', 'CONGO, THE DEMOCRATIC REPUBLIC OF THE', + 'CK', 'COOK ISLANDS', + 'CR', 'COSTA RICA', + 'CI', "COTE D'IVOIRE", + 'HR', 'CROATIA (local name: Hrvatska)', + 'CU', 'CUBA', + 'CY', 'CYPRUS', + 'CZ', 'CZECH REPUBLIC', + 'DK', 'DENMARK', + 'DJ', 'DJIBOUTI', + 'DM', 'DOMINICA', + 'DO', 'DOMINICAN REPUBLIC', + 'TP', 'EAST TIMOR', + 'EC', 'ECUADOR', + 'EG', 'EGYPT', + 'SV', 'EL SALVADOR', + 'GQ', 'EQUATORIAL GUINEA', + 'ER', 'ERITREA', + 'EE', 'ESTONIA', + 'ET', 'ETHIOPIA', + 'FK', 'FALKLAND ISLANDS (MALVINAS)', + 'FO', 'FAROE ISLANDS', + 'FJ', 'FIJI', + 'FI', 'FINLAND', + 'FR', 'FRANCE', + 'FX', 'FRANCE, METROPOLITAN', + 'GF', 'FRENCH GUIANA', + 'PF', 'FRENCH POLYNESIA', + 'TF', 'FRENCH SOUTHERN TERRITORIES', + 'GA', 'GABON', + 'GM', 'GAMBIA', + 'GE', 'GEORGIA', + 'DE', 'GERMANY', + 'GH', 'GHANA', + 'GI', 'GIBRALTAR', + 'GR', 'GREECE', + 'GL', 'GREENLAND', + 'GD', 'GRENADA', + 'GP', 'GUADELOUPE', + 'GU', 'GUAM', + 'GT', 'GUATEMALA', + 'GN', 'GUINEA', + 'GW', 'GUINEA-BISSAU', + 'GY', 'GUYANA', + 'HT', 'HAITI', + 'HM', 'HEARD AND MC DONALD ISLANDS', + 'VA', 'HOLY SEE (VATICAN CITY STATE)', + 'HN', 'HONDURAS', + 'HK', 'HONG KONG', + 'HU', 'HUNGARY', + 'IS', 'ICELAND', + 'IN', 'INDIA', + 'ID', 'INDONESIA', + 'IR', 'IRAN (ISLAMIC REPUBLIC OF)', + 'IQ', 'IRAQ', + 'IE', 'IRELAND', + 'IL', 'ISRAEL', + 'IT', 'ITALY', + 'JM', 'JAMAICA', + 'JP', 'JAPAN', + 'JO', 'JORDAN', + 'KZ', 'KAZAKHSTAN', + 'KE', 'KENYA', + 'KI', 'KIRIBATI', + 'KP', "KOREA, DEMOCRATIC PEOPLE'S REPUBLIC OF", + 'KR', 'KOREA, REPUBLIC OF', + 'KW', 'KUWAIT', + 'KG', 'KYRGYZSTAN', + 'LA', "LAO PEOPLE'S DEMOCRATIC REPUBLIC", + 'LV', 'LATVIA', + 'LB', 'LEBANON', + 'LS', 'LESOTHO', + 'LR', 'LIBERIA', + 'LY', 'LIBYAN ARAB JAMAHIRIYA', + 'LI', 'LIECHTENSTEIN', + 'LT', 'LITHUANIA', + 'LU', 'LUXEMBOURG', + 'MO', 'MACAU', + 'MK', 'MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF', + 'MG', 'MADAGASCAR', + 'MW', 'MALAWI', + 'MY', 'MALAYSIA', + 'MV', 'MALDIVES', + 'ML', 'MALI', + 'MT', 'MALTA', + 'MH', 'MARSHALL ISLANDS', + 'MQ', 'MARTINIQUE', + 'MR', 'MAURITANIA', + 'MU', 'MAURITIUS', + 'YT', 'MAYOTTE', + 'MX', 'MEXICO', + 'FM', 'MICRONESIA, FEDERATED STATES OF', + 'MD', 'MOLDOVA, REPUBLIC OF', + 'MC', 'MONACO', + 'MN', 'MONGOLIA', + 'MS', 'MONTSERRAT', + 'MA', 'MOROCCO', + 'MZ', 'MOZAMBIQUE', + 'MM', 'MYANMAR', + 'NA', 'NAMIBIA', + 'NR', 'NAURU', + 'NP', 'NEPAL', + 'NL', 'NETHERLANDS', + 'AN', 'NETHERLANDS ANTILLES', + 'NC', 'NEW CALEDONIA', + 'NZ', 'NEW ZEALAND', + 'NI', 'NICARAGUA', + 'NE', 'NIGER', + 'NG', 'NIGERIA', + 'NU', 'NIUE', + 'NF', 'NORFOLK ISLAND', + 'MP', 'NORTHERN MARIANA ISLANDS', + 'NO', 'NORWAY', + 'OM', 'OMAN', + 'PK', 'PAKISTAN', + 'PW', 'PALAU', + 'PA', 'PANAMA', + 'PG', 'PAPUA NEW GUINEA', + 'PY', 'PARAGUAY', + 'PE', 'PERU', + 'PH', 'PHILIPPINES', + 'PN', 'PITCAIRN', + 'PL', 'POLAND', + 'PT', 'PORTUGAL', + 'PR', 'PUERTO RICO', + 'QA', 'QATAR', + 'RE', 'REUNION', + 'RO', 'ROMANIA', + 'RU', 'RUSSIAN FEDERATION', + 'RW', 'RWANDA', + 'KN', 'SAINT KITTS AND NEVIS', + 'LC', 'SAINT LUCIA', + 'VC', 'SAINT VINCENT AND THE GRENADINES', + 'WS', 'SAMOA', + 'SM', 'SAN MARINO', + 'ST', 'SAO TOME AND PRINCIPE', + 'SA', 'SAUDI ARABIA', + 'SN', 'SENEGAL', + 'SC', 'SEYCHELLES', + 'SL', 'SIERRA LEONE', + 'SG', 'SINGAPORE', + 'SK', 'SLOVAKIA (Slovak Republic)', + 'SI', 'SLOVENIA', + 'SB', 'SOLOMON ISLANDS', + 'SO', 'SOMALIA', + 'ZA', 'SOUTH AFRICA', + 'GS', 'SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS', + 'ES', 'SPAIN', + 'LK', 'SRI LANKA', + 'SH', 'ST. HELENA', + 'PM', 'ST. PIERRE AND MIQUELON', + 'SD', 'SUDAN', + 'SR', 'SURINAME', + 'SJ', 'SVALBARD AND JAN MAYEN ISLANDS', + 'SZ', 'SWAZILAND', + 'SE', 'SWEDEN', + 'CH', 'SWITZERLAND', + 'SY', 'SYRIAN ARAB REPUBLIC', + 'TW', 'TAIWAN, PROVINCE OF CHINA', + 'TJ', 'TAJIKISTAN', + 'TZ', 'TANZANIA, UNITED REPUBLIC OF', + 'TH', 'THAILAND', + 'TG', 'TOGO', + 'TK', 'TOKELAU', + 'TO', 'TONGA', + 'TT', 'TRINIDAD AND TOBAGO', + 'TN', 'TUNISIA', + 'TR', 'TURKEY', + 'TM', 'TURKMENISTAN', + 'TC', 'TURKS AND CAICOS ISLANDS', + 'TV', 'TUVALU', + 'UG', 'UGANDA', + 'UA', 'UKRAINE', + 'AE', 'UNITED ARAB EMIRATES', + 'GB', 'UNITED KINGDOM', + 'US', 'UNITED STATES', + 'UM', 'UNITED STATES MINOR OUTLYING ISLANDS', + 'UY', 'URUGUAY', + 'UZ', 'UZBEKISTAN', + 'VU', 'VANUATU', + 'VE', 'VENEZUELA', + 'VN', 'VIET NAM', + 'VG', 'VIRGIN ISLANDS (BRITISH)', + 'VI', 'VIRGIN ISLANDS (U.S.)', + 'WF', 'WALLIS AND FUTUNA ISLANDS', + 'EH', 'WESTERN SAHARA', + 'YE', 'YEMEN', + 'YU', 'YUGOSLAVIA', + 'ZM', 'ZAMBIA', + 'ZW', 'ZIMBABWE', + ); return %Hash; } @@ -278,118 +278,137 @@ sub exchange { &::DEBUG("exchange(@_)"); return 'Exchange.pl needs LWP::UserAgent and HTTP::Request::Common' - if ($no_exchange); + if ($no_exchange); - my ($From, $To, $Amount, $Country); + my ( $From, $To, $Amount, $Country ); my $retval = ''; - if ($message =~ /^([\d\.\,]+)\s+(\S+)\s+(?:into|to|for)\s+(\S+)/i) { - ($Amount,$From,$To) = ($1,$2,$3); - $From = uc $From; $To = uc $To; - } elsif ($message =~ /^for\s(?:the\s)?([\w\s]+)/i) { - # looking up the currency for a country - $Country = $1; - } else { - return "that doesn't look right"; + if ( $message =~ /^([\d\.\,]+)\s+(\S+)\s+(?:into|to|for)\s+(\S+)/i ) { + ( $Amount, $From, $To ) = ( $1, $2, $3 ); + $From = uc $From; + $To = uc $To; + } + elsif ( $message =~ /^for\s(?:the\s)?([\w\s]+)/i ) { + + # looking up the currency for a country + $Country = $1; + } + else { + return "that doesn't look right"; } my $ua = new LWP::UserAgent; + # Let's pretend #$ua->agent('Mozilla/5.0 ' . $ua->agent); $ua->agent('Mozilla/5.0'); - $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy')); + $ua->proxy( 'http', $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') ); $ua->timeout(10); - my $Referer = 'http://www.xe.net/ucc/full.shtml'; - my $Converter='http://www.xe.net/ucc/convert.cgi'; + my $Referer = 'http://www.xe.net/ucc/full.shtml'; + my $Converter = 'http://www.xe.net/ucc/convert.cgi'; # Get a list of currency abbreviations... - my $grab = GET $Referer; + my $grab = GET $Referer; my $reply = $ua->request($grab); - if (!$reply->is_success) { - return 'EXCHANGE: '.$reply->status_line; + if ( !$reply->is_success ) { + return 'EXCHANGE: ' . $reply->status_line; } my $html = $reply->as_string; - my %Currencies = (grep /\S+/, - ($html =~ /option value="([^"]+)">.*?,\s*([^<]+).*?,\s*([^<]+)([^<]+)([^<]+) 'UTC', - From => $From, - To => $To, - Amount => $Amount, - ]; - - # Falsify where we came from - $req->referer($Referer); - - # Submit request - my $res = $ua->request($req); - - if ($res->is_success) { - # Went through ok - my $html = $res->as_string; - # parse each one to avoid undefined warnings - my ($When) = ($html =~ m/ as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)/gi); - my ($Cfrom) = ($html =~ m/(\d[\d,.]+)\s*$From/gi); - my ($Cto) = ($html =~ m/(\d[\d,.]+)\s*$To/gi); - #my ($When, $Cfrom, $Cto) = - # grep /\S+/, ($html =~ m/ as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)|(\d[\d,.]+)\s*$From|(\d[\d,.]+)\s* $To/gi); - - if ($When) { - return "$Cfrom $Currencies{$From} makes ". - "$Cto $Currencies{$To} (from http://www.xe.com/)"; # ." ($When)\n"; - } else { - return 'i got some error trying that'; - } - } else { - # Oh dear. - return "EXCHANGE: ". $res->status_line; - } - } else { - return "Don't know about \"$From\" as a currency" if (!exists $Currencies{$From}); - return "Don't know about \"$To\" as a currency" if (!exists $Currencies{$To}); - } + + # Country lookup + # crysflame++ for the space fix. + $retval = ''; + foreach my $Found ( grep /$Country/i, keys %CurrLookup ) { + $Found =~ s/,/ uses/g; + $retval .= "$Found, "; + } + $retval =~ s/(?:, )?\|?$//; + return substr( $retval, 0, 510 ); + } + else { + my %tld2country = &GetTlds; + if ( $From =~ /^\.(\w\w)$/ ) { # Probably a tld + $From = $tld2country{ uc $1 }; + } + if ( $To =~ /^\.(\w\w)$/ ) { # Probably a tld + $To = $tld2country{ uc $1 }; + } + + # Make sure that $Amount is of the form \d+(\.\d\d)? + $Amount = sprintf( "%.2f", $Amount ); + + # Get the exact currency abbreviations + my $newFrom = &GetAbb( $From, %CurrLookup ); + my $newTo = &GetAbb( $To, %CurrLookup ); + + $From = $newFrom if $newFrom; + $To = $newTo if $newTo; + + if ( exists $Currencies{$From} and exists $Currencies{$To} ) { + + my $req = POST $Converter, + [ + timezone => 'UTC', + From => $From, + To => $To, + Amount => $Amount, + ]; + + # Falsify where we came from + $req->referer($Referer); + + # Submit request + my $res = $ua->request($req); + + if ( $res->is_success ) { + + # Went through ok + my $html = $res->as_string; + + # parse each one to avoid undefined warnings + my ($When) = + ( $html =~ + m/ as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)/gi ); + my ($Cfrom) = ( $html =~ m/(\d[\d,.]+)\s*$From/gi ); + my ($Cto) = ( $html =~ m/(\d[\d,.]+)\s*$To/gi ); + +#my ($When, $Cfrom, $Cto) = +# grep /\S+/, ($html =~ m/ as of (\d{4}\.\d\d.\d\d\s\d\d:\d\d:\d\d\s\S+)|(\d[\d,.]+)\s*$From|(\d[\d,.]+)\s* $To/gi); + + if ($When) { + return "$Cfrom $Currencies{$From} makes " + . "$Cto $Currencies{$To} (from http://www.xe.com/)" + ; # ." ($When)\n"; + } + else { + return 'i got some error trying that'; + } + } + else { + + # Oh dear. + return "EXCHANGE: " . $res->status_line; + } + } + else { + return "Don't know about \"$From\" as a currency" + if ( !exists $Currencies{$From} ); + return "Don't know about \"$To\" as a currency" + if ( !exists $Currencies{$To} ); + } } } sub query { - my ($args) = @_; - &::performStrictReply(&exchange($args)); - return; + my ($args) = @_; + &::performStrictReply( &exchange($args) ); + return; } #print &exchange('1 usd to eur') . "\n"; diff --git a/src/Modules/Factoids.pl b/src/Modules/Factoids.pl index 12e6495..bbc0134 100644 --- a/src/Modules/Factoids.pl +++ b/src/Modules/Factoids.pl @@ -13,723 +13,798 @@ use vars qw(%param); ### # Usage: &CmdFactInfo($faqtoid, $query); sub CmdFactInfo { - my ($faqtoid, $query) = (lc $_[0], $_[1]); + my ( $faqtoid, $query ) = ( lc $_[0], $_[1] ); my @array; my $string = ''; - if ($faqtoid eq '') { - &help('factinfo'); - return; + if ( $faqtoid eq '' ) { + &help('factinfo'); + return; } - my %factinfo = &sqlSelectRowHash('factoids', '*', - { factoid_key => $faqtoid } - ); + my %factinfo = + &sqlSelectRowHash( 'factoids', '*', { factoid_key => $faqtoid } ); # factoid does not exist. - if (scalar (keys %factinfo) <= 1) { - &performReply("there's no such factoid as \002$faqtoid\002"); - return; + if ( scalar( keys %factinfo ) <= 1 ) { + &performReply("there's no such factoid as \002$faqtoid\002"); + return; } # fix for problem observed by asuffield. # why did it happen though? - if (!$factinfo{'factoid_value'}) { - &performReply("there's no such factoid as \002$faqtoid\002; deleted because we don't have factoid_value!"); - foreach (keys %factinfo) { - &DEBUG("factinfo{$_} => '$factinfo{$_}'."); - } + if ( !$factinfo{'factoid_value'} ) { + &performReply( +"there's no such factoid as \002$faqtoid\002; deleted because we don't have factoid_value!" + ); + foreach ( keys %factinfo ) { + &DEBUG("factinfo{$_} => '$factinfo{$_}'."); + } ### &delFactoid($faqtoid); - return; + return; } # created: - if ($factinfo{'created_by'}) { - - $factinfo{'created_by'} =~ s/\!/ '; - $string = "created by $factinfo{'created_by'}"; - - my $time = $factinfo{'created_time'}; - if ($time) { - if (time() - $time > 60*60*24*7) { - my $days = int( (time() - $time)/60/60/24 ); - $string .= " at \037". scalar(gmtime $time). "\037" . - " ($days days)"; - } else { - $string .= ' '.&Time2String(time() - $time).' ago'; - } - } - - push(@array,$string); + if ( $factinfo{'created_by'} ) { + + $factinfo{'created_by'} =~ s/\!/ '; + $string = "created by $factinfo{'created_by'}"; + + my $time = $factinfo{'created_time'}; + if ($time) { + if ( time() - $time > 60 * 60 * 24 * 7 ) { + my $days = int( ( time() - $time ) / 60 / 60 / 24 ); + $string .= " at \037" + . scalar( gmtime $time ) . "\037" + . " ($days days)"; + } + else { + $string .= ' ' . &Time2String( time() - $time ) . ' ago'; + } + } + + push( @array, $string ); } # modified: (TimRiker asks: why do you keep turning this off?) - if ($factinfo{'modified_by'}) { - $string = 'last modified'; - - my $time = $factinfo{'modified_time'}; - if ($time) { - if (time() - $time > 60*60*24*7) { - $string .= " at \037". scalar(gmtime $time). "\037"; - } else { - $string .= ' '.&Time2String(time() - $time).' ago '; - } - } - - $string .= ' by '.(split ',', $factinfo{'modified_by'})[0]; - - push(@array,$string); + if ( $factinfo{'modified_by'} ) { + $string = 'last modified'; + + my $time = $factinfo{'modified_time'}; + if ($time) { + if ( time() - $time > 60 * 60 * 24 * 7 ) { + $string .= " at \037" . scalar( gmtime $time ) . "\037"; + } + else { + $string .= ' ' . &Time2String( time() - $time ) . ' ago '; + } + } + + $string .= ' by ' . ( split ',', $factinfo{'modified_by'} )[0]; + + push( @array, $string ); } # requested: - if ($factinfo{'requested_by'}) { - my $requested_count = $factinfo{'requested_count'}; - - if ($requested_count) { - $string = 'it has been requested '; - if ($requested_count == 1) { - $string .= "\002once\002"; - } else { - $string .= "\002". $requested_count. "\002 ". - &fixPlural('time', $requested_count); - } - - my $requested_by = $factinfo{'requested_by'}; - $requested_by =~ /\!/; - $string .= ", last by $`"; - - my $requested_time = $factinfo{'requested_time'}; - if ($requested_time) { - if (time() - $requested_time > 60*60*24*7) { - $string .= " at \037". scalar(localtime $requested_time). "\037"; - } else { - $string .= ', '.&Time2String(time() - $requested_time).' ago'; - } - } - } else { - $string = 'has not been requested yet'; - } - - push(@array, $string); + if ( $factinfo{'requested_by'} ) { + my $requested_count = $factinfo{'requested_count'}; + + if ($requested_count) { + $string = 'it has been requested '; + if ( $requested_count == 1 ) { + $string .= "\002once\002"; + } + else { + $string .= "\002" + . $requested_count . "\002 " + . &fixPlural( 'time', $requested_count ); + } + + my $requested_by = $factinfo{'requested_by'}; + $requested_by =~ /\!/; + $string .= ", last by $`"; + + my $requested_time = $factinfo{'requested_time'}; + if ($requested_time) { + if ( time() - $requested_time > 60 * 60 * 24 * 7 ) { + $string .= + " at \037" . scalar( localtime $requested_time ) . "\037"; + } + else { + $string .= + ', ' . &Time2String( time() - $requested_time ) . ' ago'; + } + } + } + else { + $string = 'has not been requested yet'; + } + + push( @array, $string ); } # locked: - if ($factinfo{'locked_by'}) { - $factinfo{'locked_by'} =~ /\!/; - $string = "it has been locked by $`"; + if ( $factinfo{'locked_by'} ) { + $factinfo{'locked_by'} =~ /\!/; + $string = "it has been locked by $`"; - push(@array, $string); + push( @array, $string ); } # factoid was inserted not through the bot. - if (!scalar @array) { - &performReply("no extra info on \002$faqtoid\002"); - return; + if ( !scalar @array ) { + &performReply("no extra info on \002$faqtoid\002"); + return; } - &performStrictReply("$factinfo{'factoid_key'} -- ". join('; ', @array) .'.'); + &performStrictReply( + "$factinfo{'factoid_key'} -- " . join( '; ', @array ) . '.' ); return; } sub CmdFactStats { my ($type) = @_; - if ($type =~ /^author$/i) { - my %hash = &sqlSelectColHash('factoids', - 'factoid_key,created_by', undef, - 'WHERE created_by IS NOT NULL' - ); - my %author; - - foreach my $factoid (keys %hash) { - my $thisnuh = $hash{$factoid}; - - $thisnuh =~ /^(\S+)!\S+@\S+$/; - $author{lc $1}++; - } - - if (!scalar keys %author) { - return 'sorry, no factoids with created_by field.'; - } - - # work-around. - my %count; - foreach (keys %author) { - $count{ $author{$_} }{$_} = 1; - } - undef %author; - - my $count; - my @list; - foreach $count (sort { $b <=> $a } keys %count) { - my $author = join(', ', sort keys %{ $count{$count} }); - push(@list, "$count by $author"); - } - - my $prefix = 'factoid statistics by author: '; - return &formListReply(0, $prefix, @list); - - } elsif ($type =~ /^vandalism$/i) { - &status('factstats(vandalism): starting...'); - my $start_time = &timeget(); - my %data = &sqlSelectColHash('factoids', - 'factoid_key,factoid_value', undef, - 'WHERE factoid_value IS NOT NULL' - ); - my @list; - - my $delta_time = &timedelta($start_time); - &status(sprintf('factstats(vandalism): %.02f sec to retreive all factoids.', $delta_time)) if ($delta_time > 0); - $start_time = &timeget(); - - # parse the factoids. - foreach (keys %data) { - if (&validFactoid($_, $data{$_}) == 0) { - s/([\,\;]+)/\037$1\037/g; # highlight chars. - push(@list, $_); # push it. - } - } - - $delta_time = &timedelta($start_time); - &status(sprintf('factstats(vandalism): %.02f sec to complete.', $delta_time)) if ($delta_time > 0); - - # bail out on no results. - if (scalar @list == 0) { - return 'no vandalised factoids... wooohoo.'; - } - - # parse the results. - my $prefix = 'Vandalised factoid '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^total$/i) { - &status('factstats(total): starting...'); - my $start_time = &timeget(); - my @list; - my $str; - my($i,$j); - my %hash; - - ### lets do it. - # total factoids requests. - $i = &sumKey('factoids', 'requested_count'); - push(@list, "total requests - $i"); - - # total factoids modified. - $str = &countKeys('factoids', 'modified_by'); - push(@list, "total modified - $str"); - - # total factoids modified. - $j = &countKeys('factoids', 'requested_count'); - $str = &countKeys('factoids', 'factoid_key'); - push(@list, 'total non-requested - '.($str - $i)); - - # average request/factoid. - # i/j == total(requested_count)/count(requested_count) - $str = sprintf('%.01f', $i/$j); - push(@list, "average requested per factoid - $str"); - - # total prepared for deletion. - $str = scalar( &searchTable('factoids', 'factoid_key', 'factoid_value', ' #DEL') ); - push(@list, "total prepared for deletion - $str"); - - # total unique authors. - # TODO: convert to sqlSelectColHash ? (or ColArray?) - foreach ( &sqlRawReturn('SELECT created_by FROM factoids WHERE created_by IS NOT NULL') ) { - /^(\S+)!/; - my $nick = lc $1; - $hash{$nick}++; - } - push(@list, 'total unique authors - '.(scalar keys %hash) ); - undef %hash; - - # total unique requesters. - foreach ( &sqlRawReturn('SELECT requested_by FROM factoids WHERE requested_by IS NOT NULL') ) { - /^(\S+)!/; - my $nick = lc $1; - $hash{$nick}++; - } - push(@list, 'total unique requesters - '.(scalar keys %hash) ); - undef %hash; - - ### end of 'job'. - - my $delta_time = &timedelta($start_time); - &status(sprintf('factstats(broken): %.02f sec to retreive all factoids.', $delta_time)) if ($delta_time > 0); - $start_time = &timeget(); - - # bail out on no results. - if (scalar @list == 0) { - return 'no broken factoids... wooohoo.'; - } - - # parse the results. - my $prefix = 'General factoid statistics '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^deadredir$/i) { - my @list = &searchTable('factoids', 'factoid_key', - 'factoid_value', '^ see '); - my %redir; - my $f; - - for (@list) { - my $factoid = $_; - my $val = &getFactInfo($factoid, 'factoid_value'); - if ($val =~ /^ ?see( also)? (.*?)\.?$/i) { - my $redirf = lc $2; - my $redir = &getFactInfo($redirf, 'factoid_value'); - next if (defined $redir); - next if (length $val > 50); - - $redir{$redirf}{$factoid} = 1; - } - } - - my @newlist; - foreach $f (keys %redir) { - my @sublist = keys %{ $redir{$f} }; - for (@sublist) { - s/([\,\;]+)/\037$1\037/g; - } - - push(@newlist, join(', ', @sublist)." => $f"); - } - - # parse the results. - my $prefix = 'Loose link (dead) redirections in factoids '; - return &formListReply(1, $prefix, @newlist); - - } elsif ($type =~ /^dup(licate|e)$/i) { - &status('factstats(dupe): starting...'); - my $start_time = &timeget(); - my %hash = &sqlSelectColHash('factoids', - 'factoid_key,factoid_value', undef, - 'WHERE factoid_value IS NOT NULL', 1 - ); - my $refs = 0; - my @list; - my $v; - - foreach $v (keys %hash) { - my $count = scalar(keys %{ $hash{$v} }); - next if ($count == 1); - - my @sublist; - foreach (keys %{ $hash{$v} }) { - if ($v =~ /^ see /i) { - $refs++; - next; - } - - s/([\,\;]+)/\037$1\037/g; - if ($_ eq '') { - &WARN('dupe: _ = NULL. should never happen!.'); - next; - } - push(@sublist, $_); - } - - next unless (scalar @sublist); - - push(@list, join(', ', @sublist)); - } - - &status("factstats(dupe): (good) dupe refs: $refs."); - my $delta_time = &timedelta($start_time); - &status(sprintf('factstats(dupe): %.02f sec to complete', $delta_time)) if ($delta_time > 0); - - # bail out on no results. - if (scalar @list == 0) { - return 'no duplicate factoids... woohoo.'; - } - - # parse the results. - my $prefix = 'dupe factoid '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^nullfactoids$/i) { - my $query = "SELECT factoid_key,factoid_value FROM factoids WHERE factoid_value=''"; - my $sth = $dbh->prepare($query); - &ERROR("factstats(null): => '$query'.") unless $sth->execute; - - my @list; - while (my @row = $sth->fetchrow_array) { - if ($row[1] ne '') { - &DEBUG("row[1] != NULL for $row[0]."); - next; - } - - &DEBUG("row[0] => '$row[0]'."); - push(@list, $row[0]); - } - $sth->finish; - - # parse the results. - my $prefix = 'NULL factoids (not deleted yet) '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^(2|too)short$/i) { - # Custom select statement. - my $query = 'SELECT factoid_key,factoid_value FROM factoids WHERE length(factoid_value) <= 40'; - my $sth = $dbh->prepare($query); - &ERROR("factstats(lame): => '$query'.") unless $sth->execute; - - my @list; - while (my @row = $sth->fetchrow_array) { - my($key,$val) = ($row[0], $row[1]); - my $match = 0; - $match++ if ($val =~ /\s{3,}/); - next unless ($match); - - my $v = &getFactoid($val); - if (defined $v) { - &DEBUG("key $key => $val => $v"); - } - - $key =~ s/\,/\037\,\037/g; - push(@list, $key); - } - $sth->finish; - - # parse the results. - my $prefix = 'Lame factoids '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^listfix$/i) { - # Custom select statement. - my $query = 'SELECT factoid_key,factoid_value FROM factoids'; - my $sth = $dbh->prepare($query); - &ERROR("factstats(listfix): => '$query'.") unless $sth->execute; - - my @list; - while (my @row = $sth->fetchrow_array) { - my($key,$val) = ($row[0], $row[1]); - my $match = 0; - $match++ if ($val =~ /\S+,? or \S+,? or \S+,? or \S+,?/); - next unless ($match); - - $key =~ s/\,/\037\,\037/g; - push(@list, $key); - $val =~ s/,? or /, /g; - &DEBUG("fixed: => $val."); - &setFactInfo($key,'factoid_value', $val); - } - $sth->finish; - - # parse the results. - my $prefix = 'Inefficient lists fixed '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^locked$/i) { - my %hash = &sqlSelectColHash('factoids', - 'factoid_key,locked_by', undef, - 'WHERE locked_by IS NOT NULL' - ); - my @list = keys %hash; - - for (@list) { - s/([\,\;]+)/\037$1\037/g; - } - - my $prefix = "factoid statistics on $type "; - return &formListReply(0, $prefix, @list); - - } elsif ($type =~ /^new$/i) { - my %hash = &sqlSelectColHash('factoids', - 'factoid_key,created_time', undef, - 'WHERE created_time IS NOT NULL' - ); - my %age; - - foreach (keys %hash) { - my $created_time = $hash{$_}; - my $delta_time = time() - $created_time; - next if ($delta_time >= 60*60*24); - - $age{$delta_time}{$_} = 1; - } - - if (scalar keys %age == 0) { - return 'sorry, no new factoids.'; - } - - my @list; - foreach (sort {$a <=> $b} keys %age) { - push(@list, join(',', keys %{ $age{$_} })); - } - - my $prefix = 'new factoids in the last 24hours '; - return &formListReply(0, $prefix, @list); - - } elsif ($type =~ /^part(ial)?dupe$/i) { - ### requires 'custom' select statement... oh well... - my $start_time = &timeget(); - - # form length|key and key=length hash list. - &status('factstats(partdupe): forming length hash list.'); - my $query = 'SELECT factoid_key,factoid_value,length(factoid_value) AS length FROM factoids WHERE length(factoid_value) >= 192 ORDER BY length'; - my $sth = $dbh->prepare($query); - &ERROR("factstats(partdupe): => '$query'.") unless $sth->execute; - - my (@key, @list); - my (%key, %length); - while (my @row = $sth->fetchrow_array) { - $length{$row[2]}{$row[0]} = 1; # length(value)|key. - $key{$row[0]} = $row[1]; # key=value. - push(@key, $row[0]); - } - $sth->finish; - &status("factstats(partdupe): total keys => '". scalar(@key) ."'."); - &status('factstats(partdupe): now deciphering data gathered'); - - my @length = sort { $a <=> $b } keys %length; - my $key; - - foreach $key (@key) { - shift @length if (length $key{$key} == $length[0]); - - my $val = quotemeta $key{$key}; - my @sublist; - my $length; - foreach $length (@length) { - foreach (keys %{ $length{$length} }) { - if ($key{$_} =~ /^$val/i) { - s/([\,\;]+)/\037$1\037/g; - s/( and|and )/\037$1\037/g; - push(@sublist,$key.' and '.$_); - } - } - } - push(@list, join(' ,',@sublist)) if (scalar @sublist); - } - - my $delta_time = sprintf('%.02fs', &timedelta($start_time) ); - &status("factstats(partdupe): $delta_time sec to complete.") if ($delta_time > 0); - - # bail out on no results. - if (scalar @list == 0) { - return 'no initial partial duplicate factoids... woohoo.'; - } - - # parse the results. - my $prefix = 'initial partial dupe factoid '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^profanity$/i) { - my %data = &sqlSelectColHash('factoids', - 'factoid_key,factoid_value', undef, - 'WHERE factoid_value IS NOT NULL' - ); - my @list; - - foreach (keys %data) { - push(@list, $_) if (&hasProfanity($_.' '.$data{$_})); - } - - # parse the results. - my $prefix = 'Profanity in factoids '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^redir(ection)?$/i) { - my @list = &searchTable('factoids', 'factoid_key', - 'factoid_value', '^ see '); - my %redir; - my $f; - my $dangling = 0; - - for (@list) { - my $factoid = $_; - my $val = &getFactInfo($factoid, 'factoid_value'); - if ($val =~ /^ see( also)? (.*?)\.?$/i) { - my $redir = lc $2; - my $redirval = &getFactInfo($redir, 'factoid_value'); - if (defined $redirval) { - $redir{$redir}{$factoid} = 1; - } else { - &DEBUG("factstats(redir): '$factoid' has loose link => '$redir'."); - $dangling++; - } - } - } - - my @newlist; - foreach $f (keys %redir) { - my @sublist = keys %{ $redir{$f} }; - for (@sublist) { - s/([\,\;]+)/\037$1\037/g; - } - - push(@newlist, "$f => ". join(', ', @sublist)); - } - - # parse the results. - my $prefix = "Redirections in factoids, $dangling dangling "; - return &formListReply(1, $prefix, @newlist); - - } elsif ($type =~ /^request(ed)?$/i) { - my %hash = &sqlSelectColHash('factoids', - 'factoid_key,requested_count', undef, - 'WHERE requested_count IS NOT NULL', 1 - ); - - if (!scalar keys %hash) { - return 'sorry, no factoids have been questioned.'; - } - - my $count; - my @list; - my $total = 0; - foreach $count (sort {$b <=> $a} keys %hash) { - my @faqtoids = sort keys %{ $hash{$count} }; - - for (@faqtoids) { - s/([\,\;]+)/\037$1\037/g; - } - $total += $count * scalar(@faqtoids); - - push(@list, "$count - ". join(', ', @faqtoids)); - } - unshift(@list, "\037$total - TOTAL\037"); - - my $prefix = "factoid statistics on $type "; - return &formListReply(0, $prefix, @list); - - } elsif ($type =~ /^reqrate$/i) { - my %hash = &sqlSelectColHash('factoids', - "factoid_key,(unix_timestamp() - created_time)/requested_count as rate", undef, - 'WHERE requested_by IS NOT NULL and created_time IS NOT NULL ORDER BY rate LIMIT 15', 1 - ); - - my $rate; - my @list; - my $total = 0; - my $users = 0; - foreach $rate (sort { $b <=> $a } keys %hash) { - my $f = join(', ', sort keys %{ $hash{$rate} }); - my $str = "$f - ".&Time2String($rate); - $str =~ s/\002//g; - push(@list, $str); - } - - my $prefix = "Rank of top factoid rate (time/req): "; - return &formListReply(0, $prefix, @list); - - } elsif ($type =~ /^requesters?$/i) { - my %hash = &sqlSelectColHash('factoids', - 'factoid_key,requested_by', undef, - 'WHERE requested_by IS NOT NULL' - ); - my %requester; - - foreach (keys %hash) { - my $thisnuh = $hash{$_}; - - $thisnuh =~ /^(\S+)!\S+@\S+$/; - $requester{lc $1}++; - } - - if (!scalar keys %requester) { - return 'sorry, no factoids with requested_by field.'; - } - - # work-around. - my %count; - foreach (keys %requester) { - $count{ $requester{$_} }{$_} = 1; - } - undef %requester; - - my $count; - my @list; - my $total = 0; - my $users = 0; - foreach $count (sort { $b <=> $a } keys %count) { - my $requester = join(', ', sort keys %{ $count{$count} }); - $total += $count * scalar(keys %{ $count{$count} }); - $users += scalar(keys %{ $count{$count} }); - push(@list, "$count by $requester"); - } - unshift(@list, "\037$total TOTAL REQUESTS; $users UNIQUE REQUESTERS\037"); - # should not the above value be the same as collected by - # 'requested'? soemthing weird is going on! - - my $prefix = 'rank of top factoid requesters: '; - return &formListReply(0, $prefix, @list); - - } elsif ($type =~ /^seefix$/i) { - my @list = &searchTable('factoids', 'factoid_key', - 'factoid_value', '^see '); - my @newlist; - my $fixed = 0; - my %loop; - my $f; - - for (@list) { - my $factoid = $_; - my $val = &getFactInfo($factoid, 'factoid_value'); - - next unless ($val =~ /^see( also)? (.*?)\.?$/i); - - my $redirf = lc $2; - my $redir = &getFactInfo($redirf, 'factoid_value'); - - if ($redirf =~ /^\Q$factoid\W$/i) { - &delFactoid($factoid); - $loop{$factoid} = 1; - } - - if (defined $redir) { # good. - &setFactInfo($factoid,'factoid_value'," see $redir"); - $fixed++; - } else { - push(@newlist, $redirf); - } - } - - # parse the results. - &msg($who, "Fixed $fixed factoids."); - &msg($who, 'Self looped factoids removed: '. keys %loop ) if (scalar keys %loop); - - my $prefix = "Loose link (dead) redirections in factoids "; - return &formListReply(1, $prefix, @newlist); - - } elsif ($type =~ /^(2|too)long$/i) { - my @list; - my $query; - - # factoid_key. - $query = "SELECT factoid_key FROM factoids WHERE length(factoid_key) >= $param{'maxKeySize'}"; - my $sth = $dbh->prepare($query); - $sth->execute; - while (my @row = $sth->fetchrow_array) { - push(@list,$row[0]); - } - $sth->finish; - - # factoid_value. - $query = "SELECT factoid_key,factoid_value FROM factoids WHERE length(factoid_value) >= $param{'maxDataSize'}"; - $sth = $dbh->prepare($query); - $sth->execute; - while (my @row = $sth->fetchrow_array) { - push(@list,sprintf("\002%s\002 - %s", length($row[1]), $row[0])); - } - $sth->finish; - - if (scalar @list == 0) { - return 'good. no factoids exceed length.'; - } - - # parse the results. - my $prefix = 'factoid key||value exceeding length '; - return &formListReply(1, $prefix, @list); - - } elsif ($type =~ /^unrequest(ed)?$/i) { - # TODO: use sqlSelect() - my ($count) = &sqlRawReturn("SELECT COUNT(*) FROM factoids WHERE requested_count = '0'"); - - return "Unrequested factoids: $count"; + if ( $type =~ /^author$/i ) { + my %hash = &sqlSelectColHash( + 'factoids', 'factoid_key,created_by', + undef, 'WHERE created_by IS NOT NULL' + ); + my %author; + + foreach my $factoid ( keys %hash ) { + my $thisnuh = $hash{$factoid}; + + $thisnuh =~ /^(\S+)!\S+@\S+$/; + $author{ lc $1 }++; + } + + if ( !scalar keys %author ) { + return 'sorry, no factoids with created_by field.'; + } + + # work-around. + my %count; + foreach ( keys %author ) { + $count{ $author{$_} }{$_} = 1; + } + undef %author; + + my $count; + my @list; + foreach $count ( sort { $b <=> $a } keys %count ) { + my $author = join( ', ', sort keys %{ $count{$count} } ); + push( @list, "$count by $author" ); + } + + my $prefix = 'factoid statistics by author: '; + return &formListReply( 0, $prefix, @list ); + + } + elsif ( $type =~ /^vandalism$/i ) { + &status('factstats(vandalism): starting...'); + my $start_time = &timeget(); + my %data = &sqlSelectColHash( + 'factoids', 'factoid_key,factoid_value', + undef, 'WHERE factoid_value IS NOT NULL' + ); + my @list; + + my $delta_time = &timedelta($start_time); + &status( + sprintf( + 'factstats(vandalism): %.02f sec to retreive all factoids.', + $delta_time ) + ) if ( $delta_time > 0 ); + $start_time = &timeget(); + + # parse the factoids. + foreach ( keys %data ) { + if ( &validFactoid( $_, $data{$_} ) == 0 ) { + s/([\,\;]+)/\037$1\037/g; # highlight chars. + push( @list, $_ ); # push it. + } + } + + $delta_time = &timedelta($start_time); + &status( + sprintf( 'factstats(vandalism): %.02f sec to complete.', + $delta_time ) + ) if ( $delta_time > 0 ); + + # bail out on no results. + if ( scalar @list == 0 ) { + return 'no vandalised factoids... wooohoo.'; + } + + # parse the results. + my $prefix = 'Vandalised factoid '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^total$/i ) { + &status('factstats(total): starting...'); + my $start_time = &timeget(); + my @list; + my $str; + my ( $i, $j ); + my %hash; + + ### lets do it. + # total factoids requests. + $i = &sumKey( 'factoids', 'requested_count' ); + push( @list, "total requests - $i" ); + + # total factoids modified. + $str = &countKeys( 'factoids', 'modified_by' ); + push( @list, "total modified - $str" ); + + # total factoids modified. + $j = &countKeys( 'factoids', 'requested_count' ); + $str = &countKeys( 'factoids', 'factoid_key' ); + push( @list, 'total non-requested - ' . ( $str - $i ) ); + + # average request/factoid. + # i/j == total(requested_count)/count(requested_count) + $str = sprintf( '%.01f', $i / $j ); + push( @list, "average requested per factoid - $str" ); + + # total prepared for deletion. + $str = + scalar( + &searchTable( 'factoids', 'factoid_key', 'factoid_value', ' #DEL' ) + ); + push( @list, "total prepared for deletion - $str" ); + + # total unique authors. + # TODO: convert to sqlSelectColHash ? (or ColArray?) + foreach ( + &sqlRawReturn( + 'SELECT created_by FROM factoids WHERE created_by IS NOT NULL') + ) + { + /^(\S+)!/; + my $nick = lc $1; + $hash{$nick}++; + } + push( @list, 'total unique authors - ' . ( scalar keys %hash ) ); + undef %hash; + + # total unique requesters. + foreach ( + &sqlRawReturn( +'SELECT requested_by FROM factoids WHERE requested_by IS NOT NULL' + ) + ) + { + /^(\S+)!/; + my $nick = lc $1; + $hash{$nick}++; + } + push( @list, 'total unique requesters - ' . ( scalar keys %hash ) ); + undef %hash; + + ### end of 'job'. + + my $delta_time = &timedelta($start_time); + &status( + sprintf( 'factstats(broken): %.02f sec to retreive all factoids.', + $delta_time ) + ) if ( $delta_time > 0 ); + $start_time = &timeget(); + + # bail out on no results. + if ( scalar @list == 0 ) { + return 'no broken factoids... wooohoo.'; + } + + # parse the results. + my $prefix = 'General factoid statistics '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^deadredir$/i ) { + my @list = + &searchTable( 'factoids', 'factoid_key', 'factoid_value', + '^ see ' ); + my %redir; + my $f; + + for (@list) { + my $factoid = $_; + my $val = &getFactInfo( $factoid, 'factoid_value' ); + if ( $val =~ /^ ?see( also)? (.*?)\.?$/i ) { + my $redirf = lc $2; + my $redir = &getFactInfo( $redirf, 'factoid_value' ); + next if ( defined $redir ); + next if ( length $val > 50 ); + + $redir{$redirf}{$factoid} = 1; + } + } + + my @newlist; + foreach $f ( keys %redir ) { + my @sublist = keys %{ $redir{$f} }; + for (@sublist) { + s/([\,\;]+)/\037$1\037/g; + } + + push( @newlist, join( ', ', @sublist ) . " => $f" ); + } + + # parse the results. + my $prefix = 'Loose link (dead) redirections in factoids '; + return &formListReply( 1, $prefix, @newlist ); + + } + elsif ( $type =~ /^dup(licate|e)$/i ) { + &status('factstats(dupe): starting...'); + my $start_time = &timeget(); + my %hash = + &sqlSelectColHash( 'factoids', 'factoid_key,factoid_value', undef, + 'WHERE factoid_value IS NOT NULL', 1 ); + my $refs = 0; + my @list; + my $v; + + foreach $v ( keys %hash ) { + my $count = scalar( keys %{ $hash{$v} } ); + next if ( $count == 1 ); + + my @sublist; + foreach ( keys %{ $hash{$v} } ) { + if ( $v =~ /^ see /i ) { + $refs++; + next; + } + + s/([\,\;]+)/\037$1\037/g; + if ( $_ eq '' ) { + &WARN('dupe: _ = NULL. should never happen!.'); + next; + } + push( @sublist, $_ ); + } + + next unless ( scalar @sublist ); + + push( @list, join( ', ', @sublist ) ); + } + + &status("factstats(dupe): (good) dupe refs: $refs."); + my $delta_time = &timedelta($start_time); + &status( + sprintf( 'factstats(dupe): %.02f sec to complete', $delta_time ) ) + if ( $delta_time > 0 ); + + # bail out on no results. + if ( scalar @list == 0 ) { + return 'no duplicate factoids... woohoo.'; + } + + # parse the results. + my $prefix = 'dupe factoid '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^nullfactoids$/i ) { + my $query = +"SELECT factoid_key,factoid_value FROM factoids WHERE factoid_value=''"; + my $sth = $dbh->prepare($query); + &ERROR("factstats(null): => '$query'.") unless $sth->execute; + + my @list; + while ( my @row = $sth->fetchrow_array ) { + if ( $row[1] ne '' ) { + &DEBUG("row[1] != NULL for $row[0]."); + next; + } + + &DEBUG("row[0] => '$row[0]'."); + push( @list, $row[0] ); + } + $sth->finish; + + # parse the results. + my $prefix = 'NULL factoids (not deleted yet) '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^(2|too)short$/i ) { + + # Custom select statement. + my $query = +'SELECT factoid_key,factoid_value FROM factoids WHERE length(factoid_value) <= 40'; + my $sth = $dbh->prepare($query); + &ERROR("factstats(lame): => '$query'.") unless $sth->execute; + + my @list; + while ( my @row = $sth->fetchrow_array ) { + my ( $key, $val ) = ( $row[0], $row[1] ); + my $match = 0; + $match++ if ( $val =~ /\s{3,}/ ); + next unless ($match); + + my $v = &getFactoid($val); + if ( defined $v ) { + &DEBUG("key $key => $val => $v"); + } + + $key =~ s/\,/\037\,\037/g; + push( @list, $key ); + } + $sth->finish; + + # parse the results. + my $prefix = 'Lame factoids '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^listfix$/i ) { + + # Custom select statement. + my $query = 'SELECT factoid_key,factoid_value FROM factoids'; + my $sth = $dbh->prepare($query); + &ERROR("factstats(listfix): => '$query'.") unless $sth->execute; + + my @list; + while ( my @row = $sth->fetchrow_array ) { + my ( $key, $val ) = ( $row[0], $row[1] ); + my $match = 0; + $match++ if ( $val =~ /\S+,? or \S+,? or \S+,? or \S+,?/ ); + next unless ($match); + + $key =~ s/\,/\037\,\037/g; + push( @list, $key ); + $val =~ s/,? or /, /g; + &DEBUG("fixed: => $val."); + &setFactInfo( $key, 'factoid_value', $val ); + } + $sth->finish; + + # parse the results. + my $prefix = 'Inefficient lists fixed '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^locked$/i ) { + my %hash = &sqlSelectColHash( + 'factoids', 'factoid_key,locked_by', + undef, 'WHERE locked_by IS NOT NULL' + ); + my @list = keys %hash; + + for (@list) { + s/([\,\;]+)/\037$1\037/g; + } + + my $prefix = "factoid statistics on $type "; + return &formListReply( 0, $prefix, @list ); + + } + elsif ( $type =~ /^new$/i ) { + my %hash = &sqlSelectColHash( + 'factoids', 'factoid_key,created_time', + undef, 'WHERE created_time IS NOT NULL' + ); + my %age; + + foreach ( keys %hash ) { + my $created_time = $hash{$_}; + my $delta_time = time() - $created_time; + next if ( $delta_time >= 60 * 60 * 24 ); + + $age{$delta_time}{$_} = 1; + } + + if ( scalar keys %age == 0 ) { + return 'sorry, no new factoids.'; + } + + my @list; + foreach ( sort { $a <=> $b } keys %age ) { + push( @list, join( ',', keys %{ $age{$_} } ) ); + } + + my $prefix = 'new factoids in the last 24hours '; + return &formListReply( 0, $prefix, @list ); + + } + elsif ( $type =~ /^part(ial)?dupe$/i ) { + ### requires 'custom' select statement... oh well... + my $start_time = &timeget(); + + # form length|key and key=length hash list. + &status('factstats(partdupe): forming length hash list.'); + my $query = +'SELECT factoid_key,factoid_value,length(factoid_value) AS length FROM factoids WHERE length(factoid_value) >= 192 ORDER BY length'; + my $sth = $dbh->prepare($query); + &ERROR("factstats(partdupe): => '$query'.") unless $sth->execute; + + my ( @key, @list ); + my ( %key, %length ); + while ( my @row = $sth->fetchrow_array ) { + $length{ $row[2] }{ $row[0] } = 1; # length(value)|key. + $key{ $row[0] } = $row[1]; # key=value. + push( @key, $row[0] ); + } + $sth->finish; + &status( "factstats(partdupe): total keys => '" . scalar(@key) . "'." ); + &status('factstats(partdupe): now deciphering data gathered'); + + my @length = sort { $a <=> $b } keys %length; + my $key; + + foreach $key (@key) { + shift @length if ( length $key{$key} == $length[0] ); + + my $val = quotemeta $key{$key}; + my @sublist; + my $length; + foreach $length (@length) { + foreach ( keys %{ $length{$length} } ) { + if ( $key{$_} =~ /^$val/i ) { + s/([\,\;]+)/\037$1\037/g; + s/( and|and )/\037$1\037/g; + push( @sublist, $key . ' and ' . $_ ); + } + } + } + push( @list, join( ' ,', @sublist ) ) if ( scalar @sublist ); + } + + my $delta_time = sprintf( '%.02fs', &timedelta($start_time) ); + &status("factstats(partdupe): $delta_time sec to complete.") + if ( $delta_time > 0 ); + + # bail out on no results. + if ( scalar @list == 0 ) { + return 'no initial partial duplicate factoids... woohoo.'; + } + + # parse the results. + my $prefix = 'initial partial dupe factoid '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^profanity$/i ) { + my %data = &sqlSelectColHash( + 'factoids', 'factoid_key,factoid_value', + undef, 'WHERE factoid_value IS NOT NULL' + ); + my @list; + + foreach ( keys %data ) { + push( @list, $_ ) if ( &hasProfanity( $_ . ' ' . $data{$_} ) ); + } + + # parse the results. + my $prefix = 'Profanity in factoids '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^redir(ection)?$/i ) { + my @list = + &searchTable( 'factoids', 'factoid_key', 'factoid_value', + '^ see ' ); + my %redir; + my $f; + my $dangling = 0; + + for (@list) { + my $factoid = $_; + my $val = &getFactInfo( $factoid, 'factoid_value' ); + if ( $val =~ /^ see( also)? (.*?)\.?$/i ) { + my $redir = lc $2; + my $redirval = &getFactInfo( $redir, 'factoid_value' ); + if ( defined $redirval ) { + $redir{$redir}{$factoid} = 1; + } + else { + &DEBUG( +"factstats(redir): '$factoid' has loose link => '$redir'." + ); + $dangling++; + } + } + } + + my @newlist; + foreach $f ( keys %redir ) { + my @sublist = keys %{ $redir{$f} }; + for (@sublist) { + s/([\,\;]+)/\037$1\037/g; + } + + push( @newlist, "$f => " . join( ', ', @sublist ) ); + } + + # parse the results. + my $prefix = "Redirections in factoids, $dangling dangling "; + return &formListReply( 1, $prefix, @newlist ); + + } + elsif ( $type =~ /^request(ed)?$/i ) { + my %hash = + &sqlSelectColHash( 'factoids', 'factoid_key,requested_count', undef, + 'WHERE requested_count IS NOT NULL', 1 ); + + if ( !scalar keys %hash ) { + return 'sorry, no factoids have been questioned.'; + } + + my $count; + my @list; + my $total = 0; + foreach $count ( sort { $b <=> $a } keys %hash ) { + my @faqtoids = sort keys %{ $hash{$count} }; + + for (@faqtoids) { + s/([\,\;]+)/\037$1\037/g; + } + $total += $count * scalar(@faqtoids); + + push( @list, "$count - " . join( ', ', @faqtoids ) ); + } + unshift( @list, "\037$total - TOTAL\037" ); + + my $prefix = "factoid statistics on $type "; + return &formListReply( 0, $prefix, @list ); + + } + elsif ( $type =~ /^reqrate$/i ) { + my %hash = &sqlSelectColHash( + 'factoids', +"factoid_key,(unix_timestamp() - created_time)/requested_count as rate", + undef, +'WHERE requested_by IS NOT NULL and created_time IS NOT NULL ORDER BY rate LIMIT 15', + 1 + ); + + my $rate; + my @list; + my $total = 0; + my $users = 0; + foreach $rate ( sort { $b <=> $a } keys %hash ) { + my $f = join( ', ', sort keys %{ $hash{$rate} } ); + my $str = "$f - " . &Time2String($rate); + $str =~ s/\002//g; + push( @list, $str ); + } + + my $prefix = "Rank of top factoid rate (time/req): "; + return &formListReply( 0, $prefix, @list ); + + } + elsif ( $type =~ /^requesters?$/i ) { + my %hash = &sqlSelectColHash( + 'factoids', 'factoid_key,requested_by', + undef, 'WHERE requested_by IS NOT NULL' + ); + my %requester; + + foreach ( keys %hash ) { + my $thisnuh = $hash{$_}; + + $thisnuh =~ /^(\S+)!\S+@\S+$/; + $requester{ lc $1 }++; + } + + if ( !scalar keys %requester ) { + return 'sorry, no factoids with requested_by field.'; + } + + # work-around. + my %count; + foreach ( keys %requester ) { + $count{ $requester{$_} }{$_} = 1; + } + undef %requester; + + my $count; + my @list; + my $total = 0; + my $users = 0; + foreach $count ( sort { $b <=> $a } keys %count ) { + my $requester = join( ', ', sort keys %{ $count{$count} } ); + $total += $count * scalar( keys %{ $count{$count} } ); + $users += scalar( keys %{ $count{$count} } ); + push( @list, "$count by $requester" ); + } + unshift( @list, + "\037$total TOTAL REQUESTS; $users UNIQUE REQUESTERS\037" ); + + # should not the above value be the same as collected by + # 'requested'? soemthing weird is going on! + + my $prefix = 'rank of top factoid requesters: '; + return &formListReply( 0, $prefix, @list ); + + } + elsif ( $type =~ /^seefix$/i ) { + my @list = + &searchTable( 'factoids', 'factoid_key', 'factoid_value', '^see ' ); + my @newlist; + my $fixed = 0; + my %loop; + my $f; + + for (@list) { + my $factoid = $_; + my $val = &getFactInfo( $factoid, 'factoid_value' ); + + next unless ( $val =~ /^see( also)? (.*?)\.?$/i ); + + my $redirf = lc $2; + my $redir = &getFactInfo( $redirf, 'factoid_value' ); + + if ( $redirf =~ /^\Q$factoid\W$/i ) { + &delFactoid($factoid); + $loop{$factoid} = 1; + } + + if ( defined $redir ) { # good. + &setFactInfo( $factoid, 'factoid_value', " see $redir" ); + $fixed++; + } + else { + push( @newlist, $redirf ); + } + } + + # parse the results. + &msg( $who, "Fixed $fixed factoids." ); + &msg( $who, 'Self looped factoids removed: ' . keys %loop ) + if ( scalar keys %loop ); + + my $prefix = "Loose link (dead) redirections in factoids "; + return &formListReply( 1, $prefix, @newlist ); + + } + elsif ( $type =~ /^(2|too)long$/i ) { + my @list; + my $query; + + # factoid_key. + $query = +"SELECT factoid_key FROM factoids WHERE length(factoid_key) >= $param{'maxKeySize'}"; + my $sth = $dbh->prepare($query); + $sth->execute; + while ( my @row = $sth->fetchrow_array ) { + push( @list, $row[0] ); + } + $sth->finish; + + # factoid_value. + $query = +"SELECT factoid_key,factoid_value FROM factoids WHERE length(factoid_value) >= $param{'maxDataSize'}"; + $sth = $dbh->prepare($query); + $sth->execute; + while ( my @row = $sth->fetchrow_array ) { + push( @list, + sprintf( "\002%s\002 - %s", length( $row[1] ), $row[0] ) ); + } + $sth->finish; + + if ( scalar @list == 0 ) { + return 'good. no factoids exceed length.'; + } + + # parse the results. + my $prefix = 'factoid key||value exceeding length '; + return &formListReply( 1, $prefix, @list ); + + } + elsif ( $type =~ /^unrequest(ed)?$/i ) { + + # TODO: use sqlSelect() + my ($count) = + &sqlRawReturn( + "SELECT COUNT(*) FROM factoids WHERE requested_count = '0'"); + + return "Unrequested factoids: $count"; } return "error: invalid type => '$type'."; @@ -737,12 +812,13 @@ sub CmdFactStats { sub CmdListAuth { my ($query) = @_; - my $maxshow = &::getChanConfDefault('maxListReplyCount', 15, $chan); - my @list = &searchTable('factoids','factoid_key', 'created_by', "^$query!"); - @list=grep(!/\#DEL\#$/,@list) if (scalar(@list) > $maxshow); + my $maxshow = &::getChanConfDefault( 'maxListReplyCount', 15, $chan ); + my @list = + &searchTable( 'factoids', 'factoid_key', 'created_by', "^$query!" ); + @list = grep( !/\#DEL\#$/, @list ) if ( scalar(@list) > $maxshow ); my $prefix = "factoid author list by '$query' "; - &performStrictReply( &formListReply(1, $prefix, @list) ); + &performStrictReply( &formListReply( 1, $prefix, @list ) ); } 1; diff --git a/src/Modules/HTTPDtype.pl b/src/Modules/HTTPDtype.pl index ac60d61..c5b5685 100644 --- a/src/Modules/HTTPDtype.pl +++ b/src/Modules/HTTPDtype.pl @@ -8,26 +8,28 @@ use strict; package HTTPDtype; sub HTTPDtype { - my($HOST) = @_; - my($line) = ''; - my($code, $mess, %h); + my ($HOST) = @_; + my ($line) = ''; + my ( $code, $mess, %h ); # TODO: remove leading http:// and trailing :port and /foo if found $HOST = 'joeysmith.com' unless length($HOST) > 0; return unless &::loadPerlModule("Net::HTTP::NB"); return unless &::loadPerlModule("IO::Select"); - my $s = Net::HTTP::NB->new(Host => $HOST) || return; - $s->write_request(HEAD => "/"); + my $s = Net::HTTP::NB->new( Host => $HOST ) || return; + $s->write_request( HEAD => "/" ); - my $sel = IO::Select->new($s); - $line = 'Header timeout' unless $sel->can_read(10); - ($code, $mess, %h) = $s->read_response_headers; + my $sel = IO::Select->new($s); + $line = 'Header timeout' unless $sel->can_read(10); + ( $code, $mess, %h ) = $s->read_response_headers; - $line = (length($h{Server}) > 0) ? $h{Server} : - "Couldn't fetch headers from $HOST"; + $line = + ( length( $h{Server} ) > 0 ) + ? $h{Server} + : "Couldn't fetch headers from $HOST"; - &::performStrictReply($line||'Unknown Error Condition'); + &::performStrictReply( $line || 'Unknown Error Condition' ); } 1; diff --git a/src/Modules/Kernel.pl b/src/Modules/Kernel.pl index 12ae9d0..7f5d4a3 100644 --- a/src/Modules/Kernel.pl +++ b/src/Modules/Kernel.pl @@ -13,10 +13,10 @@ sub kernelGetInfo { sub Kernel { my $retval = 'Linux kernel versions'; - my @now = &kernelGetInfo(); - if (!scalar @now) { - &::msg($::who, "failed."); - return; + my @now = &kernelGetInfo(); + if ( !scalar @now ) { + &::msg( $::who, "failed." ); + return; } if ($::who =~ /^\#/) { @@ -25,19 +25,19 @@ sub Kernel { } foreach $line (@now) { - $line =~ s/The latest //; - $line =~ s/version //; - $line =~ s/of //; - $line =~ s/the //; - $line =~ s/Linux //; - $line =~ s/kernel //; - $line =~ s/tree //; - $line =~ s/ for stable//; - $line =~ s/ to stable kernels//; - $line =~ s/ for 2.4//; - $line =~ s/ for 2.2//; - $line =~ s/ is: */: /; - $retval .= ', ' . $line; + $line =~ s/The latest //; + $line =~ s/version //; + $line =~ s/of //; + $line =~ s/the //; + $line =~ s/Linux //; + $line =~ s/kernel //; + $line =~ s/tree //; + $line =~ s/ for stable//; + $line =~ s/ to stable kernels//; + $line =~ s/ for 2.4//; + $line =~ s/ for 2.2//; + $line =~ s/ is: */: /; + $retval .= ', ' . $line; } &::performStrictReply($retval); } @@ -47,48 +47,49 @@ sub kernelAnnounce { my @now = &kernelGetInfo(); my @old; - if (!scalar @now) { - &::DEBUG('kA: failure to retrieve.'); - return; + if ( !scalar @now ) { + &::DEBUG('kA: failure to retrieve.'); + return; } - if (! -f $file) { - open(OUT, ">$file"); - foreach (@now) { - print OUT "$_\n"; - } - close OUT; - - return; - } else { - open(IN, $file); - while () { - chop; - push(@old,$_); - } - close IN; + if ( !-f $file ) { + open( OUT, ">$file" ); + foreach (@now) { + print OUT "$_\n"; + } + close OUT; + + return; + } + else { + open( IN, $file ); + while () { + chop; + push( @old, $_ ); + } + close IN; } my @new; - for(my $i=0; $i$file"); + open( OUT, ">$file" ); foreach (@now) { - print OUT "$_\n"; + print OUT "$_\n"; } close OUT; diff --git a/src/Modules/Math.pl b/src/Modules/Math.pl index a3b966b..d724aba 100644 --- a/src/Modules/Math.pl +++ b/src/Modules/Math.pl @@ -7,133 +7,124 @@ use strict; use vars qw($message); my %digits = ( - 'first', '1', - 'second', '2', - 'third', '3', - 'fourth', '4', - 'fifth', '5', - 'sixth', '6', - 'seventh', '7', - 'eighth', '8', - 'ninth', '9', - 'tenth', '10', - 'one', '1', - 'two', '2', - 'three', '3', - 'four', '4', - 'five', '5', - 'six', '6', - 'seven', '7', - 'eight', '8', - 'nine', '9', - 'ten', '10' + 'first', '1', 'second', '2', 'third', '3', 'fourth', '4', + 'fifth', '5', 'sixth', '6', 'seventh', '7', 'eighth', '8', + 'ninth', '9', 'tenth', '10', 'one', '1', 'two', '2', + 'three', '3', 'four', '4', 'five', '5', 'six', '6', + 'seven', '7', 'eight', '8', 'nine', '9', 'ten', '10' ); sub perlMath { - my($locMsg) = $message; + my ($locMsg) = $message; - if ($message =~ /^\s*$/) { - return; + if ( $message =~ /^\s*$/ ) { + return; } - foreach (keys %digits) { - $locMsg =~ s/$_/$digits{$_}/g; + foreach ( keys %digits ) { + $locMsg =~ s/$_/$digits{$_}/g; } - while ($locMsg =~ /(exp ([\w\d]+))/) { - my($exp, $val) = ($1, exp $2); - $locMsg =~ s/$exp/+$val/g; + while ( $locMsg =~ /(exp ([\w\d]+))/ ) { + my ( $exp, $val ) = ( $1, exp $2 ); + $locMsg =~ s/$exp/+$val/g; } - while ($locMsg =~ /(hex2dec\s*([0-9A-Fa-f]+))/) { - my($exp, $val) = ($1, hex $2); - $locMsg =~ s/$exp/+$val/g; + while ( $locMsg =~ /(hex2dec\s*([0-9A-Fa-f]+))/ ) { + my ( $exp, $val ) = ( $1, hex $2 ); + $locMsg =~ s/$exp/+$val/g; } - if ($locMsg =~ /^\s*(dec2hex\s*(\d+))\s*\?*/) { - my ($exp, $val) = ($1, sprintf("%x", "$2")); - $locMsg =~ s/$exp/+$val/g; + if ( $locMsg =~ /^\s*(dec2hex\s*(\d+))\s*\?*/ ) { + my ( $exp, $val ) = ( $1, sprintf( "%x", "$2" ) ); + $locMsg =~ s/$exp/+$val/g; } my $e = exp(1); $locMsg =~ s/\be\b/$e/; - while ($locMsg =~ /(log\s*((\d+\.?\d*)|\d*\.?\d+))\s*/) { - my ($exp, $res) = ($1, $2); - my $val = ($res) ? log($res) : 'Infinity'; - $locMsg =~ s/$exp/+$val/g; + while ( $locMsg =~ /(log\s*((\d+\.?\d*)|\d*\.?\d+))\s*/ ) { + my ( $exp, $res ) = ( $1, $2 ); + my $val = ($res) ? log($res) : 'Infinity'; + $locMsg =~ s/$exp/+$val/g; } - while ($locMsg =~ /(bin2dec ([01]+))/) { - my $exp = $1; - my $val = join ('', unpack('B*',$2)) ; - $locMsg =~ s/$exp/+$val/g; + while ( $locMsg =~ /(bin2dec ([01]+))/ ) { + my $exp = $1; + my $val = join( '', unpack( 'B*', $2 ) ); + $locMsg =~ s/$exp/+$val/g; } - while ($locMsg =~ /(dec2bin (\d+))/) { - my $exp = $1; - my $val = join('', unpack('B*', pack('N',$2))); - $val =~ s/^0+//; - $locMsg =~ s/$exp/+$val/g; + while ( $locMsg =~ /(dec2bin (\d+))/ ) { + my $exp = $1; + my $val = join( '', unpack( 'B*', pack( 'N', $2 ) ) ); + $val =~ s/^0+//; + $locMsg =~ s/$exp/+$val/g; } for ($locMsg) { - s/\bpi\b/3.14159265/g; - s/ to the / ** /g; - s/\btimes\b/\*/g; - s/\bdiv(ided by)? /\/ /g; - s/\bover /\/ /g; - s/\bsquared/\*\*2 /g; - s/\bcubed/\*\*3 /g; - s/\bto\s+(\d+)(r?st|nd|rd|th)?( power)?/\*\*$1 /ig; - s/\bpercent of/*0.01*/ig; - s/\bpercent/*0.01/ig; - s/\% of\b/*0.01*/g; - s/\%/*0.01/g; - s/\bsquare root of (\d+)/$1 ** 0.5 /ig; - s/\bcubed? root of (\d+)/$1 **(1.0\/3.0) /ig; - s/ of / * /; - s/(bit(-| )?)?xor(\'?e?d( with))?/\^/g; - s/(bit(-| )?)?or(\'?e?d( with))?/\|/g; - s/bit(-| )?and(\'?e?d( with))?/\& /g; - s/(plus|and)/+/ig; + s/\bpi\b/3.14159265/g; + s/ to the / ** /g; + s/\btimes\b/\*/g; + s/\bdiv(ided by)? /\/ /g; + s/\bover /\/ /g; + s/\bsquared/\*\*2 /g; + s/\bcubed/\*\*3 /g; + s/\bto\s+(\d+)(r?st|nd|rd|th)?( power)?/\*\*$1 /ig; + s/\bpercent of/*0.01*/ig; + s/\bpercent/*0.01/ig; + s/\% of\b/*0.01*/g; + s/\%/*0.01/g; + s/\bsquare root of (\d+)/$1 ** 0.5 /ig; + s/\bcubed? root of (\d+)/$1 **(1.0\/3.0) /ig; + s/ of / * /; + s/(bit(-| )?)?xor(\'?e?d( with))?/\^/g; + s/(bit(-| )?)?or(\'?e?d( with))?/\|/g; + s/bit(-| )?and(\'?e?d( with))?/\& /g; + s/(plus|and)/+/ig; } # what the hell is this shit? - if (($locMsg =~ /^\s*[-\d*+\s()\/^\.\|\&\*\!]+\s*$/) - && ($locMsg !~ /^\s*\(?\d+\.?\d*\)?\s*$/) - && ($locMsg !~ /^\s*$/) - && ($locMsg !~ /^\s*[( )]+\s*$/) - && ($locMsg =~ /\d+/) - ) { - $locMsg =~ s/([0-9]+\.[0-9]+(\.[0-9]+)+)/"$1"/g; - $locMsg = eval($locMsg); - - if (defined $locMsg and $locMsg =~ /^[-+\de\.]+$/) { - $locMsg = sprintf("%1.12f", $locMsg); - $locMsg =~ s/\.?0+$//; - - if (length $locMsg > 30) { - $locMsg = "a number with quite a few digits..."; - } - } else { - if (defined $locMsg) { - &FIXME("math: locMsg => '$locMsg'..."); - } else { - &status("math: could not really compute."); - $locMsg = ''; - } - } - } else { - $locMsg = ''; + if ( ( $locMsg =~ /^\s*[-\d*+\s()\/^\.\|\&\*\!]+\s*$/ ) + && ( $locMsg !~ /^\s*\(?\d+\.?\d*\)?\s*$/ ) + && ( $locMsg !~ /^\s*$/ ) + && ( $locMsg !~ /^\s*[( )]+\s*$/ ) + && ( $locMsg =~ /\d+/ ) ) + { + $locMsg =~ s/([0-9]+\.[0-9]+(\.[0-9]+)+)/"$1"/g; + $locMsg = eval($locMsg); + + if ( defined $locMsg and $locMsg =~ /^[-+\de\.]+$/ ) { + $locMsg = sprintf( "%1.12f", $locMsg ); + $locMsg =~ s/\.?0+$//; + + if ( length $locMsg > 30 ) { + $locMsg = "a number with quite a few digits..."; + } + } + else { + if ( defined $locMsg ) { + &FIXME("math: locMsg => '$locMsg'..."); + } + else { + &status("math: could not really compute."); + $locMsg = ''; + } + } } + else { + $locMsg = ''; + } + + if ( defined $locMsg and $locMsg ne $message ) { + + # success. + return $locMsg; + } + else { - if (defined $locMsg and $locMsg ne $message) { - # success. - return $locMsg; - } else { - # no match. - return ''; + # no match. + return ''; } } diff --git a/src/Modules/News.pl b/src/Modules/News.pl index 07c037a..a161cd9 100644 --- a/src/Modules/News.pl +++ b/src/Modules/News.pl @@ -22,239 +22,267 @@ use strict; use vars qw($who $chan); sub Parse { - my($what) = @_; - $chan = undef; - $who = lc $::who; + my ($what) = @_; + $chan = undef; + $who = lc $::who; - if (!keys %::news) { - if (!exists $::cache{newsFirst}) { - &::DEBUG("news: looks like we enabled news option just then; loading up news file just in case."); - $::cache{newsFirst} = 1; - } + if ( !keys %::news ) { + if ( !exists $::cache{newsFirst} ) { + &::DEBUG( +"news: looks like we enabled news option just then; loading up news file just in case." + ); + $::cache{newsFirst} = 1; + } - &readNews(); + &readNews(); } - if ($::msgType ne 'private') { - $chan = $::chan; + if ( $::msgType ne 'private' ) { + $chan = $::chan; } - if (defined $what and $what =~ s/^($::mask{chan})\s*//) { - # TODO: check if the channel exists aswell. - $chan = lc $1; + if ( defined $what and $what =~ s/^($::mask{chan})\s*// ) { - if (!&::IsNickInChan($who, $chan)) { - &::notice($who, "sorry but you're not on $chan."); - return; - } + # TODO: check if the channel exists aswell. + $chan = lc $1; + + if ( !&::IsNickInChan( $who, $chan ) ) { + &::notice( $who, "sorry but you're not on $chan." ); + return; + } } - if (!defined $chan) { - my @chans = &::getNickInChans($who); + if ( !defined $chan ) { + my @chans = &::getNickInChans($who); - if (scalar @chans > 1) { - &::notice($who, "error: I dunno which channel you are referring to since you're on more than one. Try 'news #chan ...' instead"); - return; - } + if ( scalar @chans > 1 ) { + &::notice( $who, +"error: I dunno which channel you are referring to since you're on more than one. Try 'news #chan ...' instead" + ); + return; + } - if (scalar @chans == 0) { - &::notice($who, "error: I couldn't find you on any chan. This must be a bug!"); - return; - } + if ( scalar @chans == 0 ) { + &::notice( $who, + "error: I couldn't find you on any chan. This must be a bug!" ); + return; + } - $chan = $chans[0]; - &::VERB("Guessed $who being on chan $chan",2); - $::chan = $chan; # hack for IsChanConf(). + $chan = $chans[0]; + &::VERB( "Guessed $who being on chan $chan", 2 ); + $::chan = $chan; # hack for IsChanConf(). } - if (!defined $what or $what =~ /^\s*$/) { - &list(); - return; + if ( !defined $what or $what =~ /^\s*$/ ) { + &list(); + return; } - if ($what =~ /^add(\s+(.*))?$/i) { - &add($2); + if ( $what =~ /^add(\s+(.*))?$/i ) { + &add($2); - } elsif ($what =~ /^del(\s+(.*))?$/i) { - &del($2); + } + elsif ( $what =~ /^del(\s+(.*))?$/i ) { + &del($2); - } elsif ($what =~ /^mod(\s+(.*))?$/i) { - &mod($2); + } + elsif ( $what =~ /^mod(\s+(.*))?$/i ) { + &mod($2); - } elsif ($what =~ /^set(\s+(.*))?$/i) { - &set($2); + } + elsif ( $what =~ /^set(\s+(.*))?$/i ) { + &set($2); - } elsif ($what =~ /^(\d+)$/i) { - &::VERB("News: read shortcut called.",2); - &read($1); + } + elsif ( $what =~ /^(\d+)$/i ) { + &::VERB( "News: read shortcut called.", 2 ); + &read($1); - } elsif ($what =~ /^read(\s+(.*))?$/i) { - &read($2); + } + elsif ( $what =~ /^read(\s+(.*))?$/i ) { + &read($2); - } elsif ($what =~ /^(latest|new)(\s+(.*))?$/i) { - &latest($3 || $chan, 1); -# $::cmdstats{'News latest'}++; + } + elsif ( $what =~ /^(latest|new)(\s+(.*))?$/i ) { + &latest( $3 || $chan, 1 ); - } elsif ($what =~ /^stats?$/i) { - &stats(); + # $::cmdstats{'News latest'}++; - } elsif ($what =~ /^list$/i) { - &list(); + } + elsif ( $what =~ /^stats?$/i ) { + &stats(); - } elsif ($what =~ /^(expire|text|desc)(\s+(.*))?$/i) { - # shortcut/link. - # nice hack. - my $cmd = $1; - my($arg1,$arg2) = split(/\s+/, $3, 2); - &set("$arg1 $cmd $arg2"); + } + elsif ( $what =~ /^list$/i ) { + &list(); - } elsif ($what =~ /^help(\s+(.*))?$/i) { - &::help("news $2"); + } + elsif ( $what =~ /^(expire|text|desc)(\s+(.*))?$/i ) { - } elsif ($what =~ /^newsflush$/i) { - &::msg($who, "newsflush called... check out the logs!"); - &::newsFlush(); + # shortcut/link. + # nice hack. + my $cmd = $1; + my ( $arg1, $arg2 ) = split( /\s+/, $3, 2 ); + &set("$arg1 $cmd $arg2"); - } elsif ($what =~ /^(un)?notify$/i) { - my $state = ($1) ? 0 : 1; + } + elsif ( $what =~ /^help(\s+(.*))?$/i ) { + &::help("news $2"); - # TODO: don't notify even if 'News' is called. - if (&::IsChanConf('newsNotifyAll') <= 0) { - &::DEBUG("news: chan => $chan, ::chan => $::chan."); - &::notice($who, "not available for this channel or disabled altogether."); - return; - } + } + elsif ( $what =~ /^newsflush$/i ) { + &::msg( $who, "newsflush called... check out the logs!" ); + &::newsFlush(); - my $t = $::newsuser{$chan}{$who}; - if ($state) { # state = 1 - if (defined $t and ($t == 0 or $t == -1)) { - &::notice($who, "enabled notify."); - delete $::newsuser{$chan}{$who}; - return; - } - &::notice($who, "already enabled."); + } + elsif ( $what =~ /^(un)?notify$/i ) { + my $state = ($1) ? 0 : 1; - } else { # state = 0 - my $x = $::newsuser{$chan}{$who}; - if (defined $x and ($x == 0 or $x == -1)) { - &::notice($who, 'notify already disabled'); - return; - } - $::newsuser{$chan}{$who} = -1; - &::notice($who, "notify is now disabled."); - } + # TODO: don't notify even if 'News' is called. + if ( &::IsChanConf('newsNotifyAll') <= 0 ) { + &::DEBUG("news: chan => $chan, ::chan => $::chan."); + &::notice( $who, + "not available for this channel or disabled altogether." ); + return; + } - } else { - &::notice($who, "unknown command: $what"); + my $t = $::newsuser{$chan}{$who}; + if ($state) { # state = 1 + if ( defined $t and ( $t == 0 or $t == -1 ) ) { + &::notice( $who, "enabled notify." ); + delete $::newsuser{$chan}{$who}; + return; + } + &::notice( $who, "already enabled." ); + + } + else { # state = 0 + my $x = $::newsuser{$chan}{$who}; + if ( defined $x and ( $x == 0 or $x == -1 ) ) { + &::notice( $who, 'notify already disabled' ); + return; + } + $::newsuser{$chan}{$who} = -1; + &::notice( $who, "notify is now disabled." ); + } + + } + else { + &::notice( $who, "unknown command: $what" ); } } sub readNews { my $file = "$::bot_base_dir/infobot-news.txt"; - if (! -f $file or -z $file) { - return; + if ( !-f $file or -z $file ) { + return; } - if (fileno NEWS) { - &::DEBUG("readNews: fileno exists, should never happen."); - return; + if ( fileno NEWS ) { + &::DEBUG("readNews: fileno exists, should never happen."); + return; } - my($item,$chan); - my($ci,$cu) = (0,0); + my ( $item, $chan ); + my ( $ci, $cu ) = ( 0, 0 ); - open(NEWS, $file); + open( NEWS, $file ); while () { - chop; + chop; - # TODO: allow commands. + # TODO: allow commands. - if (/^[\s\t]+(\S+):[\s\t]+(.*)$/) { - if (!defined $item) { - &::DEBUG("news: !defined item, never happen!"); - next; - } + if (/^[\s\t]+(\S+):[\s\t]+(.*)$/) { + if ( !defined $item ) { + &::DEBUG("news: !defined item, never happen!"); + next; + } - $::news{$chan}{$item}{$1} = $2; - next; - } + $::news{$chan}{$item}{$1} = $2; + next; + } - # U