* 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
+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
# Author: Tim Riker <Tim@Rikers.org>
###
+# 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 <action> 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 "<reply> see y", then when asked for x, I will deliver factoidor command result y instead.
-
-reply: There is a special tag, <reply>, 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 <reply> Y".
-
-# now the commands...
-
-adduser: D: Administrative command to add new user to the .users file
-adduser: U: ## <user> <mask>
-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 <fromLang> <toLang> <words>
babelfish: U: translate <fromLang> <toLang> <words>
babelfish: E: x en de your cars rock
--ban: D: FIXME:
--ban: U: ## <mask|user>
--ban: E: ## *!*@owns.org
--ban: E: ## MoronMan
+bandel: D: FIXME:
+bandel: U: ## <mask|user>
+bandel: E: ## *!*@owns.org
+bandel: E: ## MoronMan
-+ban: D: FIXME:
-+ban: U: ## <mask|user> [chan] [time] [reason]
-+ban: E: ## *!*@owns.org #bots 60 stop flooding.
-+ban: E: ## *!*@*microsoft.com STOOPID
-+ban: E: ## MoronMan
+banadd: D: FIXME:
+banadd: U: ## <mask|user> [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 <who>[:] <message>}|stats|check|read
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]
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.
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: ## <user>
-deluser: E: ## bloot
-
ddesc: D: Search the Description: lines in Debian packages
ddesc: U: ## <string> [dist]
ddesc: E: ## mule
do: D: operator command to do things in a channel
do: U: ## <chan> <what>
+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: ##
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
hex: U: ## <string>
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] [<mask>]
+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] <mask>
+hostdel: E: ## *!*@owns.org
+hostdel: E: ## owner leet!leet@*.heh.org
+
httpdtype: D: Get httpd server software version / configuration
httpdtype: U: ## <hostname>
httpdtype: E: ## example.com
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: ## <string>
md5: E: ## When will infobot achieve world domination?
quote: U: ## <query...>
quote: E: ## RHAT,MSFT
+redirection: If a factoid x contains simply "<reply> 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, <reply>, 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 <reply> Y".
+
reverse: D: reverses a given string
reverse: U: ## <string>
reverse: E: ## When will infobot achieve world domination?
unlock: U: ## <factoid>
unlock: E: ## abuse
+upsidedown: D: display a string in pseudo upside down unicode text
+upsidedown: U: ## <string>
+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: ## <user> <mask>
+useradd: E: ## SomeAccount SomeAccount!someguy@example.com
+
+userdel: D: Administrative command to remove a user from the .users file
+userdel: U: ## <user>
+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: ## <account>
+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: ## <topic>
wikipedia: U: wiki <topic>
wtf: U: ## <abbreviation>
wtf: E: ## iirc
--host: D: admin command to remove hostmask from a user account
--host: U: ## [user] <mask>
--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] [<mask>]
-+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
+slashdot
+spell
+tell
+ +upsidedown
+ +wikipedia
+wtf
+zfi
+zsi
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";
# 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();
&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
# 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 = <PIDFILE> || "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 = <PIDFILE> || "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;
+++ /dev/null
-##########################################################
-# 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<http://www.google.com>.
-
-This class exports no public interface; all interaction should
-be done through L<WWW::Search> 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<WWW::Search>.
-
-=head1 HOW DOES IT WORK?
-
-C<native_setup_search> is called (from C<WWW::Search::setup_search>)
-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<native_retrieve_some> is called (from C<WWW::Search::retrieve_some>)
-whenever more hits are needed. It calls C<WWW::Search::http_request>
-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<WWW::Search> test suite mechanism.
-
-=head1 AUTHOR
-
-This backend is written and maintained/supported by Jim Smyser.
-<jsmyser@bigfoot.com>
-
-=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 <Tim@Rikers.org>
-
-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 <jsmyser@bigfoot.com>';
-$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 <b>([\d,]+)<\/b>/)
- {
- my($n) = $1;
- $self->approximate_result_count($n);
- print STDERR "Found Total: $n\n" ;
- $state = $HITS;
- }
- if ($state == $HITS &&
- m|<p><a href=([^\>]*)\>(.*?)</a\><br\>|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|<a href=(.*)\>(.*?)</a><font size=-1><br><font color=green><.*?>|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@^<p><a href=/url\?sa=U&start=\d+&q=([^<]+)\&.*?>(.*)</a><font size=-1><br>(.*)@i ||
- m@^<p><a href=([^<]+)>(.*)</a>.*?<font size=-1><br>(.*)@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 . '<br>' if not $mDesc =~ m@<br>@;
- $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@<div class=nav>@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|<a href=([^<]+)><IMG SRC=/nav_next.gif.*?>.*?|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;
-
+++ /dev/null
---- 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))
+++ /dev/null
---- 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<http://www.google.com>.
-
--Googles returns 100 Hits per page. Custom Linux Only search capable.
--
- This class exports no public interface; all interaction should
- be done through L<WWW::Search> objects.
-
-@@ -70,33 +68,41 @@
-
- This module adheres to the C<WWW::Search> 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.
- <jsmyser@bigfoot.com>
-
- =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 <jsmyser@bigfoot.com>';
- $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|<b>(\d+)</b></font> 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@^<p><a href=([^<]+)>(.*)</a>$@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@^<font size=-1><br>(.*)@i)
-- {
-- print "**Found First Description**\n" if 2 <= $self->{_debug};
-- $mDesc = $1;
-- if (not $mDesc =~ m@ @)
-- {
-- $mDesc =~ s/<.*?>//g;
-- $mDesc = $mDesc . '<br>' if not $mDesc =~ m@<br>@;
-- $hit->description($mDesc);
-- $state = $HITS;
-- }
-- }
-- elsif ($state eq $HITS &&
-- m@^(\.(.+))@i ||
-- m@^<br><font color=green>(.*)\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|<a href=([^<]+)><IMG SRC=/nav_next.gif.*?><br><.*?>.*?</A>|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 <b>([\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|<a href=(\S+)\>(.*?)</a><br><font size=-1><font color=\"#008000\"><.*?>|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@^<p><a href=/url\?sa=U&start=\d+&q=([^<]+)\&.*?>(.*)</a><font size=-1><br>(.*)@i ||
-+ m@^<p><a href=(\S+)>(.*)</a>.*?<font size=-1>(.*)@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 . '<br>' if not $mDesc =~ m@<br>@;
-+ $hit->description($mDesc) if (defined $hit);
-+ $state = $HITS;
-+
-+# description parsing
-+ } elsif ($state == $HITS && m@<b>(\.\.(.+))</b> @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@<div>@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|<a href=([^<]+)><img src=/nav_next.gif.*?>.*?|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;
-+
+++ /dev/null
---- 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@^<p><a href=([^<]+)>(.*)</a>$@i)
-+ if ($state eq $HITS && m@^<p><a href=([^<]+)>(.*)</a>@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;
- }
+++ /dev/null
---- 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<http://www.google.com>.
-
--Googles returns 100 Hits per page. Custom Linux Only search capable.
--
- This class exports no public interface; all interaction should
- be done through L<WWW::Search> objects.
-
-@@ -70,33 +68,41 @@
-
- This module adheres to the C<WWW::Search> 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.
- <jsmyser@bigfoot.com>
-
- =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 <jsmyser@bigfoot.com>';
- $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|<b>(\d+)</b></font> 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@^<p><a href=([^<]+)>(.*)</a>$@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@^<font size=-1><br>(.*)@i)
-- {
-- print "**Found First Description**\n" if 2 <= $self->{_debug};
-- $mDesc = $1;
-- if (not $mDesc =~ m@ @)
-- {
-- $mDesc =~ s/<.*?>//g;
-- $mDesc = $mDesc . '<br>' if not $mDesc =~ m@<br>@;
-- $hit->description($mDesc);
-- $state = $HITS;
-- }
-- }
-- elsif ($state eq $HITS &&
-- m@^(\.(.+))@i ||
-- m@^<br><font color=green>(.*)\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|<a href=([^<]+)><IMG SRC=/nav_next.gif.*?><br><.*?>.*?</A>|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 <b>([\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|<a href=(\S+)\>(.*?)</a><br><font size=-1><font color=\"#008000\"><.*?>|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@^<p><a href=/url\?sa=U&start=\d+&q=([^<]+)\&.*?>(.*)</a><font size=-1><br>(.*)@i ||
-+ m@^<p><a href=(\S+)>(.*)</a>.*?<font size=-1>(.*)@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 . '<br>' if not $mDesc =~ m@<br>@;
-+ $hit->description($mDesc) if (defined $hit);
-+ $state = $HITS;
-+
-+# description parsing
-+ } elsif ($state == $HITS && m@<b>(\.\.(.+))</b> @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@<div>@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|<a href=([^<]+)><img src=/nav_next.gif.*?>.*?|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;
-+
+++ /dev/null
---- 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@^<p><a href=([^<]+)>(.*)</a>$@i)
-+ if ($state eq $HITS && m@^<p><a href=([^<]+)>(.*)</a>@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;
- }
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 (<INDEX>) {
- 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 (<INDEX>) {
+ 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<scalar(@index); $i++) {
+open( OUT, ">$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;
require "src/Files.pl";
&loadDBModules();
require "src/dbi.pl";
+
package main;
# todo: main()
-if (!scalar @ARGV) {
+if ( !scalar @ARGV ) {
print "Usage: dbm2mysql <whatever dbm>\n";
print "Example: dbm2mysql.pl apt\n";
print "NOTE: suffix '-is' and '-extra' are used.\n";
my %db;
# open dbm.
-if (!dbmopen(%db, $dbfile, 0666)) {
+if ( !dbmopen( %db, $dbfile, 0666 ) ) {
&ERROR("Failed open to dbm file ($dbfile).");
exit 1;
}
# 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";
use strict;
use DB_File;
-if (!scalar @ARGV) {
+if ( !scalar @ARGV ) {
print "Usage: dbm2txt <whatever dbm>\n";
print "Example: dbm2txt.pl factoids\n";
exit 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;
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 (<IN>) {
- 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";
}
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;
$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;
require "src/modules.pl";
require "src/Factoids/DBCommon.pl";
-&loadConfig($bot_config_dir."/infobot.config");
+&loadConfig( $bot_config_dir . "/infobot.config" );
&loadDBModules();
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 (<IN>) {
- 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;
# 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
#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{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+ $return .=
+ qq{<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<title>irclog2html for $channel on $date</title>
<h1>irclog2html for $channel on $date</h1>
};
- if ($STYLE =~ /table/) {
-
$return .= "<table cellspacing=3 cellpadding=2 border=0>\n";
- }
- return $return;
+ if ( $STYLE =~ /table/ ) {
+ $return .= "<table cellspacing=3 cellpadding=2 border=0>\n";
+ }
+ return $return;
}
sub footer {
- my $return = '';
- if ($STYLE =~ /table/) {
- $return .= "</table>\n";
- }
+ my $return = '';
+ if ( $STYLE =~ /table/ ) {
+ $return .= "</table>\n";
+ }
- $return .= qq{
+ $return .= qq{
<br>Generated by irclog2html.pl by
<a href="mailto:jdub\@NOSPAMaphid.net">Jeff Waugh</a> - find it at
<a href="http://freshmeat.net/appindex/2000/03/28/954251322.html">freshmeat.net</a>!
<a href="http://infobot.sourceforge.net/">infobot</a> logs, split per channel, etc.
</body></html>
};
- 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 .= "<tr>";
- $lineout .= "<td bgcolor=\"$htmlcolour\"><font color=\"#ffffff\"><tt>$time</tt></font></td>" if $time;
- $lineout .= "<td bgcolor=\"$htmlcolour\"><font color=\"#ffffff\"><tt>$nick</tt></font></td>";
- $lineout .= "<td width=\"100%\" bgcolor=\"#eeeeee\"><tt><font color=\"$htmlcolour\">$text<\/font></tt></td></tr>\n";
- }
- elsif ($STYLE eq "simpletable") {
- $lineout .= "<tr bgcolor=\"#eeeeee\">";
- $lineout .= "<td><tt>$time</tt></td>" if $time;
- $lineout .= "<td><font color=\"$htmlcolour\"><tt>$nick</tt></font></td>";
- $lineout .= "<td width=\"100%\"><tt>$text</tt></td></tr>\n";
- }
- elsif ($STYLE eq "simplett") {
- $lineout .= "$time " if $time;
- $lineout .= "<\;$nick>\; $text<br>\n";
- }
- else {
- $lineout .= "$time " if $time;
- $lineout .= "<font color=\"$htmlcolour\"><\;$nick>\; $text<\/font><br>\n";
- }
- output_line($date, $time, $channel, $lineout);
+ my ( $date, $time, $channel, $nick, $text, $htmlcolour ) = @_;
+ my $lineout = '';
+
+ if ( $STYLE eq "table" ) {
+ $lineout .= "<tr>";
+ $lineout .=
+"<td bgcolor=\"$htmlcolour\"><font color=\"#ffffff\"><tt>$time</tt></font></td>"
+ if $time;
+ $lineout .=
+"<td bgcolor=\"$htmlcolour\"><font color=\"#ffffff\"><tt>$nick</tt></font></td>";
+ $lineout .=
+"<td width=\"100%\" bgcolor=\"#eeeeee\"><tt><font color=\"$htmlcolour\">$text<\/font></tt></td></tr>\n";
+ }
+ elsif ( $STYLE eq "simpletable" ) {
+ $lineout .= "<tr bgcolor=\"#eeeeee\">";
+ $lineout .= "<td><tt>$time</tt></td>" if $time;
+ $lineout .=
+ "<td><font color=\"$htmlcolour\"><tt>$nick</tt></font></td>";
+ $lineout .= "<td width=\"100%\"><tt>$text</tt></td></tr>\n";
+ }
+ elsif ( $STYLE eq "simplett" ) {
+ $lineout .= "$time " if $time;
+ $lineout .= "<\;$nick>\; $text<br>\n";
+ }
+ else {
+ $lineout .= "$time " if $time;
+ $lineout .=
+ "<font color=\"$htmlcolour\"><\;$nick>\; $text<\/font><br>\n";
+ }
+ output_line( $date, $time, $channel, $lineout );
}
sub output_timeservermsg {
- my ($date, $time, $channel, $line) = @_;
- my $lineout = '';
-
- if ($STYLE =~ /table/) {
- $lineout .= "<tr>";
- $lineout .= "<td><tt>$time</tt></td>" if $time;
- $lineout .= "<td colspan=2><tt>$line</tt></td></tr>\n";
- }
- else {
- $lineout .= "$time " if $time;
- $lineout .= "$line<br>\n";
- }
- output_line($date, $time, $channel, $lineout);
+ my ( $date, $time, $channel, $line ) = @_;
+ my $lineout = '';
+
+ if ( $STYLE =~ /table/ ) {
+ $lineout .= "<tr>";
+ $lineout .= "<td><tt>$time</tt></td>" if $time;
+ $lineout .= "<td colspan=2><tt>$line</tt></td></tr>\n";
+ }
+ else {
+ $lineout .= "$time " if $time;
+ $lineout .= "$line<br>\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 = <STDIN>) {
-
- 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/>/>\;/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*)/<a href="$1">$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/(\*\*\* .*)/<font color=\"$colour_nickchange\">$1<\/font>/
- } elsif ($line =~ /\*\*\* (join|mode|topic)\/(.*?) .*/) {
- $channel = lc $2;
- $line =~ s/(\*\*\* .*)/<font color=\"$colour_joined\">$1<\/font>/;
- } elsif ($line =~ /\*\*\* (part|kick|banned)\/(.*?) .*/) {
- $channel = lc $2;
- $line =~ s/(\*\*\* .*)/<font color=\"$colour_left\">$1<\/font>/;
- } elsif ($line =~ /\*\*\* .* has signed off IRC .*/) {
- # Colourise joined/left/server messages #
- $line =~ s/(\*\*\* .*)/<font color=\"$colour_left\">$1<\/font>/;
- } elsif ($line =~ /\*\*\* /) {
- $line =~ s/(\*\*\* .*)$/<font color=\"$colour_server\">$1<\/font>/;
- } elsif ($line =~ /^\* .*$/) {
- # Colourise the /me's #
- $line =~ s/^(\*.*)$/<font color=\"$colour_action\">$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 = <STDIN> ) {
+
+ 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/>/>\;/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*)/<a href="$1">$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/(\*\*\* .*)/<font color=\"$colour_nickchange\">$1<\/font>/;
+ }
+ elsif ( $line =~ /\*\*\* (join|mode|topic)\/(.*?) .*/ ) {
+ $channel = lc $2;
+ $line =~
+ s/(\*\*\* .*)/<font color=\"$colour_joined\">$1<\/font>/;
+ }
+ elsif ( $line =~ /\*\*\* (part|kick|banned)\/(.*?) .*/ ) {
+ $channel = lc $2;
+ $line =~
+ s/(\*\*\* .*)/<font color=\"$colour_left\">$1<\/font>/;
+ }
+ elsif ( $line =~ /\*\*\* .* has signed off IRC .*/ ) {
+
+ # Colourise joined/left/server messages #
+ $line =~
+ s/(\*\*\* .*)/<font color=\"$colour_left\">$1<\/font>/;
+ }
+ elsif ( $line =~ /\*\*\* / ) {
+ $line =~
+ s/(\*\*\* .*)$/<font color=\"$colour_server\">$1<\/font>/;
+ }
+ elsif ( $line =~ /^\* .*$/ ) {
+
+ # Colourise the /me's #
+ $line =~
+ s/^(\*.*)$/<font color=\"$colour_action\">$1<\/font>/;
+ }
+
+ output_timeservermsg( $date, $time, $channel, $line );
+ }
+ }
+ }
+
+ add_footers();
+
+ return 0;
}
-if (!scalar @ARGV) {
- print "Usage: irclog2html.pl <date> < logfile\n";
- print "Example: bzcat log/infobot.log-20021104.bz2 | irclog2html.pl 20021104\n";
+if ( !scalar @ARGV ) {
+ print "Usage: irclog2html.pl <date> < logfile\n";
+ print
+ "Example: bzcat log/infobot.log-20021104.bz2 | irclog2html.pl 20021104\n";
exit 0;
}
my $date = shift;
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
$bot_src_dir = "./src/";
my $dbname = shift;
-if (!defined $dbname) {
+if ( !defined $dbname ) {
print "Usage: $0 <db name>\n";
print "Example: $0 factoids\n";
exit 0;
&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;
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");
-@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;
}
#!/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 <files>\n";
print "Example: parse_warn.pl log/*\n";
exit 0;
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 (<FILE>) {
- 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 = <IN>;
- 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 = <IN>;
+ 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";
}
}
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;
}
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
require "src/Misc.pl";
require "src/Factoids/DBCommon.pl";
-if (!scalar @ARGV) {
- print "Usage: txt2mysql.pl <input.txt>\n";
- exit 0;
+if ( !scalar @ARGV ) {
+ print "Usage: txt2mysql.pl <input.txt>\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 (<IN>) {
- 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;
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";
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 (<INDEX>) {
- 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 (<INDEX>) {
+ 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<scalar(@index); $i++) {
+open( OUT, ">$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;
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 = <STDIN>);
+ chop( my $adminuser = <STDIN> );
# passwd.
system "stty -echo";
print "Password: ";
- chop(my $adminpass = <STDIN>);
+ chop( my $adminpass = <STDIN> );
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.");
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");
# 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;
###
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;
}
# 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);
}
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 <CMD>");
- return;
- }
-
- # topic over private:
- if ($msgType eq 'private' && $chan !~ /^#/) {
- &msg($who, 'error: channel argument is required.');
- &msg($who, "\002Usage\002: topic #channel <CMD>");
- 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 <CMD>" );
+ return;
+ }
+
+ # topic over private:
+ if ( $msgType eq 'private' && $chan !~ /^#/ ) {
+ &msg( $who, 'error: channel argument is required.' );
+ &msg( $who, "\002Usage\002: topic #channel <CMD>" );
+ 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
# 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.
### 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);
# 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);
}
}
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?');
}
}
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 (<IDX2>) {
- chop;
- next if (/^\*/);
+ chop;
+ next if (/^\*/);
- $pkg{$_} = 1;
+ $pkg{$_} = 1;
}
close IDX2;
- open(IDX1,$idx);
+ open( IDX1, $idx );
while (<IDX1>) {
- 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 {
$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.
&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', ) );
&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' ) );
### END OF ADDING HOOKS.
###
-&status('loaded '.scalar(keys %cmdhooks).' command hooks.');
+&status( 'loaded ' . scalar( keys %cmdhooks ) . ' command hooks.' );
1;
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
$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 = <IN>;
- 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 (<IN>) {
- 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...');
}
}
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.
- $_ = <IN>; # version string.
+ $_ = <IN>; # version string.
my $chan;
while (<IN>) {
- 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...');
}
}
# 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();
}
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
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 !~ /^</) {
- / \Q$ident$/i and last; # someone said i'm something.
- /^i('m)? / and last;
- /^(it|that|there|what)('s)?(\s+|$)/ and last;
- /^you('re)?(\s+|$)/ and last;
-
- /^(where|who|why|when|how)(\s+|$)/ and last;
- /^(this|that|these|those|they)(\s+|$)/ and last;
- /^(every(one|body)|we) / and last;
-
- /^say / and last;
- }
-
- # uncaught commands.
- /^add topic / and last; # topic management.
- /( add$| add |^add )/ and last; # borked teach statement.
- /^learn / and last; # teach. damn morons.
- /^tell (\S+) about / and last; # tell.
- /\=\~/ and last; # substituition.
-
- /^\=/ and last; # botnick = heh is.
- /wants you to know/ and last;
-
- # symbols.
- /(\"\*)/ and last;
- /, / and last;
- (/^'/ and /'$/) and last;
- (/^"/ and /"$/) and last;
-
- # delimiters.
- /\=\>/ 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 !~ /^</ ) {
+ / \Q$ident$/i and last; # someone said i'm something.
+ /^i('m)? / and last;
+ /^(it|that|there|what)('s)?(\s+|$)/ and last;
+ /^you('re)?(\s+|$)/ and last;
+
+ /^(where|who|why|when|how)(\s+|$)/ and last;
+ /^(this|that|these|those|they)(\s+|$)/ and last;
+ /^(every(one|body)|we) / and last;
+
+ /^say / and last;
+ }
+
+ # uncaught commands.
+ /^add topic / and last; # topic management.
+ /( add$| add |^add )/ and last; # borked teach statement.
+ /^learn / and last; # teach. damn morons.
+ /^tell (\S+) about / and last; # tell.
+ /\=\~/ and last; # substituition.
+
+ /^\=/ and last; # botnick = heh is.
+ /wants you to know/ and last;
+
+ # symbols.
+ /(\"\*)/ and last;
+ /, / and last;
+ ( /^'/ and /'$/ ) and last;
+ ( /^"/ and /"$/ ) and last;
+
+ # delimiters.
+ /\=\>/ 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 = "<REPLY> are" if ($mhs eq 'are');
- &setFactInfo($lhs, 'factoid_value', $rhs);
- }
+ # 'are' hack :)
+ $rhs = "<REPLY> 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', "^<REPLY> see ");
- }
-
- my $match = 0;
- for (@list) {
- my $f = $_;
- my $v = &getFactInfo($f, 'factoid_value');
- my $fsafe = quotemeta($faqtoid);
- next unless ($v =~ /^<REPLY> ?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',
+ "^<REPLY> see " );
+ }
+
+ my $match = 0;
+ for (@list) {
+ my $f = $_;
+ my $v = &getFactInfo( $f, 'factoid_value' );
+ my $fsafe = quotemeta($faqtoid);
+ next unless ( $v =~ /^<REPLY> ?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'}++;
}
#####
# 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' );
}
#####
sub delFactoid {
my ($faqtoid) = @_;
- &sqlDelete('factoids', { factoid_key => $faqtoid } );
+ &sqlDelete( 'factoids', { factoid_key => $faqtoid } );
&status("DELETED $faqtoid");
return 1;
# 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;
#####
# 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;
}
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;
}
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;
}
$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;
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;
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<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;
+ 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*<action>\s*(.*)/\cAACTION $1\cA/i;
- $result =~ s/^\s*<reply>\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*<action>\s*(.*)/\cAACTION $1\cA/i;
+ $result =~ s/^\s*<reply>\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;
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 '<reply>'
- if (!$real and $reply =~ s/^\s*<reply>\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*<action>\s*(.*)/\cAACTION $1\cA/i) {
- # only remove '<action>' 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 '<reply>'
+ if ( !$real and $reply =~ s/^\s*<reply>\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*<action>\s*(.*)/\cAACTION $1\cA/i ) {
+
+ # only remove '<action>' 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);
# <URL></URL> type
#
- while ($txt =~ /<URL>(.*)<\/URL>/){
- &status("we have to norm this <URL></URL> 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>(.*)<\/URL>/$foobar/;
+ while ( $txt =~ /<URL>(.*)<\/URL>/ ) {
+ &status("we have to norm this <URL></URL> 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>(.*)<\/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;
}
# 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';
# 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 = "<REPLY> 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 = "<REPLY> 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 =~ /^<REPLY> ?see (.*)/i) {
+ my $origlhs = $lhs;
+ while ( $exists =~ /^<REPLY> ?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 =~ /^<REPLY> ?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 =~ /^<REPLY> ?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;
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 (<FILE>) {
- 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;
# 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 (<FILE>) {
- 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;
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?
# 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;
}
# 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);
}
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 );
}
}
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).");
}
}
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();
#}
}
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");
}
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;
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!');
}
}
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 );
}
##########
# 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($_);
}
}
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;
}
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;
}
}
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};
+ }
}
}
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;
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 <nick>
- $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 <nick>
+ $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);
}
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);
}
}
# 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;
}
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' );
}
# 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);
}
}
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;
# 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;
}
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';
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'");
# 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 <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 <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 (<IN>) {
- chop;
- next unless (/^(\S+)\*$/);
- push(@wingateBad, $_);
- }
- close IN;
+ if ( &IsChanConf('Wingate') > 0 ) {
+ my $file = "$bot_base_dir/$param{'ircUser'}.wingate";
+ open( IN, $file );
+ while (<IN>) {
+ 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");
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:
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 . '_';
&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 {
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;
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);
}
}
$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}++;
}
}
$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");
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;
}
}
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");
}
sub on_useronchannel {
$conn = shift(@_);
my ($event) = @_;
- my @args = $event->args;
+ my @args = $event->args;
&DEBUG("on_useronchannel: @args");
&joinNextChan();
sub on_chanfull {
$conn = shift(@_);
my ($event) = @_;
- my @args = $event->args;
+ my @args = $event->args;
&status(">>> chanfull/$b_blue$args[1]$ob");
sub on_inviteonly {
$conn = shift(@_);
my ($event) = @_;
- my @args = $event->args;
+ my @args = $event->args;
&status(">>> inviteonly/$b_cyan$args[1]$ob");
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();
}
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};
sub on_useronchan {
$conn = shift(@_);
my ($event) = @_;
- my @args = $event->args;
+ my @args = $event->args;
&DEBUG("on_useronchan: args => @args");
&joinNextChan();
}
sub setupSchedulers {
- &VERB("Starting schedulers...",2);
+ &VERB( 'Starting schedulers...', 2 );
# ONCE OFF.
&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);
&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.");
}
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;
}
####
####
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 !~ /^</) and ($key !~ /\#DEL\#/) and ($key !~ /^cmd:/));
-
- $error++;
- if ($error == 5) {
- &ERROR("rF: tried 5 times but failed.");
- return;
- }
- }
- &action($_, "Thinks: \037$key\037 is $val");
- ### FIXME: Use &getReply() on above to format factoid properly?
- $good++;
+ last
+ if ( ( defined $val )
+ and ( $val !~ /^</ )
+ and ( $key !~ /\#DEL\#/ )
+ and ( $key !~ /^cmd:/ ) );
+
+ $error++;
+ if ( $error == 5 ) {
+ &ERROR('rF: tried 5 times but failed.');
+ return;
+ }
+ }
+ &action( $_, "Thinks: \037$key\037 is $val" );
+ ### FIXME: Use &getReply() on above to format factoid properly?
+ $good++;
}
}
sub logLoop {
if (@_) {
- &ScheduleThis(3600, 'logLoop'); # 1 hour
- return if ($_[0] eq '2'); # defer.
+ &ScheduleThis( 3600, 'logLoop' ); # 1 hour
+ return if ( $_[0] eq '2' ); # defer.
}
- return unless (defined fileno LOG);
- return unless (&IsParam('logfile'));
- return unless (&IsParam('maxLogSize'));
+ return unless ( defined fileno LOG );
+ return unless ( &IsParam('logfile') );
+ return unless ( &IsParam('maxLogSize') );
### check if current size is too large.
- 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.");
+ 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?
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.
# 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();
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 (<IN>) {
- chop;
- push(@wingateNow, $_);
- }
- close IN;
+ open( IN, $file );
+ while (<IN>) {
+ 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 );
+ }
}
}
# 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);
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 = <FILE>)) {
- $help =~ s/^[\# ].*//;
- chomp $help;
- next unless $help;
- my ($key, $val) = split(/:/, $help, 2);
+ while ( defined( my $help = <FILE> ) ) {
+ $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 '';
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);
}
}
###
# 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;
### 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 $_[$#_]";
}
}
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;
}
# 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;
# 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;
# 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;
###
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 = <IN>;
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 = <IN>;
- close IN;
+ if ( open( IN, $file ) ) {
+ my @lines = <IN>;
+ 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;
}
}
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;
+ }
}
##########
###
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 {
# 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;
}
####
# 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;
}
}
# 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);
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;
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';
}
}
sub validExec {
my ($str) = @_;
- if ($str =~ /[\`\'\"\|]/) { # invalid.
- return 0;
- } else { # valid.
- return 1;
+ if ( $str =~ /[\`\'\"\|]/ ) { # invalid.
+ return 0;
+ }
+ else { # valid.
+ return 1;
}
}
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;
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,
+ }
+ );
}
}
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;
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 = (
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" =>
"/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",
);
#####################
####
# 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;
}
}
####
# 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 (<IN>) {
- 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;
### 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 (<IN>) {
- 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.
&::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 (<IN>) {
- 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;
}
####
# 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.");
}
# 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) {
- $_ = <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 ) {
+ $_ = <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;
# 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}");
# 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) {
- $_ = <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 ) {
+ $_ = <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;
}
# 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 (<IN>) {
- 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 (<IN>) {
+ next unless (/^Package: (.*)\n$/);
+ print OUT $1 . "\n";
+ }
+ close IN;
+ }
+ close OUT;
}
return 1;
# 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 (<IN>) {
- 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 (<IN>) {
- 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;
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 ) );
}
}
$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 =~ /<HEAD>(.+?)<HR>/s;
- $report = $1;
- my $bug = {};
- ($bug->{num},$bug->{title}) = $report =~ m#\#(\d+)\<\/A\>\<BR\>(.+?)\<\/H1\>#is;
- if ($DEBUG) {
- print "Bugnum: $bug->{num}\nTitle: $bug->{title}\nReport: $report\n";
- }
- $bug->{title} =~ s/</\</g;
- $bug->{title} =~ s/>/\>/g;
- $bug->{title} =~ s/"/\"/g;
- $bug->{severity} = 'n'; #Default severity is normal
- my @bug_flags = split /(?<!\&.t)[;\.]\n/s, $report;
- foreach my $bug_flag (@bug_flags) {
- print "Bug_flag: $bug_flag\n" if $DEBUG;
- 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/</\</g;
- $bug->{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:\</) {
- $bug->{done} = 1;
- }
- elsif ($bug_flag =~ /\>Fixed\</) {
- $bug->{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 =~ /<HEAD>(.+?)<HR>/s;
+ $report = $1;
+ my $bug = {};
+ ( $bug->{num}, $bug->{title} ) =
+ $report =~ m#\#(\d+)\<\/A\>\<BR\>(.+?)\<\/H1\>#is;
+ if ($DEBUG) {
+ print "Bugnum: $bug->{num}\nTitle: $bug->{title}\nReport: $report\n";
+ }
+ $bug->{title} =~ s/</\</g;
+ $bug->{title} =~ s/>/\>/g;
+ $bug->{title} =~ s/"/\"/g;
+ $bug->{severity} = 'n'; #Default severity is normal
+ my @bug_flags = split /(?<!\&.t)[;\.]\n/s, $report;
+ foreach my $bug_flag (@bug_flags) {
+ print "Bug_flag: $bug_flag\n" if $DEBUG;
+ 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/</\</g;
+ $bug->{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:\</ ) {
+ $bug->{done} = 1;
+ }
+ elsif ( $bug_flag =~ /\>Fixed\</ ) {
+ $bug->{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($) {
}
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 =~ /<BODY[^>]*>(.+?)<HR>/si;
$report = $1;
my $bug = {};
- ($bug->{num},$bug->{title}) = $report =~ m#\#(\d+)\<\/A\>\<BR\>(.+?)\<\/H1\>#is;
+ ( $bug->{num}, $bug->{title} ) =
+ $report =~ m#\#(\d+)\<\/A\>\<BR\>(.+?)\<\/H1\>#is;
&::DEBUG("Bugnum: $bug->{num}\n");
$bug->{title} =~ s/</\</g;
$bug->{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 /(?<!\&.t)[;\.]\n/s, $report;
+
foreach my $bug_flag (@bug_flags) {
- $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/</\</g;
- $bug->{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:\</) {
- $bug->{done} = 1;
- }
- elsif ($bug_flag =~ /\>Fixed\</) {
- $bug->{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/</\</g;
+ $bug->{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:\</ ) {
+ $bug->{done} = 1;
+ }
+ elsif ( $bug_flag =~ /\>Fixed\</ ) {
+ $bug->{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
}
sub do_email {
- my($email) = @_;
+ my ($email) = @_;
my $url = "http://bugs.debian.org/$email";
# FIXME
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
my @results = &::getURL($url);
foreach (@results) {
- &::DEBUG("do_pkg: $_");
+ &::DEBUG("do_pkg: $_");
}
}
#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;
}
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(" => <NULL>.");
- }
- }
+ 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(" => <NULL>.");
+ }
+ }
}
# 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(" $_ => <NULL>.");
- }
- }
+ 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(" $_ => <NULL>.");
+ }
+ }
}
- 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");
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 );
}
}
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");
}
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;
}
&::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*([^<]+)</gi)
- );
+ my %Currencies =
+ ( grep /\S+/, ( $html =~ /option value="([^"]+)">.*?,\s*([^<]+)</gi ) );
- my %CurrLookup = reverse ($html =~ /option value="([^"]+)">([^<]+)</gi);
+ my %CurrLookup = reverse( $html =~ /option value="([^"]+)">([^<]+)</gi );
if ($Country) {
- # 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});
- }
+
+ # 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";
###
# 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/\!/ </;
- $factinfo{'created_by'} .= '>';
- $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/\!/ </;
+ $factinfo{'created_by'} .= '>';
+ $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', '^<REPLY> see ');
- my %redir;
- my $f;
-
- for (@list) {
- my $factoid = $_;
- my $val = &getFactInfo($factoid, 'factoid_value');
- if ($val =~ /^<REPLY> ?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 =~ /^<REPLY> 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', '^<REPLY> see ');
- my %redir;
- my $f;
- my $dangling = 0;
-
- for (@list) {
- my $factoid = $_;
- my $val = &getFactInfo($factoid, 'factoid_value');
- if ($val =~ /^<REPLY> 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',"<REPLY> 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',
+ '^<REPLY> see ' );
+ my %redir;
+ my $f;
+
+ for (@list) {
+ my $factoid = $_;
+ my $val = &getFactInfo( $factoid, 'factoid_value' );
+ if ( $val =~ /^<REPLY> ?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 =~ /^<REPLY> 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',
+ '^<REPLY> see ' );
+ my %redir;
+ my $f;
+ my $dangling = 0;
+
+ for (@list) {
+ my $factoid = $_;
+ my $val = &getFactInfo( $factoid, 'factoid_value' );
+ if ( $val =~ /^<REPLY> 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', "<REPLY> 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'.";
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;
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;
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 =~ /^\#/) {
}
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);
}
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 (<IN>) {
- chop;
- push(@old,$_);
- }
- close IN;
+ if ( !-f $file ) {
+ open( OUT, ">$file" );
+ foreach (@now) {
+ print OUT "$_\n";
+ }
+ close OUT;
+
+ return;
+ }
+ else {
+ open( IN, $file );
+ while (<IN>) {
+ chop;
+ push( @old, $_ );
+ }
+ close IN;
}
my @new;
- for(my $i=0; $i<scalar(@old); $i++) {
- next if ($old[$i] eq $now[$i]);
- push(@new, $now[$i]);
+ for ( my $i = 0 ; $i < scalar(@old) ; $i++ ) {
+ next if ( $old[$i] eq $now[$i] );
+ push( @new, $now[$i] );
}
- if (scalar @now != scalar @old) {
- &::DEBUG("kA: scalar mismatch; removing and exiting.");
- unlink $file;
- return;
+ if ( scalar @now != scalar @old ) {
+ &::DEBUG("kA: scalar mismatch; removing and exiting.");
+ unlink $file;
+ return;
}
- if (!scalar @new) {
- &::DEBUG("kA: no new kernels.");
- return;
+ if ( !scalar @new ) {
+ &::DEBUG("kA: no new kernels.");
+ return;
}
- open(OUT, ">$file");
+ open( OUT, ">$file" );
foreach (@now) {
- print OUT "$_\n";
+ print OUT "$_\n";
}
close OUT;
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 '';
}
}
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 (<NEWS>) {
- 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 <chan> <nick> <time>
- if (/^U\s+(\S+)\s+(\S+)\s+(\d+)$/) {
- $::newsuser{$1}{$2} = $3;
- $cu++;
- next;
- }
+ # U <chan> <nick> <time>
+ if (/^U\s+(\S+)\s+(\S+)\s+(\d+)$/) {
+ $::newsuser{$1}{$2} = $3;
+ $cu++;
+ next;
+ }
- if (/^(\S+)[\s\t]+(.*)$/) {
- $chan = $1;
- $item = $2;
- $ci++;
- }
+ if (/^(\S+)[\s\t]+(.*)$/) {
+ $chan = $1;
+ $item = $2;
+ $ci++;
+ }
}
close NEWS;
- my $cn = scalar(keys %::news);
- return unless ($ci or $cn or $cu);
-
- &::status("News: read ".
- $ci. &::fixPlural(' item', $ci). ' for '.
- $cn. &::fixPlural(' chan', $cn). ', '.
- $cu. &::fixPlural(' user', $cu), ' cache'
+ my $cn = scalar( keys %::news );
+ return unless ( $ci or $cn or $cu );
+
+ &::status(
+ "News: read " . $ci
+ . &::fixPlural( ' item', $ci ) . ' for '
+ . $cn
+ . &::fixPlural( ' chan', $cn ) . ', '
+ . $cu
+ . &::fixPlural( ' user', $cu ),
+ ' cache'
);
}
sub writeNews {
- if (!scalar keys %::news and !scalar keys %::newsuser) {
- &::VERB("wN: nothing to write.",2);
- return;
+ if ( !scalar keys %::news and !scalar keys %::newsuser ) {
+ &::VERB( "wN: nothing to write.", 2 );
+ return;
}
# should define this at the top of file.
my $file = "$::bot_base_dir/infobot-news.txt";
- if (fileno NEWS) {
- &::ERROR("News: write: fileno NEWS exists, should never happen.");
- return;
+ if ( fileno NEWS ) {
+ &::ERROR("News: write: fileno NEWS exists, should never happen.");
+ return;
}
# TODO: add commands to output file.
my $c = 0;
- my($cc,$ci,$cu) = (0,0,0);
+ my ( $cc, $ci, $cu ) = ( 0, 0, 0 );
- open(NEWS, ">$file");
- foreach $chan (sort keys %::news) {
- $c = scalar keys %{ $::news{$chan} };
- next unless ($c);
- $cc++;
- my $item;
+ open( NEWS, ">$file" );
+ foreach $chan ( sort keys %::news ) {
+ $c = scalar keys %{ $::news{$chan} };
+ next unless ($c);
+ $cc++;
+ my $item;
- foreach $item (sort keys %{ $::news{$chan} }) {
- $c = scalar keys %{ $::news{$chan}{$item} };
- next unless ($c);
- $ci++;
+ foreach $item ( sort keys %{ $::news{$chan} } ) {
+ $c = scalar keys %{ $::news{$chan}{$item} };
+ next unless ($c);
+ $ci++;
- print NEWS "$chan $item\n";
- my $what;
- foreach $what (sort keys %{ $::news{$chan}{$item} }) {
- print NEWS " $what: $::news{$chan}{$item}{$what}\n";
- }
- print NEWS "\n";
- }
+ print NEWS "$chan $item\n";
+ my $what;
+ foreach $what ( sort keys %{ $::news{$chan}{$item} } ) {
+ print NEWS " $what: $::news{$chan}{$item}{$what}\n";
+ }
+ print NEWS "\n";
+ }
}
# TODO: show how many users we wrote down.
- if (&::getChanConfList('newsKeepRead')) {
- # old users are removed in newsFlush(), perhaps it should be
- # done here.
+ if ( &::getChanConfList('newsKeepRead') ) {
+
+ # old users are removed in newsFlush(), perhaps it should be
+ # done here.
- foreach $chan (sort keys %::newsuser) {
+ foreach $chan ( sort keys %::newsuser ) {
- foreach (sort keys %{ $::newsuser{$chan} }) {
- print NEWS "U $chan $_ $::newsuser{$chan}{$_}\n";
- $cu++;
- }
- }
+ foreach ( sort keys %{ $::newsuser{$chan} } ) {
+ print NEWS "U $chan $_ $::newsuser{$chan}{$_}\n";
+ $cu++;
+ }
+ }
}
close NEWS;
}
sub add {
- my($str) = @_;
+ my ($str) = @_;
- if (!defined $chan or !defined $str or $str =~ /^\s*$/) {
- &::help('news add');
- return;
+ if ( !defined $chan or !defined $str or $str =~ /^\s*$/ ) {
+ &::help('news add');
+ return;
}
- if (length $str > 64) {
- &::notice($who, "That's not really an item (>64chars)");
- return;
+ if ( length $str > 64 ) {
+ &::notice( $who, "That's not really an item (>64chars)" );
+ return;
}
- if (exists $::news{$chan}{$str}{Time}) {
- &::notice($who, "'$str' for $chan already exists!");
- return;
+ if ( exists $::news{$chan}{$str}{Time} ) {
+ &::notice( $who, "'$str' for $chan already exists!" );
+ return;
}
- $::news{$chan}{$str}{Time} = time();
- my $expire = &::getChanConfDefault('newsDefaultExpire',7, $chan);
- $::news{$chan}{$str}{Expire} = time() + $expire*60*60*24;
- $::news{$chan}{$str}{Author} = $::who; # case!
+ $::news{$chan}{$str}{Time} = time();
+ my $expire = &::getChanConfDefault( 'newsDefaultExpire', 7, $chan );
+ $::news{$chan}{$str}{Expire} = time() + $expire * 60 * 60 * 24;
+ $::news{$chan}{$str}{Author} = $::who; # case!
- my $agestr = &::Time2String($::news{$chan}{$str}{Expire} - time() );
- my $item = &newsS2N($str);
- &::notice($who, "Added '\037$str\037' at [".gmtime(time).
- "] by \002$::who\002 for item #\002$item\002.");
- &::notice($who, "Now do 'news text $item <your_description>'");
- &::notice($who, "This item will expire at \002".
- gmtime($::news{$chan}{$str}{Expire})."\002 [$agestr from now] "
- );
+ my $agestr = &::Time2String( $::news{$chan}{$str}{Expire} - time() );
+ my $item = &newsS2N($str);
+ &::notice( $who,
+ "Added '\037$str\037' at ["
+ . gmtime(time)
+ . "] by \002$::who\002 for item #\002$item\002." );
+ &::notice( $who, "Now do 'news text $item <your_description>'" );
+ &::notice( $who,
+ "This item will expire at \002"
+ . gmtime( $::news{$chan}{$str}{Expire} )
+ . "\002 [$agestr from now] " );
&writeNews();
}
sub del {
- my($what) = @_;
- my $item = 0;
-
- if (!defined $what) {
- &::help('news del');
- return;
- }
-
- if ($what =~ /^\d+$/) {
- my $count = scalar keys %{ $::news{$chan} };
- if (!$count) {
- &::notice($who, "No news for $chan.");
- return;
- }
-
- if ($what > $count or $what < 0) {
- &::notice($who, "$what is out of range (max $count)");
- return;
- }
-
- $item = &getNewsItem($what);
- $what = $item; # hack hack hack.
-
- } else {
- $_ = &getNewsItem($what); # hack hack hack.
- $what = $_ if (defined $_);
-
- if (!exists $::news{$chan}{$what}) {
- my @found;
- foreach (keys %{ $::news{$chan} }) {
- next unless (/\Q$what\E/);
- push(@found, $_);
- }
-
- if (!scalar @found) {
- &::notice($who, "could not find $what.");
- return;
- }
-
- if (scalar @found > 1) {
- &::notice($who, "too many matches for $what.");
- return;
- }
-
- $what = $found[0];
- &::DEBUG("news: del: str: guessed what => $what");
- }
- }
-
- if (exists $::news{$chan}{$what}) {
- my $auth = 0;
- $auth++ if ($::who eq $::news{$chan}{$what}{Author});
- $auth++ if (&::IsFlag('o'));
-
- if (!$auth) {
- # TODO: show when it'll expire.
- &::notice($who, "Sorry, you cannot remove items; just let them expire on their own.");
- return;
- }
-
- &::notice($who, "ok, deleted '$what' from \002$chan\002...");
- delete $::news{$chan}{$what};
- } else {
- &::notice($who, "error: not found $what in news for $chan.");
+ my ($what) = @_;
+ my $item = 0;
+
+ if ( !defined $what ) {
+ &::help('news del');
+ return;
+ }
+
+ if ( $what =~ /^\d+$/ ) {
+ my $count = scalar keys %{ $::news{$chan} };
+ if ( !$count ) {
+ &::notice( $who, "No news for $chan." );
+ return;
+ }
+
+ if ( $what > $count or $what < 0 ) {
+ &::notice( $who, "$what is out of range (max $count)" );
+ return;
+ }
+
+ $item = &getNewsItem($what);
+ $what = $item; # hack hack hack.
+
+ }
+ else {
+ $_ = &getNewsItem($what); # hack hack hack.
+ $what = $_ if ( defined $_ );
+
+ if ( !exists $::news{$chan}{$what} ) {
+ my @found;
+ foreach ( keys %{ $::news{$chan} } ) {
+ next unless (/\Q$what\E/);
+ push( @found, $_ );
+ }
+
+ if ( !scalar @found ) {
+ &::notice( $who, "could not find $what." );
+ return;
+ }
+
+ if ( scalar @found > 1 ) {
+ &::notice( $who, "too many matches for $what." );
+ return;
+ }
+
+ $what = $found[0];
+ &::DEBUG("news: del: str: guessed what => $what");
+ }
+ }
+
+ if ( exists $::news{$chan}{$what} ) {
+ my $auth = 0;
+ $auth++ if ( $::who eq $::news{$chan}{$what}{Author} );
+ $auth++ if ( &::IsFlag('o') );
+
+ if ( !$auth ) {
+
+ # TODO: show when it'll expire.
+ &::notice( $who,
+"Sorry, you cannot remove items; just let them expire on their own."
+ );
+ return;
+ }
+
+ &::notice( $who, "ok, deleted '$what' from \002$chan\002..." );
+ delete $::news{$chan}{$what};
+ }
+ else {
+ &::notice( $who, "error: not found $what in news for $chan." );
}
}
sub list {
- if (!scalar keys %{ $::news{$chan} }) {
- &::notice($who, "No news for \002$chan\002.");
- return;
+ if ( !scalar keys %{ $::news{$chan} } ) {
+ &::notice( $who, "No news for \002$chan\002." );
+ return;
}
- if (&::IsChanConf('newsKeepRead') > 0) {
- my $x = $::newsuser{$chan}{$who};
+ if ( &::IsChanConf('newsKeepRead') > 0 ) {
+ my $x = $::newsuser{$chan}{$who};
- if (defined $x and ($x == 0 or $x == -1)) {
- &::DEBUG("news: not updating time for $who.");
- } else {
- if (!scalar keys %{ $::news{$chan} }) {
- &::DEBUG("news: should not add $chan/$who to cache!");
- }
+ if ( defined $x and ( $x == 0 or $x == -1 ) ) {
+ &::DEBUG("news: not updating time for $who.");
+ }
+ else {
+ if ( !scalar keys %{ $::news{$chan} } ) {
+ &::DEBUG("news: should not add $chan/$who to cache!");
+ }
- $::newsuser{$chan}{$who} = time();
- }
+ $::newsuser{$chan}{$who} = time();
+ }
}
# ¬ice() breaks OPN :( - using msg() instead!
my $count = scalar keys %{ $::news{$chan} };
- &::msg($who, "|==== News for \002$chan\002: ($count items)");
- my $newest = 0;
- my $expire = 0;
- my $eno = 0;
- foreach (keys %{ $::news{$chan} }) {
- my $t = $::news{$chan}{$_}{Time};
- my $e = $::news{$chan}{$_}{Expire};
- $newest = $t if ($t > $newest);
- if ($e > 1 and $e < $expire) {
- $expire = $e;
- &::DEBUG("before newsS2N($_)");
- $eno = &newsS2N($_);
- &::DEBUG("after newsS2N($_) == $eno");
- }
- }
- my $timestr = &::Time2String(time() - $newest);
- &::msg($who, "|= Last updated $timestr ago.");
- &::msg($who, " \037Num\037 \037Item ".(' 'x40)." \037");
-
-# &::DEBUG("news: list: expire = $expire");
-# &::DEBUG("news: list: eno = $eno");
+ &::msg( $who, "|==== News for \002$chan\002: ($count items)" );
+ my $newest = 0;
+ my $expire = 0;
+ my $eno = 0;
+ foreach ( keys %{ $::news{$chan} } ) {
+ my $t = $::news{$chan}{$_}{Time};
+ my $e = $::news{$chan}{$_}{Expire};
+ $newest = $t if ( $t > $newest );
+ if ( $e > 1 and $e < $expire ) {
+ $expire = $e;
+ &::DEBUG("before newsS2N($_)");
+ $eno = &newsS2N($_);
+ &::DEBUG("after newsS2N($_) == $eno");
+ }
+ }
+ my $timestr = &::Time2String( time() - $newest );
+ &::msg( $who, "|= Last updated $timestr ago." );
+ &::msg( $who, " \037Num\037 \037Item " . ( ' ' x 40 ) . " \037" );
+
+ # &::DEBUG("news: list: expire = $expire");
+ # &::DEBUG("news: list: eno = $eno");
my $i = 1;
foreach ( &getNewsAll() ) {
- my $subtopic = $_;
- my $setby = $::news{$chan}{$subtopic}{Author};
- my $chr = (exists $::News{$chan}{$subtopic}{Text}) ? '' : '*';
+ my $subtopic = $_;
+ my $setby = $::news{$chan}{$subtopic}{Author};
+ my $chr = ( exists $::News{$chan}{$subtopic}{Text} ) ? '' : '*';
- if (!defined $subtopic) {
- &::DEBUG("news: warn: subtopic == undef.");
- next;
- }
+ if ( !defined $subtopic ) {
+ &::DEBUG("news: warn: subtopic == undef.");
+ next;
+ }
- # TODO: show request stats aswell.
- &::msg($who, sprintf("\002[\002%2d\002]\002%s %s",
- $i, $chr, $subtopic));
- $i++;
+ # TODO: show request stats aswell.
+ &::msg( $who,
+ sprintf( "\002[\002%2d\002]\002%s %s", $i, $chr, $subtopic ) );
+ $i++;
}
my $z = $::newsuser{$who};
- if (defined $z) {
- &::DEBUG("cache $who: $z");
- } else {
- &::DEBUG("cache: $who doesn't have newscache set.");
+ if ( defined $z ) {
+ &::DEBUG("cache $who: $z");
+ }
+ else {
+ &::DEBUG("cache: $who doesn't have newscache set.");
}
- &::msg($who, "|= End of News.");
- &::msg($who, "use 'news read <#>' or 'news read <keyword>'");
+ &::msg( $who, "|= End of News." );
+ &::msg( $who, "use 'news read <#>' or 'news read <keyword>'" );
}
sub read {
- my($str) = @_;
+ my ($str) = @_;
- if (!defined $chan or !defined $str or $str =~ /^\s*$/) {
- &::help('news read');
- return;
+ if ( !defined $chan or !defined $str or $str =~ /^\s*$/ ) {
+ &::help('news read');
+ return;
}
- if (!scalar keys %{ $::news{$chan} }) {
- &::notice($who, "No news for \002$chan\002.");
- return;
+ if ( !scalar keys %{ $::news{$chan} } ) {
+ &::notice( $who, "No news for \002$chan\002." );
+ return;
}
- my $item = &getNewsItem($str);
- if (!defined $item or !scalar keys %{ $::news{$chan}{$item} }) {
- # TODO: numerical check.
- if ($str =~ /^(\d+)[-, ](\d+)$/ or
- $str =~ /^-(\d+)$/ or
- $str =~ /^(\d+)-$/ or 0
- ) {
- &::notice($who, "We don't support multiple requests of news items yet. Sorry.");
- return;
- }
+ my $item = &getNewsItem($str);
+ if ( !defined $item or !scalar keys %{ $::news{$chan}{$item} } ) {
- &::notice($who, "No news item called '$str'");
- return;
+ # TODO: numerical check.
+ if ( $str =~ /^(\d+)[-, ](\d+)$/
+ or $str =~ /^-(\d+)$/
+ or $str =~ /^(\d+)-$/
+ or 0 )
+ {
+ &::notice( $who,
+ "We don't support multiple requests of news items yet. Sorry."
+ );
+ return;
+ }
+
+ &::notice( $who, "No news item called '$str'" );
+ return;
}
- if (!exists $::news{$chan}{$item}{Text}) {
- &::notice($who, 'Someone forgot to add info to this news item');
- return;
+ if ( !exists $::news{$chan}{$item}{Text} ) {
+ &::notice( $who, 'Someone forgot to add info to this news item' );
+ return;
}
- my $t = gmtime( $::news{$chan}{$item}{Time} );
- my $a = $::news{$chan}{$item}{Author};
- my $text = $::news{$chan}{$item}{Text};
- my $num = &newsS2N($item);
- my $rwho = $::news{$chan}{$item}{Request_By} || $::who;
- my $rcount = $::news{$chan}{$item}{Request_Count} || 0;
+ my $t = gmtime( $::news{$chan}{$item}{Time} );
+ my $a = $::news{$chan}{$item}{Author};
+ my $text = $::news{$chan}{$item}{Text};
+ my $num = &newsS2N($item);
+ my $rwho = $::news{$chan}{$item}{Request_By} || $::who;
+ my $rcount = $::news{$chan}{$item}{Request_Count} || 0;
- if (length $text < $::param{maxKeySize}) {
- &::VERB("NEWS: Possible news->factoid redirection.",2);
- my $f = &::getFactoid($text);
+ if ( length $text < $::param{maxKeySize} ) {
+ &::VERB( "NEWS: Possible news->factoid redirection.", 2 );
+ my $f = &::getFactoid($text);
- if (defined $f) {
- &::VERB("NEWS: ok, $text is factoid redirection.",2);
- $f =~ s/^<REPLY>\s*//i; # anything else?
- $text = $f;
- }
+ if ( defined $f ) {
+ &::VERB( "NEWS: ok, $text is factoid redirection.", 2 );
+ $f =~ s/^<REPLY>\s*//i; # anything else?
+ $text = $f;
+ }
}
$_ = $::news{$chan}{$item}{'Expire'};
my $e;
if ($_) {
- $e = sprintf("\037%s\037 [%s from now]",
- scalar(gmtime($_)),
- &::Time2String($_ - time())
- );
+ $e = sprintf(
+ "\037%s\037 [%s from now]",
+ scalar( gmtime($_) ),
+ &::Time2String( $_ - time() )
+ );
}
- &::notice($who, "+- News \002$chan\002 #$num: $item");
- &::notice($who, "| Added by $a at \037$t\037");
- &::notice($who, "| Expire: $e") if (defined $e);
- &::notice($who, $text);
- &::notice($who, "| Requested \002$rcount\002 times, last by \002$rwho\002") if ($rcount and $rwho);
+ &::notice( $who, "+- News \002$chan\002 #$num: $item" );
+ &::notice( $who, "| Added by $a at \037$t\037" );
+ &::notice( $who, "| Expire: $e" ) if ( defined $e );
+ &::notice( $who, $text );
+ &::notice( $who,
+ "| Requested \002$rcount\002 times, last by \002$rwho\002" )
+ if ( $rcount and $rwho );
$::news{$chan}{$item}{'Request_By'} = $::who;
$::news{$chan}{$item}{'Request_Time'} = time();
}
sub mod {
- my($item, $str) = split /\s+/, $_[0], 2;
+ my ( $item, $str ) = split /\s+/, $_[0], 2;
- if (!defined $item or $item eq '' or $str =~ /^\s*$/) {
- &::help('news mod');
- return;
+ if ( !defined $item or $item eq '' or $str =~ /^\s*$/ ) {
+ &::help('news mod');
+ return;
}
my $news = &getNewsItem($item);
- if (!defined $news) {
- &::DEBUG("news: error: mod: news == undefined.");
- return;
+ if ( !defined $news ) {
+ &::DEBUG("news: error: mod: news == undefined.");
+ return;
}
- my $nnews = $::news{$chan}{$news}{Text};
+ my $nnews = $::news{$chan}{$news}{Text};
my $mod_news = $news;
my $mod_nnews = $nnews;
# SAR patch. mu++
- if ($str =~ m|^\s*s([/,#\|])(.+?)\1(.*?)\1([a-z]*);?\s*$|) {
- my ($delim, $op, $np, $flags) = ($1,$2,$3,$4);
-
- if ($flags !~ /^(g)?$/) {
- &::notice($who, "error: Invalid flags to regex.");
- return;
- }
-
- ### TODO: use m### to make code safe!
- # TODO: make code safer.
- my $done = 0;
- # TODO: use eval to deal with flags easily.
- if ($flags eq '') {
- $done++ if (!$done and $mod_news =~ s/\Q$op\E/$np/);
- $done++ if (!$done and $mod_nnews =~ s/\Q$op\E/$np/);
- } elsif ($flags eq 'g') {
- $done++ if ($mod_news =~ s/\Q$op\E/$np/g);
- $done++ if ($mod_nnews =~ s/\Q$op\E/$np/g);
- }
-
- if (!$done) {
- &::notice($who, "warning: regex not found in news.");
- return;
- }
-
- if ($mod_news ne $news) { # news item.
- if (exists $::news{$chan}{$mod_news}) {
- &::notice($who, "item '$mod_news' already exists.");
- return;
- }
-
- &::notice($who, "Moving item '$news' to '$mod_news' with SAR s/$op/$np/.");
- foreach (keys %{ $::news{$chan}{$news} }) {
- $::news{$chan}{$mod_news}{$_} = $::news{$chan}{$news}{$_};
- delete $::news{$chan}{$news}{$_};
- }
- # needed?
- delete $::news{$chan}{$news};
- }
-
- if ($mod_nnews ne $nnews) { # news Text/Description.
- &::notice($who, "Changing text for '$news' SAR s/$op/$np/.");
- if ($mod_news ne $news) {
- $::news{$chan}{$mod_news}{Text} = $mod_nnews;
- } else {
- $::news{$chan}{$news}{Text} = $mod_nnews;
- }
- }
-
- return;
- } else {
- &::notice($who, "error: that regex failed ;(");
- return;
- }
-
- &::notice($who, "error: Invalid regex. Try s/1/2/, s#3#4#...");
+ if ( $str =~ m|^\s*s([/,#\|])(.+?)\1(.*?)\1([a-z]*);?\s*$| ) {
+ my ( $delim, $op, $np, $flags ) = ( $1, $2, $3, $4 );
+
+ if ( $flags !~ /^(g)?$/ ) {
+ &::notice( $who, "error: Invalid flags to regex." );
+ return;
+ }
+
+ ### TODO: use m### to make code safe!
+ # TODO: make code safer.
+ my $done = 0;
+
+ # TODO: use eval to deal with flags easily.
+ if ( $flags eq '' ) {
+ $done++ if ( !$done and $mod_news =~ s/\Q$op\E/$np/ );
+ $done++ if ( !$done and $mod_nnews =~ s/\Q$op\E/$np/ );
+ }
+ elsif ( $flags eq 'g' ) {
+ $done++ if ( $mod_news =~ s/\Q$op\E/$np/g );
+ $done++ if ( $mod_nnews =~ s/\Q$op\E/$np/g );
+ }
+
+ if ( !$done ) {
+ &::notice( $who, "warning: regex not found in news." );
+ return;
+ }
+
+ if ( $mod_news ne $news ) { # news item.
+ if ( exists $::news{$chan}{$mod_news} ) {
+ &::notice( $who, "item '$mod_news' already exists." );
+ return;
+ }
+
+ &::notice( $who,
+ "Moving item '$news' to '$mod_news' with SAR s/$op/$np/." );
+ foreach ( keys %{ $::news{$chan}{$news} } ) {
+ $::news{$chan}{$mod_news}{$_} = $::news{$chan}{$news}{$_};
+ delete $::news{$chan}{$news}{$_};
+ }
+
+ # needed?
+ delete $::news{$chan}{$news};
+ }
+
+ if ( $mod_nnews ne $nnews ) { # news Text/Description.
+ &::notice( $who, "Changing text for '$news' SAR s/$op/$np/." );
+ if ( $mod_news ne $news ) {
+ $::news{$chan}{$mod_news}{Text} = $mod_nnews;
+ }
+ else {
+ $::news{$chan}{$news}{Text} = $mod_nnews;
+ }
+ }
+
+ return;
+ }
+ else {
+ &::notice( $who, "error: that regex failed ;(" );
+ return;
+ }
+
+ &::notice( $who, "error: Invalid regex. Try s/1/2/, s#3#4#..." );
}
sub set {
- my($args) = @_;
- my($item, $what, $value);
+ my ($args) = @_;
+ my ( $item, $what, $value );
- if (!defined $args) {
- &::DEBUG("news: set: args == NULL.");
- return;
+ if ( !defined $args ) {
+ &::DEBUG("news: set: args == NULL.");
+ return;
}
- $item = $1 if ($args =~ s/^(\S+)\s*//);
- $what = $1 if ($args =~ s/^(\S+)\s*//);
+ $item = $1 if ( $args =~ s/^(\S+)\s*// );
+ $what = $1 if ( $args =~ s/^(\S+)\s*// );
$value = $args;
- if ($item eq '') {
- &::help('news set');
- return;
+ if ( $item eq '' ) {
+ &::help('news set');
+ return;
}
my $news = &getNewsItem($item);
- if (!defined $news) {
- &::notice($who, "Could not find item '$item' substring or # in news list.");
- return;
+ if ( !defined $news ) {
+ &::notice( $who,
+ "Could not find item '$item' substring or # in news list." );
+ return;
}
# list all values for chan.
- if (!defined $what or $what =~ /^\s*$/) {
- &::msg($who, "set: you didn't fill me on the arguments! (what and values)");
- return;
+ if ( !defined $what or $what =~ /^\s*$/ ) {
+ &::msg( $who,
+ "set: you didn't fill me on the arguments! (what and values)" );
+ return;
}
my $ok = 0;
- my @elements = ('Expire','Text');
+ my @elements = ( 'Expire', 'Text' );
foreach (@elements) {
- next unless ($what =~ /^$_$/i);
- $what = $_;
- $ok++;
- last;
+ next unless ( $what =~ /^$_$/i );
+ $what = $_;
+ $ok++;
+ last;
}
- if (!$ok) {
- &::notice($who, "Invalid set. Try: @elements");
- return;
+ if ( !$ok ) {
+ &::notice( $who, "Invalid set. Try: @elements" );
+ return;
}
# show (read) what.
- if (!defined $value or $value =~ /^\s*$/) {
- &::msg($who, "set: you didn't fill me on the arguments! (value)");
- return;
- }
-
- if (!exists $::news{$chan}{$news}) {
- &::notice($who, "news '$news' does not exist");
- return;
- }
-
- if ($what eq 'Expire') {
- # TODO: use do_set().
-
- my $time = 0;
- my $plus = ($value =~ s/^\+//g);
- while ($value =~ s/^(\d+)(\S*)\s*//) {
- my($int,$unit) = ($1,$2);
- $time += $int if ($unit =~ /^s(ecs?)?$/i);
- $time += $int*60 if ($unit =~ /^m(in(utes?)?)?$/i);
- $time += $int*60*60 if ($unit =~ /^h(ours?)?$/i);
- $time += $int*60*60*24 if (!$unit or $unit =~ /^d(ays?)?$/i);
- $time += $int*60*60*24*7 if ($unit =~ /^w(eeks?)?$/i);
- $time += $int*60*60*24*30 if ($unit =~ /^mon(th)?$/i);
- }
-
- if ($value =~ s/^never$//i) {
- # never.
- $time = -1;
- } elsif ($plus) {
- # from now.
- $time += time();
- } else {
- # from creation of item.
- $time += $::news{$chan}{$news}{Time};
- }
-
- if (!$time or ($value and $value !~ /^never$/i)) {
- &::DEBUG("news: set: Expire... need to parse.");
- &::msg($who, "hrm... couldn't parse that.");
- return;
- }
-
- if ($time == -1) {
- &::notice($who, "Set never expire for \002$item\002." );
- } elsif ($time < -1) {
- &::DEBUG("news: time should never be negative ($time).");
- return;
- } else {
- &::notice($who, "Set expire for \002$item\002, to ".
- gmtime($time) ." [".&::Time2String($time - time())."]" );
-
- if (time() > $time) {
- &::DEBUG("news: hrm... time() > $time, should expire.");
- }
- }
-
-
- $::news{$chan}{$news}{Expire} = $time;
-
- return;
+ if ( !defined $value or $value =~ /^\s*$/ ) {
+ &::msg( $who, "set: you didn't fill me on the arguments! (value)" );
+ return;
+ }
+
+ if ( !exists $::news{$chan}{$news} ) {
+ &::notice( $who, "news '$news' does not exist" );
+ return;
+ }
+
+ if ( $what eq 'Expire' ) {
+
+ # TODO: use do_set().
+
+ my $time = 0;
+ my $plus = ( $value =~ s/^\+//g );
+ while ( $value =~ s/^(\d+)(\S*)\s*// ) {
+ my ( $int, $unit ) = ( $1, $2 );
+ $time += $int if ( $unit =~ /^s(ecs?)?$/i );
+ $time += $int * 60 if ( $unit =~ /^m(in(utes?)?)?$/i );
+ $time += $int * 60 * 60 if ( $unit =~ /^h(ours?)?$/i );
+ $time += $int * 60 * 60 * 24
+ if ( !$unit or $unit =~ /^d(ays?)?$/i );
+ $time += $int * 60 * 60 * 24 * 7 if ( $unit =~ /^w(eeks?)?$/i );
+ $time += $int * 60 * 60 * 24 * 30 if ( $unit =~ /^mon(th)?$/i );
+ }
+
+ if ( $value =~ s/^never$//i ) {
+
+ # never.
+ $time = -1;
+ }
+ elsif ($plus) {
+
+ # from now.
+ $time += time();
+ }
+ else {
+
+ # from creation of item.
+ $time += $::news{$chan}{$news}{Time};
+ }
+
+ if ( !$time or ( $value and $value !~ /^never$/i ) ) {
+ &::DEBUG("news: set: Expire... need to parse.");
+ &::msg( $who, "hrm... couldn't parse that." );
+ return;
+ }
+
+ if ( $time == -1 ) {
+ &::notice( $who, "Set never expire for \002$item\002." );
+ }
+ elsif ( $time < -1 ) {
+ &::DEBUG("news: time should never be negative ($time).");
+ return;
+ }
+ else {
+ &::notice( $who,
+ "Set expire for \002$item\002, to "
+ . gmtime($time) . " ["
+ . &::Time2String( $time - time() )
+ . "]" );
+
+ if ( time() > $time ) {
+ &::DEBUG("news: hrm... time() > $time, should expire.");
+ }
+ }
+
+ $::news{$chan}{$news}{Expire} = $time;
+
+ return;
}
my $auth = 0;
-# &::DEBUG("news: who => '$who'");
+
+ # &::DEBUG("news: who => '$who'");
my $author = $::news{$chan}{$news}{Author};
- $auth++ if ($::who eq $author);
- $auth++ if (&::IsFlag('o'));
- if (!defined $author) {
- &::DEBUG("news: news{$chan}{$news}{Author} is not defined! auth'd anyway");
- $::news{$chan}{$news}{Author} = $::who;
- $author = $::who;
- $auth++;
+ $auth++ if ( $::who eq $author );
+ $auth++ if ( &::IsFlag('o') );
+ if ( !defined $author ) {
+ &::DEBUG(
+ "news: news{$chan}{$news}{Author} is not defined! auth'd anyway");
+ $::news{$chan}{$news}{Author} = $::who;
+ $author = $::who;
+ $auth++;
}
- if (!$auth) {
- # TODO: show when it'll expire.
- &::notice($who, "Sorry, you cannot set items. (author $author owns it)");
- return;
+ if ( !$auth ) {
+
+ # TODO: show when it'll expire.
+ &::notice( $who,
+ "Sorry, you cannot set items. (author $author owns it)" );
+ return;
}
# TODO: clean this up.
my $old = $::news{$chan}{$news}{$what};
- if (defined $old) {
- &::DEBUG("news: old => $old.");
+ if ( defined $old ) {
+ &::DEBUG("news: old => $old.");
}
$::news{$chan}{$news}{$what} = $value;
- &::notice($who, "Setting [$chan]/{$news}/<$what> to '$value'.");
+ &::notice( $who, "Setting [$chan]/{$news}/<$what> to '$value'." );
}
sub latest {
- my ($tchan, $flag) = @_;
+ my ( $tchan, $flag ) = @_;
# hack hack hack. fix later.
$chan = $tchan;
$who = $::who;
# TODO: if chan = undefined, guess.
-# if (!exists $::news{$chan}) {
- if (!exists $::channels{$chan}) {
- &::notice($who, "invalid chan $chan") if ($flag);
- return;
+ # if (!exists $::news{$chan}) {
+ if ( !exists $::channels{$chan} ) {
+ &::notice( $who, "invalid chan $chan" ) if ($flag);
+ return;
}
my $t = $::newsuser{$chan}{$who};
-# if (defined $t) {
-# &::DEBUG("newsuser: $chan/$who == $t");
-# } else {
-# &::DEBUG("newsuser: $chan/$who == undefined");
-# }
- if (defined $t and ($t == 0 or $t == -1)) {
- if ($flag) {
- &::notice($who, "if you want to read news, try \002/msg $::ident news $chan\002 or \002/msg $::ident news $chan notify\002");
- } else {
- &::DEBUG("news: not displaying any new news for $who");
- return;
- }
+ # if (defined $t) {
+ # &::DEBUG("newsuser: $chan/$who == $t");
+ # } else {
+ # &::DEBUG("newsuser: $chan/$who == undefined");
+ # }
+
+ if ( defined $t and ( $t == 0 or $t == -1 ) ) {
+ if ($flag) {
+ &::notice( $who,
+"if you want to read news, try \002/msg $::ident news $chan\002 or \002/msg $::ident news $chan notify\002"
+ );
+ }
+ else {
+ &::DEBUG("news: not displaying any new news for $who");
+ return;
+ }
}
- $::chan = $chan;
- return if (&::IsChanConf('newsNotifyAll') <= 0);
+ $::chan = $chan;
+ return if ( &::IsChanConf('newsNotifyAll') <= 0 );
# I don't understand this code ;)
- $t = 1 if (!defined $t);
+ $t = 1 if ( !defined $t );
+
+ if ( !defined $t ) {
- if (!defined $t) {
-# &::msg($who, "News is disabled for $chan");
- &::DEBUG("news: $chan: something went really wrong.");
- return;
+ # &::msg($who, "News is disabled for $chan");
+ &::DEBUG("news: $chan: something went really wrong.");
+ return;
}
my @new;
- foreach (keys %{ $::news{$chan} }) {
- next if (!defined $t);
- next if ($t > $::news{$chan}{$_}{Time});
+ foreach ( keys %{ $::news{$chan} } ) {
+ next if ( !defined $t );
+ next if ( $t > $::news{$chan}{$_}{Time} );
- # don't list new items if they don't have Text.
- if (!exists $::news{$chan}{$_}{Text}) {
- if (time() - $::news{$chan}{$_}{Time} > 60*60*24*3) {
- &::DEBUG("deleting news{$chan}{$_} because it was too old and had no text info.");
- delete $::news{$chan}{$_};
- }
+ # don't list new items if they don't have Text.
+ if ( !exists $::news{$chan}{$_}{Text} ) {
+ if ( time() - $::news{$chan}{$_}{Time} > 60 * 60 * 24 * 3 ) {
+ &::DEBUG(
+"deleting news{$chan}{$_} because it was too old and had no text info."
+ );
+ delete $::news{$chan}{$_};
+ }
- next;
- }
+ next;
+ }
- push(@new, $_);
+ push( @new, $_ );
}
# !scalar @new, $flag
- if (!scalar @new and $flag) {
- &::notice($who, "no new news for $chan for $who.");
- # valid to set this?
- $::newsuser{$chan}{$who} = time();
- return;
+ if ( !scalar @new and $flag ) {
+ &::notice( $who, "no new news for $chan for $who." );
+
+ # valid to set this?
+ $::newsuser{$chan}{$who} = time();
+ return;
}
# scalar @new, !$flag
- my $unread = scalar @new;
- my $total = scalar keys %{ $::news{$chan} };
- if (!$flag && &::IsChanConf('newsTellUnread') <= 0) {
- return;
+ my $unread = scalar @new;
+ my $total = scalar keys %{ $::news{$chan} };
+ if ( !$flag && &::IsChanConf('newsTellUnread') <= 0 ) {
+ return;
}
- if (!$flag) {
- return unless ($unread);
+ if ( !$flag ) {
+ return unless ($unread);
- # just a temporary measure not to flood ourself off the
- # network with news until we get global notice() and msg()
- # throttling.
- if (time() - ($::cache{newsTime} || 0) < 5) {
- &::status("news: not displaying latest notice to $who/$chan.");
- return;
- }
+ # just a temporary measure not to flood ourself off the
+ # network with news until we get global notice() and msg()
+ # throttling.
+ if ( time() - ( $::cache{newsTime} || 0 ) < 5 ) {
+ &::status("news: not displaying latest notice to $who/$chan.");
+ return;
+ }
- $::cache{newsTime} = time();
- my $reply = "There are unread news in $chan ($unread unread, $total total). /msg $::ident news $::chan latest";
- $reply .= " If you don't want further news notification, /msg $::ident news unnotify" if ($unread == $total);
- &::notice($who, $reply);
+ $::cache{newsTime} = time();
+ my $reply =
+"There are unread news in $chan ($unread unread, $total total). /msg $::ident news $::chan latest";
+ $reply .=
+" If you don't want further news notification, /msg $::ident news unnotify"
+ if ( $unread == $total );
+ &::notice( $who, $reply );
- return;
+ return;
}
# scalar @new, $flag
- if (scalar @new) {
- &::notice($who, "+==== New news for \002$chan\002 ($unread new; $total total):");
-
- my $t = $::newsuser{$chan}{$who};
- if (defined $t and $t > 1) {
- my $timestr = &::Time2String( time() - $t );
- &::notice($who, "|= Last time read $timestr ago");
- }
-
- my $i;
- my @sorted;
- foreach (@new) {
- $i = &newsS2N($_);
- $sorted[$i] = $_;
- }
-
- for ($i=0; $i<=scalar(@sorted); $i++) {
- my $news = $sorted[$i];
- next unless (defined $news);
-
-# my $age = time() - $::news{$chan}{$news}{Time};
- my $msg = sprintf("\002[\002%2d\002]\002 %s", $i, $news);
+ if ( scalar @new ) {
+ &::notice( $who,
+ "+==== New news for \002$chan\002 ($unread new; $total total):" );
+
+ my $t = $::newsuser{$chan}{$who};
+ if ( defined $t and $t > 1 ) {
+ my $timestr = &::Time2String( time() - $t );
+ &::notice( $who, "|= Last time read $timestr ago" );
+ }
+
+ my $i;
+ my @sorted;
+ foreach (@new) {
+ $i = &newsS2N($_);
+ $sorted[$i] = $_;
+ }
+
+ for ( $i = 0 ; $i <= scalar(@sorted) ; $i++ ) {
+ my $news = $sorted[$i];
+ next unless ( defined $news );
+
+ # my $age = time() - $::news{$chan}{$news}{Time};
+ my $msg = sprintf( "\002[\002%2d\002]\002 %s", $i, $news );
### $i, $_, &::Time2String($age)
- $::conn->schedule(int((2+$i)/2), sub {
- &::notice($who, $msg);
- } );
- }
-
- # TODO: implement throttling via schedule into ¬ice() / &msg().
- $::conn->schedule(int((2+$i)/2), sub {
- &::notice($who, "|= to read, do \002news $chan read <#>\002 or \002news $chan read <keyword>\002");
- } );
-
- # lame hack to prevent dupes if we just ignore it.
- my $x = $::newsuser{$chan}{$who};
- if (defined $x and ($x == 0 or $x == -1)) {
- &::DEBUG("news: not updating time for $who. (2)");
- } else {
- $::newsuser{$chan}{$who} = time();
- }
+ $::conn->schedule(
+ int( ( 2 + $i ) / 2 ),
+ sub {
+ &::notice( $who, $msg );
+ }
+ );
+ }
+
+ # TODO: implement throttling via schedule into ¬ice() / &msg().
+ $::conn->schedule(
+ int( ( 2 + $i ) / 2 ),
+ sub {
+ &::notice( $who,
+"|= to read, do \002news $chan read <#>\002 or \002news $chan read <keyword>\002"
+ );
+ }
+ );
+
+ # lame hack to prevent dupes if we just ignore it.
+ my $x = $::newsuser{$chan}{$who};
+ if ( defined $x and ( $x == 0 or $x == -1 ) ) {
+ &::DEBUG("news: not updating time for $who. (2)");
+ }
+ else {
+ $::newsuser{$chan}{$who} = time();
+ }
}
}
sub getNewsAll {
my %time;
- foreach (keys %{ $::news{$chan} }) {
- $time{ $::news{$chan}{$_}{Time} } = $_;
+ foreach ( keys %{ $::news{$chan} } ) {
+ $time{ $::news{$chan}{$_}{Time} } = $_;
}
my @items;
- foreach (sort { $a <=> $b } keys %time) {
- push(@items, $time{$_});
+ foreach ( sort { $a <=> $b } keys %time ) {
+ push( @items, $time{$_} );
}
return @items;
}
sub newsS2N {
- my($what) = @_;
- my $item = 0;
+ my ($what) = @_;
+ my $item = 0;
my @items;
my $no;
my %time;
- foreach (keys %{ $::news{$chan} }) {
- my $t = $::news{$chan}{$_}{Time};
+ foreach ( keys %{ $::news{$chan} } ) {
+ my $t = $::news{$chan}{$_}{Time};
- if (!defined $t or $t !~ /^\d+$/) {
- &::DEBUG("news: warn: t is undefined for news{$chan}{$_}{Time}; removing item.");
- delete $::news{$chan}{$_};
- next;
- }
+ if ( !defined $t or $t !~ /^\d+$/ ) {
+ &::DEBUG(
+"news: warn: t is undefined for news{$chan}{$_}{Time}; removing item."
+ );
+ delete $::news{$chan}{$_};
+ next;
+ }
- $time{$t} = $_;
+ $time{$t} = $_;
}
- foreach (sort { $a <=> $b } keys %time) {
- $item++;
- return $item if ($time{$_} eq $what);
+ foreach ( sort { $a <=> $b } keys %time ) {
+ $item++;
+ return $item if ( $time{$_} eq $what );
}
&::DEBUG("newsS2N($what): failed...");
}
sub getNewsItem {
- my($what) = @_;
- my $item = 0;
+ my ($what) = @_;
+ my $item = 0;
- $what =~ s/^\#//; # '#1' for example.
+ $what =~ s/^\#//; # '#1' for example.
my %time;
- foreach (keys %{ $::news{$chan} }) {
- my $t = $::news{$chan}{$_}{Time};
+ foreach ( keys %{ $::news{$chan} } ) {
+ my $t = $::news{$chan}{$_}{Time};
- if (!defined $t or $t !~ /^\d+$/) {
- &::DEBUG("news: warn: t is undefined for news{$chan}{$_}{Time}; removing item.");
- delete $::news{$chan}{$_};
- next;
- }
+ if ( !defined $t or $t !~ /^\d+$/ ) {
+ &::DEBUG(
+"news: warn: t is undefined for news{$chan}{$_}{Time}; removing item."
+ );
+ delete $::news{$chan}{$_};
+ next;
+ }
- $time{$t} = $_;
+ $time{$t} = $_;
}
# number to string resolution.
- if ($what =~ /^\d+$/) {
- foreach (sort { $a <=> $b } keys %time) {
- $item++;
- return $time{$_} if ($item == $what);
- }
-
- } else {
- # partial string to full string resolution
- # in some cases, string->number resolution.
-
- my @items;
- my $no;
- foreach (sort { $a <=> $b } keys %time) {
- $item++;
-# $no = $item if ($time{$_} eq $what);
+ if ( $what =~ /^\d+$/ ) {
+ foreach ( sort { $a <=> $b } keys %time ) {
+ $item++;
+ return $time{$_} if ( $item == $what );
+ }
+
+ }
+ else {
+
+ # partial string to full string resolution
+ # in some cases, string->number resolution.
+
+ my @items;
+ my $no;
+ foreach ( sort { $a <=> $b } keys %time ) {
+ $item++;
+
+ # $no = $item if ($time{$_} eq $what);
## if ($time{$_} eq $what) {
## $no = $item;
## next;
## }
- push(@items, $time{$_}) if ($time{$_} =~ /\Q$what\E/i);
- }
+ push( @items, $time{$_} ) if ( $time{$_} =~ /\Q$what\E/i );
+ }
## if (defined $no and !@items) {
## &::DEBUG("news: string->number resolution: $what->$no.");
## return $no;
## }
- if (scalar @items > 1) {
- &::DEBUG("news: Multiple matches, not guessing.");
- &::notice($who, "Multiple matches, not guessing.");
- return;
- }
+ if ( scalar @items > 1 ) {
+ &::DEBUG("news: Multiple matches, not guessing.");
+ &::notice( $who, "Multiple matches, not guessing." );
+ return;
+ }
+
+ if (@items) {
- if (@items) {
-# &::DEBUG("news: gNI: part_string->full_string: $what->$items[0]");
- return $items[0];
- } else {
- &::DEBUG("news: gNI: No match for '$what'");
- return;
- }
+ # &::DEBUG("news: gNI: part_string->full_string: $what->$items[0]");
+ return $items[0];
+ }
+ else {
+ &::DEBUG("news: gNI: No match for '$what'");
+ return;
+ }
}
&::ERROR("news: gNI: should not happen (what = $what)");
}
sub do_set {
- my($what,$value) = @_;
+ my ( $what, $value ) = @_;
- if (!defined $chan) {
- &::DEBUG("news: do_set: chan not defined.");
- return;
+ if ( !defined $chan ) {
+ &::DEBUG("news: do_set: chan not defined.");
+ return;
}
- if (!defined $what or $what =~ /^\s*$/) {
- &::DEBUG("news: what $what is not defined.");
- return;
+ if ( !defined $what or $what =~ /^\s*$/ ) {
+ &::DEBUG("news: what $what is not defined.");
+ return;
}
- if (!defined $value or $value =~ /^\s*$/) {
- &::DEBUG("news: value $value is not defined.");
- return;
+ if ( !defined $value or $value =~ /^\s*$/ ) {
+ &::DEBUG("news: value $value is not defined.");
+ return;
}
&::TODO("news: do_set:");
sub stats {
&::DEBUG("News: stats called.");
- &::msg($who, "check my logs/console.");
- my($i,$j) = (0,0);
+ &::msg( $who, "check my logs/console." );
+ my ( $i, $j ) = ( 0, 0 );
# total request count.
- foreach $chan (keys %::news) {
- foreach (keys %{ $::news{$chan} }) {
- $i += $::news{$chan}{$_}{Request_Count};
- }
+ foreach $chan ( keys %::news ) {
+ foreach ( keys %{ $::news{$chan} } ) {
+ $i += $::news{$chan}{$_}{Request_Count};
+ }
}
&::DEBUG("news: stats: total request count => $i");
$i = 0;
# total user cached.
- foreach $chan (keys %::newsuser) {
- $i += $::newsuser{$chan}{$_};
+ foreach $chan ( keys %::newsuser ) {
+ $i += $::newsuser{$chan}{$_};
}
&::DEBUG("news: stats: total user cache => $i");
$i = 0;
# average latest time read.
my $t = time();
- foreach $chan (keys %::newsuser) {
- $i += $t - $::newsuser{$chan}{$_};
- &::DEBUG(" i = $i");
- $j++;
+ foreach $chan ( keys %::newsuser ) {
+ $i += $t - $::newsuser{$chan}{$_};
+ &::DEBUG(" i = $i");
+ $j++;
}
&::DEBUG("news: stats: average latest time read: total time: $i");
&::DEBUG("news: ... count: $j");
- &::DEBUG("news: average: ".sprintf("%.02f", $i/($j||1))." sec/user");
+ &::DEBUG( "news: average: "
+ . sprintf( "%.02f", $i / ( $j || 1 ) )
+ . " sec/user" );
$i = $j = 0;
}
use vars qw($dbh $who $chan);
sub onjoin {
- my ($nick, $user, $host, $chan) = @_;
- $nick = lc $nick;
-
- # look for a channel specific message
- my $message = &sqlSelect('onjoin', 'message', { nick => $nick, channel => $chan } ) || 0;
-
- # look for a default message
- if (!$message){
- $message = &sqlSelect('onjoin', 'message', { nick => $nick, channel => '_default' } ) || 0;
- }
-
- # print the message, if there was one
- if ($message){
- $message = substVars($message, 1);
- if ($message =~ m/^<action>\s*(.*)/){
- &status("OnJoin: $nick arrived, performing action");
- &action($chan, $1);
- }
- else{
- $message =~ s/^<reply>\s*//;
- &status("OnJoin: $nick arrived, printing message");
- &msg($chan, $message);
- }
- }
-
- return;
+ my ( $nick, $user, $host, $chan ) = @_;
+ $nick = lc $nick;
+
+ # look for a channel specific message
+ my $message =
+ &sqlSelect( 'onjoin', 'message', { nick => $nick, channel => $chan } )
+ || 0;
+
+ # look for a default message
+ if ( !$message ) {
+ $message =
+ &sqlSelect( 'onjoin', 'message',
+ { nick => $nick, channel => '_default' } )
+ || 0;
+ }
+
+ # print the message, if there was one
+ if ($message) {
+ $message = substVars( $message, 1 );
+ if ( $message =~ m/^<action>\s*(.*)/ ) {
+ &status("OnJoin: $nick arrived, performing action");
+ &action( $chan, $1 );
+ }
+ else {
+ $message =~ s/^<reply>\s*//;
+ &status("OnJoin: $nick arrived, printing message");
+ &msg( $chan, $message );
+ }
+ }
+
+ return;
}
# set and get messages
sub Cmdonjoin {
- $_ = shift;
- m/(\S*)(\s*(\S*)(\s*(.*)|)|)/;
- my $ch = $1;
- my $nick = $3;
- my $msg = $5;
-
- # get options
- my $strict = &getChanConf('onjoinStrict');
- my $ops = &getChanConf('onjoinOpsOnly');
-
- # see if they specified a channel
- if ($ch !~ m/^\#/ && $ch ne '_default'){
- $msg = $nick . ($msg ? " $msg" : '');
- $nick = $ch;
- $ch = $chan;
- }
-
- $nick = lc $nick;
-
- if ($nick =~ m/^-(.*)/){
- $nick = $1;
- if ($ops){
- if (!$channels{$chan}{o}{$who}){
- &performReply("sorry, you're not an operator");
- }
- }
- elsif ($strict){
- # regardless of strict mode, ops can always change
- if (!$channels{$chan}{o}{$who} and $nick ne $who){
- &performReply("I can't alter a message for another user (strict mode)");
- }
- }
- else{
- &sqlDelete('onjoin', { nick => $nick, channel => $ch });
- &performReply('ok');
- }
- return;
- }
-
- # if msg not set, show what the message would be
- if (!$msg){
- $nick = $who if (!$nick);
- my %row = &sqlSelectRowHash('onjoin', 'message, modified_by, modified_time', { nick => $nick, channel => $ch } );
- if ($row{'message'}){
- &performStrictReply("onjoin for $nick set by $row{modified_by} on " . localtime($row{modified_time}) . ": $row{message}");
- }
- return;
- }
-
- # only allow changes by ops
- if ($ops){
- if (!$channels{$chan}{o}{$who}){
- &performReply("sorry, you're not an operator");
- return;
- }
- }
- # only allow people to change their own message (superceded by OpsOnly)
- elsif ($strict){
- # regardless of strict mode, ops can always change
- if (!$channels{$chan}{o}{$who} and $nick ne $who){
- &performReply("I can't alter a message for another user (strict mode)");
- return;
- }
- }
-
- # remove old one (if exists) and add new message
- &sqlDelete('onjoin', { nick => $nick, channel => $ch });
- my $insert = &sqlInsert('onjoin', { nick => $nick, channel => $ch, message => $msg, modified_by => $who, modified_time => time() });
- if ($insert){
- &performReply('ok');
- }
- else{
- &performReply('whoops. database error');
- }
- return;
+ $_ = shift;
+ m/(\S*)(\s*(\S*)(\s*(.*)|)|)/;
+ my $ch = $1;
+ my $nick = $3;
+ my $msg = $5;
+
+ # get options
+ my $strict = &getChanConf('onjoinStrict');
+ my $ops = &getChanConf('onjoinOpsOnly');
+
+ # see if they specified a channel
+ if ( $ch !~ m/^\#/ && $ch ne '_default' ) {
+ $msg = $nick . ( $msg ? " $msg" : '' );
+ $nick = $ch;
+ $ch = $chan;
+ }
+
+ $nick = lc $nick;
+
+ if ( $nick =~ m/^-(.*)/ ) {
+ $nick = $1;
+ if ($ops) {
+ if ( !$channels{$chan}{o}{$who} ) {
+ &performReply("sorry, you're not an operator");
+ }
+ }
+ elsif ($strict) {
+
+ # regardless of strict mode, ops can always change
+ if ( !$channels{$chan}{o}{$who} and $nick ne $who ) {
+ &performReply(
+ "I can't alter a message for another user (strict mode)");
+ }
+ }
+ else {
+ &sqlDelete( 'onjoin', { nick => $nick, channel => $ch } );
+ &performReply('ok');
+ }
+ return;
+ }
+
+ # if msg not set, show what the message would be
+ if ( !$msg ) {
+ $nick = $who if ( !$nick );
+ my %row = &sqlSelectRowHash(
+ 'onjoin',
+ 'message, modified_by, modified_time',
+ { nick => $nick, channel => $ch }
+ );
+ if ( $row{'message'} ) {
+ &performStrictReply( "onjoin for $nick set by $row{modified_by} on "
+ . localtime( $row{modified_time} )
+ . ": $row{message}" );
+ }
+ return;
+ }
+
+ # only allow changes by ops
+ if ($ops) {
+ if ( !$channels{$chan}{o}{$who} ) {
+ &performReply("sorry, you're not an operator");
+ return;
+ }
+ }
+
+ # only allow people to change their own message (superceded by OpsOnly)
+ elsif ($strict) {
+
+ # regardless of strict mode, ops can always change
+ if ( !$channels{$chan}{o}{$who} and $nick ne $who ) {
+ &performReply(
+ "I can't alter a message for another user (strict mode)");
+ return;
+ }
+ }
+
+ # remove old one (if exists) and add new message
+ &sqlDelete( 'onjoin', { nick => $nick, channel => $ch } );
+ my $insert = &sqlInsert(
+ 'onjoin',
+ {
+ nick => $nick,
+ channel => $ch,
+ message => $msg,
+ modified_by => $who,
+ modified_time => time()
+ }
+ );
+ if ($insert) {
+ &performReply('ok');
+ }
+ else {
+ &performReply('whoops. database error');
+ }
+ return;
}
1;
my @list;
foreach (@_) {
- next unless (/<title>(.*?)<\/title>/);
- my $title = $1;
- $title =~ s/&\;/&/g;
- push(@list, $title);
+ next unless (/<title>(.*?)<\/title>/);
+ my $title = $1;
+ $title =~ s/&\;/&/g;
+ push( @list, $title );
}
return @list;
my @results = &::getURL("http://www.plug.org/index.xml");
my $retval = "i could not get the headlines.";
- if (scalar @results) {
- my $prefix = 'Plug Headlines ';
- my @list = &plugParse(@results);
- $retval = &::formListReply(0, $prefix, @list);
+ if ( scalar @results ) {
+ my $prefix = 'Plug Headlines ';
+ my @list = &plugParse(@results);
+ $retval = &::formListReply( 0, $prefix, @list );
}
&::performStrictReply($retval);
my $file = "$::param{tempDir}/plug.xml";
my @Cxml = &::getURL("http://www.plug.org/index.xml");
- if (!scalar @Cxml) {
- &::DEBUG("sdA: failure (Cxml == NULL).");
- return;
+ if ( !scalar @Cxml ) {
+ &::DEBUG("sdA: failure (Cxml == NULL).");
+ return;
}
- if (! -e $file) { # first time run.
- open(OUT, ">$file");
- foreach (@Cxml) {
- print OUT "$_\n";
- }
- close OUT;
+ if ( !-e $file ) { # first time run.
+ open( OUT, ">$file" );
+ foreach (@Cxml) {
+ print OUT "$_\n";
+ }
+ close OUT;
- return;
+ return;
}
my @Oxml;
- open(IN, $file);
+ open( IN, $file );
while (<IN>) {
- chop;
- push(@Oxml,$_);
+ chop;
+ push( @Oxml, $_ );
}
close IN;
my @new;
foreach (@Chl) {
- last if ($_ eq $Ohl[0]);
- push(@new, $_);
+ last if ( $_ eq $Ohl[0] );
+ push( @new, $_ );
}
- if (scalar @new == 0) {
- &::status("Plug: no new headlines.");
- return;
+ if ( scalar @new == 0 ) {
+ &::status("Plug: no new headlines.");
+ return;
}
- if (scalar @new == scalar @Chl) {
- &::DEBUG("sdA: scalar(new) == scalar(Chl). bad?");
+ if ( scalar @new == scalar @Chl ) {
+ &::DEBUG("sdA: scalar(new) == scalar(Chl). bad?");
}
- open(OUT,">$file");
+ open( OUT, ">$file" );
foreach (@Cxml) {
- print OUT "$_\n";
+ print OUT "$_\n";
}
close OUT;
- return "Plug: ".
- join(" \002::\002 ", @new);
+ return "Plug: " . join( " \002::\002 ", @new );
}
1;
sub Quote {
my $stock = shift;
- my @results = &::getURL('http://quote.yahoo.com/d/quotes.csv' .
- "?s=$stock&f=sl1d1t1c1ohgv&e=.csv");
+ my @results =
+ &::getURL( 'http://quote.yahoo.com/d/quotes.csv'
+ . "?s=$stock&f=sl1d1t1c1ohgv&e=.csv" );
-
- if (!scalar @results) {
- &::msg($::who, "i could not get a stock quote :(");
+ if ( !scalar @results ) {
+ &::msg( $::who, "i could not get a stock quote :(" );
}
my ($reply);
foreach my $result (@results) {
- # get rid of the quotes
- $result =~ s/\"//g;
- my ($ticker, $recent, $date, $time, $change, $open,
- $high, $low, $volume) = split(',',$result);
+ # get rid of the quotes
+ $result =~ s/\"//g;
+
+ my (
+ $ticker, $recent, $date, $time, $change,
+ $open, $high, $low, $volume
+ ) = split( ',', $result );
- # add some commas
- # "+ 0" removes trailing cr/lf/etc.
- my $newvol = commify($volume + 0);
+ # add some commas
+ # "+ 0" removes trailing cr/lf/etc.
+ my $newvol = commify( $volume + 0 );
- $reply .= ' ;; ' if $reply;
- $reply .= "$ticker: $recent ($high/$low), $date $time, " .
- "Opened $open, Volume $newvol, Change $change";
+ $reply .= ' ;; ' if $reply;
+ $reply .=
+ "$ticker: $recent ($high/$low), $date $time, "
+ . "Opened $open, Volume $newvol, Change $change";
}
- if ($reply eq '') {
- $reply = "i couldn't get the quote for $stock. sorry. :(";
+ if ( $reply eq '' ) {
+ $reply = "i couldn't get the quote for $stock. sorry. :(";
}
&::performStrictReply($reply);
use vars qw(%channels %param $dbh $who $chan);
sub getCacheEntry {
- my ( $file, $url ) = @_;
- my @entries;
+ my ( $file, $url ) = @_;
+ my @entries;
- &::DEBUG("rssFeed: Searching cache for $url");
+ &::DEBUG("rssFeed: Searching cache for $url");
- open CACHE, "<$file" or return;
- binmode( CACHE, ":encoding(UTF-8)" );
+ open CACHE, "<$file" or return;
+ binmode( CACHE, ":encoding(UTF-8)" );
- while (<CACHE>) {
- next unless /^$url:/;
- chop;
- s/^$url:(.*)/$1/;
- push @entries, $_;
- }
- close CACHE;
+ while (<CACHE>) {
+ next unless /^$url:/;
+ chop;
+ s/^$url:(.*)/$1/;
+ push @entries, $_;
+ }
+ close CACHE;
- return @entries;
+ return @entries;
}
sub saveCache {
- my ( $file, $url, @entries ) = @_;
+ my ( $file, $url, @entries ) = @_;
- open IN, "<$file" or return;
- open OUT, ">$file.tmp" or return;
+ open IN, "<$file" or return;
+ open OUT, ">$file.tmp" or return;
- binmode( IN, ":encoding(UTF-8)" );
- binmode( OUT, ":encoding(UTF-8)" );
+ binmode( IN, ":encoding(UTF-8)" );
+ binmode( OUT, ":encoding(UTF-8)" );
- # copy all but old ones
- while (<IN>) {
- next if /^$url:/;
- print OUT $_;
- }
+ # copy all but old ones
+ while (<IN>) {
+ next if /^$url:/;
+ print OUT $_;
+ }
- # append new ones
- foreach (@entries) {
- print OUT "$url:$_\n";
- }
+ # append new ones
+ foreach (@entries) {
+ print OUT "$url:$_\n";
+ }
- close IN;
- close OUT;
+ close IN;
+ close OUT;
- rename "$file.tmp", "$file";
+ rename "$file.tmp", "$file";
}
sub createCache {
- my $file = shift;
+ my $file = shift;
- &::status("rssFeed: Creating cache in $file");
+ &::status("rssFeed: Creating cache in $file");
- open CACHE, ">$file" or return;
- close CACHE;
+ open CACHE, ">$file" or return;
+ close CACHE;
}
sub getFeed {
- my ( $cacheFile, $chan, $rssFeedUrl ) = @_;
+ my ( $cacheFile, $chan, $rssFeedUrl ) = @_;
- &::DEBUG("rssFeed: URL: $rssFeedUrl");
+ &::DEBUG("rssFeed: URL: $rssFeedUrl");
- my $feed = XML::Feed->parse( URI->new($rssFeedUrl) )
- or return XML::Feed->errstr;
+ my $feed = XML::Feed->parse( URI->new($rssFeedUrl) )
+ or return XML::Feed->errstr;
- my $curTitle = $feed->title;
- &::DEBUG("rssFeed: TITLE: $curTitle");
- my @curEntries;
+ my $curTitle = $feed->title;
+ &::DEBUG("rssFeed: TITLE: $curTitle");
+ my @curEntries;
- for my $entry ( $feed->entries ) {
- &::DEBUG( "rssFeed: ENTRY: " . $entry->title );
- push @curEntries, $entry->title;
- }
+ for my $entry ( $feed->entries ) {
+ &::DEBUG( "rssFeed: ENTRY: " . $entry->title );
+ push @curEntries, $entry->title;
+ }
- # Create the cache if it doesnt exist
- &createCache($cacheFile)
- if ( !-e $cacheFile );
+ # Create the cache if it doesnt exist
+ &createCache($cacheFile)
+ if ( !-e $cacheFile );
- my @oldEntries = &getCacheEntry( $cacheFile, $rssFeedUrl );
- my @newEntries;
- foreach (@curEntries) {
- &::DEBUG("rssFeed: CACHE: $_");
- last if ( $_ eq $oldEntries[0] );
- push @newEntries, $_;
- }
+ my @oldEntries = &getCacheEntry( $cacheFile, $rssFeedUrl );
+ my @newEntries;
+ foreach (@curEntries) {
+ &::DEBUG("rssFeed: CACHE: $_");
+ last if ( $_ eq $oldEntries[0] );
+ push @newEntries, $_;
+ }
- if ( scalar @newEntries == 0 ) { # if there wasn't anything new
- return "rssFeed: No new headlines for $curTitle.";
- }
+ if ( scalar @newEntries == 0 ) { # if there wasn't anything new
+ return "rssFeed: No new headlines for $curTitle.";
+ }
- # save to hash again
- &saveCache( $cacheFile, $rssFeedUrl, @curEntries )
- or return "rssFeed: Could not save cache!";
+ # save to hash again
+ &saveCache( $cacheFile, $rssFeedUrl, @curEntries )
+ or return "rssFeed: Could not save cache!";
- my $reply = &::formListReply( 0, $curTitle, @newEntries );
- &::msg( $chan, $reply );
+ my $reply = &::formListReply( 0, $curTitle, @newEntries );
+ &::msg( $chan, $reply );
- # "\002<<\002$curTitle\002>>\002 " . join( " \002::\002 ", @newEntries ) );
+ # "\002<<\002$curTitle\002>>\002 " . join( " \002::\002 ", @newEntries ) );
- return;
+ return;
}
sub RSS {
- my ($command) = @_;
- my $cacheFile = "$::param{tempDir}/rssFeed.cache";
- my %feeds;
-
- if ( not $command =~ /^(flush|update)?$/i ) {
- &::status("rssFeed: Unknown command: $command");
- return;
- }
-
- if ( $command =~ /^flush$/i ) {
- if ( not &::IsFlag("o") ) {
- &::status("rssFeed: User $::who tried to flush the cache, but isn't +o!");
- return;
- }
- unlink $cacheFile if ( -e $cacheFile );
- &::status("rssFeed: Flushing cache.");
- &::performStrictReply("$::who: Flushed RSS Feed cache.");
- return;
- }
-
- if ( $command =~ /^update$/i ) {
- if ( not &::IsFlag("o") ) {
- &::status("rssFeed: User $::who tried to manually update feeds, but isn't +o!");
- return;
- }
- &::status("rssFeed: Manual update of feeds requested by $::who.");
- }
-
- foreach my $chan ( keys %::channels ) {
- my $rssFeedUrl = &::getChanConf( 'rssFeedUrl', $chan );
- my @urls = split / /, $rssFeedUrl;
-
- # Store by url then chan to allow for same url's in multiple channels
- foreach (@urls) { $feeds{$chan}{$_} = 1 }
- }
-
- foreach my $chans ( keys %feeds ) {
- foreach ( keys %{ $feeds{$chans} } ) {
- my $result = &getFeed( $cacheFile, $chans, $_ );
- &::status($result) if $result;
- }
- }
- return;
+ my ($command) = @_;
+ my $cacheFile = "$::param{tempDir}/rssFeed.cache";
+ my %feeds;
+
+ if ( not $command =~ /^(flush|update)?$/i ) {
+ &::status("rssFeed: Unknown command: $command");
+ return;
+ }
+
+ if ( $command =~ /^flush$/i ) {
+ if ( not &::IsFlag("o") ) {
+ &::status(
+ "rssFeed: User $::who tried to flush the cache, but isn't +o!");
+ return;
+ }
+ unlink $cacheFile if ( -e $cacheFile );
+ &::status("rssFeed: Flushing cache.");
+ &::performStrictReply("$::who: Flushed RSS Feed cache.");
+ return;
+ }
+
+ if ( $command =~ /^update$/i ) {
+ if ( not &::IsFlag("o") ) {
+ &::status(
+"rssFeed: User $::who tried to manually update feeds, but isn't +o!"
+ );
+ return;
+ }
+ &::status("rssFeed: Manual update of feeds requested by $::who.");
+ }
+
+ foreach my $chan ( keys %::channels ) {
+ my $rssFeedUrl = &::getChanConf( 'rssFeedUrl', $chan );
+ my @urls = split / /, $rssFeedUrl;
+
+ # Store by url then chan to allow for same url's in multiple channels
+ foreach (@urls) { $feeds{$chan}{$_} = 1 }
+ }
+
+ foreach my $chans ( keys %feeds ) {
+ foreach ( keys %{ $feeds{$chans} } ) {
+ my $result = &getFeed( $cacheFile, $chans, $_ );
+ &::status($result) if $result;
+ }
+ }
+ return;
}
1;
use vars qw($dbh $found $ident);
sub rootWarn {
- my ($nick,$user,$host,$chan) = @_;
- my $n = lc $nick;
- my $attempt = &sqlSelect('rootwarn', 'attempt', { nick => $n } ) || 0;
- my $warnmode = &getChanConf('rootWarnMode');
-
- if ($attempt == 0) { # first timer.
- if (defined $warnmode and $warnmode =~ /quiet/i) {
- &status('RootWarn: Detected root user; notifying user');
- } else {
- &status('RootWarn: Detected root user; notifying nick and channel.');
- &msg($chan, 'ROO'.('O' x int(rand 8))."T has landed!");
- }
-
- if ($_ = &getFactoid('root')) {
- &msg($nick, "RootWarn: $attempt : $_");
- } else {
- &status('"root" needs to be defined in database.');
- }
-
- } elsif ($attempt < 2) { # 2nd/3rd time occurrance.
- if ($_ = &getFactoid('root again')) {
- &status("RootWarn: not first time root user; msg'ing $nick.");
- &msg($nick, "RootWarn: $attempt : $_");
- } else {
- &status('"root again" needs to be defined in database.');
- }
-
- } else { # >3rd time occurrance.
- # disable this for the time being.
- if (0 and $warnmode =~ /aggressive/i) {
- if ($channels{$chan}{'o'}{$ident}) {
- &status("RootWarn: $nick... sigh... bye bye.");
- rawout("MODE $chan +b *!root\@$host"); # ban
- &kick($chan,$nick,'bye bye');
- }
- } elsif ($_ = &getFactoid('root again')) {
- &status("RootWarn: $attempt times; msg'ing $nick.");
- &msg($nick, "RootWarn: $attempt : $_");
- } else {
- &status("root again needs to be defined in database.");
- }
+ my ( $nick, $user, $host, $chan ) = @_;
+ my $n = lc $nick;
+ my $attempt = &sqlSelect( 'rootwarn', 'attempt', { nick => $n } ) || 0;
+ my $warnmode = &getChanConf('rootWarnMode');
+
+ if ( $attempt == 0 ) { # first timer.
+ if ( defined $warnmode and $warnmode =~ /quiet/i ) {
+ &status('RootWarn: Detected root user; notifying user');
+ }
+ else {
+ &status(
+ 'RootWarn: Detected root user; notifying nick and channel.');
+ &msg( $chan, 'ROO' . ( 'O' x int( rand 8 ) ) . "T has landed!" );
+ }
+
+ if ( $_ = &getFactoid('root') ) {
+ &msg( $nick, "RootWarn: $attempt : $_" );
+ }
+ else {
+ &status('"root" needs to be defined in database.');
+ }
+
+ }
+ elsif ( $attempt < 2 ) { # 2nd/3rd time occurrance.
+ if ( $_ = &getFactoid('root again') ) {
+ &status("RootWarn: not first time root user; msg'ing $nick.");
+ &msg( $nick, "RootWarn: $attempt : $_" );
+ }
+ else {
+ &status('"root again" needs to be defined in database.');
+ }
+
+ }
+ else { # >3rd time occurrance.
+ # disable this for the time being.
+ if ( 0 and $warnmode =~ /aggressive/i ) {
+ if ( $channels{$chan}{'o'}{$ident} ) {
+ &status("RootWarn: $nick... sigh... bye bye.");
+ rawout("MODE $chan +b *!root\@$host"); # ban
+ &kick( $chan, $nick, 'bye bye' );
+ }
+ }
+ elsif ( $_ = &getFactoid('root again') ) {
+ &status("RootWarn: $attempt times; msg'ing $nick.");
+ &msg( $nick, "RootWarn: $attempt : $_" );
+ }
+ else {
+ &status("root again needs to be defined in database.");
+ }
}
$attempt++;
### TODO: OPTIMIZE THIS.
# ok... don't record the attempt if nick==root.
- return if ($nick eq 'root');
-
- &sqlSet('rootwarn', { nick => lc($nick) }, {
- attempt => $attempt,
- time => time(),
- host => $user."\@".$host,
- channel => $chan,
- } );
+ return if ( $nick eq 'root' );
+
+ &sqlSet(
+ 'rootwarn',
+ { nick => lc($nick) },
+ {
+ attempt => $attempt,
+ time => time(),
+ host => $user . "\@" . $host,
+ channel => $chan,
+ }
+ );
return;
}
my $reply;
my $count = &countKeys('rootwarn');
- if ($count == 0) {
- &performReply("no-one has been warned about root, woohoo");
- return;
+ if ( $count == 0 ) {
+ &performReply("no-one has been warned about root, woohoo");
+ return;
}
# reply #1.
- $reply = 'there '.&fixPlural('has',$count) ." been \002$count\002 ".
- &fixPlural('rooter',$count) ." warned about root.";
-
- if ($param{'DBType'} !~ /^(pg|my)sql$/i) {
- &FIXME("rootwarn does not yet support non-{my,pg}sql.");
- return;
+ $reply = 'there '
+ . &fixPlural( 'has', $count )
+ . " been \002$count\002 "
+ . &fixPlural( 'rooter', $count )
+ . " warned about root.";
+
+ if ( $param{'DBType'} !~ /^(pg|my)sql$/i ) {
+ &FIXME("rootwarn does not yet support non-{my,pg}sql.");
+ return;
}
# reply #2.
$found = 0;
my $query = "SELECT attempt FROM rootwarn WHERE attempt > 2";
- my $sth = $dbh->prepare($query);
+ my $sth = $dbh->prepare($query);
$sth->execute;
- while (my @row = $sth->fetchrow_array) {
- $found++;
+ while ( my @row = $sth->fetchrow_array ) {
+ $found++;
}
$sth->finish;
if ($found) {
- $reply .= " Of which, \002$found\002 ".
- &fixPlural('rooter',$found).' '.
- &fixPlural('has',$found).
- " done it at least 3 times.";
+ $reply .=
+ " Of which, \002$found\002 "
+ . &fixPlural( 'rooter', $found ) . ' '
+ . &fixPlural( 'has', $found )
+ . " done it at least 3 times.";
}
&performStrictReply($reply);
use strict;
sub Rss::Titles {
- return join(' ',@_)=~m/<title>\s*(.*?)\s*<\/title>/gi;
+ return join( ' ', @_ ) =~ m/<title>\s*(.*?)\s*<\/title>/gi;
}
sub Rss::Rss {
- my ($message) = @_;
- my @results = &::getURL($message);
- my $retval = "i could not get the rss feed.";
+ my ($message) = @_;
+ my @results = &::getURL($message);
+ my $retval = "i could not get the rss feed.";
- my @list = &Rss::Titles(@results) if (scalar @results);
- $retval = &::formListReply(0, 'Titles: ', @list) if (scalar @list);
+ my @list = &Rss::Titles(@results) if ( scalar @results );
+ $retval = &::formListReply( 0, 'Titles: ', @list ) if ( scalar @list );
- &::performStrictReply($retval);
+ &::performStrictReply($retval);
}
1;
###
# Search(keys||vals, str);
sub Search {
- my ($type, $str) = @_;
+ my ( $type, $str ) = @_;
my $start_time = &::timeget();
my @list;
- my $maxshow = &::getChanConfDefault('maxListReplyCount', 15, $::chan);
+ my $maxshow = &::getChanConfDefault( 'maxListReplyCount', 15, $::chan );
- $type =~ s/s$//; # nice work-around.
+ $type =~ s/s$//; # nice work-around.
- if ($type eq 'value') {
- # search by value.
- @list = &::searchTable('factoids', 'factoid_key', 'factoid_value', $str);
- } else {
- # search by key.
- @list = &::searchTable('factoids', 'factoid_key', 'factoid_key', $str);
+ if ( $type eq 'value' ) {
+
+ # search by value.
+ @list =
+ &::searchTable( 'factoids', 'factoid_key', 'factoid_value', $str );
+ }
+ else {
+
+ # search by key.
+ @list =
+ &::searchTable( 'factoids', 'factoid_key', 'factoid_key', $str );
}
- @list=grep(!/\#DEL\#$/,@list) if (scalar(@list) > $maxshow);
- my $delta_time = sprintf("%.02f", &::timedelta($start_time) );
- &::status("search: took $delta_time sec for query.") if ($delta_time > 0);
+ @list = grep( !/\#DEL\#$/, @list ) if ( scalar(@list) > $maxshow );
+ my $delta_time = sprintf( "%.02f", &::timedelta($start_time) );
+ &::status("search: took $delta_time sec for query.") if ( $delta_time > 0 );
my $prefix = "Factoid search of '\002$str\002' by $type ";
- &::performStrictReply( &::formListReply(1, $prefix, @list) );
+ &::performStrictReply( &::formListReply( 1, $prefix, @list ) );
}
1;
my ($chan) = @_;
my @results;
- return if (!exists $topic{$chan});
- return if (!exists $topic{$chan}{'Current'});
+ return if ( !exists $topic{$chan} );
+ return if ( !exists $topic{$chan}{'Current'} );
- foreach (split /\|\|/, $topic{$chan}{'Current'}) {
- s/^\s+//;
- s/\s+$//;
+ foreach ( split /\|\|/, $topic{$chan}{'Current'} ) {
+ s/^\s+//;
+ s/\s+$//;
- # very nice fix to solve the null subtopic problem.
- # if nick contains a space, treat topic as ownerless.
- if (/^\(.*?\)$/) {
- next unless ($1 =~ /\s/);
- }
+ # very nice fix to solve the null subtopic problem.
+ # if nick contains a space, treat topic as ownerless.
+ if (/^\(.*?\)$/) {
+ next unless ( $1 =~ /\s/ );
+ }
- my $subtopic = $_;
- my $owner = 'Unknown';
+ my $subtopic = $_;
+ my $owner = 'Unknown';
- if (/(.*)\s+\((.*?)\)$/) {
- $subtopic = $1;
- $owner = $2;
- }
+ if (/(.*)\s+\((.*?)\)$/) {
+ $subtopic = $1;
+ $owner = $2;
+ }
- if (grep /^\Q$subtopic\E\|\|\Q$owner\E$/, @results) {
- &status("Topic: we have found a dupe ($subtopic) in the topic, not adding.");
- next;
- }
+ if ( grep /^\Q$subtopic\E\|\|\Q$owner\E$/, @results ) {
+ &status(
+"Topic: we have found a dupe ($subtopic) in the topic, not adding."
+ );
+ next;
+ }
- push(@results, "$subtopic||$owner");
+ push( @results, "$subtopic||$owner" );
}
return @results;
###
# Usage: &topicCipher(@topics);
sub topicCipher {
- return if (!@_);
+ return if ( !@_ );
my @topic;
foreach (@_) {
- my ($subtopic, $setby) = split /\|\|/;
+ my ( $subtopic, $setby ) = split /\|\|/;
- if ($param{'topicAuthor'} eq '1' and (!$setby =~ /^(unknown|)$/i)) {
- push(@topic, "$subtopic ($setby)");
- } else {
- push(@topic, "$subtopic");
- }
+ if ( $param{'topicAuthor'} eq '1' and ( !$setby =~ /^(unknown|)$/i ) ) {
+ push( @topic, "$subtopic ($setby)" );
+ }
+ else {
+ push( @topic, "$subtopic" );
+ }
}
- return join(' || ', @topic);
+ return join( ' || ', @topic );
}
###
# Usage: &topicNew($chan, $topic, $updateMsg);
sub topicNew {
- my ($chan, $topic, $updateMsg) = @_;
+ my ( $chan, $topic, $updateMsg ) = @_;
my $maxlen = 470;
- if ($channels{$chan}{t} and !$channels{$chan}{o}{$ident}) {
- &msg($who, "error: cannot change topic without ops. (channel is +t) :(");
- return 0;
+ if ( $channels{$chan}{t} and !$channels{$chan}{o}{$ident} ) {
+ &msg( $who,
+ "error: cannot change topic without ops. (channel is +t) :(" );
+ return 0;
}
- if (defined $topiccmp{$chan} and $topiccmp{$chan} eq $topic) {
- &msg($who, "warning: action had no effect on topic; no change required.");
- return 0;
+ if ( defined $topiccmp{$chan} and $topiccmp{$chan} eq $topic ) {
+ &msg( $who,
+ "warning: action had no effect on topic; no change required." );
+ return 0;
}
# bail out if the new topic is too long.
- my $newlen = length($chan.$topic);
- if ($newlen > $maxlen) {
- &msg($who, "new topic will be too long. ($newlen > $maxlen)");
- return 0;
+ my $newlen = length( $chan . $topic );
+ if ( $newlen > $maxlen ) {
+ &msg( $who, "new topic will be too long. ($newlen > $maxlen)" );
+ return 0;
}
$topic{$chan}{'Current'} = $topic;
- if ($cache{topicNotUpdate}{$chan}) {
- &msg($who, "done. 'flush' to finalize changes.");
- delete $cache{topicNotUpdate}{$chan};
- return 1;
+ if ( $cache{topicNotUpdate}{$chan} ) {
+ &msg( $who, "done. 'flush' to finalize changes." );
+ delete $cache{topicNotUpdate}{$chan};
+ return 1;
}
- if (defined $updateMsg && $updateMsg ne '') {
- &msg($who, $updateMsg);
+ if ( defined $updateMsg && $updateMsg ne '' ) {
+ &msg( $who, $updateMsg );
}
$topic{$chan}{'Last'} = $topic;
- $topic{$chan}{'Who'} = $orig{who}."!".$uh;
+ $topic{$chan}{'Who'} = $orig{who} . "!" . $uh;
$topic{$chan}{'Time'} = time();
if ($topic) {
- $conn->topic($chan, $topic);
- &topicAddHistory($chan, $topic);
- } else {
- $conn->topic($chan, ' ');
+ $conn->topic( $chan, $topic );
+ &topicAddHistory( $chan, $topic );
+ }
+ else {
+ $conn->topic( $chan, ' ' );
}
return 1;
###
# Usage: &topicAddHistory($chan,$topic);
sub topicAddHistory {
- my ($chan, $topic) = @_;
- my $dupe = 0;
+ my ( $chan, $topic ) = @_;
+ my $dupe = 0;
+
+ return 1 if ( $topic eq '' ); # required fix.
- return 1 if ($topic eq ''); # required fix.
+ foreach ( @{ $topic{$chan}{'History'} } ) {
+ next if ( $_ ne '' and $_ ne $topic );
- foreach (@{ $topic{$chan}{'History'} }) {
- next if ($_ ne '' and $_ ne $topic);
- # checking length is required.
+ # checking length is required.
- # slightly weird to put a return statement in a loop.
- return 1;
+ # slightly weird to put a return statement in a loop.
+ return 1;
}
# WTF IS THIS FOR?
my @topics = @{ $topic{$chan}{'History'} };
- unshift(@topics, $topic);
- pop(@topics) while (scalar @topics > 6);
+ unshift( @topics, $topic );
+ pop(@topics) while ( scalar @topics > 6 );
$topic{$chan}{'History'} = \@topics;
return $dupe;
# cmd: add.
sub do_add {
- my ($chan, $args) = @_;
+ my ( $chan, $args ) = @_;
- if ($args eq '') {
- &help('topic add');
- return;
+ if ( $args eq '' ) {
+ &help('topic add');
+ return;
}
# heh, joeyh. 19990819. -xk
- if ($who =~ /\|\|/) {
- &msg($who, 'error: you have an invalid nick, loser!');
- return;
+ if ( $who =~ /\|\|/ ) {
+ &msg( $who, 'error: you have an invalid nick, loser!' );
+ return;
}
- return if ($channels{$chan}{t} and !&hasFlag('T'));
+ return if ( $channels{$chan}{t} and !&hasFlag('T') );
my @prev = &topicDecipher($chan);
my $new;
+
# If bot new to chan and topic is blank, it still got a (owner). This is fix
- if ($param{'topicAuthor'} eq '1') {
- $new = "$args ($orig{who})";
- } else {
- $new = "$args";
+ if ( $param{'topicAuthor'} eq '1' ) {
+ $new = "$args ($orig{who})";
+ }
+ else {
+ $new = "$args";
}
$topic{$chan}{'What'} = "Added '$args'.";
- if (scalar @prev) {
- my $str = sprintf("%s||%s", $args, $who);
- $new = &topicCipher(@prev, $str);
+ if ( scalar @prev ) {
+ my $str = sprintf( "%s||%s", $args, $who );
+ $new = &topicCipher( @prev, $str );
}
- &topicNew($chan, $new, '');
+ &topicNew( $chan, $new, '' );
}
# cmd: delete.
sub do_delete {
- my ($chan, $args) = @_;
- my @subtopics = &topicDecipher($chan);
- my $topiccount = scalar @subtopics;
+ my ( $chan, $args ) = @_;
+ my @subtopics = &topicDecipher($chan);
+ my $topiccount = scalar @subtopics;
- if ($topiccount == 0) {
- &msg($who, 'No topic set.');
- return;
+ if ( $topiccount == 0 ) {
+ &msg( $who, 'No topic set.' );
+ return;
}
- if ($args eq '') {
- &help('topic del');
- return;
+ if ( $args eq '' ) {
+ &help('topic del');
+ return;
}
for ($args) {
- $_ = sprintf(",%s,", $args);
- s/\s+//g;
- s/(first|1st)/1/i;
- s/last/$topiccount/i;
- s/,-(\d+)/,1-$1/;
- s/(\d+)-,/,$1-$topiccount/;
+ $_ = sprintf( ",%s,", $args );
+ s/\s+//g;
+ s/(first|1st)/1/i;
+ s/last/$topiccount/i;
+ s/,-(\d+)/,1-$1/;
+ s/(\d+)-,/,$1-$topiccount/;
}
- if ($args !~ /[\,\-\d]/) {
- &msg($who, "error: Invalid argument ($args).");
- return;
+ if ( $args !~ /[\,\-\d]/ ) {
+ &msg( $who, "error: Invalid argument ($args)." );
+ return;
}
my @delete;
- foreach (split ',', $args) {
- next if ($_ eq '');
+ foreach ( split ',', $args ) {
+ next if ( $_ eq '' );
- # change to hash list instead of array?
- if (/^(\d+)-(\d+)$/) {
- my ($from,$to) = ($1,$2);
- ($from,$to) = ($2,$1) if ($from > $to);
+ # change to hash list instead of array?
+ if (/^(\d+)-(\d+)$/) {
+ my ( $from, $to ) = ( $1, $2 );
+ ( $from, $to ) = ( $2, $1 ) if ( $from > $to );
- push(@delete, $1..$2);
- } elsif (/^(\d+)$/) {
- push(@delete, $1);
- } else {
- &msg($who, "error: Invalid sub-argument ($_).");
- return;
- }
+ push( @delete, $1 .. $2 );
+ }
+ elsif (/^(\d+)$/) {
+ push( @delete, $1 );
+ }
+ else {
+ &msg( $who, "error: Invalid sub-argument ($_)." );
+ return;
+ }
- $topic{$chan}{'What'} = 'Deleted '.join("/",@delete);
+ $topic{$chan}{'What'} = 'Deleted ' . join( "/", @delete );
}
foreach (@delete) {
- if ($_ > $topiccount || $_ < 1) {
- &msg($who, "error: argument out of range. (max: $topiccount)");
- return;
- }
+ if ( $_ > $topiccount || $_ < 1 ) {
+ &msg( $who, "error: argument out of range. (max: $topiccount)" );
+ return;
+ }
- # skip if already deleted.
- # only checked if x-y range is given.
- next unless (defined($subtopics[$_-1]));
+ # skip if already deleted.
+ # only checked if x-y range is given.
+ next unless ( defined( $subtopics[ $_ - 1 ] ) );
- my ($subtopic,$whoby) = split('\|\|', $subtopics[$_-1]);
+ my ( $subtopic, $whoby ) = split( '\|\|', $subtopics[ $_ - 1 ] );
- $whoby = 'unknown' if ($whoby eq '');
+ $whoby = 'unknown' if ( $whoby eq '' );
- &msg($who, "Deleting topic: $subtopic ($whoby)");
- undef $subtopics[$_-1];
+ &msg( $who, "Deleting topic: $subtopic ($whoby)" );
+ undef $subtopics[ $_ - 1 ];
}
my @newtopics;
foreach (@subtopics) {
- next unless (defined $_);
- push(@newtopics, $_);
+ next unless ( defined $_ );
+ push( @newtopics, $_ );
}
- &topicNew($chan, &topicCipher(@newtopics), '');
+ &topicNew( $chan, &topicCipher(@newtopics), '' );
}
# cmd: list
sub do_list {
- my ($chan, $args) = @_;
+ my ( $chan, $args ) = @_;
my @topics = &topicDecipher($chan);
- if (!scalar @topics) {
- &msg($who, "No topics for \002$chan\002.");
- return;
+ if ( !scalar @topics ) {
+ &msg( $who, "No topics for \002$chan\002." );
+ return;
}
- &msg($who, "Topics for \002$chan\002:");
- &msg($who, "No \002[\002 Set by \002]\002 Topic");
+ &msg( $who, "Topics for \002$chan\002:" );
+ &msg( $who, "No \002[\002 Set by \002]\002 Topic" );
my $i = 1;
foreach (@topics) {
- my ($subtopic, $setby) = split /\|\|/;
+ my ( $subtopic, $setby ) = split /\|\|/;
- my $str = sprintf(" %d. [%-10s] %s", $i, $setby, $subtopic);
- # is there a better way of doing this?
- $str =~ s/ (\[)/ \002$1/g;
- $str =~ s/ (\])/ \002$1/g;
+ my $str = sprintf( " %d. [%-10s] %s", $i, $setby, $subtopic );
- &msg($who, $str);
- $i++;
+ # is there a better way of doing this?
+ $str =~ s/ (\[)/ \002$1/g;
+ $str =~ s/ (\])/ \002$1/g;
+
+ &msg( $who, $str );
+ $i++;
}
- &msg($who, "End of Topics.");
+ &msg( $who, "End of Topics." );
}
# cmd: modify.
sub do_modify {
- my ($chan, $args) = @_;
+ my ( $chan, $args ) = @_;
- if ($args eq '') {
- &help('topic mod');
- return;
+ if ( $args eq '' ) {
+ &help('topic mod');
+ return;
}
# a warning message instead of halting. we kind of trust the user now.
- if ($args =~ /\|\|/) {
- &msg($who, "warning: adding double pipes manually == evil. be warned.");
+ if ( $args =~ /\|\|/ ) {
+ &msg( $who,
+ "warning: adding double pipes manually == evil. be warned." );
}
$topic{$chan}{'What'} = "SAR $args";
# SAR patch. mu++
- if ($args =~ m|^\s*s([/,#])(.+?)\1(.*?)\1([a-z]*);?\s*$|) {
- my ($delim, $op, $np, $flags) = ($1,$2,$3,$4);
+ if ( $args =~ m|^\s*s([/,#])(.+?)\1(.*?)\1([a-z]*);?\s*$| ) {
+ my ( $delim, $op, $np, $flags ) = ( $1, $2, $3, $4 );
- if ($flags !~ /^(g)?$/) {
- &msg($who, "error: Invalid flags to regex.");
- return;
- }
+ if ( $flags !~ /^(g)?$/ ) {
+ &msg( $who, "error: Invalid flags to regex." );
+ return;
+ }
- my $topic = $topic{$chan}{'Current'};
+ my $topic = $topic{$chan}{'Current'};
- ### TODO: use m### to make code safe!
- if (($flags eq 'g' and $topic =~ s/\Q$op\E/$np/g) ||
- ($flags eq '' and $topic =~ s/\Q$op\E/$np/)
- ) {
+ ### TODO: use m### to make code safe!
+ if ( ( $flags eq 'g' and $topic =~ s/\Q$op\E/$np/g )
+ || ( $flags eq '' and $topic =~ s/\Q$op\E/$np/ ) )
+ {
- $_ = "Modifying topic with sar s/$op/$np/.";
- &topicNew($chan, $topic, $_);
- } else {
- &msg($who, "warning: regex not found in topic.");
- }
+ $_ = "Modifying topic with sar s/$op/$np/.";
+ &topicNew( $chan, $topic, $_ );
+ }
+ else {
+ &msg( $who, "warning: regex not found in topic." );
+ }
- return;
+ return;
}
- &msg($who, "error: Invalid regex. Try s/1/2/, s#3#4#...");
+ &msg( $who, "error: Invalid regex. Try s/1/2/, s#3#4#..." );
}
# cmd: move.
sub do_move {
- my ($chan, $args) = @_;
+ my ( $chan, $args ) = @_;
- if ($args eq '') {
- &help('topic mv');
- return;
+ if ( $args eq '' ) {
+ &help('topic mv');
+ return;
}
- my ($from, $action, $to);
+ my ( $from, $action, $to );
+
# better way of doing this?
- if ($args =~ /^(first|last|\d+)\s+(before|after|swap)\s+(first|last|\d+)$/i) {
- ($from, $action, $to) = ($1,$2,$3);
- } else {
- &msg($who, "Invalid arguments.");
- return;
+ if ( $args =~
+ /^(first|last|\d+)\s+(before|after|swap)\s+(first|last|\d+)$/i )
+ {
+ ( $from, $action, $to ) = ( $1, $2, $3 );
+ }
+ else {
+ &msg( $who, "Invalid arguments." );
+ return;
}
- my @subtopics = &topicDecipher($chan);
+ my @subtopics = &topicDecipher($chan);
my @newtopics;
my $topiccount = scalar @subtopics;
- if ($topiccount == 1) {
- &msg($who, "error: impossible to move the only subtopic, dumbass.");
- return;
+ if ( $topiccount == 1 ) {
+ &msg( $who, "error: impossible to move the only subtopic, dumbass." );
+ return;
}
# Is there an easier way to do this?
$from =~ s/last/$topiccount/i;
$to =~ s/last/$topiccount/i;
- if ($from > $topiccount || $to > $topiccount || $from < 1 || $to < 1) {
- &msg($who, "error: <from> or <to> is out of range.");
- return;
+ if ( $from > $topiccount || $to > $topiccount || $from < 1 || $to < 1 ) {
+ &msg( $who, "error: <from> or <to> is out of range." );
+ return;
}
- if ($from == $to) {
- &msg($who, "error: <from> and <to> are the same.");
- return;
+ if ( $from == $to ) {
+ &msg( $who, "error: <from> and <to> are the same." );
+ return;
}
$topic{$chan}{'What'} = "Move $from to $to";
- if ($action =~ /^(swap)$/i) {
- my $tmp = $subtopics[$to - 1];
- $subtopics[$to - 1] = $subtopics[$from - 1];
- $subtopics[$from - 1] = $tmp;
+ if ( $action =~ /^(swap)$/i ) {
+ my $tmp = $subtopics[ $to - 1 ];
+ $subtopics[ $to - 1 ] = $subtopics[ $from - 1 ];
+ $subtopics[ $from - 1 ] = $tmp;
- $_ = "Swapped #\002$from\002 with #\002$to\002.";
- &topicNew($chan, &topicCipher(@subtopics), $_);
- return;
+ $_ = "Swapped #\002$from\002 with #\002$to\002.";
+ &topicNew( $chan, &topicCipher(@subtopics), $_ );
+ return;
}
# action != swap:
# Is there a better way to do this? guess not.
- my $i = 1;
- my $subtopic = $subtopics[$from - 1];
+ my $i = 1;
+ my $subtopic = $subtopics[ $from - 1 ];
foreach (@subtopics) {
- my $j = $i*2 - 1;
- $newtopics[$j] = $_ if ($i != $from);
- $i++;
+ my $j = $i * 2 - 1;
+ $newtopics[$j] = $_ if ( $i != $from );
+ $i++;
+ }
+
+ if ( $action =~ /^(before|b4)$/i ) {
+ $newtopics[ $to * 2 - 2 ] = $subtopic;
}
+ else {
- if ($action =~ /^(before|b4)$/i) {
- $newtopics[$to*2-2] = $subtopic;
- } else {
- # action =~ /after/.
- $newtopics[$to*2] = $subtopic;
+ # action =~ /after/.
+ $newtopics[ $to * 2 ] = $subtopic;
}
- undef @subtopics; # lets reuse this array.
+ undef @subtopics; # lets reuse this array.
foreach (@newtopics) {
- next if (!defined $_ or $_ eq '');
- push(@subtopics, $_);
+ next if ( !defined $_ or $_ eq '' );
+ push( @subtopics, $_ );
}
$_ = "Moved #\002$from\002 $action #\002$to\002.";
- &topicNew($chan, &topicCipher(@subtopics), $_);
+ &topicNew( $chan, &topicCipher(@subtopics), $_ );
}
# cmd: shuffle.
sub do_shuffle {
- my ($chan, $args) = @_;
- my @subtopics = &topicDecipher($chan);
+ my ( $chan, $args ) = @_;
+ my @subtopics = &topicDecipher($chan);
my @newtopics;
$topic{$chan}{'What'} = 'shuffled';
- foreach (&makeRandom(scalar @subtopics)) {
- push(@newtopics, $subtopics[$_]);
+ foreach ( &makeRandom( scalar @subtopics ) ) {
+ push( @newtopics, $subtopics[$_] );
}
$_ = "Shuffling the bag of lollies.";
- &topicNew($chan, &topicCipher(@newtopics), $_);
+ &topicNew( $chan, &topicCipher(@newtopics), $_ );
}
# cmd: history.
sub do_history {
- my ($chan, $args) = @_;
+ my ( $chan, $args ) = @_;
- if (!scalar @{ $topic{$chan}{'History'} }) {
- &msg($who, "Sorry, no topics in history list.");
- return;
+ if ( !scalar @{ $topic{$chan}{'History'} } ) {
+ &msg( $who, "Sorry, no topics in history list." );
+ return;
}
- &msg($who, "History of topics on \002$chan\002:");
- for (1 .. scalar @{ $topic{$chan}{'History'} }) {
- my $topic = ${ $topic{$chan}{'History'} }[$_-1];
- &msg($who, " #\002$_\002: $topic");
+ &msg( $who, "History of topics on \002$chan\002:" );
+ for ( 1 .. scalar @{ $topic{$chan}{'History'} } ) {
+ my $topic = ${ $topic{$chan}{'History'} }[ $_ - 1 ];
+ &msg( $who, " #\002$_\002: $topic" );
- # To prevent excess floods.
- sleep 1 if (length($topic) > 160);
+ # To prevent excess floods.
+ sleep 1 if ( length($topic) > 160 );
}
- &msg($who, "End of list.");
+ &msg( $who, "End of list." );
}
# cmd: restore.
sub do_restore {
- my ($chan, $args) = @_;
+ my ( $chan, $args ) = @_;
- if ($args eq '') {
- &help('topic restore');
- return;
+ if ( $args eq '' ) {
+ &help('topic restore');
+ return;
}
$topic{$chan}{'What'} = "Restore topic $args";
# following needs to be verified.
- if ($args =~ /^last$/i) {
- if (${ $topic{$chan}{'History'} }[0] eq $topic{$chan}{'Current'}) {
- &msg($who,"error: cannot restore last topic because it's mine.");
- return;
- }
- $args = 1;
+ if ( $args =~ /^last$/i ) {
+ if ( ${ $topic{$chan}{'History'} }[0] eq $topic{$chan}{'Current'} ) {
+ &msg( $who, "error: cannot restore last topic because it's mine." );
+ return;
+ }
+ $args = 1;
}
- if ($args !~ /\d+/) {
- &msg($who, "error: argument is not positive integer.");
- return;
+ if ( $args !~ /\d+/ ) {
+ &msg( $who, "error: argument is not positive integer." );
+ return;
}
- if ($args > $#{ $topic{$chan}{'History'} } || $args < 1) {
- &msg($who, "error: argument is out of range.");
- return;
+ if ( $args > $#{ $topic{$chan}{'History'} } || $args < 1 ) {
+ &msg( $who, "error: argument is out of range." );
+ return;
}
$_ = "Changing topic according to request.";
- &topicNew($chan, ${ $topic{$chan}{'History'} }[$args-1], $_);
+ &topicNew( $chan, ${ $topic{$chan}{'History'} }[ $args - 1 ], $_ );
}
# cmd: rehash.
$_ = "Rehashing topic...";
$topic{$chan}{'What'} = 'Rehash';
- &topicNew($chan, $topic{$chan}{'Current'}, $_, 1);
+ &topicNew( $chan, $topic{$chan}{'Current'}, $_, 1 );
}
# cmd: info.
my ($chan) = @_;
my $reply = "no topic info.";
- if (exists $topic{$chan}{'Who'} and exists $topic{$chan}{'Time'}) {
- $reply = "topic on \002$chan\002 was last set by ".
- $topic{$chan}{'Who'}. ". This was done ".
- &Time2String(time() - $topic{$chan}{'Time'}) .' ago'.
- ". Length: ".length($topic{$chan}{'Current'});
- my $change = $topic{$chan}{'What'};
- $reply .= ". Change => $change" if (defined $change);
+ if ( exists $topic{$chan}{'Who'} and exists $topic{$chan}{'Time'} ) {
+ $reply =
+ "topic on \002$chan\002 was last set by "
+ . $topic{$chan}{'Who'}
+ . ". This was done "
+ . &Time2String( time() - $topic{$chan}{'Time'} ) . ' ago'
+ . ". Length: "
+ . length( $topic{$chan}{'Current'} );
+ my $change = $topic{$chan}{'What'};
+ $reply .= ". Change => $change" if ( defined $change );
}
&performStrictReply($reply);
###
# Usage: &Topic($cmd, $args);
sub Topic {
- my ($chan, $cmd, $args) = @_;
+ my ( $chan, $cmd, $args ) = @_;
- if ($cmd =~ /^-(\S+)/) {
- $cache{topicNotUpdate}{$chan} = 1;
- $cmd = $1;
+ if ( $cmd =~ /^-(\S+)/ ) {
+ $cache{topicNotUpdate}{$chan} = 1;
+ $cmd = $1;
}
- if ($cmd =~ /^(add)$/i) {
- &do_add($chan, $args);
+ if ( $cmd =~ /^(add)$/i ) {
+ &do_add( $chan, $args );
- } elsif ($cmd =~ /^(del|delete|rm|remove|kill|purge)$/i) {
- &do_delete($chan, $args);
+ }
+ elsif ( $cmd =~ /^(del|delete|rm|remove|kill|purge)$/i ) {
+ &do_delete( $chan, $args );
- } elsif ($cmd =~ /^list$/i) {
- &do_list($chan, $args);
+ }
+ elsif ( $cmd =~ /^list$/i ) {
+ &do_list( $chan, $args );
- } elsif ($cmd =~ /^(mod|modify|change|alter)$/i) {
- &do_modify($chan, $args);
+ }
+ elsif ( $cmd =~ /^(mod|modify|change|alter)$/i ) {
+ &do_modify( $chan, $args );
- } elsif ($cmd =~ /^(mv|move)$/i) {
- &do_move($chan, $args);
+ }
+ elsif ( $cmd =~ /^(mv|move)$/i ) {
+ &do_move( $chan, $args );
- } elsif ($cmd =~ /^shuffle$/i) {
- &do_shuffle($chan, $args);
+ }
+ elsif ( $cmd =~ /^shuffle$/i ) {
+ &do_shuffle( $chan, $args );
- } elsif ($cmd =~ /^(history)$/i) {
- &do_history($chan, $args);
+ }
+ elsif ( $cmd =~ /^(history)$/i ) {
+ &do_history( $chan, $args );
- } elsif ($cmd =~ /^restore$/i) {
- &do_restore($chan, $args);
+ }
+ elsif ( $cmd =~ /^restore$/i ) {
+ &do_restore( $chan, $args );
- } elsif ($cmd =~ /^(flush|rehash)$/i) {
- &do_rehash($chan);
+ }
+ elsif ( $cmd =~ /^(flush|rehash)$/i ) {
+ &do_rehash($chan);
- } elsif ($cmd =~ /^info$/i) {
- &do_info($chan);
+ }
+ elsif ( $cmd =~ /^info$/i ) {
+ &do_info($chan);
- } else {
- ### HELP:
- if ($cmd ne '' and $cmd !~ /^help/i) {
- &msg($who, "Invalid command [$cmd].");
- &msg($who, "Try 'help topic'.");
- return;
- }
+ }
+ else {
+ ### HELP:
+ if ( $cmd ne '' and $cmd !~ /^help/i ) {
+ &msg( $who, "Invalid command [$cmd]." );
+ &msg( $who, "Try 'help topic'." );
+ return;
+ }
- &help('topic');
+ &help('topic');
}
return;
use strict;
sub convertUnits {
- my ($from,$to) = @_;
+ my ( $from, $to ) = @_;
- if ($from =~ /([+-]?[\d\.]+(?:e[+-]?[\d]+)?)\s+(temp[CFK])/){
- $from = qq|${2}(${1})|;
- }
+ if ( $from =~ /([+-]?[\d\.]+(?:e[+-]?[\d]+)?)\s+(temp[CFK])/ ) {
+ $from = qq|${2}(${1})|;
+ }
- my $units = new IO::File;
- open $units, '-|', 'units', $from, $to or &::DEBUG("Unable to run units: $!") and return;
- my $response = readline ($units);
- if ($response =~ /\s+\*\s+([+-]?[\d\.]+(?:e[+-]?[\d]+)?)/ or $response =~ /\t([+-]?[\d\.]+(?:e[+-]?[\d]+)?)/){
- &::performStrictReply(sprintf("$from is approximately \002%.6g\002 $to", $1));
- }
- else {
- &::performStrictReply("$from cannot be converted to ${to}: $response");
- }
- return;
+ my $units = new IO::File;
+ open $units, '-|', 'units', $from, $to
+ or &::DEBUG("Unable to run units: $!")
+ and return;
+ my $response = readline($units);
+ if ( $response =~ /\s+\*\s+([+-]?[\d\.]+(?:e[+-]?[\d]+)?)/
+ or $response =~ /\t([+-]?[\d\.]+(?:e[+-]?[\d]+)?)/ )
+ {
+ &::performStrictReply(
+ sprintf( "$from is approximately \002%.6g\002 $to", $1 ) );
+ }
+ else {
+ &::performStrictReply("$from cannot be converted to ${to}: $response");
+ }
+ return;
}
1;
my $uptimerecords = 3;
sub uptimeNow {
- return time() - $^T;
+ return time() - $^T;
}
sub uptimeStr {
- my $uptimenow = &uptimeNow();
+ my $uptimenow = &uptimeNow();
- if (defined $_[0]) {
- return "$uptimenow.$$ running $bot_version, ended ". gmtime(time());
- } else {
- return "$uptimenow running $bot_version";
- }
+ if ( defined $_[0] ) {
+ return "$uptimenow.$$ running $bot_version, ended " . gmtime( time() );
+ }
+ else {
+ return "$uptimenow running $bot_version";
+ }
}
sub uptimeGetInfo {
- my (%uptime,%done);
- my ($uptime,$pid);
- my @results;
- my $file = $file{utm};
-
- if (!open(IN, $file)) {
- &status("Writing uptime file for first time usage (nothing special).");
- open(OUT,">$file");
- close OUT;
- } else {
- while (<IN>) {
- chop;
-
- if (/^(\d+)\.(\d+) (.*)/) {
- $uptime{$1}{$2} = $3;
- }
+ my ( %uptime, %done );
+ my ( $uptime, $pid );
+ my @results;
+ my $file = $file{utm};
+
+ if ( !open( IN, $file ) ) {
+ &status("Writing uptime file for first time usage (nothing special).");
+ open( OUT, ">$file" );
+ close OUT;
+ }
+ else {
+ while (<IN>) {
+ chop;
+
+ if (/^(\d+)\.(\d+) (.*)/) {
+ $uptime{$1}{$2} = $3;
+ }
+ }
+ close IN;
}
- close IN;
- }
-
- &uptimeStr(1) =~ /^(\d+)\.(\d+) (.*)/;
- $uptime{$1}{$2} = $3;
-
- # fixed up bad implementation :)
- # should be no problems, even if uptime or pid is duplicated.
- ## WARN: run away forks may get through here, have to fix.
- foreach $uptime (sort {$b <=> $a} keys %uptime) {
- foreach $pid (keys %{ $uptime{$uptime} }) {
- next if (exists $done{$pid});
-
- push(@results,"$uptime.$pid $uptime{$uptime}{$pid}");
- $done{$pid} = 1;
- last if (scalar @results == $uptimerecords);
+
+ &uptimeStr(1) =~ /^(\d+)\.(\d+) (.*)/;
+ $uptime{$1}{$2} = $3;
+
+ # fixed up bad implementation :)
+ # should be no problems, even if uptime or pid is duplicated.
+ ## WARN: run away forks may get through here, have to fix.
+ foreach $uptime ( sort { $b <=> $a } keys %uptime ) {
+ foreach $pid ( keys %{ $uptime{$uptime} } ) {
+ next if ( exists $done{$pid} );
+
+ push( @results, "$uptime.$pid $uptime{$uptime}{$pid}" );
+ $done{$pid} = 1;
+ last if ( scalar @results == $uptimerecords );
+ }
+ last if ( scalar @results == $uptimerecords );
}
- last if (scalar @results == $uptimerecords);
- }
- return @results;
+ return @results;
}
sub uptimeWriteFile {
- my @results = &uptimeGetInfo();
- my $file = $file{utm};
+ my @results = &uptimeGetInfo();
+ my $file = $file{utm};
- if ($$ != $bot_pid) {
- &FIXME('uptime: forked process doing weird things!');
- exit 0;
- }
+ if ( $$ != $bot_pid ) {
+ &FIXME('uptime: forked process doing weird things!');
+ exit 0;
+ }
- if (!open(OUT,">$file")) {
- &status("error: cannot write to $file.");
- return;
- }
+ if ( !open( OUT, ">$file" ) ) {
+ &status("error: cannot write to $file.");
+ return;
+ }
- foreach (@results) {
- print OUT "$_\n";
- }
+ foreach (@results) {
+ print OUT "$_\n";
+ }
- close OUT;
- &status('--- Saved uptime records.');
+ close OUT;
+ &status('--- Saved uptime records.');
}
1;
use strict;
use vars qw(%users %ignore %sched %bans %mask %cache %channels %param
- %chanconf %dcc);
+ %chanconf %dcc);
use vars qw($who $chan $message $msgType $user $chnick $conn $ident
- $verifyUser $ucount_userfile $utime_userfile $lobotomized
- $utime_chanfile $ucount_chanfile);
+ $verifyUser $ucount_userfile $utime_userfile $lobotomized
+ $utime_chanfile $ucount_chanfile);
use vars qw(@backlog);
sub userDCC {
+
# hrm...
$message =~ s/\s+$//;
### for all users.
# quit.
- if ($message =~ /^(exit|quit)$/i) {
- # do ircII clients support remote close? if so, cool!
- &FIXME("userDCC: quit called.");
- &dcc_close($who);
- &status("userDCC: after dcc_close!");
+ if ( $message =~ /^(exit|quit)$/i ) {
+
+ # do ircII clients support remote close? if so, cool!
+ &FIXME("userDCC: quit called.");
+ &dcc_close($who);
+ &status("userDCC: after dcc_close!");
- return;
+ return;
}
# who.
- if ($message =~ /^who$/) {
- my $count = scalar(keys %{ $dcc{'CHAT'} });
- my $dccCHAT = $message;
+ if ( $message =~ /^who$/ ) {
+ my $count = scalar( keys %{ $dcc{'CHAT'} } );
+ my $dccCHAT = $message;
- &performStrictReply("Start of who ($count users).");
- foreach (keys %{ $dcc{'CHAT'} }) {
- &performStrictReply("=> $_");
- }
- &performStrictReply("End of who.");
+ &performStrictReply("Start of who ($count users).");
+ foreach ( keys %{ $dcc{'CHAT'} } ) {
+ &performStrictReply("=> $_");
+ }
+ &performStrictReply("End of who.");
- return;
+ return;
}
### for those users with enough flags.
- if ($message =~ /^tellme(\s+(.*))?$/i) {
- my $args = $2;
- if ($args =~ /^\s*$/) {
- &help('tellme');
- return;
- }
+ if ( $message =~ /^tellme(\s+(.*))?$/i ) {
+ my $args = $2;
+ if ( $args =~ /^\s*$/ ) {
+ &help('tellme');
+ return;
+ }
- my $result = &doQuestion($args);
- &performStrictReply($result);
+ my $result = &doQuestion($args);
+ &performStrictReply($result);
- return;
+ return;
}
# 4op.
- if ($message =~ /^4op(\s+($mask{chan}))?$/i) {
- return unless (&hasFlag('o'));
-
- my $chan = $2;
-
- if ($chan eq '') {
- &help('4op');
- return;
- }
-
- if (!$channels{$chan}{'o'}{$ident}) {
- &msg($who, "i don't have ops on $chan to do that.");
- return;
- }
-
- # on non-4mode(<4) servers, this may be exploited.
- if ($channels{$chan}{'o'}{$who}) {
- rawout("MODE $chan -o+o-o+o". (" $who" x 4));
- } else {
- rawout("MODE $chan +o-o+o-o". (" $who" x 4));
- }
-
- return;
+ if ( $message =~ /^4op(\s+($mask{chan}))?$/i ) {
+ return unless ( &hasFlag('o') );
+
+ my $chan = $2;
+
+ if ( $chan eq '' ) {
+ &help('4op');
+ return;
+ }
+
+ if ( !$channels{$chan}{'o'}{$ident} ) {
+ &msg( $who, "i don't have ops on $chan to do that." );
+ return;
+ }
+
+ # on non-4mode(<4) servers, this may be exploited.
+ if ( $channels{$chan}{'o'}{$who} ) {
+ rawout( "MODE $chan -o+o-o+o" . ( " $who" x 4 ) );
+ }
+ else {
+ rawout( "MODE $chan +o-o+o-o" . ( " $who" x 4 ) );
+ }
+
+ return;
}
# opme.
- if ($message =~ /^opme(\s+($mask{chan}))?$/i) {
- return unless (&hasFlag('o'));
- return unless (&hasFlag('A'));
+ if ( $message =~ /^opme(\s+($mask{chan}))?$/i ) {
+ return unless ( &hasFlag('o') );
+ return unless ( &hasFlag('A') );
- my $chan = $2;
+ my $chan = $2;
- if ($chan eq '') {
- &help('4op');
- return;
- }
+ if ( $chan eq '' ) {
+ &help('4op');
+ return;
+ }
- # can this be exploited?
- rawout("MODE $chan +o $who");
+ # can this be exploited?
+ rawout("MODE $chan +o $who");
- return;
+ return;
}
# backlog.
- if ($message =~ /^backlog(\s+(.*))?$/i) {
- return unless (&hasFlag('o'));
- return unless (&IsParam('backlog'));
- my $num = $2;
- my $max = $param{'backlog'};
-
- if (!defined $num) {
- &help('backlog');
- return;
- } elsif ($num !~ /^\d+/) {
- &msg($who, "error: argument is not positive integer.");
- return;
- } elsif ($num > $max or $num < 0) {
- &msg($who, "error: argument is out of range (max $max).");
- return;
- }
-
- &msg($who, "Start of backlog...");
- for (0..$num-1) {
- sleep 1 if ($_ % 4 == 0 and $_ != 0);
- $conn->privmsg($who, "[".($_+1)."]: $backlog[$max-$num+$_]");
- }
- &msg($who, "End of backlog.");
-
- return;
+ if ( $message =~ /^backlog(\s+(.*))?$/i ) {
+ return unless ( &hasFlag('o') );
+ return unless ( &IsParam('backlog') );
+ my $num = $2;
+ my $max = $param{'backlog'};
+
+ if ( !defined $num ) {
+ &help('backlog');
+ return;
+ }
+ elsif ( $num !~ /^\d+/ ) {
+ &msg( $who, "error: argument is not positive integer." );
+ return;
+ }
+ elsif ( $num > $max or $num < 0 ) {
+ &msg( $who, "error: argument is out of range (max $max)." );
+ return;
+ }
+
+ &msg( $who, "Start of backlog..." );
+ for ( 0 .. $num - 1 ) {
+ sleep 1 if ( $_ % 4 == 0 and $_ != 0 );
+ $conn->privmsg( $who,
+ "[" . ( $_ + 1 ) . "]: $backlog[$max-$num+$_]" );
+ }
+ &msg( $who, "End of backlog." );
+
+ return;
}
# dump variables.
- if ($message =~ /^dumpvars$/i) {
- return unless (&hasFlag('o'));
- return unless (&IsParam('DumpVars'));
+ if ( $message =~ /^dumpvars$/i ) {
+ return unless ( &hasFlag('o') );
+ return unless ( &IsParam('DumpVars') );
- &status("Dumping all variables...");
- &dumpallvars();
+ &status("Dumping all variables...");
+ &dumpallvars();
- return;
+ return;
}
# dump variables ][.
- if ($message =~ /^symdump$/i) {
- return unless (&hasFlag('o'));
- return unless (&IsParam('DumpVars2'));
+ if ( $message =~ /^symdump$/i ) {
+ return unless ( &hasFlag('o') );
+ return unless ( &IsParam('DumpVars2') );
- &status("Dumping all variables...");
- &symdumpAllFile();
+ &status("Dumping all variables...");
+ &symdumpAllFile();
- return;
+ return;
}
# kick.
- if ($message =~ /^kick(\s+(.*?))$/) {
- return unless (&hasFlag('o'));
+ if ( $message =~ /^kick(\s+(.*?))$/ ) {
+ return unless ( &hasFlag('o') );
- my $arg = $2;
+ my $arg = $2;
- if ($arg eq '') {
- &help('kick');
- return;
- }
- my @args = split(/\s+/, $arg);
- my ($nick,$chan,$reason) = @args;
+ if ( $arg eq '' ) {
+ &help('kick');
+ return;
+ }
+ my @args = split( /\s+/, $arg );
+ my ( $nick, $chan, $reason ) = @args;
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
- }
+ if ( &validChan($chan) == 0 ) {
+ &msg( $who, "error: invalid channel \002$chan\002" );
+ return;
+ }
- if (&IsNickInChan($nick,$chan) == 0) {
- &msg($who,"$nick is not in $chan.");
- return;
- }
+ if ( &IsNickInChan( $nick, $chan ) == 0 ) {
+ &msg( $who, "$nick is not in $chan." );
+ return;
+ }
- &kick($nick,$chan,$reason);
+ &kick( $nick, $chan, $reason );
- return;
+ return;
}
# mode.
- if ($message =~ /^mode(\s+(.*))?$/) {
- return unless (&hasFlag('n'));
- my ($chan,$mode) = split /\s+/,$2,2;
+ if ( $message =~ /^mode(\s+(.*))?$/ ) {
+ return unless ( &hasFlag('n') );
+ my ( $chan, $mode ) = split /\s+/, $2, 2;
- if ($chan eq '') {
- &help('mode');
- return;
- }
+ if ( $chan eq '' ) {
+ &help('mode');
+ return;
+ }
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
- }
+ if ( &validChan($chan) == 0 ) {
+ &msg( $who, "error: invalid channel \002$chan\002" );
+ return;
+ }
- if (!$channels{$chan}{o}{$ident}) {
- &msg($who,"error: don't have ops on \002$chan\002");
- return;
- }
+ if ( !$channels{$chan}{o}{$ident} ) {
+ &msg( $who, "error: don't have ops on \002$chan\002" );
+ return;
+ }
- &mode($chan, $mode);
+ &mode( $chan, $mode );
- return;
+ return;
}
# part.
- if ($message =~ /^part(\s+(\S+))?$/i) {
- return unless (&hasFlag('o'));
- my $jchan = $2;
-
- if ($jchan !~ /^$mask{chan}$/) {
- &msg($who, "error, invalid chan.");
- &help('part');
- return;
- }
-
- if (!&validChan($jchan)) {
- &msg($who, "error, I'm not on that chan.");
- return;
- }
-
- &msg($jchan, "Leaving. (courtesy of $who).");
- &part($jchan);
- return;
+ if ( $message =~ /^part(\s+(\S+))?$/i ) {
+ return unless ( &hasFlag('o') );
+ my $jchan = $2;
+
+ if ( $jchan !~ /^$mask{chan}$/ ) {
+ &msg( $who, "error, invalid chan." );
+ &help('part');
+ return;
+ }
+
+ if ( !&validChan($jchan) ) {
+ &msg( $who, "error, I'm not on that chan." );
+ return;
+ }
+
+ &msg( $jchan, "Leaving. (courtesy of $who)." );
+ &part($jchan);
+ return;
}
# lobotomy. sometimes we want the bot to be _QUIET_.
- if ($message =~ /^(lobotomy|bequiet)$/i) {
- return unless (&hasFlag('o'));
-
- if ($lobotomized) {
- &performReply("i'm already lobotomized");
- } else {
- &performReply('i have been lobotomized');
- $lobotomized = 1;
- }
-
- return;
+ if ( $message =~ /^(lobotomy|bequiet)$/i ) {
+ return unless ( &hasFlag('o') );
+
+ if ($lobotomized) {
+ &performReply("i'm already lobotomized");
+ }
+ else {
+ &performReply('i have been lobotomized');
+ $lobotomized = 1;
+ }
+
+ return;
}
# unlobotomy.
- if ($message =~ /^(unlobotomy|benoisy)$/i) {
- return unless (&hasFlag('o'));
-
- if ($lobotomized) {
- &performReply('i have been unlobotomized, woohoo');
- $lobotomized = 0;
- delete $cache{lobotomy};
-# undef $cache{lobotomy}; # ??
- } else {
- &performReply("i'm not lobotomized");
- }
-
- return;
+ if ( $message =~ /^(unlobotomy|benoisy)$/i ) {
+ return unless ( &hasFlag('o') );
+
+ if ($lobotomized) {
+ &performReply('i have been unlobotomized, woohoo');
+ $lobotomized = 0;
+ delete $cache{lobotomy};
+
+ # undef $cache{lobotomy}; # ??
+ }
+ else {
+ &performReply("i'm not lobotomized");
+ }
+
+ return;
}
# op.
- if ($message =~ /^op(\s+(.*))?$/i) {
- return unless (&hasFlag('o'));
- my ($opee) = lc $2;
- my @chans;
-
- if ($opee =~ / /) {
- if ($opee =~ /^(\S+)\s+(\S+)$/) {
- $opee = $1;
- @chans = ($2);
- if (!&validChan($2)) {
- &msg($who,"error: invalid chan ($2).");
- return;
- }
- } else {
- &msg($who,"error: invalid params.");
- return;
- }
- } else {
- @chans = keys %channels;
- }
-
- my $found = 0;
- my $op = 0;
- foreach (@chans) {
- next unless (&IsNickInChan($opee,$_));
- $found++;
- if ($channels{$_}{'o'}{$opee}) {
- &performStrictReply("op: $opee already has ops on $_");
- next;
- }
- $op++;
-
- &performStrictReply("opping $opee on $_");
- &op($_, $opee);
- }
-
- if ($found != $op) {
- &performStrictReply("op: opped on all possible channels.");
- } else {
- &DEBUG("op: found => '$found'.");
- &DEBUG("op: op => '$op'.");
- }
-
- return;
+ if ( $message =~ /^op(\s+(.*))?$/i ) {
+ return unless ( &hasFlag('o') );
+ my ($opee) = lc $2;
+ my @chans;
+
+ if ( $opee =~ / / ) {
+ if ( $opee =~ /^(\S+)\s+(\S+)$/ ) {
+ $opee = $1;
+ @chans = ($2);
+ if ( !&validChan($2) ) {
+ &msg( $who, "error: invalid chan ($2)." );
+ return;
+ }
+ }
+ else {
+ &msg( $who, "error: invalid params." );
+ return;
+ }
+ }
+ else {
+ @chans = keys %channels;
+ }
+
+ my $found = 0;
+ my $op = 0;
+ foreach (@chans) {
+ next unless ( &IsNickInChan( $opee, $_ ) );
+ $found++;
+ if ( $channels{$_}{'o'}{$opee} ) {
+ &performStrictReply("op: $opee already has ops on $_");
+ next;
+ }
+ $op++;
+
+ &performStrictReply("opping $opee on $_");
+ &op( $_, $opee );
+ }
+
+ if ( $found != $op ) {
+ &performStrictReply("op: opped on all possible channels.");
+ }
+ else {
+ &DEBUG("op: found => '$found'.");
+ &DEBUG("op: op => '$op'.");
+ }
+
+ return;
}
# deop.
- if ($message =~ /^deop(\s+(.*))?$/i) {
- return unless (&hasFlag('o'));
- my ($opee) = lc $2;
- my @chans;
-
- if ($opee =~ / /) {
- if ($opee =~ /^(\S+)\s+(\S+)$/) {
- $opee = $1;
- @chans = ($2);
- if (!&validChan($2)) {
- &msg($who,"error: invalid chan ($2).");
- return;
- }
- } else {
- &msg($who,"error: invalid params.");
- return;
- }
- } else {
- @chans = keys %channels;
- }
-
- my $found = 0;
- my $op = 0;
- foreach (@chans) {
- next unless (&IsNickInChan($opee,$_));
- $found++;
- if (!exists $channels{$_}{'o'}{$opee}) {
- &status("deop: $opee already has no ops on $_");
- next;
- }
- $op++;
-
- &status("deopping $opee on $_ at ${who}'s request");
- &deop($_, $opee);
- }
-
- if ($found != $op) {
- &status("deop: deopped on all possible channels.");
- } else {
- &DEBUG("deop: found => '$found'.");
- &DEBUG("deop: op => '$op'.");
- }
-
- return;
+ if ( $message =~ /^deop(\s+(.*))?$/i ) {
+ return unless ( &hasFlag('o') );
+ my ($opee) = lc $2;
+ my @chans;
+
+ if ( $opee =~ / / ) {
+ if ( $opee =~ /^(\S+)\s+(\S+)$/ ) {
+ $opee = $1;
+ @chans = ($2);
+ if ( !&validChan($2) ) {
+ &msg( $who, "error: invalid chan ($2)." );
+ return;
+ }
+ }
+ else {
+ &msg( $who, "error: invalid params." );
+ return;
+ }
+ }
+ else {
+ @chans = keys %channels;
+ }
+
+ my $found = 0;
+ my $op = 0;
+ foreach (@chans) {
+ next unless ( &IsNickInChan( $opee, $_ ) );
+ $found++;
+ if ( !exists $channels{$_}{'o'}{$opee} ) {
+ &status("deop: $opee already has no ops on $_");
+ next;
+ }
+ $op++;
+
+ &status("deopping $opee on $_ at ${who}'s request");
+ &deop( $_, $opee );
+ }
+
+ if ( $found != $op ) {
+ &status("deop: deopped on all possible channels.");
+ }
+ else {
+ &DEBUG("deop: found => '$found'.");
+ &DEBUG("deop: op => '$op'.");
+ }
+
+ return;
}
# say.
- if ($message =~ s/^say\s+(\S+)\s+(.*)//) {
- return unless (&hasFlag('o'));
- my ($chan,$msg) = (lc $1, $2);
+ if ( $message =~ s/^say\s+(\S+)\s+(.*)// ) {
+ return unless ( &hasFlag('o') );
+ my ( $chan, $msg ) = ( lc $1, $2 );
- &DEBUG("chan => '$1', msg => '$msg'.");
+ &DEBUG("chan => '$1', msg => '$msg'.");
- &msg($chan, $msg);
+ &msg( $chan, $msg );
- return;
+ return;
}
# do.
- if ($message =~ s/^do\s+(\S+)\s+(.*)//) {
- return unless (&hasFlag('o'));
- my ($chan,$msg) = (lc $1, $2);
+ if ( $message =~ s/^do\s+(\S+)\s+(.*)// ) {
+ return unless ( &hasFlag('o') );
+ my ( $chan, $msg ) = ( lc $1, $2 );
- &DEBUG("chan => '$1', msg => '$msg'.");
+ &DEBUG("chan => '$1', msg => '$msg'.");
- &action($chan, $msg);
+ &action( $chan, $msg );
- return;
+ return;
}
# die.
- if ($message =~ /^die$/) {
- return unless (&hasFlag('n'));
+ if ( $message =~ /^die$/ ) {
+ return unless ( &hasFlag('n') );
- &doExit();
+ &doExit();
- &status("Dying by $who\'s request");
- exit 0;
+ &status("Dying by $who\'s request");
+ exit 0;
}
# global factoid substitution.
- if ($message =~ m|^\* =~ s([/,#])(.+?)\1(.*?)\1;?\s*$|) {
- my ($delim,$op,$np) = ($1, $2, $3);
- return unless (&hasFlag('n'));
- ### TODO: support flags to do full-on global.
-
- # incorrect format.
- if ($np =~ /$delim/) {
- &performReply("looks like you used the delimiter too many times. You may want to use a different delimiter, like ':' or '#'.");
- return;
- }
-
- ### TODO: fix up $op to support mysql/sqlite/pgsql
- ### TODO: => add db/sql specific function to fix this.
- my @list = &searchTable('factoids', 'factoid_key',
- 'factoid_value', $op);
-
- if (!scalar @list) {
- &performReply("Expression didn't match anything.");
- return;
- }
-
- if (scalar @list > 100) {
- &performReply("regex found more than 100 matches... not doing.");
- return;
- }
-
- &status("gsubst: going to alter ".scalar(@list)." factoids.");
- &performReply('going to alter '.scalar(@list)." factoids.");
-
- my $error = 0;
- foreach (@list) {
- my $faqtoid = $_;
-
- next if (&IsLocked($faqtoid) == 1);
- my $result = &getFactoid($faqtoid);
- my $was = $result;
- &DEBUG("was($faqtoid) => '$was'.");
-
- # global global
- # we could support global local (once off).
- if ($result =~ s/\Q$op/$np/gi) {
- if (length $result > $param{'maxDataSize'}) {
- &performReply("that's too long (or was long)");
- return;
- }
- &setFactInfo($faqtoid, 'factoid_value', $result);
- &status("update: '$faqtoid' =is=> '$result'; was '$was'");
- } else {
- &WARN("subst: that's weird... thought we found the string ($op) in '$faqtoid'.");
- $error++;
- }
- }
-
- if ($error) {
- &ERROR("Some warnings/errors?");
- }
-
- &performReply("Ok... did s/$op/$np/ for ".
- (scalar(@list) - $error).' factoids');
-
- return;
+ if ( $message =~ m|^\* =~ s([/,#])(.+?)\1(.*?)\1;?\s*$| ) {
+ my ( $delim, $op, $np ) = ( $1, $2, $3 );
+ return unless ( &hasFlag('n') );
+ ### TODO: support flags to do full-on global.
+
+ # incorrect format.
+ if ( $np =~ /$delim/ ) {
+ &performReply(
+"looks like you used the delimiter too many times. You may want to use a different delimiter, like ':' or '#'."
+ );
+ return;
+ }
+
+ ### TODO: fix up $op to support mysql/sqlite/pgsql
+ ### TODO: => add db/sql specific function to fix this.
+ my @list =
+ &searchTable( 'factoids', 'factoid_key', 'factoid_value', $op );
+
+ if ( !scalar @list ) {
+ &performReply("Expression didn't match anything.");
+ return;
+ }
+
+ if ( scalar @list > 100 ) {
+ &performReply("regex found more than 100 matches... not doing.");
+ return;
+ }
+
+ &status( "gsubst: going to alter " . scalar(@list) . " factoids." );
+ &performReply( 'going to alter ' . scalar(@list) . " factoids." );
+
+ my $error = 0;
+ foreach (@list) {
+ my $faqtoid = $_;
+
+ next if ( &IsLocked($faqtoid) == 1 );
+ my $result = &getFactoid($faqtoid);
+ my $was = $result;
+ &DEBUG("was($faqtoid) => '$was'.");
+
+ # global global
+ # we could support global local (once off).
+ if ( $result =~ s/\Q$op/$np/gi ) {
+ if ( length $result > $param{'maxDataSize'} ) {
+ &performReply("that's too long (or was long)");
+ return;
+ }
+ &setFactInfo( $faqtoid, 'factoid_value', $result );
+ &status("update: '$faqtoid' =is=> '$result'; was '$was'");
+ }
+ else {
+ &WARN(
+"subst: that's weird... thought we found the string ($op) in '$faqtoid'."
+ );
+ $error++;
+ }
+ }
+
+ if ($error) {
+ &ERROR("Some warnings/errors?");
+ }
+
+ &performReply( "Ok... did s/$op/$np/ for "
+ . ( scalar(@list) - $error )
+ . ' factoids' );
+
+ return;
}
# jump.
- if ($message =~ /^jump(\s+(\S+))?$/i) {
- return unless (&hasFlag('n'));
-
- if ($2 eq '') {
- &help('jump');
- return;
- }
-
- my ($server,$port);
- if ($2 =~ /^(\S+)(:(\d+))?$/) {
- $server = $1;
- $port = $3 || 6667;
- } else {
- &msg($who,"invalid format.");
- return;
- }
-
- &status("jumping servers... $server...");
- $conn->quit("jumping to $server");
-
- if (&irc($server,$port) == 0) {
- &ircloop();
- }
+ if ( $message =~ /^jump(\s+(\S+))?$/i ) {
+ return unless ( &hasFlag('n') );
+
+ if ( $2 eq '' ) {
+ &help('jump');
+ return;
+ }
+
+ my ( $server, $port );
+ if ( $2 =~ /^(\S+)(:(\d+))?$/ ) {
+ $server = $1;
+ $port = $3 || 6667;
+ }
+ else {
+ &msg( $who, "invalid format." );
+ return;
+ }
+
+ &status("jumping servers... $server...");
+ $conn->quit("jumping to $server");
+
+ if ( &irc( $server, $port ) == 0 ) {
+ &ircloop();
+ }
}
# reload.
- if ($message =~ /^reload$/i) {
- return unless (&hasFlag('n'));
+ if ( $message =~ /^reload$/i ) {
+ return unless ( &hasFlag('n') );
- &status("USER reload $who");
- &performStrictReply("reloading...");
- &reloadAllModules();
- &performStrictReply("reloaded.");
+ &status("USER reload $who");
+ &performStrictReply("reloading...");
+ &reloadAllModules();
+ &performStrictReply("reloaded.");
- return;
+ return;
}
# reset.
- if ($message =~ /^reset$/i) {
- return unless (&hasFlag('n'));
-
- &msg($who,"resetting...");
- my @done;
- foreach ( keys %channels, keys %chanconf ) {
- my $c = $_;
- next if (grep /^\Q$c\E$/i, @done);
-
- &part($_);
-
- push(@done, $_);
- sleep 1;
- }
- &DEBUG('before clearircvars');
- &clearIRCVars();
- &DEBUG('before joinnextchan');
- &joinNextChan();
- &DEBUG('after joinnextchan');
-
- &status("USER reset $who");
- &msg($who,'reset complete');
-
- return;
+ if ( $message =~ /^reset$/i ) {
+ return unless ( &hasFlag('n') );
+
+ &msg( $who, "resetting..." );
+ my @done;
+ foreach ( keys %channels, keys %chanconf ) {
+ my $c = $_;
+ next if ( grep /^\Q$c\E$/i, @done );
+
+ &part($_);
+
+ push( @done, $_ );
+ sleep 1;
+ }
+ &DEBUG('before clearircvars');
+ &clearIRCVars();
+ &DEBUG('before joinnextchan');
+ &joinNextChan();
+ &DEBUG('after joinnextchan');
+
+ &status("USER reset $who");
+ &msg( $who, 'reset complete' );
+
+ return;
}
# rehash.
- if ($message =~ /^rehash$/) {
- return unless (&hasFlag('n'));
+ if ( $message =~ /^rehash$/ ) {
+ return unless ( &hasFlag('n') );
- &msg($who,"rehashing...");
- &restart('REHASH');
- &status("USER rehash $who");
- &msg($who,'rehashed');
+ &msg( $who, "rehashing..." );
+ &restart('REHASH');
+ &status("USER rehash $who");
+ &msg( $who, 'rehashed' );
- return;
+ return;
}
#####
##### USER//CHAN SPECIFIC CONFIGURATION COMMANDS
#####
- if ($message =~ /^chaninfo(\s+(.*))?$/) {
- my @args = split /[\s\t]+/, $2; # hrm.
+ if ( $message =~ /^chaninfo(\s+(.*))?$/ ) {
+ my @args = split /[\s\t]+/, $2; # hrm.
- if (scalar @args != 1) {
- &help('chaninfo');
- return;
- }
+ if ( scalar @args != 1 ) {
+ &help('chaninfo');
+ return;
+ }
- if (!exists $chanconf{$args[0]}) {
- &performStrictReply("no such channel $args[0]");
- return;
- }
+ if ( !exists $chanconf{ $args[0] } ) {
+ &performStrictReply("no such channel $args[0]");
+ return;
+ }
- &performStrictReply("showing channel conf.");
- foreach (sort keys %{ $chanconf{$args[0]} }) {
- &performStrictReply("$chan: $_ => $chanconf{$args[0]}{$_}");
- }
- &performStrictReply("End of chaninfo.");
+ &performStrictReply("showing channel conf.");
+ foreach ( sort keys %{ $chanconf{ $args[0] } } ) {
+ &performStrictReply("$chan: $_ => $chanconf{$args[0]}{$_}");
+ }
+ &performStrictReply("End of chaninfo.");
- return;
+ return;
}
- # +chan.
- if ($message =~ /^(chanset|\+chan)(\s+(.*?))?$/) {
- my $cmd = $1;
- my $args = $3;
- my $no_chan = 0;
-
- if (!defined $args) {
- &help($cmd);
- return;
- }
-
- my @chans;
- while ($args =~ s/^($mask{chan})\s*//) {
- push(@chans, lc($1));
- }
-
- if (!scalar @chans) {
- push(@chans, '_default');
- $no_chan = 1;
- }
-
- my($what,$val) = split /[\s\t]+/, $args, 2;
-
- ### TODO: "cannot set values without +m".
- return unless (&hasFlag('n'));
-
- # READ ONLY.
- if (defined $what and $what !~ /^[-+]/ and !defined $val and $no_chan) {
- &performStrictReply("Showing $what values on all channels...");
-
- my %vals;
- foreach (keys %chanconf) {
- my $val;
- if (defined $chanconf{$_}{$what}) {
- $val = $chanconf{$_}{$what};
- } else {
- $val = "NOT-SET";
- }
- $vals{$val}{$_} = 1;
- }
-
- foreach (keys %vals) {
- &performStrictReply(" $what = $_(" . scalar(keys %{$vals{$_}}) . "): ".join(' ', sort keys %{ $vals{$_} } ) );
- }
-
- &performStrictReply("End of list.");
-
- return;
- }
-
- ### TODO: move to UserDCC again.
- if ($cmd eq 'chanset' and !defined $what) {
- &DEBUG("showing channel conf.");
-
- foreach $chan (@chans) {
- if ($chan eq '_default') {
- &performStrictReply('Default channel settings');
- } else {
- &performStrictReply("chan: $chan (see _default also)");
- }
- my @items;
- my $str = '';
- foreach (sort keys %{ $chanconf{$chan} }) {
- my $newstr = join(', ', @items);
- ### TODO: make length use channel line limit?
- if (length $newstr > 370) {
- &performStrictReply(" $str");
- @items = ();
- }
- $str = $newstr;
- push(@items, "$_ => $chanconf{$chan}{$_}");
- }
- if (@items) {
- my $str = join(', ', @items);
- &performStrictReply(" $str");
- }
- }
- return;
- }
-
- $cache{confvars}{$what} = $val;
- &rehashConfVars();
-
- foreach (@chans) {
- &chanSet($cmd, $_, $what, $val);
- }
-
- return;
+ # chanadd.
+ if ( $message =~ /^(chanset|chanadd)(\s+(.*?))?$/ ) {
+ my $cmd = $1;
+ my $args = $3;
+ my $no_chan = 0;
+
+ if ( !defined $args ) {
+ &help($cmd);
+ return;
+ }
+
+ my @chans;
+ while ( $args =~ s/^($mask{chan})\s*// ) {
+ push( @chans, lc($1) );
+ }
+
+ if ( !scalar @chans ) {
+ push( @chans, '_default' );
+ $no_chan = 1;
+ }
+
+ my ( $what, $val ) = split /[\s\t]+/, $args, 2;
+
+ ### TODO: "cannot set values without +m".
+ return unless ( &hasFlag('n') );
+
+ # READ ONLY.
+ if ( defined $what and $what !~ /^[-+]/ and !defined $val and $no_chan )
+ {
+ &performStrictReply("Showing $what values on all channels...");
+
+ my %vals;
+ foreach ( keys %chanconf ) {
+ my $val;
+ if ( defined $chanconf{$_}{$what} ) {
+ $val = $chanconf{$_}{$what};
+ }
+ else {
+ $val = "NOT-SET";
+ }
+ $vals{$val}{$_} = 1;
+ }
+
+ foreach ( keys %vals ) {
+ &performStrictReply( " $what = $_("
+ . scalar( keys %{ $vals{$_} } ) . "): "
+ . join( ' ', sort keys %{ $vals{$_} } ) );
+ }
+
+ &performStrictReply("End of list.");
+
+ return;
+ }
+
+ ### TODO: move to UserDCC again.
+ if ( $cmd eq 'chanset' and !defined $what ) {
+ &DEBUG("showing channel conf.");
+
+ foreach $chan (@chans) {
+ if ( $chan eq '_default' ) {
+ &performStrictReply('Default channel settings');
+ }
+ else {
+ &performStrictReply("chan: $chan (see _default also)");
+ }
+ my @items;
+ my $str = '';
+ foreach ( sort keys %{ $chanconf{$chan} } ) {
+ my $newstr = join( ', ', @items );
+ ### TODO: make length use channel line limit?
+ if ( length $newstr > 370 ) {
+ &performStrictReply(" $str");
+ @items = ();
+ }
+ $str = $newstr;
+ push( @items, "$_ => $chanconf{$chan}{$_}" );
+ }
+ if (@items) {
+ my $str = join( ', ', @items );
+ &performStrictReply(" $str");
+ }
+ }
+ return;
+ }
+
+ $cache{confvars}{$what} = $val;
+ &rehashConfVars();
+
+ foreach (@chans) {
+ &chanSet( $cmd, $_, $what, $val );
+ }
+
+ return;
}
- if ($message =~ /^(chanunset|\-chan)(\s+(.*))?$/) {
- return unless (&hasFlag('n'));
- my $args = $3;
- my $no_chan = 0;
-
- if (!defined $args) {
- &help('chanunset');
- return;
- }
-
- my ($chan);
- my $delete = 0;
- if ($args =~ s/^(\-)?($mask{chan})\s*//) {
- $chan = $2;
- $delete = ($1) ? 1 : 0;
- } else {
- &VERB("no chan arg; setting to default.",2);
- $chan = '_default';
- $no_chan = 1;
- }
-
- if (!exists $chanconf{$chan}) {
- &performStrictReply("no such channel $chan");
- return;
- }
-
- if ($args ne '') {
-
- if (!&getChanConf($args,$chan)) {
- &performStrictReply("$args does not exist for $chan");
- return;
- }
-
- my @chans = &ChanConfList($args);
- &DEBUG("scalar chans => ".scalar(@chans) );
- if (scalar @chans == 1 and $chans[0] eq '_default' and !$no_chan) {
- &performStrictReply("ok, $args was set only for _default; unsetting for _defaul but setting for other chans.");
-
- my $val = $chanconf{$_}{_default};
- foreach (keys %chanconf) {
- $chanconf{$_}{$args} = $val;
- }
- delete $chanconf{_default}{$args};
- $cache{confvars}{$args} = 0;
- &rehashConfVars();
-
- return;
- }
-
- if ($no_chan and !exists($chanconf{_default}{$args})) {
- &performStrictReply("ok, $args for _default does not exist, removing from all chans.");
-
- foreach (keys %chanconf) {
- next unless (exists $chanconf{$_}{$args});
- &DEBUG("delete chanconf{$_}{$args};");
- delete $chanconf{$_}{$args};
- }
- $cache{confvars}{$args} = 0;
- &rehashConfVars();
-
- return;
- }
-
- &performStrictReply("Unsetting channel ($chan) option $args. (was $chanconf{$chan}{$args})");
- delete $chanconf{$chan}{$args};
-
- return;
- }
-
- if ($delete) {
- &performStrictReply("Deleting channel $chan for sure!");
- $utime_chanfile = time();
- $ucount_chanfile++;
-
- &part($chan);
- &performStrictReply("Leaving $chan...");
-
- delete $chanconf{$chan};
- } else {
- &performStrictReply("Prefix channel with '-' to delete for sure.");
- }
-
- return;
+ if ( $message =~ /^(chanunset|chandel)(\s+(.*))?$/ ) {
+ return unless ( &hasFlag('n') );
+ my $cmd = $1;
+ my $args = $3;
+ my $no_chan = 0;
+
+ if ( !defined $args ) {
+ &help($cmd);
+ return;
+ }
+
+ my ($chan);
+ my $delete = 0;
+ if ( $args =~ s/^(\-)?($mask{chan})\s*// ) {
+ $chan = $2;
+ $delete = ($1) ? 1 : 0;
+ }
+ else {
+ &VERB( "no chan arg; setting to default.", 2 );
+ $chan = '_default';
+ $no_chan = 1;
+ }
+
+ if ( !exists $chanconf{$chan} ) {
+ &performStrictReply("no such channel $chan");
+ return;
+ }
+
+ if ( $args ne '' ) {
+
+ if ( !&getChanConf( $args, $chan ) ) {
+ &performStrictReply("$args does not exist for $chan");
+ return;
+ }
+
+ my @chans = &ChanConfList($args);
+ &DEBUG( "scalar chans => " . scalar(@chans) );
+ if ( scalar @chans == 1 and $chans[0] eq '_default' and !$no_chan )
+ {
+ &performStrictReply(
+"ok, $args was set only for _default; unsetting for _defaul but setting for other chans."
+ );
+
+ my $val = $chanconf{$_}{_default};
+ foreach ( keys %chanconf ) {
+ $chanconf{$_}{$args} = $val;
+ }
+ delete $chanconf{_default}{$args};
+ $cache{confvars}{$args} = 0;
+ &rehashConfVars();
+
+ return;
+ }
+
+ if ( $no_chan and !exists( $chanconf{_default}{$args} ) ) {
+ &performStrictReply(
+"ok, $args for _default does not exist, removing from all chans."
+ );
+
+ foreach ( keys %chanconf ) {
+ next unless ( exists $chanconf{$_}{$args} );
+ &DEBUG("delete chanconf{$_}{$args};");
+ delete $chanconf{$_}{$args};
+ }
+ $cache{confvars}{$args} = 0;
+ &rehashConfVars();
+
+ return;
+ }
+
+ &performStrictReply(
+"Unsetting channel ($chan) option $args. (was $chanconf{$chan}{$args})"
+ );
+ delete $chanconf{$chan}{$args};
+
+ return;
+ }
+
+ if ($delete) {
+ &performStrictReply("Deleting channel $chan for sure!");
+ $utime_chanfile = time();
+ $ucount_chanfile++;
+
+ &part($chan);
+ &performStrictReply("Leaving $chan...");
+
+ delete $chanconf{$chan};
+ }
+ else {
+ &performStrictReply("Prefix channel with '-' to delete for sure.");
+ }
+
+ return;
}
- if ($message =~ /^newpass(\s+(.*))?$/) {
- my(@args) = split /[\s\t]+/, $2 || '';
+ if ( $message =~ /^newpass(\s+(.*))?$/ ) {
+ my (@args) = split /[\s\t]+/, $2 || '';
- if (scalar @args != 1) {
- &help('newpass');
- return;
- }
+ if ( scalar @args != 1 ) {
+ &help('newpass');
+ return;
+ }
- my $u = &getUser($who);
- my $crypt = &mkcrypt($args[0]);
+ my $u = &getUser($who);
+ my $crypt = &mkcrypt( $args[0] );
- &performStrictReply("Set your passwd to '$crypt'");
- $users{$u}{PASS} = $crypt;
+ &performStrictReply("Set your passwd to '$crypt'");
+ $users{$u}{PASS} = $crypt;
- $utime_userfile = time();
- $ucount_userfile++;
+ $utime_userfile = time();
+ $ucount_userfile++;
- return;
+ return;
}
- if ($message =~ /^chpass(\s+(.*))?$/) {
- my(@args) = split /[\s\t]+/, $2 || '';
+ if ( $message =~ /^chpass(\s+(.*))?$/ ) {
+ my (@args) = split /[\s\t]+/, $2 || '';
- if (!scalar @args) {
- &help('chpass');
- return;
- }
+ if ( !scalar @args ) {
+ &help('chpass');
+ return;
+ }
- if (!&IsUser($args[0])) {
- &performStrictReply("user $args[0] is not valid.");
- return;
- }
+ if ( !&IsUser( $args[0] ) ) {
+ &performStrictReply("user $args[0] is not valid.");
+ return;
+ }
- my $u = &getUser($args[0]);
- if (!defined $u) {
- &performStrictReply("Internal error, u = NULL.");
- return;
- }
+ my $u = &getUser( $args[0] );
+ if ( !defined $u ) {
+ &performStrictReply("Internal error, u = NULL.");
+ return;
+ }
- if (scalar @args == 1) {
- # del pass.
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannot remove passwd of others.");
- return;
- }
+ if ( scalar @args == 1 ) {
- if (!exists $users{$u}{PASS}) {
- &performStrictReply("$u does not have pass set anyway.");
- return;
- }
+ # del pass.
+ if ( !&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i ) {
+ &performStrictReply("cannot remove passwd of others.");
+ return;
+ }
- &performStrictReply("Deleted pass from $u.");
+ if ( !exists $users{$u}{PASS} ) {
+ &performStrictReply("$u does not have pass set anyway.");
+ return;
+ }
- $utime_userfile = time();
- $ucount_userfile++;
+ &performStrictReply("Deleted pass from $u.");
- delete $users{$u}{PASS};
+ $utime_userfile = time();
+ $ucount_userfile++;
- return;
- }
+ delete $users{$u}{PASS};
- my $crypt = &mkcrypt($args[1]);
- &performStrictReply("Set $u's passwd to '$crypt'");
- $users{$u}{PASS} = $crypt;
+ return;
+ }
- $utime_userfile = time();
- $ucount_userfile++;
+ my $crypt = &mkcrypt( $args[1] );
+ &performStrictReply("Set $u's passwd to '$crypt'");
+ $users{$u}{PASS} = $crypt;
- return;
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ return;
}
- if ($message =~ /^chattr(\s+(.*))?$/) {
- my(@args) = split /[\s\t]+/, $2 || '';
-
- if (!scalar @args) {
- &help('chattr');
- return;
- }
-
- my $chflag;
- my $user;
- if ($args[0] =~ /^$mask{nick}$/i) {
- # <nick>
- $user = &getUser($args[0]);
- $chflag = $args[1];
- } else {
- # <flags>
- $user = &getUser($who);
- &DEBUG("user $who... nope.") unless (defined $user);
- $user = &getUser($verifyUser);
- $chflag = $args[0];
- }
-
- if (!defined $user) {
- &performStrictReply("user does not exist.");
- return;
- }
-
- my $flags = $users{$user}{FLAGS};
- if (!defined $chflag) {
- &performStrictReply("Flags for $user: $flags");
- return;
- }
-
- &DEBUG("who => $who");
- &DEBUG("verifyUser => $verifyUser");
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannto change attributes of others.");
- return 'REPLY';
- }
-
- my $state;
- my $change = 0;
- foreach (split //, $chflag) {
- if ($_ eq "+") { $state = 1; next; }
- if ($_ eq "-") { $state = 0; next; }
-
- if (!defined $state) {
- &performStrictReply("no initial + or - was found in attr.");
- return;
- }
-
- if ($state) {
- next if ($flags =~ /\Q$_\E/);
- $flags .= $_;
- } else {
- if (&IsParam('owner')
- and $param{owner} =~ /^\Q$user\E$/i
- and $flags =~ /[nmo]/
- ) {
- &performStrictReply("not removing flag $_ for $user.");
- next;
- }
- next unless ($flags =~ s/\Q$_\E//);
- }
-
- $change++;
- }
-
- if ($change) {
- $utime_userfile = time();
- $ucount_userfile++;
- #$flags.*FLAGS sort
- $flags = join('', sort split('', $flags));
- &performStrictReply("Current flags: $flags");
- $users{$user}{FLAGS} = $flags;
- } else {
- &performStrictReply("No flags changed: $flags");
- }
-
- return;
+ if ( $message =~ /^chattr(\s+(.*))?$/ ) {
+ my (@args) = split /[\s\t]+/, $2 || '';
+
+ if ( !scalar @args ) {
+ &help('chattr');
+ return;
+ }
+
+ my $chflag;
+ my $user;
+ if ( $args[0] =~ /^$mask{nick}$/i ) {
+
+ # <nick>
+ $user = &getUser( $args[0] );
+ $chflag = $args[1];
+ }
+ else {
+
+ # <flags>
+ $user = &getUser($who);
+ &DEBUG("user $who... nope.") unless ( defined $user );
+ $user = &getUser($verifyUser);
+ $chflag = $args[0];
+ }
+
+ if ( !defined $user ) {
+ &performStrictReply("user does not exist.");
+ return;
+ }
+
+ my $flags = $users{$user}{FLAGS};
+ if ( !defined $chflag ) {
+ &performStrictReply("Flags for $user: $flags");
+ return;
+ }
+
+ &DEBUG("who => $who");
+ &DEBUG("verifyUser => $verifyUser");
+ if ( !&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i ) {
+ &performStrictReply("cannto change attributes of others.");
+ return 'REPLY';
+ }
+
+ my $state;
+ my $change = 0;
+ foreach ( split //, $chflag ) {
+ if ( $_ eq "+" ) { $state = 1; next; }
+ if ( $_ eq "-" ) { $state = 0; next; }
+
+ if ( !defined $state ) {
+ &performStrictReply("no initial + or - was found in attr.");
+ return;
+ }
+
+ if ($state) {
+ next if ( $flags =~ /\Q$_\E/ );
+ $flags .= $_;
+ }
+ else {
+ if ( &IsParam('owner')
+ and $param{owner} =~ /^\Q$user\E$/i
+ and $flags =~ /[nmo]/ )
+ {
+ &performStrictReply("not removing flag $_ for $user.");
+ next;
+ }
+ next unless ( $flags =~ s/\Q$_\E// );
+ }
+
+ $change++;
+ }
+
+ if ($change) {
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ #$flags.*FLAGS sort
+ $flags = join( '', sort split( '', $flags ) );
+ &performStrictReply("Current flags: $flags");
+ $users{$user}{FLAGS} = $flags;
+ }
+ else {
+ &performStrictReply("No flags changed: $flags");
+ }
+
+ return;
}
- if ($message =~ /^chnick(\s+(.*))?$/) {
- my(@args) = split /[\s\t]+/, $2 || '';
-
- if ($who eq '_default') {
- &WARN("$who or verifyuser tried to run chnick.");
- return 'REPLY';
- }
-
- if (!scalar @args or scalar @args > 2) {
- &help('chnick');
- return;
- }
-
- if (scalar @args == 1) { # 1
- $user = &getUser($who);
- &DEBUG("nope, not $who.") unless (defined $user);
- $user ||= &getUser($verifyUser);
- $chnick = $args[0];
- } else { # 2
- $user = &getUser($args[0]);
- $chnick = $args[1];
- }
-
- if (!defined $user) {
- &performStrictReply("user $who or $args[0] does not exist.");
- return;
- }
-
- if ($user =~ /^\Q$chnick\E$/i) {
- &performStrictReply("user == chnick. why should I do that?");
- return;
- }
-
- if (&getUser($chnick)) {
- &performStrictReply("user $chnick is already used!");
- return;
- }
-
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannto change nick of others.");
- return 'REPLY' if ($who eq '_default');
- return;
- }
-
- foreach (keys %{ $users{$user} }) {
- $users{$chnick}{$_} = $users{$user}{$_};
- delete $users{$user}{$_};
- }
- undef $users{$user}; # ???
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- &performStrictReply("Changed '$user' to '$chnick' successfully.");
-
- return;
+ if ( $message =~ /^chnick(\s+(.*))?$/ ) {
+ my (@args) = split /[\s\t]+/, $2 || '';
+
+ if ( $who eq '_default' ) {
+ &WARN("$who or verifyuser tried to run chnick.");
+ return 'REPLY';
+ }
+
+ if ( !scalar @args or scalar @args > 2 ) {
+ &help('chnick');
+ return;
+ }
+
+ if ( scalar @args == 1 ) { # 1
+ $user = &getUser($who);
+ &DEBUG("nope, not $who.") unless ( defined $user );
+ $user ||= &getUser($verifyUser);
+ $chnick = $args[0];
+ }
+ else { # 2
+ $user = &getUser( $args[0] );
+ $chnick = $args[1];
+ }
+
+ if ( !defined $user ) {
+ &performStrictReply("user $who or $args[0] does not exist.");
+ return;
+ }
+
+ if ( $user =~ /^\Q$chnick\E$/i ) {
+ &performStrictReply("user == chnick. why should I do that?");
+ return;
+ }
+
+ if ( &getUser($chnick) ) {
+ &performStrictReply("user $chnick is already used!");
+ return;
+ }
+
+ if ( !&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i ) {
+ &performStrictReply("cannto change nick of others.");
+ return 'REPLY' if ( $who eq '_default' );
+ return;
+ }
+
+ foreach ( keys %{ $users{$user} } ) {
+ $users{$chnick}{$_} = $users{$user}{$_};
+ delete $users{$user}{$_};
+ }
+ undef $users{$user}; # ???
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ &performStrictReply("Changed '$user' to '$chnick' successfully.");
+
+ return;
}
- if ($message =~ /^([-+])host(\s+(.*))?$/) {
- my $cmd = $1.'host';
- my(@args) = split /[\s\t]+/, $3 || '';
- my $state = ($1 eq "+") ? 1 : 0;
-
- if (!scalar @args) {
- &help($cmd);
- return;
- }
-
- if ($who eq '_default') {
- &WARN("$who or verifyuser tried to run $cmd.");
- return 'REPLY';
- }
-
- my ($user,$mask);
- if ($args[0] =~ /^$mask{nick}$/i) { # <nick>
- return unless (&hasFlag('n'));
- $user = &getUser($args[0]);
- $mask = $args[1];
- } else { # <mask>
- # FIXME: who or verifyUser. (don't remember why)
- $user = &getUser($who);
- $mask = $args[0];
- }
-
- if (!defined $user) {
- &performStrictReply("user $user does not exist.");
- return;
- }
-
- if (!defined $mask) {
- &performStrictReply("Hostmasks for $user: " . join(' ', keys %{$users{$user}{HOSTS}}));
- return;
- }
-
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannto change masks of others.");
- return;
- }
-
- my $count = scalar keys %{ $users{$user}{HOSTS} };
-
- if ($state) { # add.
- if ($mask !~ /^$mask{nuh}$/) {
- &performStrictReply("error: mask ($mask) is not a real hostmask.");
- return;
- }
-
- if (exists $users{$user}{HOSTS}{$mask}) {
- &performStrictReply("mask $mask already exists.");
- return;
- }
-
- ### TODO: override support.
- $users{$user}{HOSTS}{$mask} = 1;
-
- &performStrictReply("Added $mask to list of masks.");
-
- } else { # delete.
-
- if (!exists $users{$user}{HOSTS}{$mask}) {
- &performStrictReply("mask $mask does not exist.");
- return;
- }
-
- ### TODO: wildcard support. ?
- delete $users{$user}{HOSTS}{$mask};
-
- if (scalar keys %{ $users{$user}{HOSTS} } != $count) {
- &performStrictReply("Removed $mask from list of masks.");
- } else {
- &performStrictReply("error: could not find $mask in list of masks.");
- return;
- }
- }
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- return;
+ if ( $message =~ /^(hostadd|hostdel)(\s+(.*))?$/ ) {
+ my $cmd = $1;
+ my (@args) = split /[\s\t]+/, $3 || '';
+ my $state = ( $1 eq "hostadd" ) ? 1 : 0;
+
+ if ( !scalar @args ) {
+ &help($cmd);
+ return;
+ }
+
+ if ( $who eq '_default' ) {
+ &WARN("$who or verifyuser tried to run $cmd.");
+ return 'REPLY';
+ }
+
+ my ( $user, $mask );
+ if ( $args[0] =~ /^$mask{nick}$/i ) { # <nick>
+ return unless ( &hasFlag('n') );
+ $user = &getUser( $args[0] );
+ $mask = $args[1];
+ }
+ else { # <mask>
+ # FIXME: who or verifyUser. (don't remember why)
+ $user = &getUser($who);
+ $mask = $args[0];
+ }
+
+ if ( !defined $user ) {
+ &performStrictReply("user $user does not exist.");
+ return;
+ }
+
+ if ( !defined $mask ) {
+ &performStrictReply( "Hostmasks for $user: "
+ . join( ' ', keys %{ $users{$user}{HOSTS} } ) );
+ return;
+ }
+
+ if ( !&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i ) {
+ &performStrictReply("cannto change masks of others.");
+ return;
+ }
+
+ my $count = scalar keys %{ $users{$user}{HOSTS} };
+
+ if ($state) { # add.
+ if ( $mask !~ /^$mask{nuh}$/ ) {
+ &performStrictReply(
+ "error: mask ($mask) is not a real hostmask.");
+ return;
+ }
+
+ if ( exists $users{$user}{HOSTS}{$mask} ) {
+ &performStrictReply("mask $mask already exists.");
+ return;
+ }
+
+ ### TODO: override support.
+ $users{$user}{HOSTS}{$mask} = 1;
+
+ &performStrictReply("Added $mask to list of masks.");
+
+ }
+ else { # delete.
+
+ if ( !exists $users{$user}{HOSTS}{$mask} ) {
+ &performStrictReply("mask $mask does not exist.");
+ return;
+ }
+
+ ### TODO: wildcard support. ?
+ delete $users{$user}{HOSTS}{$mask};
+
+ if ( scalar keys %{ $users{$user}{HOSTS} } != $count ) {
+ &performStrictReply("Removed $mask from list of masks.");
+ }
+ else {
+ &performStrictReply(
+ "error: could not find $mask in list of masks.");
+ return;
+ }
+ }
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ return;
}
- if ($message =~ /^([-+])ban(\s+(.*))?$/) {
- my $cmd = $1.'ban';
- my $flatarg = $3;
- my(@args) = split /[\s\t]+/, $3 || '';
- my $state = ($1 eq "+") ? 1 : 0;
-
- if (!scalar @args) {
- &help($cmd);
- return;
- }
-
- my($mask,$chan,$time,$reason);
-
- if ($flatarg =~ s/^($mask{nuh})\s*//) {
- $mask = $1;
- } else {
- &DEBUG("arg does not contain nuh mask?");
- }
-
- if ($flatarg =~ s/^($mask{chan})\s*//) {
- $chan = $1;
- } else {
- $chan = '*'; # _default instead?
- }
-
- if ($state == 0) { # delete.
- my @c = &banDel($mask);
-
- foreach (@c) {
- &unban($mask, $_);
- }
-
- if (@c) {
- &performStrictReply("Removed $mask from chans: @c");
- } else {
- &performStrictReply("$mask was not found in ban list.");
- }
-
- return;
- }
-
- ###
- # add ban.
- ###
-
- # time.
- if ($flatarg =~ s/^(\d+)\s*//) {
- $time = $1;
- &DEBUG("time = $time.");
- if ($time < 0) {
- &performStrictReply("error: time cannot be negatime?");
- return;
- }
- } else {
- $time = 0;
- }
-
- if ($flatarg =~ s/^(.*)$//) { # need length?
- $reason = $1;
- }
-
- if (!&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i) {
- &performStrictReply("cannto change masks of others.");
- return;
- }
-
- if ($mask !~ /^$mask{nuh}$/) {
- &performStrictReply("error: mask ($mask) is not a real hostmask.");
- return;
- }
-
- if ( &banAdd($mask,$chan,$time,$reason) == 2) {
- &performStrictReply("ban already exists; overwriting.");
- }
- &performStrictReply("Added $mask for $chan (time => $time, reason => $reason)");
-
- return;
+ if ( $message =~ /^(banadd|bandel)(\s+(.*))?$/ ) {
+ my $cmd = $1;
+ my $flatarg = $3;
+ my (@args) = split /[\s\t]+/, $3 || '';
+ my $state = ( $1 eq "banadd" ) ? 1 : 0;
+
+ if ( !scalar @args ) {
+ &help($cmd);
+ return;
+ }
+
+ my ( $mask, $chan, $time, $reason );
+
+ if ( $flatarg =~ s/^($mask{nuh})\s*// ) {
+ $mask = $1;
+ }
+ else {
+ &DEBUG("arg does not contain nuh mask?");
+ }
+
+ if ( $flatarg =~ s/^($mask{chan})\s*// ) {
+ $chan = $1;
+ }
+ else {
+ $chan = '*'; # _default instead?
+ }
+
+ if ( $state == 0 ) { # delete.
+ my @c = &banDel($mask);
+
+ foreach (@c) {
+ &unban( $mask, $_ );
+ }
+
+ if (@c) {
+ &performStrictReply("Removed $mask from chans: @c");
+ }
+ else {
+ &performStrictReply("$mask was not found in ban list.");
+ }
+
+ return;
+ }
+
+ ###
+ # add ban.
+ ###
+
+ # time.
+ if ( $flatarg =~ s/^(\d+)\s*// ) {
+ $time = $1;
+ &DEBUG("time = $time.");
+ if ( $time < 0 ) {
+ &performStrictReply("error: time cannot be negatime?");
+ return;
+ }
+ }
+ else {
+ $time = 0;
+ }
+
+ if ( $flatarg =~ s/^(.*)$// ) { # need length?
+ $reason = $1;
+ }
+
+ if ( !&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i ) {
+ &performStrictReply("cannto change masks of others.");
+ return;
+ }
+
+ if ( $mask !~ /^$mask{nuh}$/ ) {
+ &performStrictReply("error: mask ($mask) is not a real hostmask.");
+ return;
+ }
+
+ if ( &banAdd( $mask, $chan, $time, $reason ) == 2 ) {
+ &performStrictReply("ban already exists; overwriting.");
+ }
+ &performStrictReply(
+ "Added $mask for $chan (time => $time, reason => $reason)");
+
+ return;
}
- if ($message =~ /^whois(\s+(.*))?$/) {
- my $arg = $2;
-
- if (!defined $arg) {
- &help('whois');
- return;
- }
-
- my $user = &getUser($arg);
- if (!defined $user) {
- &performStrictReply("whois: user $user does not exist.");
- return;
- }
-
- ### TODO: better (eggdrop-like) output.
- &performStrictReply("user: $user");
- foreach (keys %{ $users{$user} }) {
- my $ref = ref $users{$user}{$_};
-
- if ($ref eq 'HASH') {
- my $type = $_;
- ### DOES NOT WORK???
- foreach (keys %{ $users{$user}{$type} }) {
- &performStrictReply(" $type => $_");
- }
- next;
- }
-
- &performStrictReply(" $_ => $users{$user}{$_}");
- }
- &performStrictReply("End of USER whois.");
-
- return;
+ if ( $message =~ /^whois(\s+(.*))?$/ ) {
+ my $arg = $2;
+
+ if ( !defined $arg ) {
+ &help('whois');
+ return;
+ }
+
+ my $user = &getUser($arg);
+ if ( !defined $user ) {
+ &performStrictReply("whois: user '$arg' does not exist.");
+ return;
+ }
+
+ ### TODO: better (eggdrop-like) output.
+ &performStrictReply("user: $user");
+ foreach ( keys %{ $users{$user} } ) {
+ my $ref = ref $users{$user}{$_};
+
+ if ( $ref eq 'HASH' ) {
+ my $type = $_;
+ ### DOES NOT WORK???
+ foreach ( keys %{ $users{$user}{$type} } ) {
+ &performStrictReply(" $type => $_");
+ }
+ next;
+ }
+
+ &performStrictReply(" $_ => $users{$user}{$_}");
+ }
+ &performStrictReply("End of USER whois.");
+
+ return;
}
- if ($message =~ /^bans(\s+(.*))?$/) {
- my $arg = $2;
-
- if (defined $arg) {
- if ($arg ne '_default' and !&validChan($arg) ) {
- &performStrictReply("error: chan $chan is invalid.");
- return;
- }
- }
-
- if (!scalar keys %bans) {
- &performStrictReply("Ban list is empty.");
- return;
- }
-
- my $c;
- &performStrictReply(" mask: expire, time-added, count, who-by, reason");
- foreach $c (keys %bans) {
- next unless (!defined $arg or $arg =~ /^\Q$c\E$/i);
- &performStrictReply(" $c:");
-
- foreach (keys %{ $bans{$c} }) {
- my $val = $bans{$c}{$_};
-
- if (ref $val eq 'ARRAY') {
- my @array = @{ $val };
- &performStrictReply(" $_: @array");
- } else {
- &DEBUG("unknown ban: $val");
- }
- }
- }
- &performStrictReply("END of bans.");
-
- return;
+ if ( $message =~ /^bans(\s+(.*))?$/ ) {
+ my $arg = $2;
+
+ if ( defined $arg ) {
+ if ( $arg ne '_default' and !&validChan($arg) ) {
+ &performStrictReply("error: chan $chan is invalid.");
+ return;
+ }
+ }
+
+ if ( !scalar keys %bans ) {
+ &performStrictReply("Ban list is empty.");
+ return;
+ }
+
+ my $c;
+ &performStrictReply(
+ " mask: expire, time-added, count, who-by, reason");
+ foreach $c ( keys %bans ) {
+ next unless ( !defined $arg or $arg =~ /^\Q$c\E$/i );
+ &performStrictReply(" $c:");
+
+ foreach ( keys %{ $bans{$c} } ) {
+ my $val = $bans{$c}{$_};
+
+ if ( ref $val eq 'ARRAY' ) {
+ my @array = @{$val};
+ &performStrictReply(" $_: @array");
+ }
+ else {
+ &DEBUG("unknown ban: $val");
+ }
+ }
+ }
+ &performStrictReply("END of bans.");
+
+ return;
}
- if ($message =~ /^banlist(\s+(.*))?$/) {
- my $arg = $2;
+ if ( $message =~ /^banlist(\s+(.*))?$/ ) {
+ my $arg = $2;
- if (defined $arg and $arg !~ /^$mask{chan}$/) {
- &performStrictReply("error: chan $chan is invalid.");
- return;
- }
+ if ( defined $arg and $arg !~ /^$mask{chan}$/ ) {
+ &performStrictReply("error: chan $chan is invalid.");
+ return;
+ }
- &DEBUG("bans for global or arg => $arg.");
- foreach (keys %bans) { #CHANGE!!!
- &DEBUG(" $_ => $bans{$_}.");
- }
+ &DEBUG("bans for global or arg => $arg.");
+ foreach ( keys %bans ) { #CHANGE!!!
+ &DEBUG(" $_ => $bans{$_}.");
+ }
- &DEBUG("End of bans.");
- &performStrictReply("END of bans.");
+ &DEBUG("End of bans.");
+ &performStrictReply("END of bans.");
- return;
+ return;
}
- if ($message =~ /^save$/) {
- return unless (&hasFlag('o'));
+ if ( $message =~ /^save$/ ) {
+ return unless ( &hasFlag('o') );
- &writeUserFile();
- &writeChanFile();
- &performStrictReply('saved user and chan files');
+ &writeUserFile();
+ &writeChanFile();
+ &performStrictReply('saved user and chan files');
- return;
+ return;
}
### ALIASES.
$message =~ s/^(del|un)ignore/-ignore/;
# ignore.
- if ($message =~ /^(\+|\-)ignore(\s+(.*))?$/i) {
- return unless (&hasFlag('o'));
- my $state = ($1 eq "+") ? 1 : 0;
- my $str = $1.'ignore';
- my $args = $3;
-
- if (!$args) {
- &help($str);
- return;
- }
-
- my($mask,$chan,$time,$comment);
-
- # mask.
- if ($args =~ s/^($mask{nuh})\s*//) {
- $mask = $1;
- } else {
- &ERROR("no NUH mask?");
- return;
- }
-
- if (!$state) { # delignore.
- if ( &ignoreDel($mask) ) {
- &performStrictReply("ok, deleted ignores for $mask.");
- } else {
- &performStrictReply("could not find $mask in ignore list.");
- }
- return;
- }
-
- ###
- # addignore.
- ###
-
- # chan.
- if ($args =~ s/^($mask{chan}|\*)\s*//) {
- $chan = $1;
- } else {
- $chan = '*';
- }
-
- # time.
- if ($args =~ s/^(\d+)\s*//) {
- $time = $1; # time is in minutes
- } else {
- $time = 0;
- }
-
- # time.
- if ($args) {
- $comment = $args;
- } else {
- $comment = "added by $who";
- }
-
- if ( &ignoreAdd($mask, $chan, $time, $comment) > 1) {
- &performStrictReply("FIXME: $mask already in ignore list; written over anyway.");
- } else {
- &performStrictReply("added $mask to ignore list.");
- }
-
- return;
+ if ( $message =~ /^(\+|\-)ignore(\s+(.*))?$/i ) {
+ return unless ( &hasFlag('o') );
+ my $state = ( $1 eq "+" ) ? 1 : 0;
+ my $str = $1 . 'ignore';
+ my $args = $3;
+
+ if ( !$args ) {
+ &help($str);
+ return;
+ }
+
+ my ( $mask, $chan, $time, $comment );
+
+ # mask.
+ if ( $args =~ s/^($mask{nuh})\s*// ) {
+ $mask = $1;
+ }
+ else {
+ &ERROR("no NUH mask?");
+ return;
+ }
+
+ if ( !$state ) { # delignore.
+ if ( &ignoreDel($mask) ) {
+ &performStrictReply("ok, deleted ignores for $mask.");
+ }
+ else {
+ &performStrictReply("could not find $mask in ignore list.");
+ }
+ return;
+ }
+
+ ###
+ # addignore.
+ ###
+
+ # chan.
+ if ( $args =~ s/^($mask{chan}|\*)\s*// ) {
+ $chan = $1;
+ }
+ else {
+ $chan = '*';
+ }
+
+ # time.
+ if ( $args =~ s/^(\d+)\s*// ) {
+ $time = $1; # time is in minutes
+ }
+ else {
+ $time = 0;
+ }
+
+ # time.
+ if ($args) {
+ $comment = $args;
+ }
+ else {
+ $comment = "added by $who";
+ }
+
+ if ( &ignoreAdd( $mask, $chan, $time, $comment ) > 1 ) {
+ &performStrictReply(
+ "FIXME: $mask already in ignore list; written over anyway.");
+ }
+ else {
+ &performStrictReply("added $mask to ignore list.");
+ }
+
+ return;
}
- if ($message =~ /^ignore(\s+(.*))?$/) {
- my $arg = $2;
-
- if (defined $arg) {
- if ($arg !~ /^$mask{chan}$/) {
- &performStrictReply("error: chan $chan is invalid.");
- return;
- }
-
- if (!&validChan($arg)) {
- &performStrictReply("error: chan $arg is invalid.");
- return;
- }
-
- &performStrictReply("Showing bans for $arg only.");
- }
-
- if (!scalar keys %ignore) {
- &performStrictReply("Ignore list is empty.");
- return;
- }
-
- ### TODO: proper (eggdrop-like) formatting.
- my $c;
- &performStrictReply(" mask: expire, time-added, who, comment");
- foreach $c (keys %ignore) {
- next unless (!defined $arg or $arg =~ /^\Q$c\E$/i);
- &performStrictReply(" $c:");
-
- foreach (keys %{ $ignore{$c} }) {
- my $ref = ref $ignore{$c}{$_};
- if ($ref eq 'ARRAY') {
- my @array = @{ $ignore{$c}{$_} };
- &performStrictReply(" $_: @array");
- } else {
- &DEBUG("unknown ignore line?");
- }
- }
- }
- &performStrictReply("END of ignore.");
-
- return;
+ if ( $message =~ /^ignore(\s+(.*))?$/ ) {
+ my $arg = $2;
+
+ if ( defined $arg ) {
+ if ( $arg !~ /^$mask{chan}$/ ) {
+ &performStrictReply("error: chan $chan is invalid.");
+ return;
+ }
+
+ if ( !&validChan($arg) ) {
+ &performStrictReply("error: chan $arg is invalid.");
+ return;
+ }
+
+ &performStrictReply("Showing bans for $arg only.");
+ }
+
+ if ( !scalar keys %ignore ) {
+ &performStrictReply("Ignore list is empty.");
+ return;
+ }
+
+ ### TODO: proper (eggdrop-like) formatting.
+ my $c;
+ &performStrictReply(" mask: expire, time-added, who, comment");
+ foreach $c ( keys %ignore ) {
+ next unless ( !defined $arg or $arg =~ /^\Q$c\E$/i );
+ &performStrictReply(" $c:");
+
+ foreach ( keys %{ $ignore{$c} } ) {
+ my $ref = ref $ignore{$c}{$_};
+ if ( $ref eq 'ARRAY' ) {
+ my @array = @{ $ignore{$c}{$_} };
+ &performStrictReply(" $_: @array");
+ }
+ else {
+ &DEBUG("unknown ignore line?");
+ }
+ }
+ }
+ &performStrictReply("END of ignore.");
+
+ return;
}
- # adduser/deluser.
- if ($message =~ /^(add|del)user(\s+(.*))?$/i) {
- my $str = $1;
- my $strstr = $1.'user';
- my @args = split /\s+/, $3 || '';
- my $args = $3;
- my $state = ($str =~ /^(add)$/) ? 1 : 0;
-
- if (!scalar @args) {
- &help($strstr);
- return;
- }
-
- if ($str eq 'add') {
- if (scalar @args != 2) {
- &performStrictReply('adduser requires hostmask argument.');
- return;
- }
- } elsif (scalar @args != 1) {
- &performStrictReply('too many arguments.');
- return;
- }
-
- if ($state) {
- # adduser.
- if (scalar @args == 1) {
- $args[1] = &getHostMask($args[0]);
- &performStrictReply("Attemping to guess $args[0]'s hostmask...");
-
- # crude hack... crappy Net::IRC
- $conn->schedule(5, sub {
- # hopefully this is right.
- my $nick = (keys %{ $cache{nuhInfo} })[0];
- if (!defined $nick) {
- &performStrictReply("couldn't get nuhinfo... adding user without a hostmask.");
- &userAdd($nick);
- return;
- }
- my $mask = &makeHostMask( $cache{nuhInfo}{$nick}{NUH} );
-
- if ( &userAdd($nick, $mask) ) {
- # success.
- &performStrictReply("Added $nick with flags $users{$nick}{FLAGS}");
- my @hosts = keys %{ $users{$nick}{HOSTS} };
- &performStrictReply("hosts: @hosts");
- }
- });
- return;
- }
-
- &DEBUG("args => @args");
- if ( &userAdd(@args) ) { # success.
- &performStrictReply("Added $args[0] with flags $users{$args[0]}{FLAGS}");
- my @hosts = keys %{ $users{$args[0]}{HOSTS} };
- &performStrictReply("hosts: @hosts");
-
- } else { # failure.
- &performStrictReply("User $args[0] already exists");
- }
-
- } else { # deluser.
-
- if ( &userDel($args[0]) ) { # success.
- &performStrictReply("Deleted $args[0] successfully.");
-
- } else { # failure.
- &performStrictReply("User $args[0] does not exist.");
- }
-
- }
- return;
+ # useradd/userdel.
+ if ( $message =~ /^(useradd|userdel)(\s+(.*))?$/i ) {
+ my $cmd = $1;
+ my @args = split /\s+/, $3 || '';
+ my $args = $3;
+ my $state = ( $cmd eq "useradd" ) ? 1 : 0;
+
+ if ( !scalar @args ) {
+ &help($cmd);
+ return;
+ }
+
+ if ( $cmd eq 'useradd' ) {
+ if ( scalar @args != 2 ) {
+ &performStrictReply('useradd requires hostmask argument.');
+ return;
+ }
+ }
+ elsif ( scalar @args != 1 ) {
+ &performStrictReply('too many arguments.');
+ return;
+ }
+
+ if ($state) {
+
+ # adduser.
+ if ( scalar @args == 1 ) {
+ $args[1] = &getHostMask( $args[0] );
+ &performStrictReply(
+ "Attemping to guess $args[0]'s hostmask...");
+
+ # crude hack... crappy Net::IRC
+ $conn->schedule(
+ 5,
+ sub {
+
+ # hopefully this is right.
+ my $nick = ( keys %{ $cache{nuhInfo} } )[0];
+ if ( !defined $nick ) {
+ &performStrictReply(
+"couldn't get nuhinfo... adding user without a hostmask."
+ );
+ &userAdd($nick);
+ return;
+ }
+ my $mask = &makeHostMask( $cache{nuhInfo}{$nick}{NUH} );
+
+ if ( &userAdd( $nick, $mask ) ) {
+
+ # success.
+ &performStrictReply(
+ "Added $nick with flags $users{$nick}{FLAGS}");
+ my @hosts = keys %{ $users{$nick}{HOSTS} };
+ &performStrictReply("hosts: @hosts");
+ }
+ }
+ );
+ return;
+ }
+
+ &DEBUG("args => @args");
+ if ( &userAdd(@args) ) { # success.
+ &performStrictReply(
+ "Added $args[0] with flags $users{$args[0]}{FLAGS}");
+ my @hosts = keys %{ $users{ $args[0] }{HOSTS} };
+ &performStrictReply("hosts: @hosts");
+
+ }
+ else { # failure.
+ &performStrictReply("User $args[0] already exists");
+ }
+
+ }
+ else { # deluser.
+
+ if ( &userDel( $args[0] ) ) { # success.
+ &performStrictReply("Deleted $args[0] successfully.");
+
+ }
+ else { # failure.
+ &performStrictReply("User $args[0] does not exist.");
+ }
+
+ }
+ return;
}
- if ($message =~ /^sched$/) {
- my @list;
- my @run;
-
- my %time;
- foreach (keys %sched) {
- next unless (exists $sched{$_}{TIME});
- $time{ $sched{$_}{TIME}-time() }{$_} = 1;
- push(@list,$_);
-
- next unless (exists $sched{$_}{RUNNING});
- push(@run,$_);
- }
-
- my @time;
- foreach (sort { $a <=> $b } keys %time) {
- my $str = join(', ', sort keys %{ $time{$_} });
- &DEBUG("time => $_, str => $str");
- push(@time, "$str (".&Time2String($_).")");
- }
-
- &performStrictReply( &formListReply(0, "Schedulers: ", @time ) );
- &performStrictReply( &formListReply(0, "Scheds to run: ", sort @list ) );
- &performStrictReply( &formListReply(0, "Scheds running(should not happen?) ", sort @run ) );
-
- return;
+ if ( $message =~ /^sched$/ ) {
+ my @list;
+ my @run;
+
+ my %time;
+ foreach ( keys %sched ) {
+ next unless ( exists $sched{$_}{TIME} );
+ $time{ $sched{$_}{TIME} - time() }{$_} = 1;
+ push( @list, $_ );
+
+ next unless ( exists $sched{$_}{RUNNING} );
+ push( @run, $_ );
+ }
+
+ my @time;
+ foreach ( sort { $a <=> $b } keys %time ) {
+ my $str = join( ', ', sort keys %{ $time{$_} } );
+ &DEBUG("time => $_, str => $str");
+ push( @time, "$str (" . &Time2String($_) . ")" );
+ }
+
+ &performStrictReply( &formListReply( 0, "Schedulers: ", @time ) );
+ &performStrictReply(
+ &formListReply( 0, "Scheds to run: ", sort @list ) );
+ &performStrictReply(
+ &formListReply(
+ 0, "Scheds running(should not happen?) ",
+ sort @run
+ )
+ );
+
+ return;
}
# quite a cool hack: reply in DCC CHAT.
- $msgType = 'chat' if (exists $dcc{'CHAT'}{$who});
+ $msgType = 'chat' if ( exists $dcc{'CHAT'}{$who} );
my $done = 0;
$done++ if &parseCmdHook($message);
- $done++ unless (&Modules());
+ $done++ unless ( &Modules() );
if ($done) {
- &DEBUG("running non DCC CHAT command inside DCC CHAT!");
- return;
+ &DEBUG("running non DCC CHAT command inside DCC CHAT!");
+ return;
}
return 'REPLY';
use strict;
my $orderOfInfo = 'RN,J,C,W,D';
-my %infoDesc = (
- 'RN' => 'Real Name',
- 'J' => 'Occupation',
- 'C' => 'Contact',
- 'W' => 'URL',
- 'D' => 'Description',
+my %infoDesc = (
+ 'RN' => 'Real Name',
+ 'J' => 'Occupation',
+ 'C' => 'Contact',
+ 'W' => 'URL',
+ 'D' => 'Description',
);
sub UserInfo2Hash {
my ($text) = @_;
my %hash;
- foreach (split /\|/, $text) {
- if (/^\s*(\S+):\s*(.*)\s*$/) {
- $hash{$1} = $2;
- }
+ foreach ( split /\|/, $text ) {
+ if (/^\s*(\S+):\s*(.*)\s*$/) {
+ $hash{$1} = $2;
+ }
}
return %hash;
my (%hash) = @_;
my @array;
- foreach (sort keys %hash) {
- push(@array, "$_: $hash{$_}");
+ foreach ( sort keys %hash ) {
+ push( @array, "$_: $hash{$_}" );
}
- join('|', @array);
+ join( '|', @array );
}
###
sub UserInfoGet {
my ($query) = @_;
- $query =~ s/^\s+|\s+$//g if (defined $query);
+ $query =~ s/^\s+|\s+$//g if ( defined $query );
- if (!defined $query or $query =~ /^$/) {
- &help('userinfo');
- return;
+ if ( !defined $query or $query =~ /^$/ ) {
+ &help('userinfo');
+ return;
}
- if ($query !~ /^$mask{nick}$/) {
- &msg($who, "Invalid query of '$query'.");
- return;
+ if ( $query !~ /^$mask{nick}$/ ) {
+ &msg( $who, "Invalid query of '$query'." );
+ return;
}
my $result;
- if ($result = &getFactoid($query.' info')) {
- # good.
- } else { # bad.
- &performReply("No User Information on \002$query\002");
- return;
+ if ( $result = &getFactoid( $query . ' info' ) ) {
+
+ # good.
+ }
+ else { # bad.
+ &performReply("No User Information on \002$query\002");
+ return;
}
- if ($result !~ /\|/) {
- &msg($who, "Invalid User Information for '$query'.");
- return;
+ if ( $result !~ /\|/ ) {
+ &msg( $who, "Invalid User Information for '$query'." );
+ return;
}
my %userInfo = &UserInfo2Hash($result);
my @reply;
- foreach (split ',', $orderOfInfo) {
- next unless (exists $userInfo{$_});
- push(@reply, "$infoDesc{$_}: $userInfo{$_}");
+ foreach ( split ',', $orderOfInfo ) {
+ next unless ( exists $userInfo{$_} );
+ push( @reply, "$infoDesc{$_}: $userInfo{$_}" );
}
- &performStrictReply("User Information on $userInfo{'N'} -- ".
- join(', ', @reply));
+ &performStrictReply(
+ "User Information on $userInfo{'N'} -- " . join( ', ', @reply ) );
}
sub UserInfoSet {
- my($type, $what) = @_;
+ my ( $type, $what ) = @_;
my %userInfo;
my $info;
- if (&IsLocked("$who info")) {
- &DEBUG("UIS: IsLocked('$who info') == 1.");
- return;
+ if ( &IsLocked("$who info") ) {
+ &DEBUG("UIS: IsLocked('$who info') == 1.");
+ return;
}
my $new = 0;
- if (my $result = &getFactoid("$who info")) {
- %userInfo = &UserInfo2Hash($result);
- } else {
- &DEBUG("UIS: new = 1!");
- $userInfo{'N'} = $who;
- $new = 1;
+ if ( my $result = &getFactoid("$who info") ) {
+ %userInfo = &UserInfo2Hash($result);
+ }
+ else {
+ &DEBUG("UIS: new = 1!");
+ $userInfo{'N'} = $who;
+ $new = 1;
}
### TODO: hash for %infoS2L.
- if ($type =~ /^(RN|real\s*name)$/i) {
- $info = 'RN';
- } elsif ($type =~ /^(J|job|occupation|school|life)$/i) {
- $info = 'J';
- } elsif ($type =~ /^(C|contact|email|phone)$/i) {
- $info = 'C';
- } elsif ($type =~ /^(W|www|url|web\s*page|home\s*page)$/i) {
- $info = 'W';
- } elsif ($type =~ /^(D|desc\S+)$/i) {
- $info = 'D';
- } elsif ($type =~ /^(O|opt\S+)$/i) {
- $info = 'O';
- } else {
- &msg($who, "Unknown type '$type'.");
- return;
- }
-
- if (!defined $what) { # !defined.
- if (exists $userInfo{$info}) {
- &msg($who, "Current \002$infoDesc{$info}\002 is: '$userInfo{$info}'.");
- } else {
- &msg($who, "No current \002$infoDesc{$info}\002.");
- }
-
- my @remain;
- foreach (split ',', $orderOfInfo) {
- next if (exists $userInfo{$_});
- push(@remain, $infoDesc{$_});
- }
- if (scalar @remain) {
- ### TODO: show short-cut (identifier) aswell.
- &msg($who, "Remaining slots to fill: ".join(' ', @remain));
- } else {
+ if ( $type =~ /^(RN|real\s*name)$/i ) {
+ $info = 'RN';
+ }
+ elsif ( $type =~ /^(J|job|occupation|school|life)$/i ) {
+ $info = 'J';
+ }
+ elsif ( $type =~ /^(C|contact|email|phone)$/i ) {
+ $info = 'C';
+ }
+ elsif ( $type =~ /^(W|www|url|web\s*page|home\s*page)$/i ) {
+ $info = 'W';
+ }
+ elsif ( $type =~ /^(D|desc\S+)$/i ) {
+ $info = 'D';
+ }
+ elsif ( $type =~ /^(O|opt\S+)$/i ) {
+ $info = 'O';
+ }
+ else {
+ &msg( $who, "Unknown type '$type'." );
+ return;
+ }
+
+ if ( !defined $what ) { # !defined.
+ if ( exists $userInfo{$info} ) {
+ &msg( $who,
+ "Current \002$infoDesc{$info}\002 is: '$userInfo{$info}'." );
+ }
+ else {
+ &msg( $who, "No current \002$infoDesc{$info}\002." );
+ }
+
+ my @remain;
+ foreach ( split ',', $orderOfInfo ) {
+ next if ( exists $userInfo{$_} );
+ push( @remain, $infoDesc{$_} );
+ }
+ if ( scalar @remain ) {
+ ### TODO: show short-cut (identifier) aswell.
+ &msg( $who, "Remaining slots to fill: " . join( ' ', @remain ) );
+ }
+ else {
### &msg($who, "Personal Information completely filled. Good.");
- }
-
- return;
- } elsif ($what =~ /^$/) { # defined but NULL. UNSET
- if (exists $userInfo{$info}) {
- &msg($who, "Unsetting \002$infoDesc{$info}\002 ($userInfo{$info}).");
- delete $userInfo{$info};
- } else {
- &msg($who, "\002$infoDesc{$info}\002 is already empty!");
- return;
- }
- } else { # defined.
- if (exists $userInfo{$info}) {
- &msg($who, "\002$infoDesc{$info}\002 was '$userInfo{$info}'.");
- &msg($who, "Now is: '$what'.");
- } else {
- &msg($who, "\002$infoDesc{$info}\002 is now '$what'.");
- }
- $userInfo{$info} = $what;
- }
-
- &setFactInfo($who.' info', 'factoid_value', &Hash2UserInfo(%userInfo));
+ }
+
+ return;
+ }
+ elsif ( $what =~ /^$/ ) { # defined but NULL. UNSET
+ if ( exists $userInfo{$info} ) {
+ &msg( $who,
+ "Unsetting \002$infoDesc{$info}\002 ($userInfo{$info})." );
+ delete $userInfo{$info};
+ }
+ else {
+ &msg( $who, "\002$infoDesc{$info}\002 is already empty!" );
+ return;
+ }
+ }
+ else { # defined.
+ if ( exists $userInfo{$info} ) {
+ &msg( $who, "\002$infoDesc{$info}\002 was '$userInfo{$info}'." );
+ &msg( $who, "Now is: '$what'." );
+ }
+ else {
+ &msg( $who, "\002$infoDesc{$info}\002 is now '$what'." );
+ }
+ $userInfo{$info} = $what;
+ }
+
+ &setFactInfo( $who . ' info', 'factoid_value', &Hash2UserInfo(%userInfo) );
if ($new) {
- &DEBUG("UIS: locking '$who info'.");
- &DEBUG("UIS: nuh => '$nuh'.");
- &setFactInfo("$who info", "locked_by", $nuh);
- &setFactInfo("$who info", "locked_time", time());
+ &DEBUG("UIS: locking '$who info'.");
+ &DEBUG("UIS: nuh => '$nuh'.");
+ &setFactInfo( "$who info", "locked_by", $nuh );
+ &setFactInfo( "$who info", "locked_time", time() );
}
}
use strict;
use vars qw(@W3Search_engines $W3Search_regex);
+
@W3Search_engines = qw(AltaVista Dejanews Excite Gopher HotBot Infoseek
- Lycos Magellan PLweb SFgate Simple Verity Google z);
+ Lycos Magellan PLweb SFgate Simple Verity Google z);
$W3Search_regex = join '|', @W3Search_engines;
-my $maxshow = 5;
+my $maxshow = 5;
sub W3Search {
- my ($where, $what, $type) = @_;
+ my ( $where, $what, $type ) = @_;
my $retval = "$where can't find \002$what\002";
my $Search;
my @matches = grep { lc($_) eq lc($where) ? $_ : undef } @W3Search_engines;
if (@matches) {
- $where = shift @matches;
- } else {
- &::msg($::who, "i don't know how to check '$where'");
- return;
+ $where = shift @matches;
+ }
+ else {
+ &::msg( $::who, "i don't know how to check '$where'" );
+ return;
}
return unless &::loadPerlModule("WWW::Search");
- eval {
- $Search = new WWW::Search($where, agent_name => 'Mozilla/4.5');
- };
+ eval { $Search = new WWW::Search( $where, agent_name => 'Mozilla/4.5' ); };
- if (!defined $Search) {
- &::msg($::who, "$where is invalid search.");
- return;
+ if ( !defined $Search ) {
+ &::msg( $::who, "$where is invalid search." );
+ return;
}
- my $Query = WWW::Search::escape_query($what);
- $Search->native_query($Query,
- {
- num => 10,
-# search_debug => 2,
-# search_parse_debug => 2,
- }
+ my $Query = WWW::Search::escape_query($what);
+ $Search->native_query(
+ $Query,
+ {
+ num => 10,
+
+ # search_debug => 2,
+ # search_parse_debug => 2,
+ }
);
- $Search->http_proxy($::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+ $Search->http_proxy( $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') );
+
#my $max = $Search->maximum_to_retrieve(10); # DOES NOT WORK.
- my (@results, $count, $r);
- $retval = "$where says \002$what\002 is at ";
- while ($r = $Search->next_result()) {
- my $url = $r->url();
- $retval .= ' or ' if ($count > 0);
- $retval .= $url;
- last if ++$count >= $maxshow;
+ my ( @results, $count, $r );
+ $retval = "$where says \002$what\002 is at ";
+ while ( $r = $Search->next_result() ) {
+ my $url = $r->url();
+ $retval .= ' or ' if ( $count > 0 );
+ $retval .= $url;
+ last if ++$count >= $maxshow;
}
&::performStrictReply($retval);
# put in a timeout.
my $no_weather;
-my $cache_time = 60 * 40 ; # 40 minute cache time
-my $default = 'KAGC';
+my $cache_time = 60 * 40; # 40 minute cache time
+my $default = 'KAGC';
BEGIN {
$no_weather = 0;
}
sub Weather {
- my ($args) = @_;
- &::performStrictReply(&queryText($args, 'weather'));
- return;
+ my ($args) = @_;
+ &::performStrictReply( &queryText( $args, 'weather' ) );
+ return;
}
sub Metar {
- my ($args) = @_;
- &::performStrictReply(&queryText($args, 'metar'));
- return;
+ my ($args) = @_;
+ &::performStrictReply( &queryText( $args, 'metar' ) );
+ return;
}
sub queryText {
my ($station) = shift;
- my ($wxmode) = shift;
+ my ($wxmode) = shift;
my $result;
$station = uc($station);
$station =~ s/for //i;
if ($no_weather) {
- return 0;
- } else {
-
- if (exists $cache{$station}) {
- my ($time, $response) = split $; , $cache{$station};
- if ((time() - $time) < $cache_time) {
- return $response;
- }
- }
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
-
- $ua->timeout(10);
- my $request = new HTTP::Request('GET', "http://weather.noaa.gov/weather/current/$station.html");
- my $response = $ua->request($request);
-
- if (!$response->is_success) {
- if ($response->code == 404) {
- return "I can't find station code \"$station\""
- . " (see http://www.nws.noaa.gov/oso/site.shtml"
- . " or http://www.nws.noaa.gov/tg/siteloc.shtml"
- . " for ICAO locations codes).";
- } else {
- return 'Something failed in connecting to the NOAA web'
- . " server. Try again later.";
- }
- }
-
- $content = $response->content;
- $content =~ s|.*?<BODY[^>]*>||is;
- #$content =~ s|.*?current weather conditions.*?<BR>([^<]*?)\s*<.*?</TR>||is;
- $content =~ s|.*?current weather conditions[^<]*(<[^>]+>\s*)+||is;
- $content =~ s|([^<]*?)\s*<.*?</TR>||is;
- my $place = $1;
- chomp $place;
-
- $content =~ s|.*?<TR>(?:\s*<[^>]+>)*\s*([^<]+)\s<.*?</TR>||is;
- my $id = $1;
- chomp $id;
-
- $content =~ s|.*?conditions at.*?</TD>||is;
-
- #$content =~ s|.*?<OPTION SELECTED>\s+([^<]+)\s<OPTION>.*?</TR>||s; # local time
- $content =~ s|.*?<BR>\s+([^<]+?)\s*</FORM>.*?</TR>||s; # UTC
- my $time = $1;
- $time =~ s/-//g;
- $time =~ s/\s+/ /g;
-
- $content =~ s|\s(.*?)<TD COLSPAN=2>||s;
- my $features = $1;
-
- while ($features =~ s|.*?<TD ALIGN[^>]*>(?:\s*<[^>]+>)*\s+([^<]+?)\s+<.*?<TD>(?:\s*<[^>]+>)*\s+([^<]+?)\s<.*?/TD>||s) {
- my ($f,$v) = ($1, $2);
- chomp $f; chomp $v;
- $feat{$f} = $v;
- }
-
- $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s; # max temp;
- $max_temp = $1;
- $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s;
- $min_temp = $1;
-
- if ($time) {
- if ($wxmode eq 'metar' && defined($feat{'ob'})) {
- return ('METAR ' . $place . ": " . $feat{'ob'});
- }
-
- $result = "$place; $id; last updated: $time";
- foreach (sort keys %feat) {
- next if $_ eq 'ob';
- $result .= "; $_: $feat{$_}";
- }
- my $t = time();
- $cache{$station} = join $;, $t, $result;
- } else {
- $result = "I can't find that station code (see http://weather.noaa.gov/weather/curcond.html for locations and codes)";
- }
- return $result;
+ return 0;
+ }
+ else {
+
+ if ( exists $cache{$station} ) {
+ my ( $time, $response ) = split $;, $cache{$station};
+ if ( ( time() - $time ) < $cache_time ) {
+ return $response;
+ }
+ }
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy( 'http', $::param{'httpProxy'} )
+ if ( &::IsParam('httpProxy') );
+
+ $ua->timeout(10);
+ my $request =
+ new HTTP::Request( 'GET',
+ "http://weather.noaa.gov/weather/current/$station.html" );
+ my $response = $ua->request($request);
+
+ if ( !$response->is_success ) {
+ if ( $response->code == 404 ) {
+ return "I can't find station code \"$station\""
+ . " (see http://www.nws.noaa.gov/oso/site.shtml"
+ . " or http://www.nws.noaa.gov/tg/siteloc.shtml"
+ . " for ICAO locations codes).";
+ }
+ else {
+ return 'Something failed in connecting to the NOAA web'
+ . " server. Try again later.";
+ }
+ }
+
+ $content = $response->content;
+ $content =~ s|.*?<BODY[^>]*>||is;
+
+ #$content =~ s|.*?current weather conditions.*?<BR>([^<]*?)\s*<.*?</TR>||is;
+ $content =~ s|.*?current weather conditions[^<]*(<[^>]+>\s*)+||is;
+ $content =~ s|([^<]*?)\s*<.*?</TR>||is;
+ my $place = $1;
+ chomp $place;
+
+ $content =~ s|.*?<TR>(?:\s*<[^>]+>)*\s*([^<]+)\s<.*?</TR>||is;
+ my $id = $1;
+ chomp $id;
+
+ $content =~ s|.*?conditions at.*?</TD>||is;
+
+#$content =~ s|.*?<OPTION SELECTED>\s+([^<]+)\s<OPTION>.*?</TR>||s; # local time
+ $content =~ s|.*?<BR>\s+([^<]+?)\s*</FORM>.*?</TR>||s; # UTC
+ my $time = $1;
+ $time =~ s/-//g;
+ $time =~ s/\s+/ /g;
+
+ $content =~ s|\s(.*?)<TD COLSPAN=2>||s;
+ my $features = $1;
+
+ while ( $features =~
+s|.*?<TD ALIGN[^>]*>(?:\s*<[^>]+>)*\s+([^<]+?)\s+<.*?<TD>(?:\s*<[^>]+>)*\s+([^<]+?)\s<.*?/TD>||s
+ )
+ {
+ my ( $f, $v ) = ( $1, $2 );
+ chomp $f;
+ chomp $v;
+ $feat{$f} = $v;
+ }
+
+ $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s; # max temp;
+ $max_temp = $1;
+ $content =~ s|.*?>(\d+\S+\s+\(\S+\)).*?</TD>||s;
+ $min_temp = $1;
+
+ if ($time) {
+ if ( $wxmode eq 'metar' && defined( $feat{'ob'} ) ) {
+ return ( 'METAR ' . $place . ": " . $feat{'ob'} );
+ }
+
+ $result = "$place; $id; last updated: $time";
+ foreach ( sort keys %feat ) {
+ next if $_ eq 'ob';
+ $result .= "; $_: $feat{$_}";
+ }
+ my $t = time();
+ $cache{$station} = join $;, $t, $result;
+ }
+ else {
+ $result =
+"I can't find that station code (see http://weather.noaa.gov/weather/curcond.html for locations and codes)";
+ }
+ return $result;
}
}
if (0) {
- if (-t STDIN) {
- my $result = Weather::NOAA::get($default);
- $result =~ s/; /\n/g;
- print "\n$result\n\n";
+ if ( -t STDIN ) {
+ my $result = Weather::NOAA::get($default);
+ $result =~ s/; /\n/g;
+ print "\n$result\n\n";
}
}
my $file = "$::infobot_base_dir/$::param{'ircUser'}.wingate";
my @hosts;
- open(IN, $file);
+ open( IN, $file );
while (<IN>) {
- chop;
- next if (/\*$/); # wingate. or forget about it?
- push(@hosts,$_);
+ chop;
+ next if (/\*$/); # wingate. or forget about it?
+ push( @hosts, $_ );
}
close IN;
foreach (@_) {
- next if (grep /^$_$/, @hosts);
+ next if ( grep /^$_$/, @hosts );
- &::DEBUG("W: _ => '$_'.");
- &Wingate($_);
+ &::DEBUG("W: _ => '$_'.");
+ &Wingate($_);
}
}
my ($host) = @_;
my $sock = IO::Socket::INET->new(
- PeerAddr => $host,
- PeerPort => 'telnet(23)',
- Proto => 'tcp'
+ PeerAddr => $host,
+ PeerPort => 'telnet(23)',
+ Proto => 'tcp'
### Timeout => 10, # enough :)
);
- if (!defined $sock) {
- &::status("Wingate: connection refused to $host");
- return;
+ if ( !defined $sock ) {
+ &::status("Wingate: connection refused to $host");
+ return;
}
$sock->timeout(10);
my $errors = 0;
my ($luser);
- foreach $luser ($select->can_read(1)) {
- my $buf;
- my $len = 0;
- if (!defined($len = sysread($luser, $buf, 512))) {
- &::status("Wingate: connection lost to $luser/$host.");
- $select->remove($luser);
- close($luser);
- next;
- }
-
- if ($len == 9) {
- $len = sysread($luser, $buf, 512);
- }
-
- my $wingate = 0;
- $wingate++ if ($buf =~ /^WinGate\>/);
- $wingate++ if ($buf =~ /^Too many connected users - try again later$/);
-
- if ($wingate) {
- &::status("Wingate: RUNNING ON $host BY $::who.");
-
- if (&::IsChanConf('wingateBan') > 0) {
- &::ban("*!*\@$host", '');
- }
-
- my $reason = &::getChanConf('wingateKick');
- if ($reason) {
- &::kick($::who, '', $reason);
- }
-
- push(@::wingateBad, "$host\*");
- &::wingateWriteFile();
- } else {
+ foreach $luser ( $select->can_read(1) ) {
+ my $buf;
+ my $len = 0;
+ if ( !defined( $len = sysread( $luser, $buf, 512 ) ) ) {
+ &::status("Wingate: connection lost to $luser/$host.");
+ $select->remove($luser);
+ close($luser);
+ next;
+ }
+
+ if ( $len == 9 ) {
+ $len = sysread( $luser, $buf, 512 );
+ }
+
+ my $wingate = 0;
+ $wingate++ if ( $buf =~ /^WinGate\>/ );
+ $wingate++
+ if ( $buf =~ /^Too many connected users - try again later$/ );
+
+ if ($wingate) {
+ &::status("Wingate: RUNNING ON $host BY $::who.");
+
+ if ( &::IsChanConf('wingateBan') > 0 ) {
+ &::ban( "*!*\@$host", '' );
+ }
+
+ my $reason = &::getChanConf('wingateKick');
+ if ($reason) {
+ &::kick( $::who, '', $reason );
+ }
+
+ push( @::wingateBad, "$host\*" );
+ &::wingateWriteFile();
+ }
+ else {
### &::DEBUG("no wingate.");
- }
+ }
- ### TODO: close telnet connection correctly!
- $select->remove($luser);
- close($luser);
+ ### TODO: close telnet connection correctly!
+ $select->remove($luser);
+ close($luser);
}
return;
use strict;
-my $no_zippy; # Can't think of any situation in which this won't work..
+my $no_zippy; # Can't think of any situation in which this won't work..
sub zippy::get {
my @yows;
&::DEBUG('Reading zippy data');
while (<DATA>) {
- chomp;
- push @yows, $_;
+ chomp;
+ push @yows, $_;
}
- if ($no_zippy) { # ..but just in case :-)
- return "YOW! I'm an INFOBOT without ZIPPY!" if $::addressed;
+ if ($no_zippy) { # ..but just in case :-)
+ return "YOW! I'm an INFOBOT without ZIPPY!" if $::addressed;
}
- srand(); # fork seems to not change rand. force it here
- my $yow = $yows[rand(@yows)];
+ srand(); # fork seems to not change rand. force it here
+ my $yow = $yows[ rand(@yows) ];
&::performStrictReply($yow);
}
BEGIN {
eval "use URI::Escape"; # utility functions for encoding the
- if ($@) { $no_babelfish++}; # babelfish request
+ if ($@) { $no_babelfish++ }
+ ; # babelfish request
eval "use LWP::UserAgent";
- if ($@) { $no_babelfish++};
+ if ($@) { $no_babelfish++ }
}
BEGIN {
- # Translate some feasible abbreviations into the ones babelfish
- # expects.
+
+ # Translate some feasible abbreviations into the ones babelfish
+ # expects.
use vars qw!%lang_code $lang_regex!;
%lang_code = (
- 'de' => 'de',
- 'ge' => 'de',
- 'gr' => 'el',
- 'el' => 'el',
- 'sp' => 'es',
- 'es' => 'es',
- 'en' => 'en',
- 'fr' => 'fr',
- 'it' => 'it',
- 'ja' => 'ja',
- 'jp' => 'ja',
- 'ko' => 'ko',
- 'kr' => 'ko',
- 'nl' => 'nl',
- 'po' => 'pt',
- 'pt' => 'pt',
- 'ru' => 'ru',
- 'zh' => 'zh',
- 'zt' => 'zt'
- );
-
- # Here's how we recognize the language you're asking for. It looks
- # like RTSL saves you a few keystrokes in #perl, huh?
- $lang_regex = join '|', keys %lang_code;
+ 'de' => 'de',
+ 'ge' => 'de',
+ 'gr' => 'el',
+ 'el' => 'el',
+ 'sp' => 'es',
+ 'es' => 'es',
+ 'en' => 'en',
+ 'fr' => 'fr',
+ 'it' => 'it',
+ 'ja' => 'ja',
+ 'jp' => 'ja',
+ 'ko' => 'ko',
+ 'kr' => 'ko',
+ 'nl' => 'nl',
+ 'po' => 'pt',
+ 'pt' => 'pt',
+ 'ru' => 'ru',
+ 'zh' => 'zh',
+ 'zt' => 'zt'
+ );
+
+ # Here's how we recognize the language you're asking for. It looks
+ # like RTSL saves you a few keystrokes in #perl, huh?
+ $lang_regex = join '|', keys %lang_code;
}
sub babelfishParam {
return '' if $no_babelfish;
- my ($from, $to, $phrase) = @_;
- &::DEBUG("babelfish($from, $to, $phrase)");
+ my ( $from, $to, $phrase ) = @_;
+ &::DEBUG("babelfish($from, $to, $phrase)");
+
+ $from = $lang_code{$from};
+ $to = $lang_code{$to};
- $from = $lang_code{$from};
- $to = $lang_code{$to};
+ my $ua = new LWP::UserAgent;
+ $ua->proxy( 'http', $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') );
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
- # Let's pretend
- $ua->agent("Mozilla/5.0 " . $ua->agent);
- $ua->timeout(5);
+ # Let's pretend
+ $ua->agent( "Mozilla/5.0 " . $ua->agent );
+ $ua->timeout(5);
- my $req = HTTP::Request->new('POST', $url);
+ my $req = HTTP::Request->new( 'POST', $url );
-# babelfish ignored this, but it SHOULD work
-# Accept-Charset: iso-8859-1
-# $req->header('Accept-Charset' => 'iso-8859-1');
-# print $req->header('Accept-Charset');
- $req->header('Accept-Language' => 'en');
- $req->content_type('application/x-www-form-urlencoded');
+ # babelfish ignored this, but it SHOULD work
+ # Accept-Charset: iso-8859-1
+ # $req->header('Accept-Charset' => 'iso-8859-1');
+ # print $req->header('Accept-Charset');
+ $req->header( 'Accept-Language' => 'en' );
+ $req->content_type('application/x-www-form-urlencoded');
- return translate($phrase, "${from}_${to}", $req, $ua);
+ return translate( $phrase, "${from}_${to}", $req, $ua );
}
sub translate {
return '' if $no_babelfish;
- my ($phrase, $languagepair, $req, $ua) = @_;
- &::DEBUG("translate($phrase, $languagepair, $req, $ua)");
+ my ( $phrase, $languagepair, $req, $ua ) = @_;
+ &::DEBUG("translate($phrase, $languagepair, $req, $ua)");
+
+ my $trtext = uri_escape($phrase);
+ $req->content("trtext=$trtext&lp=$languagepair");
+ &::DEBUG("$url??trtext=$trtext&lp=$languagepair");
+
+ my $res = $ua->request($req);
+ my $translated;
- my $trtext = uri_escape($phrase);
- $req->content("trtext=$trtext&lp=$languagepair");
- &::DEBUG("$url??trtext=$trtext&lp=$languagepair");
+ if ( $res->is_success ) {
+ my $html = $res->content;
- my $res = $ua->request($req);
- my $translated;
+ # This method subject to change with the whims of Altavista's design
+ # staff.
+ ($translated) = $html;
- if ($res->is_success) {
- my $html = $res->content;
- # This method subject to change with the whims of Altavista's design
- # staff.
- ($translated) = $html;
+ $translated =~ s/<[^>]*>//sg;
+ $translated =~ s/ / /sg;
+ $translated =~ s/\s+/ /sg;
- $translated =~ s/<[^>]*>//sg;
- $translated =~ s/ / /sg;
- $translated =~ s/\s+/ /sg;
- #&::DEBUG("$translated\n===remove <attributes>\n");
+ #&::DEBUG("$translated\n===remove <attributes>\n");
- $translated =~ s/\s*Translate again.*//i;
- &::DEBUG("$translated\n===remove after 'Translate again'\n");
+ $translated =~ s/\s*Translate again.*//i;
+ &::DEBUG("$translated\n===remove after 'Translate again'\n");
- $translated =~ s/[^:]*?:\s*(Help\s*)?//s;
- &::DEBUG("len=" . length($translated) . " $translated\n===remove to first ':', optional Help\n");
+ $translated =~ s/[^:]*?:\s*(Help\s*)?//s;
+ &::DEBUG( "len="
+ . length($translated)
+ . " $translated\n===remove to first ':', optional Help\n" );
- $translated =~ s/\n/ /g;
- # FIXME: should we do unicode->iso (no. use utf8!)
- } else {
- $translated = ":("; # failure
- }
- $translated = "babelfish.pl: result too long, probably an error" if (length($translated) > 700);
+ $translated =~ s/\n/ /g;
- return $translated
+ # FIXME: should we do unicode->iso (no. use utf8!)
+ }
+ else {
+ $translated = ":("; # failure
+ }
+ $translated = "babelfish.pl: result too long, probably an error"
+ if ( length($translated) > 700 );
+
+ return $translated;
}
sub babelfish {
- my ($message) = @_;
- my $babel_lang_regex = "de|ge|gr|el|sp|es|en|fr|it|ja|jp|ko|kr|nl|po|pt|ru|zh|zt";
- if ($message =~ m{
+ my ($message) = @_;
+ my $babel_lang_regex =
+ "de|ge|gr|el|sp|es|en|fr|it|ja|jp|ko|kr|nl|po|pt|ru|zh|zt";
+ if (
+ $message =~ m{
($babel_lang_regex)\w* # from language?
\s+
($babel_lang_regex)\w* # to language?
\s*
(.+) # The phrase to be translated
- }xoi) {
- &::performStrictReply(&babelfishParam(lc $1, lc $2, lc $3));
- }
- return;
+ }xoi
+ )
+ {
+ &::performStrictReply( &babelfishParam( lc $1, lc $2, lc $3 ) );
+ }
+ return;
}
if (0) {
- if (-t STDIN) {
- #my $result = babelfish::babelfish('en sp hello world');
- #my $result = babelfish::babelfish('en sp The cheese is old and moldy, where is the bathroom?');
- my $result = babelfish::babelfish('en gr doesn\'t seem to translate things longer than 40 characters');
- $result =~ s/; /\n/g;
- print "Babelfish says: \"$result\"\n";
+ if ( -t STDIN ) {
+
+#my $result = babelfish::babelfish('en sp hello world');
+#my $result = babelfish::babelfish('en sp The cheese is old and moldy, where is the bathroom?');
+ my $result =
+ babelfish::babelfish(
+ 'en gr doesn\'t seem to translate things longer than 40 characters'
+ );
+ $result =~ s/; /\n/g;
+ print "Babelfish says: \"$result\"\n";
}
}
use strict;
sub parse {
- my($what) = @_;
+ my ($what) = @_;
- if (!defined $what or $what =~ /^\s*$/) {
- &::help('botmail');
- return;
+ if ( !defined $what or $what =~ /^\s*$/ ) {
+ &::help('botmail');
+ return;
}
- if ($what =~ /^(to|for|add)\s+(.*)$/i) {
- &add( split(/\s+/, $2, 2) );
+ if ( $what =~ /^(to|for|add)\s+(.*)$/i ) {
+ &add( split( /\s+/, $2, 2 ) );
- } elsif ($what =~ /^stats?$/i) {
- &stats();
+ }
+ elsif ( $what =~ /^stats?$/i ) {
+ &stats();
- } elsif ($what =~ /^check?$/i) {
- &check( $1, 1);
+ }
+ elsif ( $what =~ /^check?$/i ) {
+ &check( $1, 1 );
- } elsif ($what =~ /^(read|next)$/i) {
- # TODO: read specific items? nah, will make this too complex.
- &next($::who);
+ }
+ elsif ( $what =~ /^(read|next)$/i ) {
+
+ # TODO: read specific items? nah, will make this too complex.
+ &next($::who);
}
}
sub stats {
- my $botmail = &::countKeys('botmail');
- &::msg($::who, "I have \002$botmail\002 ". &::fixPlural('message', $botmail). ".");
+ my $botmail = &::countKeys('botmail');
+ &::msg( $::who,
+ "I have \002$botmail\002 "
+ . &::fixPlural( 'message', $botmail )
+ . "." );
}
#####
# Usage: botmail::check($recipient, [$always])
sub check {
- my($recipient, $always) = @_;
+ my ( $recipient, $always ) = @_;
$recipient ||= $::who;
- my %from = &::sqlSelectColHash('botmail', "srcwho,time", {
- dstwho => lc $recipient
- } );
- my $t = keys %from;
- my $from = join(", ", keys %from);
+ my %from =
+ &::sqlSelectColHash( 'botmail', "srcwho,time",
+ { dstwho => lc $recipient } );
+ my $t = keys %from;
+ my $from = join( ", ", keys %from );
- if ($t == 0) {
- &::msg($recipient, "You have no botmail.") if ($always);
- } else {
- &::msg($recipient, "You have $t messages awaiting, from: $from (botmail read)");
+ if ( $t == 0 ) {
+ &::msg( $recipient, "You have no botmail." ) if ($always);
+ }
+ else {
+ &::msg( $recipient,
+ "You have $t messages awaiting, from: $from (botmail read)" );
}
}
#####
# Usage: botmail::next($recipient)
sub next {
- my($recipient) = @_;
-
- my %hash = &::sqlSelectRowHash('botmail', '*', {
- dstwho => lc $recipient
- } );
-
- if (scalar (keys %hash) <= 1) {
- &::msg($recipient, "You have no botmail.");
- } else {
- my $date = scalar(gmtime $hash{'time'});
- my $ago = &::Time2String(time() - $hash{'time'});
- &::msg($recipient, "From $hash{srcwho} ($hash{srcuh}) on $date ($ago ago):");
- &::msg($recipient, $hash{'msg'});
- &::sqlDelete('botmail', { 'dstwho'=>$hash{dstwho}, 'srcwho'=>$hash{srcwho}});
+ my ($recipient) = @_;
+
+ my %hash =
+ &::sqlSelectRowHash( 'botmail', '*', { dstwho => lc $recipient } );
+
+ if ( scalar( keys %hash ) <= 1 ) {
+ &::msg( $recipient, "You have no botmail." );
+ }
+ else {
+ my $date = scalar( gmtime $hash{'time'} );
+ my $ago = &::Time2String( time() - $hash{'time'} );
+ &::msg( $recipient,
+ "From $hash{srcwho} ($hash{srcuh}) on $date ($ago ago):" );
+ &::msg( $recipient, $hash{'msg'} );
+ &::sqlDelete( 'botmail',
+ { 'dstwho' => $hash{dstwho}, 'srcwho' => $hash{srcwho} } );
}
}
#####
# Usage: botmail::add($recipient, $msg)
sub add {
- my($recipient, $msg) = @_;
+ my ( $recipient, $msg ) = @_;
&::DEBUG("botmail::add(@_)");
# allow optional trailing : ie: botmail for foo[:] hello
$recipient =~ s/:$//;
- # only support 1 botmail with unique dstwho/srcwho to have same
- # functionality as botmail from infobot.
- # Note: I removed the &::sqlQuote reference. Seems to be working and inserting fine without it here. -- troubled
- my %hash = &::sqlSelectRowHash('botmail', '*', {
- srcwho => lc $::who,
- dstwho => lc $recipient
- } );
-
- if (scalar (keys %hash) > 1) {
- &::msg($::who, "$recipient already has a message queued from you");
- return;
+# only support 1 botmail with unique dstwho/srcwho to have same
+# functionality as botmail from infobot.
+# Note: I removed the &::sqlQuote reference. Seems to be working and inserting fine without it here. -- troubled
+ my %hash = &::sqlSelectRowHash(
+ 'botmail',
+ '*',
+ {
+ srcwho => lc $::who,
+ dstwho => lc $recipient
+ }
+ );
+
+ if ( scalar( keys %hash ) > 1 ) {
+ &::msg( $::who, "$recipient already has a message queued from you" );
+ return;
}
- &::sqlInsert('botmail', {
- 'dstwho' => lc $recipient,
- 'srcwho' => lc $::who,
- 'srcuh' => $::nuh,
- 'time' => time(),
- 'msg' => $msg,
- } );
-
- &::msg($::who, "OK, $::who, I'll let $recipient know.");
+ &::sqlInsert(
+ 'botmail',
+ {
+ 'dstwho' => lc $recipient,
+ 'srcwho' => lc $::who,
+ 'srcuh' => $::nuh,
+ 'time' => time(),
+ 'msg' => $msg,
+ }
+ );
+
+ &::msg( $::who, "OK, $::who, I'll let $recipient know." );
}
1;
package case;
sub upper {
- my($message) = @_;
+ my ($message) = @_;
+
# make it green like an old terminal
- &::performStrictReply("\00303" . uc $message);
+ &::performStrictReply( "\00303" . uc $message );
}
sub lower {
- my($message) = @_;
- &::performStrictReply(lc $message);
+ my ($message) = @_;
+ &::performStrictReply( lc $message );
}
1;
sub countdown {
my ($query) = @_;
- my $file = "$bot_base_dir/$param{'ircUser'}.countdown";
- my (%date, %desc);
+ my $file = "$bot_data_dir/$param{'ircUser'}.countdown";
+ my ( %date, %desc );
my $reply;
- if (!open(IN,$file)) {
- &ERROR("cannot open $file.");
- return 0;
+ if ( !open( IN, $file ) ) {
+ &ERROR("cannot open $file.");
+ return 0;
}
while (<IN>) {
- chop;
- s/[\s\t]+/ /g;
+ chop;
+ s/[\s\t]+/ /g;
- if (/^(\d{8}) (\S+) (.*)$/) {
- $date{$2} = $1;
- $desc{$2} = $3;
- }
+ if (/^(\d{8}) (\S+) (.*)$/) {
+ $date{$2} = $1;
+ $desc{$2} = $3;
+ }
}
close IN;
- if (defined $query) { # argument.
- if (!exists $date{$query}) {
- &msg($who,"error: $query is not in my countdown list.");
- return 0;
- }
-
- $date{$query} =~ /^(\d{4})(\d{2})(\d{2})$/;
- my($year,$month,$day) = ($1,$2,$3);
- my $sqldate = "$1-$2-$3";
-
- ### SQL SPECIFIC.
- my ($to_days,$dayname,$monname);
-
- if ($param{'DBType'} =~ /^(mysql|sqlite(2)?)$/i) {
- $to_days = (&sqlRawReturn("SELECT TO_DAYS(NOW()) - TO_DAYS('$sqldate')"))[0];
- $dayname = (&sqlRawReturn("SELECT DAYNAME('$sqldate')"))[0];
- $monname = (&sqlRawReturn("SELECT MONTHNAME('$sqldate')"))[0];
-
- } elsif ($param{'DBType'} =~ /^pgsql$/i) {
- $to_days = (&sqlRawReturn("SELECT date_trunc('day',
- 'now'::timestamp - '$sqldate')"))[0];
- $dayname = qw(Sun Mon Tue Wed Thu Fri Sat)[(&sqlRawReturn("SELECT extract(dow from timestamp '$sqldate')"))[0]];
- $monname = qw(BAD Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[(&sqlRawReturn("SELECT extract(month from timestamp '$sqldate')"))[0]];
-
- } else {
- &ERROR("countdown: invalid DBType " . $param{'DBType'} . ".");
- return 1;
- }
-
- if ($to_days =~ /^\D+$/) {
- my $str = "to_days is not integer.";
- &msg($who,$str);
- &ERROR($str);
-
- return 1;
- }
-
- my @gmtime = gmtime(time());
- my $daysec = ($gmtime[2]*60*60) + ($gmtime[1]*60) + ($gmtime[0]);
- my $time = ($to_days*24*60*60);
-
- if ($to_days >= 0) { # already passed.
- $time += $daysec;
- $reply = "T plus ". &Time2String($time) ." ago";
- } else { # time to go.
- $time = -$time - $daysec;
- $reply = "T minus ". &Time2String($time);
- }
- $reply .= ", \002(\002$desc{$query}\002)\002 at $dayname, $monname $day $year";
-
- &performStrictReply($reply .".");
- return 1;
- } else { # no argument.
- my $prefix = "countdown list ";
-
- &performStrictReply( &formListReply(0, $prefix, sort keys %date) );
-
- return 1;
+ if ( defined $query ) { # argument.
+ if ( !exists $date{$query} ) {
+ &msg( $who, "error: $query is not in my countdown list." );
+ return 0;
+ }
+
+ $date{$query} =~ /^(\d{4})(\d{2})(\d{2})$/;
+ my ( $year, $month, $day ) = ( $1, $2, $3 );
+ my $sqldate = "$1-$2-$3";
+
+ ### SQL SPECIFIC.
+ my ( $to_days, $dayname, $monname );
+
+ if ( $param{'DBType'} =~ /^(mysql|sqlite(2)?)$/i ) {
+ $to_days =
+ ( &sqlRawReturn("SELECT TO_DAYS(NOW()) - TO_DAYS('$sqldate')") )
+ [0];
+ $dayname = ( &sqlRawReturn("SELECT DAYNAME('$sqldate')") )[0];
+ $monname = ( &sqlRawReturn("SELECT MONTHNAME('$sqldate')") )[0];
+
+ }
+ elsif ( $param{'DBType'} =~ /^pgsql$/i ) {
+ $to_days = (
+ &sqlRawReturn(
+ "SELECT date_trunc('day',
+ 'now'::timestamp - '$sqldate')"
+ )
+ )[0];
+ $dayname = qw(Sun Mon Tue Wed Thu Fri Sat) [
+ (
+ &sqlRawReturn(
+ "SELECT extract(dow from timestamp '$sqldate')")
+ )[0]
+ ];
+ $monname = qw(BAD Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) [
+ (
+ &sqlRawReturn(
+ "SELECT extract(month from timestamp '$sqldate')")
+ )[0]
+ ];
+
+ }
+ else {
+ &ERROR( "countdown: invalid DBType " . $param{'DBType'} . "." );
+ return 1;
+ }
+
+ if ( $to_days =~ /^\D+$/ ) {
+ my $str = "to_days is not integer.";
+ &msg( $who, $str );
+ &ERROR($str);
+
+ return 1;
+ }
+
+ my @gmtime = gmtime( time() );
+ my $daysec =
+ ( $gmtime[2] * 60 * 60 ) + ( $gmtime[1] * 60 ) + ( $gmtime[0] );
+ my $time = ( $to_days * 24 * 60 * 60 );
+
+ if ( $to_days >= 0 ) { # already passed.
+ $time += $daysec;
+ $reply = "T plus " . &Time2String($time) . " ago";
+ }
+ else { # time to go.
+ $time = -$time - $daysec;
+ $reply = "T minus " . &Time2String($time);
+ }
+ $reply .=
+ ", \002(\002$desc{$query}\002)\002 at $dayname, $monname $day $year";
+
+ &performStrictReply( $reply . "." );
+ return 1;
+ }
+ else { # no argument.
+ my $prefix = "countdown list ";
+
+ &performStrictReply( &formListReply( 0, $prefix, sort keys %date ) );
+
+ return 1;
}
}
use warnings;
sub dice::roll_array ($) {
- my($line) = shift;
+ my ($line) = shift;
- my(@throws) = ();
+ my (@throws) = ();
return @throws unless $line =~ m{
^ # beginning of line
(\d+)? # optional count in $1
| # or
% # a percent sign for d% = d100
)
- }x; # whitespace allowed
+ }x; # whitespace allowed
- my($num) = $1 || 1;
- my($type) = $2;
+ my ($num) = $1 || 1;
+ my ($type) = $2;
return @throws if $num > 100;
- $type = 100 if $type eq '%';
+ $type = 100 if $type eq '%';
return @throws if $type < 2;
- for( 1 .. $num ) {
- push @throws, int (rand $type) + 1;
+ for ( 1 .. $num ) {
+ push @throws, int( rand $type ) + 1;
}
return @throws;
}
sub dice::roll ($) {
- my($line) = shift;
+ my ($line) = shift;
$line =~ s/ //g;
([-+xX*/bB]) # a + - * / b(est) in $2
(\d+) # an offset in $3
)? # both of those last are optional
- }x; # whitespace allowed in re
+ }x; # whitespace allowed in re
- my($dice_string) = $1;
- my($sign) = $2 || '';
- my($offset) = $3 || 0;
+ my ($dice_string) = $1;
+ my ($sign) = $2 || '';
+ my ($offset) = $3 || 0;
$sign = lc $sign;
- my(@throws) = roll_array( $dice_string );
+ my (@throws) = roll_array($dice_string);
return '' unless @throws > 0;
- my($retval) = "rolled " . join(',', @throws);
+ my ($retval) = "rolled " . join( ',', @throws );
- my(@result);
- if( $sign eq 'b' ) {
+ my (@result);
+ if ( $sign eq 'b' ) {
$offset = 0 if $offset < 0;
$offset = @throws if $offset > @throws;
- @throws = sort { $b <=> $a } @throws; # sort numerically, descending
- @result = @throws[ 0 .. $offset-1 ]; # pick off the $offset first ones
- $retval .= " best $offset";
- } else {
+ @throws = sort { $b <=> $a } @throws; # sort numerically, descending
+ @result = @throws[ 0 .. $offset - 1 ]; # pick off the $offset first ones
+ $retval .= " best $offset";
+ }
+ else {
@result = @throws;
$retval .= " $sign $offset" if $sign;
}
- my($sum) = 0;
+ my ($sum) = 0;
$sum += $_ foreach @result;
- $sum += $offset if $sign eq '+';
- $sum -= $offset if $sign eq '-';
- $sum *= $offset if ($sign eq '*' || $sign eq 'x');
+ $sum += $offset if $sign eq '+';
+ $sum -= $offset if $sign eq '-';
+ $sum *= $offset if ( $sign eq '*' || $sign eq 'x' );
do { $sum /= $offset; $sum = int $sum; } if $sign eq '/';
return "$retval = $sum";
sub dice::dice {
my ($message) = @_;
- srand(); # fork seems to not change rand. force it here
+ srand(); # fork seems to not change rand. force it here
my $retval = roll($message);
&::performStrictReply($retval);
use strict;
sub dns::dns {
- my $dns = shift;
- my($match, $x, $y, $result, $pid);
+ my $dns = shift;
+ my ( $match, $x, $y, $result, $pid );
- if ($dns =~ /(\d+\.\d+\.\d+\.\d+)/) {
- use Socket;
+ if ( $dns =~ /(\d+\.\d+\.\d+\.\d+)/ ) {
+ use Socket;
- &::status("DNS query by IP address: $dns");
+ &::status("DNS query by IP address: $dns");
- $y = pack('C4', split(/\./, $dns));
- $x = (gethostbyaddr($y, &AF_INET));
+ $y = pack( 'C4', split( /\./, $dns ) );
+ $x = ( gethostbyaddr( $y, &AF_INET ) );
- if ($x !~ /^\s*$/) {
- $result = "$dns is $x" unless ($x =~ /^\s*$/);
- } else {
- $result = "I can't find the address $dns in DNS";
- }
+ if ( $x !~ /^\s*$/ ) {
+ $result = "$dns is $x" unless ( $x =~ /^\s*$/ );
+ }
+ else {
+ $result = "I can't find the address $dns in DNS";
+ }
- } else {
+ }
+ else {
- &::status("DNS query by name: $dns");
- $x = join('.',unpack('C4',(gethostbyname($dns))[4]));
+ &::status("DNS query by name: $dns");
+ $x = join( '.', unpack( 'C4', ( gethostbyname($dns) )[4] ) );
- if ($x !~ /^\s*$/) {
- $result = "$dns is $x";
- } else {
- $result = "I can't find $dns in DNS";
- }
- }
+ if ( $x !~ /^\s*$/ ) {
+ $result = "$dns is $x";
+ }
+ else {
+ $result = "I can't find $dns in DNS";
+ }
+ }
- return($result);
+ return ($result);
}
sub dns::query {
- &::performStrictReply(&dns(@_));
- return;
+ &::performStrictReply( &dns(@_) );
+ return;
}
1;
push @conv, hex($3);
push @conv, hex($4);
- $result = uc "$hexstr = " . join(".", @conv);
- } else {
+ $result = uc "$hexstr = " . join( ".", @conv );
+ }
+ else {
$result = "Invalid string: $hexstr";
}
- return($result);
+ return ($result);
}
sub hex2ip::query {
- &::performStrictReply(&convert(@_));
- return;
+ &::performStrictReply( &convert(@_) );
+ return;
}
1;
my @nouns;
&::DEBUG('Reading insult data');
while (<DATA>) {
- chomp;
- push(@adjs, split(' ', $1)) if /^adj\s*(.*)/;
- push(@amts, split(' ', $1)) if /^amt\s*(.*)/;
- push(@nouns, split(' ', $1)) if /^noun\s*(.*)/;
+ chomp;
+ push( @adjs, split( ' ', $1 ) ) if /^adj\s*(.*)/;
+ push( @amts, split( ' ', $1 ) ) if /^amt\s*(.*)/;
+ push( @nouns, split( ' ', $1 ) ) if /^noun\s*(.*)/;
}
- grep(s/\|/ /g, @adjs);
- grep(s/\|/ /g, @amts);
- grep(s/\|/ /g, @nouns);
- srand(); # fork seems to not change rand. force it here
- my $adj = @adjs[rand(@adjs)];
+ grep( s/\|/ /g, @adjs );
+ grep( s/\|/ /g, @amts );
+ grep( s/\|/ /g, @nouns );
+ srand(); # fork seems to not change rand. force it here
+ my $adj = @adjs[ rand(@adjs) ];
my $n;
$n = 'n' if $adj =~ /^[aeiouih]/;
- my $amt = @amts[rand(@amts)];
- my $adj2 = @adjs[rand(@adjs)];
- my $noun = @nouns[rand(@nouns)];
+ my $amt = @amts[ rand(@amts) ];
+ my $adj2 = @adjs[ rand(@adjs) ];
+ my $noun = @nouns[ rand(@nouns) ];
my $whois = "$insultwho is";
- $whois = 'You are' if ($insultwho eq $::who or $insultwho eq 'me');
+ $whois = 'You are' if ( $insultwho eq $::who or $insultwho eq 'me' );
&::performStrictReply("$whois nothing but a$n $adj $amt of $adj2 $noun");
}
package md5;
sub md5 {
- my($message) = @_;
+ my ($message) = @_;
return unless &::loadPerlModule('Digest::MD5');
- &::performStrictReply(&Digest::MD5::md5_hex($message));
+ &::performStrictReply( &Digest::MD5::md5_hex($message) );
}
1;
use strict;
-my $pi = 3.14159265;
-my $score = 0;
-my $verbose = 0;
+my $pi = 3.14159265;
+my $score = 0;
+my $verbose = 0;
sub query {
- my ($message) = @_;
-
- my $term = (lc $message eq 'me') ? $::who : $message;
+ my ($message) = @_;
+
+ my $term = ( lc $message eq 'me' ) ? $::who : $message;
+
+ if ( $term =~ /^$::mask{chan}$/ ) {
+ &::status("Doing nickometer for chan $term.");
+
+ if ( !&::validChan($term) ) {
+ &::msg( $::who, "error: channel is invalid." );
+ return;
+ }
+
+ # step 1.
+ my %nickometer;
+ foreach ( keys %{ $::channels{ lc $term }{''} } ) {
+ my $str = $_;
+ if ( !defined $str ) {
+ &WARN("nickometer: nick in chan $term undefined?");
+ next;
+ }
+
+ my $value = &nickometer($str);
+ $nickometer{$value}{$str} = 1;
+ }
+
+ # step 2.
+ ### TODO: compact with map?
+ my @list;
+ foreach ( sort { $b <=> $a } keys %nickometer ) {
+ my $str = join( ', ', sort keys %{ $nickometer{$_} } );
+ push( @list, "$str ($_%)" );
+ }
+
+ &::performStrictReply(
+ &::formListReply( 0, "Nickometer list for $term ", @list ) );
+
+ return;
+ }
- if ($term =~ /^$::mask{chan}$/) {
- &::status("Doing nickometer for chan $term.");
+ my $percentage = &nickometer($term);
- if (!&::validChan($term)) {
- &::msg($::who, "error: channel is invalid.");
- return;
+ if ( $percentage =~ /NaN/ ) {
+ $percentage = 'off the scale';
}
-
- # step 1.
- my %nickometer;
- foreach (keys %{ $::channels{lc $term}{''} }) {
- my $str = $_;
- if (!defined $str) {
- &WARN("nickometer: nick in chan $term undefined?");
- next;
- }
-
- my $value = &nickometer($str);
- $nickometer{$value}{$str} = 1;
+ else {
+ $percentage = sprintf( "%0.4f", $percentage );
+ $percentage =~ s/(\.\d+)0+$/$1/;
+ $percentage .= '%';
}
- # step 2.
- ### TODO: compact with map?
- my @list;
- foreach (sort {$b <=> $a} keys %nickometer) {
- my $str = join(', ', sort keys %{ $nickometer{$_} });
- push(@list, "$str ($_%)");
+ if ( $::msgType eq 'public' ) {
+ &::say("'$term' is $percentage lame, $::who");
+ }
+ else {
+ &::msg( $::who,
+ "the 'lame nick-o-meter' reading for $term is $percentage, $::who"
+ );
}
-
- &::performStrictReply( &::formListReply(0, "Nickometer list for $term ", @list) );
return;
- }
-
- my $percentage = &nickometer($term);
-
- if ($percentage =~ /NaN/) {
- $percentage = 'off the scale';
- } else {
- $percentage = sprintf("%0.4f", $percentage);
- $percentage =~ s/(\.\d+)0+$/$1/;
- $percentage .= '%';
- }
-
- if ($::msgType eq 'public') {
- &::say("'$term' is $percentage lame, $::who");
- } else {
- &::msg($::who, "the 'lame nick-o-meter' reading for $term is $percentage, $::who");
- }
-
- return;
}
sub nickometer ($) {
- my ($text) = @_;
- $score = 0;
+ my ($text) = @_;
+ $score = 0;
-# return unless &loadPerlModule("Getopt::Std");
- return unless &::loadPerlModule("Math::Trig");
+ # return unless &loadPerlModule("Getopt::Std");
+ return unless &::loadPerlModule("Math::Trig");
- if (!defined $text) {
- &::DEBUG("nickometer: arg == NULL. $text");
- return;
- }
-
- # Deal with special cases (precede with \ to prevent de-k3wlt0k)
- my %special_cost = (
- '69' => 500,
- 'dea?th' => 500,
- 'dark' => 400,
- 'n[i1]ght' => 300,
- 'n[i1]te' => 500,
- 'fuck' => 500,
- 'sh[i1]t' => 500,
- 'coo[l1]' => 500,
- 'kew[l1]' => 500,
- 'lame' => 500,
- 'dood' => 500,
- 'dude' => 500,
- '[l1](oo?|u)[sz]er' => 500,
- '[l1]eet' => 500,
- 'e[l1]ite' => 500,
- '[l1]ord' => 500,
- 'pron' => 1000,
- 'warez' => 1000,
- 'xx' => 100,
- '\[rkx]0' => 1000,
- '\0[rkx]' => 1000,
- );
-
- foreach my $special (keys %special_cost) {
- my $special_pattern = $special;
- my $raw = ($special_pattern =~ s/^\\//);
- my $nick = $text;
- unless (defined $raw) {
- $nick =~ tr/023457+8/ozeasttb/;
+ if ( !defined $text ) {
+ &::DEBUG("nickometer: arg == NULL. $text");
+ return;
+ }
+
+ # Deal with special cases (precede with \ to prevent de-k3wlt0k)
+ my %special_cost = (
+ '69' => 500,
+ 'dea?th' => 500,
+ 'dark' => 400,
+ 'n[i1]ght' => 300,
+ 'n[i1]te' => 500,
+ 'fuck' => 500,
+ 'sh[i1]t' => 500,
+ 'coo[l1]' => 500,
+ 'kew[l1]' => 500,
+ 'lame' => 500,
+ 'dood' => 500,
+ 'dude' => 500,
+ '[l1](oo?|u)[sz]er' => 500,
+ '[l1]eet' => 500,
+ 'e[l1]ite' => 500,
+ '[l1]ord' => 500,
+ 'pron' => 1000,
+ 'warez' => 1000,
+ 'xx' => 100,
+ '\[rkx]0' => 1000,
+ '\0[rkx]' => 1000,
+ );
+
+ foreach my $special ( keys %special_cost ) {
+ my $special_pattern = $special;
+ my $raw = ( $special_pattern =~ s/^\\// );
+ my $nick = $text;
+ unless ( defined $raw ) {
+ $nick =~ tr/023457+8/ozeasttb/;
+ }
+ &punish( $special_cost{$special},
+ "matched special case /$special_pattern/" )
+ if ( defined $nick and $nick =~ /$special_pattern/i );
}
- &punish($special_cost{$special}, "matched special case /$special_pattern/")
- if (defined $nick and $nick =~ /$special_pattern/i);
- }
- # Allow Perl referencing
- $text =~ s/^\\([A-Za-z])/$1/;
+ # Allow Perl referencing
+ $text =~ s/^\\([A-Za-z])/$1/;
- # C-- ain't so bad either
- $text =~ s/^C--$/C/;
+ # C-- ain't so bad either
+ $text =~ s/^C--$/C/;
- # Punish consecutive non-alphas
- $text =~ s/([^A-Za-z0-9]{2,})
+ # Punish consecutive non-alphas
+ $text =~ s/([^A-Za-z0-9]{2,})
/my $consecutive = length($1);
&punish(&slow_pow(10, $consecutive),
"$consecutive total consecutive non-alphas")
$1
/egx;
- # Remove balanced brackets (and punish a little bit) and punish for unmatched
- while ($text =~ s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x ||
- $text =~ s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x ||
- $text =~ s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x)
- {
- print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
- &punish(15, 'brackets');
- }
- my $parentheses = $text =~ tr/(){}[]/(){}[]/;
- &punish(&slow_pow(10, $parentheses),
- "$parentheses unmatched " .
- ($parentheses == 1 ? 'parenthesis' : 'parentheses'))
- if $parentheses;
-
- # Punish k3wlt0k
- my @k3wlt0k_weights = (5, 5, 2, 5, 2, 3, 1, 2, 2, 2);
- for my $digit (0 .. 9) {
- my $occurrences = $text =~ s/$digit/$digit/g || 0;
- &punish($k3wlt0k_weights[$digit] * $occurrences * 30,
- $occurrences . ' ' .
- (($occurrences == 1) ? 'occurrence' : 'occurrences') .
- " of $digit")
- if $occurrences;
- }
-
- # An alpha caps is not lame in middle or at end, provided the first
- # alpha is caps.
- my $orig_case = $text;
- $text =~ s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
-
- # A caps first alpha is sometimes not lame
- $text =~ s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
-
- # Punish uppercase to lowercase shifts and vice-versa, modulo
- # exceptions above
- my $case_shifts = &case_shifts($orig_case);
- &punish(&slow_pow(9, $case_shifts),
- $case_shifts . ' case ' .
- (($case_shifts == 1) ? 'shift' : 'shifts'))
- if ($case_shifts > 1 && /[A-Z]/);
-
- # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
- &punish(50, 'last alpha lame') if $orig_case =~ /[XZ][^a-zA-Z]*$/;
-
- # Punish letter to numeric shifts and vice-versa
- my $number_shifts = &number_shifts($_);
- &punish(&slow_pow(9, $number_shifts),
- $number_shifts . ' letter/number ' .
- (($number_shifts == 1) ? 'shift' : 'shifts'))
- if $number_shifts > 1;
-
- # Punish extraneous caps
- my $caps = $text =~ tr/A-Z/A-Z/;
- &punish(&slow_pow(7, $caps), "$caps extraneous caps") if $caps;
-
- # One and only one trailing underscore is OK.
- $text =~ s/\_$//;
-
- # Now punish anything that's left
- my $remains = $text;
- $remains =~ tr/a-zA-Z0-9//d;
- my $remains_length = length($remains);
-
- &punish(50 * $remains_length + &slow_pow(9, $remains_length),
- $remains_length . ' extraneous ' .
- (($remains_length == 1) ? 'symbol' : 'symbols'))
- if $remains;
-
- print "\nRaw lameness score is $score\n" if $verbose;
-
- # Use an appropriate function to map [0, +inf) to [0, 100)
- my $percentage = 100 *
- (1 + &Math::Trig::tanh(($score-400)/400)) *
- (1 - 1/(1+$score/5)) / 2;
-
- my $digits = 2 * (2 - &round_up(log(100 - $percentage) / log(10)));
-
- return sprintf "%.${digits}f", $percentage;
+ # Remove balanced brackets (and punish a little bit) and punish for unmatched
+ while ($text =~ s/^([^()]*) (\() (.*) (\)) ([^()]*) $/$1$3$5/x
+ || $text =~ s/^([^{}]*) (\{) (.*) (\}) ([^{}]*) $/$1$3$5/x
+ || $text =~ s/^([^\[\]]*) (\[) (.*) (\]) ([^\[\]]*) $/$1$3$5/x )
+ {
+ print "Removed $2$4 outside parentheses; nick now $_\n" if $verbose;
+ &punish( 15, 'brackets' );
+ }
+ my $parentheses = $text =~ tr/(){}[]/(){}[]/;
+ &punish(
+ &slow_pow( 10, $parentheses ),
+ "$parentheses unmatched "
+ . ( $parentheses == 1 ? 'parenthesis' : 'parentheses' )
+ ) if $parentheses;
+
+ # Punish k3wlt0k
+ my @k3wlt0k_weights = ( 5, 5, 2, 5, 2, 3, 1, 2, 2, 2 );
+ for my $digit ( 0 .. 9 ) {
+ my $occurrences = $text =~ s/$digit/$digit/g || 0;
+ &punish(
+ $k3wlt0k_weights[$digit] * $occurrences * 30,
+ $occurrences . ' '
+ . ( ( $occurrences == 1 ) ? 'occurrence' : 'occurrences' )
+ . " of $digit"
+ ) if $occurrences;
+ }
+
+ # An alpha caps is not lame in middle or at end, provided the first
+ # alpha is caps.
+ my $orig_case = $text;
+ $text =~ s/^([^A-Za-z]*[A-Z].*[a-z].*?)[_-]?([A-Z])/$1\l$2/;
+
+ # A caps first alpha is sometimes not lame
+ $text =~ s/^([^A-Za-z]*)([A-Z])([a-z])/$1\l$2$3/;
+
+ # Punish uppercase to lowercase shifts and vice-versa, modulo
+ # exceptions above
+ my $case_shifts = &case_shifts($orig_case);
+ &punish(
+ &slow_pow( 9, $case_shifts ),
+ $case_shifts . ' case ' . ( ( $case_shifts == 1 ) ? 'shift' : 'shifts' )
+ ) if ( $case_shifts > 1 && /[A-Z]/ );
+
+ # Punish lame endings (TorgoX, WraithX et al. might kill me for this :-)
+ &punish( 50, 'last alpha lame' ) if $orig_case =~ /[XZ][^a-zA-Z]*$/;
+
+ # Punish letter to numeric shifts and vice-versa
+ my $number_shifts = &number_shifts($_);
+ &punish(
+ &slow_pow( 9, $number_shifts ),
+ $number_shifts
+ . ' letter/number '
+ . ( ( $number_shifts == 1 ) ? 'shift' : 'shifts' )
+ ) if $number_shifts > 1;
+
+ # Punish extraneous caps
+ my $caps = $text =~ tr/A-Z/A-Z/;
+ &punish( &slow_pow( 7, $caps ), "$caps extraneous caps" ) if $caps;
+
+ # One and only one trailing underscore is OK.
+ $text =~ s/\_$//;
+
+ # Now punish anything that's left
+ my $remains = $text;
+ $remains =~ tr/a-zA-Z0-9//d;
+ my $remains_length = length($remains);
+
+ &punish(
+ 50 * $remains_length + &slow_pow( 9, $remains_length ),
+ $remains_length
+ . ' extraneous '
+ . ( ( $remains_length == 1 ) ? 'symbol' : 'symbols' )
+ ) if $remains;
+
+ print "\nRaw lameness score is $score\n" if $verbose;
+
+ # Use an appropriate function to map [0, +inf) to [0, 100)
+ my $percentage = 100 * ( 1 + &Math::Trig::tanh( ( $score - 400 ) / 400 ) ) *
+ ( 1 - 1 / ( 1 + $score / 5 ) ) / 2;
+
+ my $digits = 2 * ( 2 - &round_up( log( 100 - $percentage ) / log(10) ) );
+
+ return sprintf "%.${digits}f", $percentage;
}
sub case_shifts ($) {
- # This is a neat trick suggested by freeside. Thanks freeside!
- my $shifts = shift;
+ # This is a neat trick suggested by freeside. Thanks freeside!
+
+ my $shifts = shift;
- $shifts =~ tr/A-Za-z//cd;
- $shifts =~ tr/A-Z/U/s;
- $shifts =~ tr/a-z/l/s;
+ $shifts =~ tr/A-Za-z//cd;
+ $shifts =~ tr/A-Z/U/s;
+ $shifts =~ tr/a-z/l/s;
- return length($shifts) - 1;
+ return length($shifts) - 1;
}
sub number_shifts ($) {
- my $shifts = shift;
+ my $shifts = shift;
- $shifts =~ tr/A-Za-z0-9//cd;
- $shifts =~ tr/A-Za-z/l/s;
- $shifts =~ tr/0-9/n/s;
+ $shifts =~ tr/A-Za-z0-9//cd;
+ $shifts =~ tr/A-Za-z/l/s;
+ $shifts =~ tr/0-9/n/s;
- return length($shifts) - 1;
+ return length($shifts) - 1;
}
sub slow_pow ($$) {
- my ($x, $y) = @_;
+ my ( $x, $y ) = @_;
- return $x ** &slow_exponent($y);
+ return $x**&slow_exponent($y);
}
sub slow_exponent ($) {
- my $x = shift;
+ my $x = shift;
- return 1.3 * $x * (1 - &Math::Trig::atan($x/6) *2/$pi);
+ return 1.3 * $x * ( 1 - &Math::Trig::atan( $x / 6 ) * 2 / $pi );
}
sub round_up ($) {
- my $float = shift;
+ my $float = shift;
- return int($float) + ((int($float) == $float) ? 0 : 1);
+ return int($float) + ( ( int($float) == $float ) ? 0 : 1 );
}
sub punish ($$) {
- my ($damage, $reason) = @_;
+ my ( $damage, $reason ) = @_;
- return unless $damage;
+ return unless $damage;
- $score += $damage;
- print "$damage lameness points awarded: $reason\n" if $verbose;
+ $score += $damage;
+ print "$damage lameness points awarded: $reason\n" if $verbose;
}
1;
my $no_page;
BEGIN {
- eval qq{
+ eval qq{
use Mail::Mailer qw(sendmail);
};
- $no_page++ if ($@);
+ $no_page++ if ($@);
}
sub pager::page {
- my ($message) = @_;
- my ($retval);
-
- # TODO only allow registered users?
-
- if ($no_page) {
- &::status('page module requires Mail::Mailer.');
- return 'page module not active';
- }
-
- unless ($message =~ /^(\S+)\s+(.*)$/) {
- return undef;
- }
-
- my $from = $::who;
- my $to = $1;
- my $msg = $2;
-
- # allow optional trailing : ie: page foo[:] hello
- $to =~ s/:$//;
-
- my $tofactoid = &::getFactoid(lc "${to}'s pager");
- if ($tofactoid =~ /(\S+@\S+)/) {
- my $toaddr = $1;
- $toaddr =~ s/^mailto://;
- # TODO require sender-locked factoid?
-
- my $fromfactoid = &::getFactoid(lc "${from}'s pager");
-
- my $fromaddr;
- if ($fromfactoid =~ /(\S+@\S+)/) {
- $fromaddr = $1;
- $fromaddr =~ s/^mailto://;
- } else {
- # TODO require sender to have valid self-locked pager factoid?
- $fromaddr = 'infobot@example.com';
- }
-
- my $channel = $::chan || 'infobot';
- # TODO disallow use from private message? $chan='_default'
-
- &::status("pager: from $from <$fromaddr>, to $to <$toaddr>, msg \"$msg\"");
- my %headers = (
- To => "$to <$toaddr>",
- From => "$from <$fromaddr>",
- Subject => "Message from $channel!",
- 'X-Mailer' => 'infobot',
- );
-
-# my $logmsg;
-# for (keys %headers) {
-# $logmsg .= "$_: $headers{$_}\n";
-# }
-# $logmsg .= "\n$msg\n";
-# &::status("pager:\n$logmsg");
-
- my $failed;
- my $mailer = new Mail::Mailer 'sendmail';
- $failed++ unless $mailer->open(\%headers);
- $failed++ unless print $mailer "$msg\n";
- $failed++ unless $mailer->close;
-
- if ($failed) {
- $retval='Sorry, an error occurred while sending mail.';
- } else {
- $retval="$from: I sent mail to $toaddr from $fromaddr.";
- }
- } else {
- $retval="Sorry, I don't know ${to}'s email address.";
- }
- &::performStrictReply($retval);
+ my ($message) = @_;
+ my ($retval);
+
+ # TODO only allow registered users?
+
+ if ($no_page) {
+ &::status('page module requires Mail::Mailer.');
+ return 'page module not active';
+ }
+
+ unless ( $message =~ /^(\S+)\s+(.*)$/ ) {
+ return undef;
+ }
+
+ my $from = $::who;
+ my $to = $1;
+ my $msg = $2;
+
+ # allow optional trailing : ie: page foo[:] hello
+ $to =~ s/:$//;
+
+ my $tofactoid = &::getFactoid( lc "${to}'s pager" );
+ if ( $tofactoid =~ /(\S+@\S+)/ ) {
+ my $toaddr = $1;
+ $toaddr =~ s/^mailto://;
+
+ # TODO require sender-locked factoid?
+
+ my $fromfactoid = &::getFactoid( lc "${from}'s pager" );
+
+ my $fromaddr;
+ if ( $fromfactoid =~ /(\S+@\S+)/ ) {
+ $fromaddr = $1;
+ $fromaddr =~ s/^mailto://;
+ }
+ else {
+
+ # TODO require sender to have valid self-locked pager factoid?
+ $fromaddr = 'infobot@example.com';
+ }
+
+ my $channel = $::chan || 'infobot';
+
+ # TODO disallow use from private message? $chan='_default'
+
+ &::status(
+ "pager: from $from <$fromaddr>, to $to <$toaddr>, msg \"$msg\"");
+ my %headers = (
+ To => "$to <$toaddr>",
+ From => "$from <$fromaddr>",
+ Subject => "Message from $channel!",
+ 'X-Mailer' => 'infobot',
+ );
+
+ # my $logmsg;
+ # for (keys %headers) {
+ # $logmsg .= "$_: $headers{$_}\n";
+ # }
+ # $logmsg .= "\n$msg\n";
+ # &::status("pager:\n$logmsg");
+
+ my $failed;
+ my $mailer = new Mail::Mailer 'sendmail';
+ $failed++ unless $mailer->open( \%headers );
+ $failed++ unless print $mailer "$msg\n";
+ $failed++ unless $mailer->close;
+
+ if ($failed) {
+ $retval = 'Sorry, an error occurred while sending mail.';
+ }
+ else {
+ $retval = "$from: I sent mail to $toaddr from $fromaddr.";
+ }
+ }
+ else {
+ $retval = "Sorry, I don't know ${to}'s email address.";
+ }
+ &::performStrictReply($retval);
}
'pager';
package piglatin;
-sub piglatin
-{
- my ($text) = @_;
- my $piglatin;
- my $suffix = 'ay';
+sub piglatin {
+ my ($text) = @_;
+ my $piglatin;
+ my $suffix = 'ay';
- # FIXME: does not handle:
- # non-trailing punctuation and hyphens
- # y as vowel 'style' -> 'ylestay'
- # contractions
- for my $word (split /\s+/, $text) {
- my ($pigword, $postfix);
- #($word,$postfix) = $word =~ s/^([a-z]*)([,.!\?;:'"])?$//i;
- if ($word =~ s/([,.!\?;:'"])$//i) {
- $postfix = $1;
- }
- if ($word =~ /^(qu)(.*)/ ) {
- $pigword = "$2$1$suffix";
- } elsif ($word =~ /^(Qu)(.)(.*)/ ) {
- $pigword = uc($2) . $3 . lc($1) . $suffix;
- } elsif ($word =~ /^([bcdfghjklmnpqrstvwxyz]+)(.*)/ ) {
- $pigword = "$2$1$suffix";
- } elsif ($word =~ /^([BCDFGHJKLMNPQRSTVWXYZ])([bcdfghjklmnpqrstvwxyz]*)([aeiouy])(.*)/ ) {
- $pigword = uc($3) . $4 . lc($1) . $2 . $suffix;
- } else {
- $pigword = $word . 'w' . $suffix;
+ # FIXME: does not handle:
+ # non-trailing punctuation and hyphens
+ # y as vowel 'style' -> 'ylestay'
+ # contractions
+ for my $word ( split /\s+/, $text ) {
+ my ( $pigword, $postfix );
+
+ #($word,$postfix) = $word =~ s/^([a-z]*)([,.!\?;:'"])?$//i;
+ if ( $word =~ s/([,.!\?;:'"])$//i ) {
+ $postfix = $1;
+ }
+ if ( $word =~ /^(qu)(.*)/ ) {
+ $pigword = "$2$1$suffix";
+ }
+ elsif ( $word =~ /^(Qu)(.)(.*)/ ) {
+ $pigword = uc($2) . $3 . lc($1) . $suffix;
+ }
+ elsif ( $word =~ /^([bcdfghjklmnpqrstvwxyz]+)(.*)/ ) {
+ $pigword = "$2$1$suffix";
+ }
+ elsif ( $word =~
+ /^([BCDFGHJKLMNPQRSTVWXYZ])([bcdfghjklmnpqrstvwxyz]*)([aeiouy])(.*)/
+ )
+ {
+ $pigword = uc($3) . $4 . lc($1) . $2 . $suffix;
+ }
+ else {
+ $pigword = $word . 'w' . $suffix;
+ }
+ $piglatin .= ' ' if $piglatin;
+ $piglatin .= $pigword . $postfix;
}
- $piglatin .= ' ' if $piglatin;
- $piglatin .= $pigword . $postfix;
- }
- &::performStrictReply($piglatin||'failed');
+ &::performStrictReply( $piglatin || 'failed' );
}
1;
package reverse;
sub reverse {
- my($message) = @_;
- &::performStrictReply(join('',reverse(split('',$message))));
+ my ($message) = @_;
+ &::performStrictReply( join( '', reverse( split( '', $message ) ) ) );
}
1;
package scramble;
-sub scramble
-{
- my ($text) = @_;
- my $scrambled;
-
- return unless &::loadPerlModule("List::Util");
- srand(); # fork seems to not change rand. force it here
- for my $orig_word (split /\s+/, $text)
- {
- # skip words that are less than four characters in length
- $scrambled .= "$orig_word " and next if length($orig_word) < 4;
-
- # get first and last characters, and middle characters
- # optional characters are for punctuation, etc.
- my ($first, $middle, $last) = $orig_word =~ /^['"]?(.)(.+)'?(.)[,.!?;:'"]?$/;
-
- my ($new_middle, $cnt);
-
- # shuffle until $new_middle is different from $middle
- do
- {
- # theoretically, this loop could loop forever, so
- # a counter is used. once $cnt > 10 then use a
- # simple regex to scramble and call it good
-
- if (++$cnt > 10)
- {
- # non-random shuffle, but good enough
- ($new_middle = $middle) =~ s/(.)(.)/$2$1/g;
- }
-
- # shuffle the middle letters
- $new_middle = join '', List::Util::shuffle(split //, $middle);
- }
- while (($cnt < 10) && ($middle eq $new_middle));
+sub scramble {
+ my ($text) = @_;
+ my $scrambled;
+
+ return unless &::loadPerlModule("List::Util");
+ srand(); # fork seems to not change rand. force it here
+ for my $orig_word ( split /\s+/, $text ) {
+
+ # skip words that are less than four characters in length
+ $scrambled .= "$orig_word " and next if length($orig_word) < 4;
+
+ # get first and last characters, and middle characters
+ # optional characters are for punctuation, etc.
+ my ( $first, $middle, $last ) =
+ $orig_word =~ /^['"]?(.)(.+)'?(.)[,.!?;:'"]?$/;
+
+ my ( $new_middle, $cnt );
+
+ # shuffle until $new_middle is different from $middle
+ do {
- # add the word to the list...
- $scrambled .= "$first$new_middle$last ";
- }
+ # theoretically, this loop could loop forever, so
+ # a counter is used. once $cnt > 10 then use a
+ # simple regex to scramble and call it good
+
+ if ( ++$cnt > 10 ) {
+
+ # non-random shuffle, but good enough
+ ( $new_middle = $middle ) =~ s/(.)(.)/$2$1/g;
+ }
+
+ # shuffle the middle letters
+ $new_middle = join '', List::Util::shuffle( split //, $middle );
+ } while ( ( $cnt < 10 ) && ( $middle eq $new_middle ) );
+
+ # add the word to the list...
+ $scrambled .= "$first$new_middle$last ";
+ }
- # remove the single trailing space, and any other space that may have
- # been included in the original string
- $scrambled =~ s/\s+$//;
+ # remove the single trailing space, and any other space that may have
+ # been included in the original string
+ $scrambled =~ s/\s+$//;
- &::performStrictReply($scrambled||'Unknown Error Condition');
+ &::performStrictReply( $scrambled || 'Unknown Error Condition' );
}
1;
my @list;
foreach (@_) {
- next unless (/<title>(.*?)<\/title>/);
- my $title = $1;
- $title =~ s/&\;/&/g;
- push(@list, $title);
+ next unless (/<title>(.*?)<\/title>/);
+ my $title = $1;
+ $title =~ s/&\;/&/g;
+ push( @list, $title );
}
return @list;
my @results = &::getURL("http://slashdot.org/slashdot.xml");
my $retval = "i could not get the headlines.";
- if (scalar @results) {
- my $prefix = 'Slashdot Headlines ';
- my @list = &slashdotParse(@results);
- $retval = &::formListReply(0, $prefix, @list);
+ if ( scalar @results ) {
+ my $prefix = 'Slashdot Headlines ';
+ my @list = &slashdotParse(@results);
+ $retval = &::formListReply( 0, $prefix, @list );
}
&::performStrictReply($retval);
my $file = "$::param{tempDir}/slashdot.xml";
my @Cxml = &::getURL("http://slashdot.org/slashdot.xml");
- if (!scalar @Cxml) {
- &::DEBUG("sdA: failure (Cxml == NULL).");
- return;
+ if ( !scalar @Cxml ) {
+ &::DEBUG("sdA: failure (Cxml == NULL).");
+ return;
}
- if (! -e $file) { # first time run.
- open(OUT, ">$file");
- foreach (@Cxml) {
- print OUT "$_\n";
- }
- close OUT;
+ if ( !-e $file ) { # first time run.
+ open( OUT, ">$file" );
+ foreach (@Cxml) {
+ print OUT "$_\n";
+ }
+ close OUT;
- return;
+ return;
}
my @Oxml;
- open(IN, $file);
+ open( IN, $file );
while (<IN>) {
- chop;
- push(@Oxml,$_);
+ chop;
+ push( @Oxml, $_ );
}
close IN;
my @new;
foreach (@Chl) {
- last if ($_ eq $Ohl[0]);
- push(@new, $_);
+ last if ( $_ eq $Ohl[0] );
+ push( @new, $_ );
}
- if (scalar @new == 0) {
- &::status("Slashdot: no new headlines.");
- return;
+ if ( scalar @new == 0 ) {
+ &::status("Slashdot: no new headlines.");
+ return;
}
- if (scalar @new == scalar @Chl) {
- &::DEBUG("sdA: scalar(new) == scalar(Chl). bad?");
+ if ( scalar @new == scalar @Chl ) {
+ &::DEBUG("sdA: scalar(new) == scalar(Chl). bad?");
}
- open(OUT,">$file");
+ open( OUT, ">$file" );
foreach (@Cxml) {
- print OUT "$_\n";
+ print OUT "$_\n";
}
close OUT;
- return "Slashdot: News for nerds, stuff that matters -- ".
- join(" \002::\002 ", @new);
+ return "Slashdot: News for nerds, stuff that matters -- "
+ . join( " \002::\002 ", @new );
}
1;
use strict;
sub spell::spell {
- my $query = shift;
- if ($query =~ m/[^[:alpha:]]/) {
- return('only one word of alphabetic characters supported');
- }
-
- my $binary;
- my @binaries = (
- '/usr/bin/aspell',
- '/usr/bin/ispell',
- '/usr/bin/spell'
- );
-
- foreach (@binaries) {
- if (-x $_) {
- $binary=$_;
- last;
- }
- }
-
- if (!$binary) {
- return('no binary found.');
- }
-
- if (!&::validExec($query)) {
- return('argument appears to be fuzzy.');
- }
-
- my $reply = "I can't find alternate spellings for '$query'";
-
- foreach (`/bin/echo '$query' | $binary -a -S`) {
- chop;
- last if !length; # end of query.
-
- if (/^\@/) { # intro line.
- next;
- } elsif (/^\*/) { # possibly correct.
- $reply = "'$query' may be spelled correctly";
- last;
- } elsif (/^\&/) { # possible correction(s).
- s/^\& (\S+) \d+ \d+: //;
- my @array = split(/,? /);
-
- $reply = "possible spellings for $query: @array";
- last;
- } elsif (/^\+/) {
- &::DEBUG("spell: '+' found => '$_'.");
- last;
- } elsif (/^# (.*?) 0$/) {
- # none found.
- last;
- } else {
- &::DEBUG("spell: unknown: '$_'.");
- }
- }
-
- return($reply);
+ my $query = shift;
+ if ( $query =~ m/[^[:alpha:]]/ ) {
+ return ('only one word of alphabetic characters supported');
+ }
+
+ my $binary;
+ my @binaries = ( '/usr/bin/aspell', '/usr/bin/ispell', '/usr/bin/spell' );
+
+ foreach (@binaries) {
+ if ( -x $_ ) {
+ $binary = $_;
+ last;
+ }
+ }
+
+ if ( !$binary ) {
+ return ('no binary found.');
+ }
+
+ if ( !&::validExec($query) ) {
+ return ('argument appears to be fuzzy.');
+ }
+
+ my $reply = "I can't find alternate spellings for '$query'";
+
+ foreach (`/bin/echo '$query' | $binary -a -S`) {
+ chop;
+ last if !length; # end of query.
+
+ if (/^\@/) { # intro line.
+ next;
+ }
+ elsif (/^\*/) { # possibly correct.
+ $reply = "'$query' may be spelled correctly";
+ last;
+ }
+ elsif (/^\&/) { # possible correction(s).
+ s/^\& (\S+) \d+ \d+: //;
+ my @array = split(/,? /);
+
+ $reply = "possible spellings for $query: @array";
+ last;
+ }
+ elsif (/^\+/) {
+ &::DEBUG("spell: '+' found => '$_'.");
+ last;
+ }
+ elsif (/^# (.*?) 0$/) {
+
+ # none found.
+ last;
+ }
+ else {
+ &::DEBUG("spell: unknown: '$_'.");
+ }
+ }
+
+ return ($reply);
}
sub spell::query {
- &::performStrictReply(&spell(@_));
- return;
+ &::performStrictReply( &spell(@_) );
+ return;
}
1;
--- /dev/null
+#upsidedown.pl: display a string in pseudo-upsidedown utf-8 characters
+# Author: Tim Riker
+# Licensing: Artistic License
+# Version: v0.1 (20080425)
+#
+# taken from http://www.xs4all.nl/~johnpc/uniud/uniud-0.14.tar.gz
+#
+# NOTICE: This source contains UTF-8 unicode characters, but only in the
+# comments. You can safely remove them if your editor barfs on them.
+
+use strict;
+use utf8;
+use PerlIO;
+use Getopt::Long qw(:config nopermute bundling auto_help);
+use Pod::Usage;
+use vars qw($VERSION);
+
+$VERSION = 0.14;
+
+package upsidedown;
+
+#die "huh?" unless ${^UNICODE} == 127; # force -CSDAL
+
+my %updown = (
+ ' ' => ' ',
+ '!' => "\x{00a1}", # ¡
+ '"' => "\x{201e}", # „
+ '#' => '#',
+ '$' => '$',
+ '%' => '%',
+ '&' => "\x{214b}", # ⅋
+ "'" => "\x{0375}", # ͵
+ '(' => ')',
+ ')' => '(',
+ '*' => '*',
+ '+' => '+',
+ ',' => "\x{2018}", # ‘
+ '-' => '-',
+ '.' => "\x{02d9}", # ˙
+ '/' => '/',
+ '0' => '0',
+ '1' => "\x{002c}\x{20d3}", # ,⃓ can be improved
+ '2' => "\x{10f7}", # ჷ
+ '3' => "\x{03b5}", # ε
+ '4' => "\x{21c1}\x{20d3}", # ⇁⃓ can be improved
+ '5' => "\x{1515}", # ᔕ or maybe just "S"
+ '6' => '9',
+ '7' => "\x{005f}\x{0338}", # _̸
+ '8' => '8',
+ '9' => '6',
+ ':' => ':',
+ ';' => "\x{22c5}\x{0315}", # ⋅̕ sloppy, should be improved
+ '<' => '>',
+ '=' => '=',
+ '>' => '<',
+ '?' => "\x{00bf}", # ¿
+ '@' => '@', # can be improved
+ 'A' => "\x{13cc}", # Ꮜ
+ 'B' => "\x{03f4}", # ϴ can be improved
+ 'C' => "\x{0186}", # Ɔ
+ 'D' => 'p', # should be an uppercase D!!
+ 'E' => "\x{018e}", # Ǝ
+ 'F' => "\x{2132}", # Ⅎ
+ 'G' => "\x{2141}", # ⅁
+ 'H' => 'H',
+ 'I' => 'I',
+ 'J' => "\x{017f}\x{0332}", # ſ̲
+ 'K' => "\x{029e}", # ʞ should be an uppercase K!!
+ 'L' => "\x{2142}", # ⅂
+ 'M' => "\x{019c}", # Ɯ or maybe just "W"
+ 'N' => 'N',
+ 'O' => 'O',
+ 'P' => 'd', # should be uppercase P
+ 'Q' => "\x{053e}", # Ծ can be improved
+ 'R' => "\x{0222}", # Ȣ can be improved
+ 'S' => 'S',
+ 'T' => "\x{22a5}", # ⊥
+ 'U' => "\x{144e}", # ᑎ
+ 'V' => "\x{039b}", # Λ
+ 'W' => 'M',
+ 'X' => 'X',
+ 'Y' => "\x{2144}", # ⅄
+ 'Z' => 'Z',
+ '[' => ']',
+ '\\' => '\\',
+ ']' => '[',
+ '^' => "\x{203f}", # ‿
+ '_' => "\x{203e}", # ‾
+ '`' => "\x{0020}\x{0316}", # ̖
+ 'a' => "\x{0250}", # ɐ
+ 'b' => 'q',
+ 'c' => "\x{0254}", # ɔ
+ 'd' => 'p',
+ 'e' => "\x{01dd}", # ǝ
+ 'f' => "\x{025f}", # ɟ
+ 'g' => "\x{0253}", # ɓ
+ 'h' => "\x{0265}", # ɥ
+ 'i' => "\x{0131}\x{0323}", # ı̣
+ 'j' => "\x{017f}\x{0323}", # ſ̣
+ 'k' => "\x{029e}", # ʞ
+ 'l' => "\x{01ae}", # Ʈ can be improved
+ 'm' => "\x{026f}", # ɯ
+ 'n' => 'u',
+ 'o' => 'o',
+ 'p' => 'd',
+ 'q' => 'b',
+ 'r' => "\x{0279}", # ɹ
+ 's' => 's',
+ 't' => "\x{0287}", # ʇ
+ 'u' => 'n',
+ 'v' => "\x{028c}", # ʌ
+ 'w' => "\x{028d}", # ʍ
+ 'x' => 'x',
+ 'y' => "\x{028e}", # ʎ
+ 'z' => 'z',
+ '{' => '}',
+ '|' => '|',
+ '}' => '{',
+ '~' => "\x{223c}", # ∼
+);
+my $missing = "\x{fffd}"; # � replacement character
+
+# turnedstr - handle turning one string
+sub turnedstr {
+ my $str = shift;
+ my $turned = '';
+ my $tlength = 0;
+
+ for my $char ( $str =~ /(\X)/g ) {
+ if ( exists $updown{$char} ) {
+ my $t = $updown{$char};
+ $t = $missing if !length($t);
+ $turned = $t . $turned;
+ $tlength++;
+ }
+ elsif ( $char eq "\t" ) {
+ my $tablen = 8 - $tlength % 8;
+ $turned = " " x $tablen . $turned;
+ $tlength += $tablen;
+ }
+ elsif ( ord($char) >= 32 ) {
+ ### other chars copied literally
+ $turned = $char . $turned;
+ $tlength++;
+ }
+ }
+
+ return $turned;
+}
+
+sub upsidedown {
+ my ($message) = @_;
+ &::performStrictReply( turnedstr( $message ) );
+}
+
+1;
+
+# vim:ts=4:sw=4:expandtab:tw=80
# This program is distributed under the same terms as infobot.
package wikipedia;
+
use strict;
my $missing;
-my $wikipedia_base_url = 'http://www.wikipedia.org/wiki/';
+my $wikipedia_base_url = 'http://www.wikipedia.org/wiki/';
my $wikipedia_search_url = $wikipedia_base_url . 'Special:Search?';
my $wikipedia_export_url = $wikipedia_base_url . 'Special:Export/';
BEGIN {
- # utility functions for encoding the wikipedia request
- eval "use URI::Escape";
- if ($@) {
- $missing++;
- }
-
- eval "use LWP::UserAgent";
- if ($@) {
- $missing++;
- }
-
- eval "use HTML::Entities";
- if ($@) {
- $missing++;
- }
+
+ # utility functions for encoding the wikipedia request
+ eval "use URI::Escape";
+ if ($@) {
+ $missing++;
+ }
+
+ eval "use LWP::UserAgent";
+ if ($@) {
+ $missing++;
+ }
+
+ eval "use HTML::Entities";
+ if ($@) {
+ $missing++;
+ }
}
sub wikipedia {
- return '' if $missing;
- my ($phrase) = @_;
- my ($reply, $valid_result) = wikipedia_lookup(@_);
- if ($reply) {
- &::performStrictReply($reply);
- } else {
- &::performStrictReply("'$phrase' not found in Wikipedia. Perhaps try a different spelling or case?");
- }
+ return '' if $missing;
+ my ($phrase) = @_;
+ my ( $reply, $valid_result ) = wikipedia_lookup(@_);
+ if ($reply) {
+ &::performStrictReply($reply);
+ }
+ else {
+ &::performStrictReply(
+"'$phrase' not found in Wikipedia. Perhaps try a different spelling or case?"
+ );
+ }
}
sub wikipedia_silent {
- return '' if $missing;
- my ($reply, $valid_result) = wikipedia_lookup(@_);
- if ($valid_result and $reply) {
- &::performStrictReply($reply);
- }
+ return '' if $missing;
+ my ( $reply, $valid_result ) = wikipedia_lookup(@_);
+ if ( $valid_result and $reply ) {
+ &::performStrictReply($reply);
+ }
}
sub wikipedia_lookup {
- my ($phrase) = @_;
- &::DEBUG("wikipedia($phrase)");
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
- # Let's pretend
- $ua->agent("Mozilla/5.0 " . $ua->agent);
- $ua->timeout(5);
-
- # chop ? from the end
- $phrase =~ s/\?$//;
- # convert phrase to wikipedia conventions
-# $phrase = uri_escape($phrase);
-# $phrase =~ s/%20/+/g;
-# $phrase =~ s/%25/%/g;
- $phrase =~ s/ /+/g;
-
- # using the search form will make the request case-insensitive
- # HEAD will follow redirects, catching the first mode of redirects
- # that wikipedia uses
- my $url = $wikipedia_search_url . 'search=' . $phrase . '&go=Go';
- my $req = HTTP::Request->new('HEAD', $url);
- $req->header('Accept-Language' => 'en');
- &::DEBUG($url);
-
- my $res = $ua->request($req);
- &::DEBUG($res->code);
-
- if (!$res->is_success) {
- return("Wikipedia might be temporarily unavailable (".$res->code."). Please try again in a few minutes...",
- 0);
- } else {
- # we have been redirected somewhere
- # (either content or the generic Search form)
- # let's find the title of the article
- $url = $res->request->uri;
- $phrase = $url;
- $phrase =~ s/.*\/wiki\///;
-
- if (!$res->code == '200') {
- return("Wikipedia might be temporarily unavailable or something is broken (".$res->code."). Please try again later...",
- 0);
- } else {
- if ($url =~ m/Special:Search/) {
- # we were sent to the the search page
- return("I couldn't find a matching article in wikipedia, look for yerselves: " . $url,
- 0);
- } else {
- # we hit content, let's retrieve it
- my $text = wikipedia_get_text($phrase);
-
- # filtering unprintables
- $text =~ s/[[:cntrl:]]//g;
- # filtering headings
- $text =~ s/==+[^=]*=+//g;
- # filtering wikipedia tables
- $text =~ s/\{\|[^}]+\|\}//g;
- # some people cannot live without HTML tags, even in a wiki
- # $text =~ s/<div.*>//gi;
- # $text =~ s/<!--.*>//gi;
- # $text =~ s/<[^>]*>//g;
- # or HTML entities
- $text =~ s/&/&/g;
- decode_entities($text);
- # or tags, again
- $text =~ s/<[^>]*>//g;
- #$text =~ s/[&#]+[0-9a-z]+;//gi;
- # filter wikipedia tags: [[abc: def]]
- $text =~ s/\[\[[[:alpha:]]*:[^]]*\]\]//gi;
- # {{abc}}:tag
- $text =~ s/\{\{[[:alpha:]]+\}\}:[^\s]+//gi;
- # {{abc}}
- $text =~ s/\{\{[[:alpha:]]+\}\}//gi;
- # unescape quotes
- $text =~ s/'''/'/g;
- $text =~ s/''/"/g;
- # filter wikipedia links: [[tag|link]] -> link
- $text =~ s/\[\[[^]]+\|([^]]+)\]\]/$1/g;
- # [[link]] -> link
- $text =~ s/\[\[([^]]+)\]\]/$1/g;
- # shrink whitespace
- $text =~ s/[[:space:]]+/ /g;
- # chop leading whitespace
- $text =~ s/^ //g;
-
- # shorten article to first one or two sentences
- # new: we rely on the output function to know what to do
- # with long messages
- #$text = substr($text, 0, 330);
- #$text =~ s/(.+)\.([^.]*)$/$1./g;
-
- return('At ' . $url . " (URL), Wikipedia explains: " . $text,
- 1);
- }
+ my ($phrase) = @_;
+ &::DEBUG("wikipedia($phrase)");
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy( 'http', $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') );
+
+ # Let's pretend
+ $ua->agent( "Mozilla/5.0 " . $ua->agent );
+ $ua->timeout(5);
+
+ # chop ? from the end
+ $phrase =~ s/\?$//;
+
+ # convert phrase to wikipedia conventions
+ # $phrase = uri_escape($phrase);
+ # $phrase =~ s/%20/+/g;
+ # $phrase =~ s/%25/%/g;
+ $phrase =~ s/ /+/g;
+
+ # using the search form will make the request case-insensitive
+ # HEAD will follow redirects, catching the first mode of redirects
+ # that wikipedia uses
+ my $url = $wikipedia_search_url . 'search=' . $phrase . '&go=Go';
+ my $req = HTTP::Request->new( 'HEAD', $url );
+ $req->header( 'Accept-Language' => 'en' );
+ &::DEBUG($url);
+
+ my $res = $ua->request($req);
+ &::DEBUG( $res->code );
+
+ if ( !$res->is_success ) {
+ return (
+ "Wikipedia might be temporarily unavailable ("
+ . $res->code
+ . "). Please try again in a few minutes...",
+ 0
+ );
+ }
+ else {
+
+ # we have been redirected somewhere
+ # (either content or the generic Search form)
+ # let's find the title of the article
+ $url = $res->request->uri;
+ $phrase = $url;
+ $phrase =~ s/.*\/wiki\///;
+
+ if ( !$res->code == '200' ) {
+ return (
+"Wikipedia might be temporarily unavailable or something is broken ("
+ . $res->code
+ . "). Please try again later...",
+ 0
+ );
+ }
+ else {
+ if ( $url =~ m/Special:Search/ ) {
+
+ # we were sent to the the search page
+ return (
+"I couldn't find a matching article in wikipedia, look for yerselves: "
+ . $url,
+ 0
+ );
+ }
+ else {
+
+ # we hit content, let's retrieve it
+ my $text = wikipedia_get_text($phrase);
+
+ # filtering unprintables
+ $text =~ s/[[:cntrl:]]//g;
+
+ # filtering headings
+ $text =~ s/==+[^=]*=+//g;
+
+ # filtering wikipedia tables
+ $text =~ s/\{\|[^}]+\|\}//g;
+
+ # some people cannot live without HTML tags, even in a wiki
+ # $text =~ s/<div.*>//gi;
+ # $text =~ s/<!--.*>//gi;
+ # $text =~ s/<[^>]*>//g;
+ # or HTML entities
+ $text =~ s/&/&/g;
+ decode_entities($text);
+
+ # or tags, again
+ $text =~ s/<[^>]*>//g;
+
+ #$text =~ s/[&#]+[0-9a-z]+;//gi;
+ # filter wikipedia tags: [[abc: def]]
+ $text =~ s/\[\[[[:alpha:]]*:[^]]*\]\]//gi;
+
+ # {{abc}}:tag
+ $text =~ s/\{\{[[:alpha:]]+\}\}:[^\s]+//gi;
+
+ # {{abc}}
+ $text =~ s/\{\{[[:alpha:]]+\}\}//gi;
+
+ # unescape quotes
+ $text =~ s/'''/'/g;
+ $text =~ s/''/"/g;
+
+ # filter wikipedia links: [[tag|link]] -> link
+ $text =~ s/\[\[[^]]+\|([^]]+)\]\]/$1/g;
+
+ # [[link]] -> link
+ $text =~ s/\[\[([^]]+)\]\]/$1/g;
+
+ # shrink whitespace
+ $text =~ s/[[:space:]]+/ /g;
+
+ # chop leading whitespace
+ $text =~ s/^ //g;
+
+ # shorten article to first one or two sentences
+ # new: we rely on the output function to know what to do
+ # with long messages
+ #$text = substr($text, 0, 330);
+ #$text =~ s/(.+)\.([^.]*)$/$1./g;
+
+ return ( 'At ' . $url . " (URL), Wikipedia explains: " . $text,
+ 1 );
+ }
+ }
}
- }
}
sub wikipedia_get_text {
- return '' if $missing;
- my ($article) = @_;
- &::DEBUG("wikipedia_get_text($article)");
-
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
- # Let's pretend
- $ua->agent("Mozilla/5.0 " . $ua->agent);
- $ua->timeout(5);
-
- &::DEBUG($wikipedia_export_url . $article);
- my $req = HTTP::Request->new('GET', $wikipedia_export_url .
- $article);
- $req->header('Accept-Language' => 'en');
- $req->header('Accept-Charset' => 'utf-8');
-
- my $res = $ua->request($req);
- my ($title, $redirect, $text);
- &::DEBUG($res->code);
-
- if ($res->is_success) {
- if ($res->code == '200' ) {
- foreach (split(/\n/, $res->as_string)) {
- if (/<title>(.*?)<\/title>/) {
- $title = $1;
- $title =~ s/&\;/&/g;
- } elsif (/#REDIRECT\s*\[\[(.*?)\]\]/i) {
- $redirect = $1;
- $redirect =~ tr/ /_/;
- &::DEBUG('wiki redirect to ' . $redirect);
- last;
- } elsif (/<text[^>]*>(.*)/) {
- $text = '"' . $1;
- } elsif (/(.*)<\/text>/) {
- $text = $text . ' ' . $1 . '"';
- last;
- } elsif ($text) {
- $text = $text . ' ' . $_;
- }
- }
- &::DEBUG("wikipedia returned text: " . $text .
- ', redirect ' . $redirect. "\n");
-
- if (!$redirect and !$text) {
- return ($res->as_string);
- }
- return ($text or wikipedia_get_text($redirect))
+ return '' if $missing;
+ my ($article) = @_;
+ &::DEBUG("wikipedia_get_text($article)");
+
+ my $ua = new LWP::UserAgent;
+ $ua->proxy( 'http', $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') );
+
+ # Let's pretend
+ $ua->agent( "Mozilla/5.0 " . $ua->agent );
+ $ua->timeout(5);
+
+ &::DEBUG( $wikipedia_export_url . $article );
+ my $req = HTTP::Request->new( 'GET', $wikipedia_export_url . $article );
+ $req->header( 'Accept-Language' => 'en' );
+ $req->header( 'Accept-Charset' => 'utf-8' );
+
+ my $res = $ua->request($req);
+ my ( $title, $redirect, $text );
+ &::DEBUG( $res->code );
+
+ if ( $res->is_success ) {
+ if ( $res->code == '200' ) {
+ foreach ( split( /\n/, $res->as_string ) ) {
+ if (/<title>(.*?)<\/title>/) {
+ $title = $1;
+ $title =~ s/&\;/&/g;
+ }
+ elsif (/#REDIRECT\s*\[\[(.*?)\]\]/i) {
+ $redirect = $1;
+ $redirect =~ tr/ /_/;
+ &::DEBUG( 'wiki redirect to ' . $redirect );
+ last;
+ }
+ elsif (/<text[^>]*>(.*)/) {
+ $text = '"' . $1;
+ }
+ elsif (/(.*)<\/text>/) {
+ $text = $text . ' ' . $1 . '"';
+ last;
+ }
+ elsif ($text) {
+ $text = $text . ' ' . $_;
+ }
+ }
+ &::DEBUG( "wikipedia returned text: " . $text
+ . ', redirect '
+ . $redirect
+ . "\n" );
+
+ if ( !$redirect and !$text ) {
+ return ( $res->as_string );
+ }
+ return ( $text or wikipedia_get_text($redirect) );
+ }
}
- }
}
use strict;
sub wtf::wtf {
- my $query = shift;
- my $binary;
- my @binaries = (
- '/usr/games/wtf',
- '/usr/local/bin/wtf'
- );
- foreach (@binaries) {
- if (-x $_) {
- $binary=$_;
- last;
- }
- }
- if (!$binary) {
- return("no binary found.");
- }
- if ($query =~ /^$|[^\w]/){
- return("usage: wtf <foo>.");
- }
- if (!&::validExec($query)) {
- return("argument appears to be fuzzy.");
- }
+ my $query = shift;
+ my $binary;
+ my @binaries = ( '/usr/games/wtf', '/usr/local/bin/wtf' );
+ foreach (@binaries) {
+ if ( -x $_ ) {
+ $binary = $_;
+ last;
+ }
+ }
+ if ( !$binary ) {
+ return ("no binary found.");
+ }
+ if ( $query =~ /^$|[^\w]/ ) {
+ return ("usage: wtf <foo>.");
+ }
+ if ( !&::validExec($query) ) {
+ return ("argument appears to be fuzzy.");
+ }
- my $reply ='';
- foreach (`$binary '$query' 2>&1`){
- $reply .= $_;
- }
- $reply =~ s/\n/ /;
- chomp($reply);
- return($reply);
+ my $reply = '';
+ foreach (`$binary '$query' 2>&1`) {
+ $reply .= $_;
+ }
+ $reply =~ s/\n/ /;
+ chomp($reply);
+ return ($reply);
}
sub wtf::query {
- &::performStrictReply(&wtf(@_));
- return;
+ &::performStrictReply( &wtf(@_) );
+ return;
}
1;
my $no_zfi;
BEGIN {
- $no_zfi = 0;
- eval "use LWP::UserAgent";
- $no_zfi++ if ($@);
+ $no_zfi = 0;
+ eval "use LWP::UserAgent";
+ $no_zfi++ if ($@);
}
sub queryText {
- my ($query) = @_;
+ my ($query) = @_;
- if ($no_zfi) {
- &::status("zfi module requires LWP::UserAgent.");
- return '';
- }
+ if ($no_zfi) {
+ &::status("zfi module requires LWP::UserAgent.");
+ return '';
+ }
- my $res_return = 5;
+ my $res_return = 5;
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+ my $ua = new LWP::UserAgent;
+ $ua->proxy( 'http', $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') );
- $ua->timeout(10);
+ $ua->timeout(10);
- my $searchpath;
- if ($query) {
- $searchpath = "http://zaurii.com/zfi/zfibot.php?query=$query";
- } else {
- $searchpath = "http://zaurii.com/zfi/zfibot.php";
- }
+ my $searchpath;
+ if ($query) {
+ $searchpath = "http://zaurii.com/zfi/zfibot.php?query=$query";
+ }
+ else {
+ $searchpath = "http://zaurii.com/zfi/zfibot.php";
+ }
- my $request = new HTTP::Request('GET', "$searchpath");
- my $response = $ua->request($request);
+ my $request = new HTTP::Request( 'GET', "$searchpath" );
+ my $response = $ua->request($request);
- if (!$response->is_success) {
- return "Something failed in connecting to the ZFI web server. Try again later.";
- }
+ if ( !$response->is_success ) {
+ return
+"Something failed in connecting to the ZFI web server. Try again later.";
+ }
- my $content = $response->content;
+ my $content = $response->content;
- if ($content =~ /No entries found/im) {
- return "No results were found searching ZFI for '$query'.";
- }
+ if ( $content =~ /No entries found/im ) {
+ return "No results were found searching ZFI for '$query'.";
+ }
- my $res_count = 0; #local counter
- my $res_display = 0; #results displayed
+ my $res_count = 0; #local counter
+ my $res_display = 0; #results displayed
- my @lines = split(/\n/,$content);
+ my @lines = split( /\n/, $content );
- my $result = '';
- foreach my $line (@lines) {
- if (length($line) > 10) {
- my ($name, $href, $desc) = split(/\|/,$line);
+ my $result = '';
+ foreach my $line (@lines) {
+ if ( length($line) > 10 ) {
+ my ( $name, $href, $desc ) = split( /\|/, $line );
- if ($res_count < $res_return) {
- $result .= "$name ($desc) $href : ";
- $res_display ++;
- }
- $res_count ++;
- }
- }
+ if ( $res_count < $res_return ) {
+ $result .= "$name ($desc) $href : ";
+ $res_display++;
+ }
+ $res_count++;
+ }
+ }
- if (($query) && ($res_count > $res_display)) {
- $result .= "$res_display of $res_count shown. All at http://zaurii.com/zfi/index.phtml?p=r&r=$query";
- }
+ if ( ($query) && ( $res_count > $res_display ) ) {
+ $result .=
+"$res_display of $res_count shown. All at http://zaurii.com/zfi/index.phtml?p=r&r=$query";
+ }
- return $result;
+ return $result;
}
sub query {
- my ($args) = @_;
- &::performStrictReply(&queryText($args));
- return;
+ my ($args) = @_;
+ &::performStrictReply( &queryText($args) );
+ return;
}
1;
use strict;
BEGIN {
- $no_zsi = 0;
- eval "use LWP::UserAgent";
- $no_zsi++ if ($@);
+ $no_zsi = 0;
+ eval "use LWP::UserAgent";
+ $no_zsi++ if ($@);
}
sub queryText {
- my ($query) = @_;
+ my ($query) = @_;
- if ($no_zsi) {
- &::status("zsi module requires LWP::UserAgent.");
- return '';
- }
+ if ($no_zsi) {
+ &::status("zsi module requires LWP::UserAgent.");
+ return '';
+ }
- my $res_return = 5;
+ my $res_return = 5;
- my $ua = new LWP::UserAgent;
- $ua->proxy('http', $::param{'httpProxy'}) if (&::IsParam('httpProxy'));
+ my $ua = new LWP::UserAgent;
+ $ua->proxy( 'http', $::param{'httpProxy'} ) if ( &::IsParam('httpProxy') );
- $ua->timeout(10);
+ $ua->timeout(10);
- my $searchpath;
- if ($query) {
- $searchpath = "http://killefiz.de/zaurus/zsibot.php?query=$query";
- } else {
- $searchpath = "http://killefiz.de/zaurus/zsibot.php";
- }
+ my $searchpath;
+ if ($query) {
+ $searchpath = "http://killefiz.de/zaurus/zsibot.php?query=$query";
+ }
+ else {
+ $searchpath = "http://killefiz.de/zaurus/zsibot.php";
+ }
- my $request = new HTTP::Request('GET', "$searchpath");
- my $response = $ua->request($request);
+ my $request = new HTTP::Request( 'GET', "$searchpath" );
+ my $response = $ua->request($request);
- if (!$response->is_success) {
- return "Something failed in connecting to the ZSI web server. Try again later.";
- }
+ if ( !$response->is_success ) {
+ return
+"Something failed in connecting to the ZSI web server. Try again later.";
+ }
- my $content = $response->content;
+ my $content = $response->content;
- if ($content =~ /No entries found/im) {
- return "No results were found searching ZSI for '$query'.";
- }
+ if ( $content =~ /No entries found/im ) {
+ return "No results were found searching ZSI for '$query'.";
+ }
- my $res_count = 0; #local counter
- my $res_display = 0; #results displayed
+ my $res_count = 0; #local counter
+ my $res_display = 0; #results displayed
- my @lines = split(/\n/,$content);
+ my @lines = split( /\n/, $content );
- my $result = '';
- foreach my $line (@lines) {
- if (length($line) > 10) {
- my ($name, $href, $desc) = split(/\|/,$line);
+ my $result = '';
+ foreach my $line (@lines) {
+ if ( length($line) > 10 ) {
+ my ( $name, $href, $desc ) = split( /\|/, $line );
- if ($res_count < $res_return) {
- $result .= "$name ($desc) $href : ";
- $res_display ++;
- }
- $res_count ++;
- }
- }
+ if ( $res_count < $res_return ) {
+ $result .= "$name ($desc) $href : ";
+ $res_display++;
+ }
+ $res_count++;
+ }
+ }
- if (($query) && ($res_count > $res_display)) {
- $result .= "$res_display of $res_count shown. All at http://killefiz.de/zaurus/search.php?q=$query";
- }
+ if ( ($query) && ( $res_count > $res_display ) ) {
+ $result .=
+"$res_display of $res_count shown. All at http://killefiz.de/zaurus/search.php?q=$query";
+ }
- return $result;
+ return $result;
}
sub query {
- my ($args) = @_;
- &::performStrictReply(&queryText($args));
- return;
+ my ($args) = @_;
+ &::performStrictReply( &queryText($args) );
+ return;
}
1;
# Usage: &ftpGet($host,$dir,$file,[$lfile]);
sub ftpGet {
- my ($host,$dir,$file,$lfile) = @_;
- my $verbose_ftp = 1;
+ my ( $host, $dir, $file, $lfile ) = @_;
+ my $verbose_ftp = 1;
- return unless &loadPerlModule("Net::FTP");
+ return unless &loadPerlModule('Net::FTP');
&status("FTP: opening connection to $host.") if ($verbose_ftp);
- my $ftp = Net::FTP->new($host,
- 'Timeout' => 1*60,
+ my $ftp = Net::FTP->new(
+ $host,
+ 'Timeout' => 1 * 60,
### 'BlockSize' => 1024, # ???
);
return if ($@);
# login.
- if ($ftp->login()) {
- &status("FTP: logged in successfully.") if ($verbose_ftp);
- } else {
- &status("FTP: login failed.");
- $ftp->quit();
- return 0;
+ if ( $ftp->login() ) {
+ &status('FTP: logged in successfully.') if ($verbose_ftp);
+ }
+ else {
+ &status('FTP: login failed.');
+ $ftp->quit();
+ return 0;
}
# change directories.
- if ($ftp->cwd($dir)) {
- &status("FTP: changed dirs to $dir.") if ($verbose_ftp);
- } else {
- &status("FTP: cwd dir ($dir) does not exist.");
- $ftp->quit();
- return 0;
+ if ( $ftp->cwd($dir) ) {
+ &status("FTP: changed dirs to $dir.") if ($verbose_ftp);
+ }
+ else {
+ &status("FTP: cwd dir ($dir) does not exist.");
+ $ftp->quit();
+ return 0;
}
# get the size of the file.
- my ($size, $lsize);
- if ($size = $ftp->size($file)) {
- &status("FTP: file size is $size") if ($verbose_ftp);
- my $thisfile = $file || $lfile;
-
- if ( -f $thisfile) {
- $lsize = -s $thisfile;
- if ($_ != $lsize) {
- &status("FTP: local size is $lsize; downloading.") if ($verbose_ftp);
- } else {
- &status("FTP: same size; skipping.");
- system("touch $thisfile"); # lame hack.
- $ftp->quit();
- return 1;
- }
- }
- } else {
- &status("FTP: file does not exist.");
- $ftp->quit();
- return 0;
- }
-
- my $start_time = &timeget();
- if (defined $lfile) {
- &status("FTP: getting $file as $lfile.") if ($verbose_ftp);
- $ftp->get($file,$lfile);
- } else {
- &status("FTP: getting $file.") if ($verbose_ftp);
- $ftp->get($file);
- }
-
- if (defined $lsize) {
- &DEBUG("FTP: locsize => '$lsize'.");
- if ($size != $lsize) {
- &FIXME("FTP: downloaded file seems truncated.");
- }
- }
-
- my $delta_time = &timedelta($start_time);
- if ($delta_time > 0 and $verbose_ftp) {
- &status(sprintf("FTP: %.02f sec to complete.", $delta_time));
- my ($rateunit,$rate) = ('B', $size / $delta_time);
- if ($rate > 1024) {
- $rate /= 1024;
- $rateunit = 'kB';
- }
- &status(sprintf("FTP: %.01f ${rateunit}/sec.", $rate));
+ my ( $size, $lsize );
+ if ( $size = $ftp->size($file) ) {
+ &status("FTP: file size is $size") if ($verbose_ftp);
+ my $thisfile = $file || $lfile;
+
+ if ( -f $thisfile ) {
+ $lsize = -s $thisfile;
+ if ( $_ != $lsize ) {
+ &status("FTP: local size is $lsize; downloading.")
+ if ($verbose_ftp);
+ }
+ else {
+ &status('FTP: same size; skipping.');
+ system("touch $thisfile"); # lame hack.
+ $ftp->quit();
+ return 1;
+ }
+ }
+ }
+ else {
+ &status('FTP: file does not exist.');
+ $ftp->quit();
+ return 0;
+ }
+
+ my $start_time = &timeget();
+ if ( defined $lfile ) {
+ &status("FTP: getting $file as $lfile.") if ($verbose_ftp);
+ $ftp->get( $file, $lfile );
+ }
+ else {
+ &status("FTP: getting $file.") if ($verbose_ftp);
+ $ftp->get($file);
+ }
+
+ if ( defined $lsize ) {
+ &DEBUG("FTP: locsize => '$lsize'.");
+ if ( $size != $lsize ) {
+ &FIXME('FTP: downloaded file seems truncated.');
+ }
+ }
+
+ my $delta_time = &timedelta($start_time);
+ if ( $delta_time > 0 and $verbose_ftp ) {
+ &status( sprintf( 'FTP: %.02f sec to complete.', $delta_time ) );
+ my ( $rateunit, $rate ) = ( 'B', $size / $delta_time );
+ if ( $rate > 1024 ) {
+ $rate /= 1024;
+ $rateunit = 'kB';
+ }
+ &status( sprintf( "FTP: %.01f ${rateunit}/sec.", $rate ) );
}
$ftp->quit();
# Usage: &ftpList($host,$dir);
sub ftpList {
- my ($host,$dir) = @_;
+ my ( $host, $dir ) = @_;
my $verbose_ftp = 1;
- return unless &loadPerlModule("Net::FTP");
+ return unless &loadPerlModule('Net::FTP');
&status("FTP: opening connection to $host.") if ($verbose_ftp);
- my $ftp = Net::FTP->new($host,'Timeout'=>60);
+ my $ftp = Net::FTP->new( $host, 'Timeout' => 60 );
return if ($@);
# login.
- if ($ftp->login()) {
- &status("FTP: logged in successfully.") if ($verbose_ftp);
- } else {
- &status("FTP: login failed.");
- $ftp->quit();
- return;
+ if ( $ftp->login() ) {
+ &status('FTP: logged in successfully.') if ($verbose_ftp);
+ }
+ else {
+ &status('FTP: login failed.');
+ $ftp->quit();
+ return;
}
# change directories.
- if ($ftp->cwd($dir)) {
- &status("FTP: changed dirs to $dir.") if ($verbose_ftp);
- } else {
- &status("FTP: cwd dir ($dir) does not exist.");
- $ftp->quit();
- return;
- }
-
- &status("FTP: doing ls.") if ($verbose_ftp);
- foreach ($ftp->dir()) {
- # modes d uid gid size month day time file.
- if (/^(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+) (\S{3})\s+(\d+) \d+:\d+ (.*)$/) {
- # name = size.
- $ftp{$8} = $5;
- } else {
- &DEBUG("FTP: UNKNOWN => '$_'.");
- }
- }
- &status("FTP: ls done. ". scalar(keys %ftp) ." entries.");
+ if ( $ftp->cwd($dir) ) {
+ &status("FTP: changed dirs to $dir.") if ($verbose_ftp);
+ }
+ else {
+ &status("FTP: cwd dir ($dir) does not exist.");
+ $ftp->quit();
+ return;
+ }
+
+ &status('FTP: doing ls.') if ($verbose_ftp);
+ foreach ( $ftp->dir() ) {
+
+ # modes d uid gid size month day time file.
+ if (
+/^(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+) (\S{3})\s+(\d+) \d+:\d+ (.*)$/
+ )
+ {
+
+ # name = size.
+ $ftp{$8} = $5;
+ }
+ else {
+ &DEBUG("FTP: UNKNOWN => '$_'.");
+ }
+ }
+ &status( 'FTP: ls done. ' . scalar( keys %ftp ) . ' entries.' );
$ftp->quit();
return %ftp;
# Usage: &getURL($url, [$post]);
# TODO: rename this to getHTTP
sub getURL {
- my ($url,$post) = @_;
- my ($ua,$res,$req);
+ my ( $url, $post ) = @_;
+ my ( $ua, $res, $req );
- return unless &loadPerlModule("LWP::UserAgent");
+ return unless &loadPerlModule('LWP::UserAgent');
$ua = new LWP::UserAgent;
- $ua->proxy('http', $param{'httpProxy'}) if &IsParam('httpProxy');
+ $ua->proxy( 'http', $param{'httpProxy'} ) if &IsParam('httpProxy');
- if (defined $post) {
- $req = new HTTP::Request('POST',$url);
- $req->content_type('application/x-www-form-urlencoded');
- $req->content($post);
- } else {
- $req = new HTTP::Request('GET',$url);
+ if ( defined $post ) {
+ $req = new HTTP::Request( 'POST', $url );
+ $req->content_type('application/x-www-form-urlencoded');
+ $req->content($post);
+ }
+ else {
+ $req = new HTTP::Request( 'GET', $url );
}
&status("getURL: getting '$url'");
my $time = time();
$res = $ua->request($req);
- my $size = length($res->content);
- if ($size and time - $time) {
- my $rate = int( $size/1000/(time - $time) );
- &status("getURL: Done (took ".&Time2String(time - $time).", $rate k/sec)");
+ my $size = length( $res->content );
+ if ( $size and time - $time ) {
+ my $rate = int( $size / 1000 / ( time - $time ) );
+ &status('getURL: Done (took '
+ . &Time2String( time - $time )
+ . ", $rate k/sec)" );
}
# return NULL upon error.
- return unless ($res->is_success);
+ return unless ( $res->is_success );
- return(split '\n', $res->content);
+ return ( split '\n', $res->content );
}
sub getURLAsFile {
- my ($url,$file) = @_;
- my ($ua,$res,$req);
+ my ( $url, $file ) = @_;
+ my ( $ua, $res, $req );
my $time = time();
- unless (&loadPerlModule('LWP::UserAgent')) {
- &::DEBUG('getURLAsFile: LWP::UserAgent not installed');
- return;
+ unless ( &loadPerlModule('LWP::UserAgent') ) {
+ &::DEBUG('getURLAsFile: LWP::UserAgent not installed');
+ return;
}
$ua = new LWP::UserAgent;
- $ua->proxy('http', $param{'httpProxy'}) if &IsParam('httpProxy');
- $req = HTTP::Request->new('GET', $url);
+ $ua->proxy( 'http', $param{'httpProxy'} ) if &IsParam('httpProxy');
+ $req = HTTP::Request->new( 'GET', $url );
&status("getURLAsFile: getting '$url' as '$file'");
- $res = $ua->request($req, $file);
+ $res = $ua->request( $req, $file );
- my $delta_time = time() - $time;
+ my $delta_time = time() - $time;
if ($delta_time) {
- my $size = -s $file || 0;
- my $rate = int($size / $delta_time / 1024);
- &status("getURLAsFile: Done. ($rate kB/sec)");
+ my $size = -s $file || 0;
+ my $rate = int( $size / $delta_time / 1024 );
+ &status("getURLAsFile: Done. ($rate kB/sec)");
}
return $res;
use strict;
use vars qw($who $msgType $addressed $message $ident $user $host $chan
- $learnok $talkok $force_public_reply $noreply $addrchar
- $literal $addressedother $userHandle $lobotomized);
-use vars qw(%channels %users %param %cache %chanconf %mask %orig %lang
- );
+ $learnok $talkok $force_public_reply $noreply $addrchar
+ $literal $addressedother $userHandle $lobotomized);
+use vars qw(%channels %users %param %cache %chanconf %mask %orig %lang);
sub process {
- $learnok = 0; # Able to learn?
- $talkok = 0; # Able to yap?
+ $learnok = 0; # Able to learn?
+ $talkok = 0; # Able to yap?
$force_public_reply = 0;
- $literal = 0;
+ $literal = 0;
- return 'X' if $who eq $ident; # self-message.
+ return 'X' if $who eq $ident; # self-message.
return 'addressedother set' if ($addressedother);
- $talkok = ($param{'addressing'} =~ /^OPTIONAL$/i or $addressed);
- $learnok = 1 if ($addressed);
- if ($param{'learn'} =~ /^HUNGRY$/i) {
- $learnok = 1;
- $addrchar = 1;
- $talkok = 1;
+ $talkok = ( $param{'addressing'} =~ /^OPTIONAL$/i or $addressed );
+ $learnok = 1 if ($addressed);
+ if ( $param{'learn'} =~ /^HUNGRY$/i ) {
+ $learnok = 1;
+ $addrchar = 1;
+ $talkok = 1;
}
- &shmFlush(); # hack.
+ &shmFlush(); # hack.
- # hack to support channel +o as "+o" in bot user file.
+ # hack to support channel +o as '+o' in bot user file.
# requires +O in user file.
# is $who arg lowercase?
- if (exists $channels{$chan}{o}{ $orig{who} } && &IsFlag('O') eq 'O') {
- &status("Gave $who/$chan +o (+O)\'ness");
- $users{$userHandle}{FLAGS} .= 'o';
+ if ( exists $channels{$chan}{o}{ $orig{who} } && &IsFlag('O') eq 'O' ) {
+ &status("Gave $who/$chan +o (+O)\'ness");
+ $users{$userHandle}{FLAGS} .= 'o';
}
# check if we have our head intact.
if ($lobotomized) {
- if ($addressed and IsFlag('o') eq 'o') {
- my $delta_time = time() - ($cache{lobotomy}{$who} || 0);
- &msg($who, "give me an unlobotomy.") if ($delta_time > 60*60);
- $cache{lobotomy}{$who} = time();
- }
- return 'LOBOTOMY' unless IsFlag('A');
+ if ( $addressed and IsFlag('o') eq 'o' ) {
+ my $delta_time = time() - ( $cache{lobotomy}{$who} || 0 );
+ &msg( $who, 'give me an unlobotomy.' ) if ( $delta_time > 60 * 60 );
+ $cache{lobotomy}{$who} = time();
+ }
+ return 'LOBOTOMY' unless IsFlag('A');
}
# talkMethod.
- if ($param{'talkMethod'} =~ /^PRIVATE$/i) {
- if ($msgType =~ /public/ and $addressed) {
- &msg($who, "sorry. i'm in 'PRIVATE' talkMethod mode ".
- "while you sent a message to me ${msgType}ly.");
-
- return 'TALKMETHOD';
- }
+ if ( $param{'talkMethod'} =~ /^PRIVATE$/i ) {
+ if ( $msgType =~ /public/ and $addressed ) {
+ &msg( $who,
+ "sorry. i'm in 'PRIVATE' talkMethod mode "
+ . "while you sent a message to me ${msgType}ly." );
+
+ return 'TALKMETHOD';
+ }
}
# join, must be done before outsider checking.
- if ($message =~ /^join(\s+(.*))?\s*$/i) {
- return 'join: not addr' unless ($addressed);
-
- $2 =~ /^($mask{chan})(\s+(\S+))?/;
- my($joinchan, $key) = (lc $1, $3);
-
- if ($joinchan eq '') {
- &help('join');
- return;
- }
-
- if ($joinchan !~ /^$mask{chan}$/) {
- &msg($who, "$joinchan is not a valid channel name.");
- return;
- }
-
- if (&IsFlag('o') ne 'o') {
- if (!exists $chanconf{$joinchan}) {
- &msg($who, "I am not allowed to join $joinchan.");
- return;
- }
-
- if (&validChan($joinchan)) {
- &msg($who,"warn: I'm already on $joinchan, joining anyway...");
- }
- }
- $cache{join}{$joinchan} = $who; # used for on_join self.
-
- &status("JOIN $joinchan $key <$who>");
- &msg($who, "joining $joinchan $key");
- &joinchan($joinchan, $key);
- &joinNextChan(); # hack.
-
- return;
+ if ( $message =~ /^join(\s+(.*))?\s*$/i ) {
+ return 'join: not addr' unless ($addressed);
+
+ $2 =~ /^($mask{chan})(\s+(\S+))?/;
+ my ( $joinchan, $key ) = ( lc $1, $3 );
+
+ if ( $joinchan eq '' ) {
+ &help('join');
+ return;
+ }
+
+ if ( $joinchan !~ /^$mask{chan}$/ ) {
+ &msg( $who, "$joinchan is not a valid channel name." );
+ return;
+ }
+
+ if ( &IsFlag('o') ne 'o' ) {
+ if ( !exists $chanconf{$joinchan} ) {
+ &msg( $who, "I am not allowed to join $joinchan." );
+ return;
+ }
+
+ if ( &validChan($joinchan) ) {
+ &msg( $who,
+ "warn: I'm already on $joinchan, joining anyway..." );
+ }
+ }
+ $cache{join}{$joinchan} = $who; # used for on_join self.
+
+ &status("JOIN $joinchan $key <$who>");
+ &msg( $who, "joining $joinchan $key" );
+ &joinchan( $joinchan, $key );
+ &joinNextChan(); # hack.
+
+ return;
}
# 'identify'
- if ($msgType =~ /private/ and $message =~ s/^identify//i) {
- $message =~ s/^\s+|\s+$//g;
- my @array = split / /, $message;
-
- if ($who =~ /^_default$/i) {
- &performStrictReply("you are too eleet.");
- return;
- }
-
- if (!scalar @array or scalar @array > 2) {
- &help('identify');
- return;
- }
-
- my $do_nick = $array[1] || $who;
-
- if (!exists $users{$do_nick}) {
- &performStrictReply("nick $do_nick is not in user list.");
- return;
- }
-
- my $crypt = $users{$do_nick}{PASS};
- if (!defined $crypt) {
- &performStrictReply("user $do_nick has no passwd set.");
- return;
- }
-
- if (!&ckpasswd($array[0], $crypt)) {
- &performStrictReply("invalid passwd for $do_nick.");
- return;
- }
-
- my $mask = "$who!$user@".&makeHostMask($host);
- ### TODO: prevent adding multiple dupe masks?
- ### TODO: make &addHostMask() CMD?
- &performStrictReply("Added $mask for $do_nick...");
- $users{$do_nick}{HOSTS}{$mask} = 1;
-
- return;
+ if ( $msgType =~ /private/ and $message =~ s/^identify//i ) {
+ $message =~ s/^\s+|\s+$//g;
+ my @array = split / /, $message;
+
+ if ( $who =~ /^_default$/i ) {
+ &performStrictReply('you are too eleet.');
+ return;
+ }
+
+ if ( !scalar @array or scalar @array > 2 ) {
+ &help('identify');
+ return;
+ }
+
+ my $do_nick = $array[1] || $who;
+
+ if ( !exists $users{$do_nick} ) {
+ &performStrictReply("nick $do_nick is not in user list.");
+ return;
+ }
+
+ my $crypt = $users{$do_nick}{PASS};
+ if ( !defined $crypt ) {
+ &performStrictReply("user $do_nick has no passwd set.");
+ return;
+ }
+
+ if ( !&ckpasswd( $array[0], $crypt ) ) {
+ &performStrictReply("invalid passwd for $do_nick.");
+ return;
+ }
+
+ my $mask = "$who!$user@" . &makeHostMask($host);
+ ### TODO: prevent adding multiple dupe masks?
+ ### TODO: make &addHostMask() CMD?
+ &performStrictReply("Added $mask for $do_nick...");
+ $users{$do_nick}{HOSTS}{$mask} = 1;
+
+ return;
}
# 'pass'
- if ($msgType =~ /private/ and $message =~ s/^pass//i) {
- $message =~ s/^\s+|\s+$//g;
- my @array = split ' ', $message;
-
- if ($who =~ /^_default$/i) {
- &performStrictReply("you are too eleet.");
- return;
- }
-
- if (scalar @array != 1) {
- &help('pass');
- return;
- }
-
- # TODO: use &getUser()?
- my $first = 1;
- foreach (keys %users) {
- if ($users{$_}{FLAGS} =~ /n/) {
- $first = 0;
- last;
- }
- }
-
- if (!exists $users{$who} and !$first) {
- &performStrictReply("nick $who is not in user list.");
- return;
- }
-
- if ($first) {
- &performStrictReply("First time user... adding you as Master.");
- $users{$who}{FLAGS} = 'aemnorst';
- }
-
- my $crypt = $users{$who}{PASS};
- if (defined $crypt) {
- &performStrictReply("user $who already has pass set.");
- return;
- }
-
- if (!defined $host) {
- &WARN("pass: host == NULL.");
- return;
- }
-
- if (!scalar keys %{ $users{$who}{HOSTS} }) {
- my $mask = "*!$user@".&makeHostMask($host);
- &performStrictReply("Added hostmask '\002$mask\002' to $who");
- $users{$who}{HOSTS}{$mask} = 1;
- }
-
- $crypt = &mkcrypt($array[0]);
- $users{$who}{PASS} = $crypt;
- &performStrictReply("new pass for $who, crypt $crypt.");
-
- return;
+ if ( $msgType =~ /private/ and $message =~ s/^pass//i ) {
+ $message =~ s/^\s+|\s+$//g;
+ my @array = split ' ', $message;
+
+ if ( $who =~ /^_default$/i ) {
+ &performStrictReply('you are too eleet.');
+ return;
+ }
+
+ if ( scalar @array != 1 ) {
+ &help('pass');
+ return;
+ }
+
+ # TODO: use &getUser()?
+ my $first = 1;
+ foreach ( keys %users ) {
+ if ( $users{$_}{FLAGS} =~ /n/ ) {
+ $first = 0;
+ last;
+ }
+ }
+
+ if ( !exists $users{$who} and !$first ) {
+ &performStrictReply("nick $who is not in user list.");
+ return;
+ }
+
+ if ($first) {
+ &performStrictReply('First time user... adding you as Master.');
+ $users{$who}{FLAGS} = 'aemnorst';
+ }
+
+ my $crypt = $users{$who}{PASS};
+ if ( defined $crypt ) {
+ &performStrictReply("user $who already has pass set.");
+ return;
+ }
+
+ if ( !defined $host ) {
+ &WARN('pass: host == NULL.');
+ return;
+ }
+
+ if ( !scalar keys %{ $users{$who}{HOSTS} } ) {
+ my $mask = "*!$user@" . &makeHostMask($host);
+ &performStrictReply("Added hostmask '\002$mask\002' to $who");
+ $users{$who}{HOSTS}{$mask} = 1;
+ }
+
+ $crypt = &mkcrypt( $array[0] );
+ $users{$who}{PASS} = $crypt;
+ &performStrictReply("new pass for $who, crypt $crypt.");
+
+ return;
}
# allowOutsiders.
- if (&IsParam('disallowOutsiders') and $msgType =~ /private/i) {
- my $found = 0;
-
- foreach (keys %channels) {
- # don't test for $channel{_default} elsewhere !!!
- next if (/^\s*$/ || /^_?default$/);
- next unless (&IsNickInChan($who,$_));
-
- $found++;
- last;
- }
-
- if (!$found and scalar(keys %channels)) {
- &status("OUTSIDER <$who> $message");
- return 'OUTSIDER';
- }
+ if ( &IsParam('disallowOutsiders') and $msgType =~ /private/i ) {
+ my $found = 0;
+
+ foreach ( keys %channels ) {
+
+ # don't test for $channel{_default} elsewhere !!!
+ next if ( /^\s*$/ || /^_?default$/ );
+ next unless ( &IsNickInChan( $who, $_ ) );
+
+ $found++;
+ last;
+ }
+
+ if ( !$found and scalar( keys %channels ) ) {
+ &status("OUTSIDER <$who> $message");
+ return 'OUTSIDER';
+ }
}
# override msgType.
- if ($msgType =~ /public/ and $message =~ s/^\+//) {
- &status("Process: '+' flag detected; changing reply to public");
- $msgType = 'public';
- $who = $chan; # major hack to fix &msg().
- $force_public_reply++;
- # notice is still NOTICE but to whole channel => good.
+ if ( $msgType =~ /public/ and $message =~ s/^\+// ) {
+ &status("Process: '+' flag detected; changing reply to public");
+ $msgType = 'public';
+ $who = $chan; # major hack to fix &msg().
+ $force_public_reply++;
+
+ # notice is still NOTICE but to whole channel => good.
}
# User Processing, for all users.
if ($addressed) {
- my $retval;
- return 'SOMETHING parseCmdHook' if &parseCmdHook($message);
+ my $retval;
+ return 'SOMETHING parseCmdHook' if &parseCmdHook($message);
- $retval = &userCommands();
- return unless (defined $retval);
- return if ($retval eq $noreply);
+ $retval = &userCommands();
+ return unless ( defined $retval );
+ return if ( $retval eq $noreply );
}
###
###
# confused? is this for infobot communications?
- foreach (keys %{ $lang{'confused'} }) {
- my $y = $_;
+ foreach ( keys %{ $lang{'confused'} } ) {
+ my $y = $_;
- next unless ($message =~ /^\Q$y\E\s*/);
- return 'CONFUSO';
+ next unless ( $message =~ /^\Q$y\E\s*/ );
+ return 'CONFUSO';
}
# hello. [took me a while to fix this. -xk]
- if ($orig{message} =~ /^(\Q$ident\E\S?[:, ]\S?)?\s*(h(ello|i( there)?|owdy|ey|ola))( \Q$ident\E)?\s*$/i) {
- return '' unless ($talkok);
-
- # 'mynick: hi' or 'hi mynick' or 'hi'.
- &status("somebody said hello");
-
- # 50% chance of replying to a random greeting when not addressed
- if (!defined $5 and $addressed == 0 and rand() < 0.5) {
- &status("not returning unaddressed greeting");
- return;
- }
-
- # customized random message.
- my $tmp = (rand() < 0.5) ? ", $who" : '';
- &performStrictReply( &getRandom(keys %{ $lang{'hello'} }) . $tmp );
- return;
+ if ( $orig{message} =~
+/^(\Q$ident\E\S?[:, ]\S?)?\s*(h(ello|i( there)?|owdy|ey|ola))( \Q$ident\E)?\s*$/i
+ )
+ {
+ return '' unless ($talkok);
+
+ # 'mynick: hi' or 'hi mynick' or 'hi'.
+ &status('somebody said hello');
+
+ # 50% chance of replying to a random greeting when not addressed
+ if ( !defined $5 and $addressed == 0 and rand() < 0.5 ) {
+ &status('not returning unaddressed greeting');
+ return;
+ }
+
+ # customized random message.
+ my $tmp = ( rand() < 0.5 ) ? ", $who" : '';
+ &performStrictReply( &getRandom( keys %{ $lang{'hello'} } ) . $tmp );
+ return;
}
# greetings.
- if ($message =~ /how (the hell )?are (ya|you)( doin\'?g?)?\?*$/) {
+ if ( $message =~ /how (the hell )?are (ya|you)( doin\'?g?)?\?*$/ ) {
- &performReply(&getRandom(keys %{ $lang{'howareyou'} }));
- return;
+ &performReply( &getRandom( keys %{ $lang{'howareyou'} } ) );
+ return;
}
# praise.
- if ($message =~ /you (rock|rewl|rule|are so+ coo+l)/ ||
- $message =~ /(good (bo(t|y)|g([ui]|r+)rl))|(bot( |\-)?snack)/i)
+ if ( $message =~ /you (rock|rewl|rule|are so+ coo+l)/
+ || $message =~ /(good (bo(t|y)|g([ui]|r+)rl))|(bot( |\-)?snack)/i )
{
- return 'praise: no addr' unless ($addressed);
+ return 'praise: no addr' unless ($addressed);
- &performReply(&getRandom(keys %{ $lang{'praise'} }));
- return;
+ &performReply( &getRandom( keys %{ $lang{'praise'} } ) );
+ return;
}
# thanks.
- if ($message =~ /^than(ks?|x)( you)?( \S+)?/i) {
- return 'thank: no addr' unless ($message =~ /$ident/ or $talkok);
+ if ( $message =~ /^than(ks?|x)( you)?( \S+)?/i ) {
+ return 'thank: no addr' unless ( $message =~ /$ident/ or $talkok );
- &performReply( &getRandom(keys %{ $lang{'welcome'} }) );
- return;
+ &performReply( &getRandom( keys %{ $lang{'welcome'} } ) );
+ return;
}
###
###
# karma. set...
- if ($msgType =~ /public/i && $message =~ /^(\S+)(--|\+\+)\s*$/ &&
- $addressed && &IsChanConfOrWarn('karma')
- ) {
- # to request factoids such as "g++" or "libstdc++", append "?" to the query.
- my ($term,$inc) = (lc $1,$2);
-
- if (lc $term eq lc $who) {
- &msg($who, "please don't karma yourself");
- return;
- }
-
- my $karma = &sqlSelect('stats', 'counter',
- { nick => $term, type => 'karma' }) || 0;
- if ($inc eq '++') {
- $karma++;
- } else {
- $karma--;
- }
-
- &sqlSet('stats', {'nick' => $term, type => 'karma', channel => 'PRIVATE'}, {
- 'time' => time(),
- counter => $karma,
- } );
-
- return;
+ if ( $msgType =~ /public/i
+ && $message =~ /^(\S+)(--|\+\+)\s*$/
+ && $addressed
+ && &IsChanConfOrWarn('karma') )
+ {
+
+ # to request factoids such as 'g++' or 'libstdc++', append '?' to the query.
+ my ( $term, $inc ) = ( lc $1, $2 );
+
+ if ( lc $term eq lc $who ) {
+ &msg( $who, "please don't karma yourself" );
+ return;
+ }
+
+ my $karma =
+ &sqlSelect( 'stats', 'counter', { nick => $term, type => 'karma' } )
+ || 0;
+ if ( $inc eq '++' ) {
+ $karma++;
+ }
+ else {
+ $karma--;
+ }
+
+ &sqlSet(
+ 'stats',
+ { 'nick' => $term, type => 'karma', channel => 'PRIVATE' },
+ {
+ 'time' => time(),
+ counter => $karma,
+ }
+ );
+
+ return;
}
# here's where the external routines get called.
# if they return anything but null, that's the 'answer'.
if ($addressed) {
- my $er = &Modules();
- if (!defined $er) {
- return 'SOMETHING 1';
- }
-
- # allow administration of bot via messages (default is DCC CHAT only)
- if (&IsFlag('A')) {
- &loadMyModule('UserDCC');
- $er = &userDCC();
- if (!defined $er) {
- return 'SOMETHING 2';
- }
- }
-
- if (0 and $addrchar) {
- &msg($who, "I don't trust people to use the core commands while addressing me in a short-cut way.");
- return;
- }
+ my $er = &Modules();
+ if ( !defined $er ) {
+ return 'SOMETHING 1';
+ }
+
+ # allow administration of bot via messages (default is DCC CHAT only)
+ if ( &IsFlag('A') ) {
+ &loadMyModule('UserDCC');
+ $er = &userDCC();
+ if ( !defined $er ) {
+ return 'SOMETHING 2';
+ }
+ }
+
+ if ( 0 and $addrchar ) {
+ &msg( $who,
+"I don't trust people to use the core commands while addressing me in a short-cut way."
+ );
+ return;
+ }
}
- if (&IsParam('factoids') and $param{'DBType'} =~ /^(mysql|sqlite(2)?|pgsql)$/i) {
- &FactoidStuff();
- } elsif ($param{'DBType'} =~ /^none$/i) {
- return "NO FACTOIDS.";
- } else {
- &ERROR("INVALID FACTOID SUPPORT? ($param{'DBType'})");
- &shutdown();
- exit 0;
+ if ( &IsParam('factoids')
+ and $param{'DBType'} =~ /^(mysql|sqlite(2)?|pgsql)$/i )
+ {
+ &FactoidStuff();
+ }
+ elsif ( $param{'DBType'} =~ /^none$/i ) {
+ return 'NO FACTOIDS.';
+ }
+ else {
+ &ERROR("INVALID FACTOID SUPPORT? ($param{'DBType'})");
+ &shutdown();
+ exit 0;
}
}
sub openSHM {
my $IPC_PRIVATE = 0;
- my $size = 2000;
+ my $size = 2000;
- if (&IsParam('noSHM')) {
- &status("Shared memory: Disabled. WARNING: bot may become unreliable");
- return 0;
+ if ( &IsParam('noSHM') ) {
+ &status('Shared memory: Disabled. WARNING: bot may become unreliable');
+ return 0;
}
- if (defined( $_ = shmget($IPC_PRIVATE, $size, 0777) )) {
- &status("Created shared memory (shm) key: [$_]");
- $shm_keys{$_} = {time => time,
- accessed => 0,
- key => $_,
- };
- return $_;
- } else {
- &ERROR("openSHM: failed.");
- &ERROR("Please delete some shared memory with ipcs or ipcrm.");
- exit 1;
+ if ( defined( $_ = shmget( $IPC_PRIVATE, $size, 0777 ) ) ) {
+ &status("Created shared memory (shm) key: [$_]");
+ $shm_keys{$_} = {
+ time => time,
+ accessed => 0,
+ key => $_,
+ };
+ return $_;
+ }
+ else {
+ &ERROR('openSHM: failed.');
+ &ERROR('Please delete some shared memory with ipcs or ipcrm.');
+ exit 1;
}
}
my ($key) = @_;
my $IPC_RMID = 0;
- return '' if (!defined $key);
+ return '' if ( !defined $key );
&shmFlush();
&status("Closed shared memory (shm) key: [$key]");
- return shmctl($key, $IPC_RMID, 0);
+ return shmctl( $key, $IPC_RMID, 0 );
}
sub shmRead {
- my ($key) = @_;
+ my ($key) = @_;
my $position = 0;
- my $size = 3*80;
- my $retval = '';
-
- return '' if (&IsParam('noSHM'));
-
- if (shmread($key,$retval,$position,$size)) {
- #&DEBUG("shmRead($key): $retval");
- return $retval;
- } else {
- &ERROR("shmRead: failed: $!");
- if (exists $shm_keys{$_}) {
- closeSHM($key);
- }
- ### TODO: if this fails, never try again.
- # What use is opening a SHM segment if we're not going to read it?
- # &openSHM();
- return '';
+ my $size = 3 * 80;
+ my $retval = '';
+
+ return '' if ( &IsParam('noSHM') );
+
+ if ( shmread( $key, $retval, $position, $size ) ) {
+
+ #&DEBUG("shmRead($key): $retval");
+ return $retval;
+ }
+ else {
+ &ERROR("shmRead: failed: $!");
+ if ( exists $shm_keys{$_} ) {
+ closeSHM($key);
+ }
+ ### TODO: if this fails, never try again.
+ # What use is opening a SHM segment if we're not going to read it?
+ # &openSHM();
+ return '';
}
}
sub shmWrite {
- my ($key, $str) = @_;
+ my ( $key, $str ) = @_;
my $position = 0;
- my $size = 80*3;
+ my $size = 80 * 3;
- return if (&IsParam('noSHM'));
+ return if ( &IsParam('noSHM') );
$shm_keys{$keys}{accessed} = 1;
- if (length($str) > $size) {
- &status("ERROR: length(str) (..)>$size...");
- return;
+ if ( length($str) > $size ) {
+ &status("ERROR: length(str) (..)>$size...");
+ return;
}
- if (length($str) == 0) {
- # does $size overwrite the whole lot?
- # if not, set to 2000.
- if (!shmwrite($key, '', $position, $size)) {
- &ERROR("shmWrite: failed: $!");
- }
- return;
+ if ( length($str) == 0 ) {
+
+ # does $size overwrite the whole lot?
+ # if not, set to 2000.
+ if ( !shmwrite( $key, '', $position, $size ) ) {
+ &ERROR("shmWrite: failed: $!");
+ }
+ return;
}
my $read = &shmRead($key);
$read =~ s/\0+//g;
- if ($read eq '') {
- $str = sprintf("%s:%d:%d: ", $param{ircUser}, $bot_pid, time());
- } else {
- $str = $read ."||". $str;
+ if ( $read eq '' ) {
+ $str = sprintf( '%s:%d:%d: ', $param{ircUser}, $bot_pid, time() );
+ }
+ else {
+ $str = $read . '||' . $str;
}
- if (!shmwrite($key, $str, $position, $size)) {
- &DEBUG("shmWrite($key, $str)");
- &ERROR("shmWrite: failed: $!");
+ if ( !shmwrite( $key, $str, $position, $size ) ) {
+ &DEBUG("shmWrite($key, $str)");
+ &ERROR("shmWrite: failed: $!");
}
}
# Usage: &addForked($name);
# Return: 1 for success, 0 for failure.
sub addForked {
- my ($name) = @_;
- my $forker_timeout = 360; # 6mins, in seconds.
- $forker = $name;
+ my ($name) = @_;
+ my $forker_timeout = 360; # 6mins, in seconds.
+ $forker = $name;
- if (!defined $name) {
- &WARN("addForked: name == NULL.");
- return 0;
+ if ( !defined $name ) {
+ &WARN('addForked: name == NULL.');
+ return 0;
}
- foreach (keys %forked) {
- my $n = $_;
- my $time = time() - $forked{$n}{Time};
- next unless ($time > $forker_timeout);
+ foreach ( keys %forked ) {
+ my $n = $_;
+ my $time = time() - $forked{$n}{Time};
+ next unless ( $time > $forker_timeout );
- ### TODO: use &time2string()?
- &WARN("Fork: looks like we lost '$n', executed $time ago");
+ ### TODO: use &time2string()?
+ &WARN("Fork: looks like we lost '$n', executed $time ago");
- my $pid = $forked{$n}{PID};
- if (!defined $pid) {
- &WARN("Fork: no pid for $n.");
- delete $forked{$n};
- next;
- }
+ my $pid = $forked{$n}{PID};
+ if ( !defined $pid ) {
+ &WARN("Fork: no pid for $n.");
+ delete $forked{$n};
+ next;
+ }
- if ($pid == $bot_pid) {
- # don't kill parent, just warn.
- &status("Fork: pid == \$bot_pid == \$\$ ($bot_pid)");
+ if ( $pid == $bot_pid ) {
- } elsif ( -d "/proc/$pid") { # pid != bot_pid.
- &status("Fork: killing $name ($pid)");
- kill 9, $pid;
- }
+ # don't kill parent, just warn.
+ &status("Fork: pid == \$bot_pid == \$\$ ($bot_pid)");
- delete $forked{$n};
+ }
+ elsif ( -d "/proc/$pid" ) { # pid != bot_pid.
+ &status("Fork: killing $name ($pid)");
+ kill 9, $pid;
+ }
+
+ delete $forked{$n};
}
my $count = 0;
- while (scalar keys %forked > 1) { # 2 or more == fail.
- sleep 1;
-
- if ($count > 3) { # 3 seconds.
- my $list = join(', ', keys %forked);
- if (defined $who) {
- &msg($who, "exceeded allowed forked count (shm $shm): $list");
- } else {
- &status("Fork: I ran too many forked processes :) Giving up $name. Shm: $shm");
- }
-
- return 0;
- }
-
- $count++;
+ while ( scalar keys %forked > 1 ) { # 2 or more == fail.
+ sleep 1;
+
+ if ( $count > 3 ) { # 3 seconds.
+ my $list = join( ', ', keys %forked );
+ if ( defined $who ) {
+ &msg( $who, "exceeded allowed forked count (shm $shm): $list" );
+ }
+ else {
+ &status(
+"Fork: I ran too many forked processes :) Giving up $name. Shm: $shm"
+ );
+ }
+
+ return 0;
+ }
+
+ $count++;
}
- if (exists $forked{$name} and !scalar keys %{ $forked{$name} }) {
- &WARN("addF: forked{$name} exists but is empty; deleting.");
- undef $forked{$name};
+ if ( exists $forked{$name} and !scalar keys %{ $forked{$name} } ) {
+ &WARN("addF: forked{$name} exists but is empty; deleting.");
+ undef $forked{$name};
}
- if (exists $forked{$name} and scalar keys %{ $forked{$name} }) {
- my $time = $forked{$name}{Time};
- my $continue = 0;
+ if ( exists $forked{$name} and scalar keys %{ $forked{$name} } ) {
+ my $time = $forked{$name}{Time};
+ my $continue = 0;
- $continue++ if ($forked{$name}{PID} == $$);
+ $continue++ if ( $forked{$name}{PID} == $$ );
- if ($continue) {
- &WARN("hrm.. fork pid == mypid == $$; how did this happen?");
+ if ($continue) {
+ &WARN("hrm.. fork pid == mypid == $$; how did this happen?");
- } elsif ( -d "/proc/$forked{$name}{PID}") {
- &status("fork: still running; good. BAIL OUT.");
- return 0;
+ }
+ elsif ( -d "/proc/$forked{$name}{PID}" ) {
+ &status('fork: still running; good. BAIL OUT.');
+ return 0;
- } else {
- &WARN("Found dead fork; removing and resetting.");
- $continue = 1;
- }
+ }
+ else {
+ &WARN('Found dead fork; removing and resetting.');
+ $continue = 1;
+ }
- if ($continue) {
- # NOTHING.
+ if ($continue) {
- } elsif (time() - $time > 900) { # stale fork > 15m.
- &status("forked: forked{$name} presumably exited without notifying us.");
+ # NOTHING.
- } else { # fresh fork.
- &msg($who, "$name is already running ". &Time2String(time() - $time));
- return 0;
- }
+ }
+ elsif ( time() - $time > 900 ) { # stale fork > 15m.
+ &status(
+ "forked: forked{$name} presumably exited without notifying us."
+ );
+
+ }
+ else { # fresh fork.
+ &msg( $who,
+ "$name is already running " . &Time2String( time() - $time ) );
+ return 0;
+ }
}
- $forked{$name}{Time} = time();
- $forked{$name}{PID} = $$;
- $forkedtime = time();
+ $forked{$name}{Time} = time();
+ $forked{$name}{PID} = $$;
+ $forkedtime = time();
$count{'Fork'}++;
return 1;
}
sub delForked {
- my ($name) = @_;
+ my ($name) = @_;
- return if ($$ == $bot_pid);
+ return if ( $$ == $bot_pid );
- if (!defined $name) {
- &WARN("delForked: name == NULL.");
- POSIX::_exit(0);
+ if ( !defined $name ) {
+ &WARN('delForked: name == NULL.');
+ POSIX::_exit(0);
}
- if ($name =~ /\.pl/) {
- &WARN("dF: name is name of source file ($name). FIX IT!");
+ if ( $name =~ /\.pl/ ) {
+ &WARN("dF: name is name of source file ($name). FIX IT!");
}
- &showProc(); # just for informational purposes.
+ &showProc(); # just for informational purposes.
- if (exists $forked{$name}) {
- my $timestr = &Time2String(time() - $forked{$name}{Time});
- &status("fork: took $timestr for $name.");
- &shmWrite($shm,"DELETE FORK $name");
- } else {
- &ERROR("delForked: forked{$name} does not exist. should not happen.");
+ if ( exists $forked{$name} ) {
+ my $timestr = &Time2String( time() - $forked{$name}{Time} );
+ &status("fork: took $timestr for $name.");
+ &shmWrite( $shm, "DELETE FORK $name" );
+ }
+ else {
+ &ERROR("delForked: forked{$name} does not exist. should not happen.");
}
&status("--- fork finished for '$name' ---");
}
sub shmFlush {
- return if ($$ != $::bot_pid); # fork protection.
+ return if ( $$ != $::bot_pid ); # fork protection.
if (@_) {
- &ScheduleThis(15, 'shmFlush');
- return if ($_[0] eq '2');
+ &ScheduleThis( 15 * 60, 'shmFlush' ); # 15 minutes
+ return if ( $_[0] eq '2' );
}
my $time;
my $shmmsg = &shmRead($shm);
+
# remove padded \0's.
$shmmsg =~ s/\0//g;
- return if (length($shmmsg) == 0);
- if ($shmmsg =~ s/^(\S+):(\d+):(\d+): //) {
- my $n = $1;
- my $pid = $2;
- $time = $3;
- } else {
- &status("warn: shmmsg='$shmmsg'.");
- return;
+ return if ( length($shmmsg) == 0 );
+ if ( $shmmsg =~ s/^(\S+):(\d+):(\d+): // ) {
+ my $n = $1;
+ my $pid = $2;
+ $time = $3;
+ }
+ else {
+ &status("warn: shmmsg='$shmmsg'.");
+ return;
}
- foreach (split '\|\|', $shmmsg) {
- next if (/^$/);
- &VERB("shm: Processing '$_'.",2);
-
- if (/^DCC SEND (\S+) (\S+)$/) {
- my ($nick,$file) = ($1,$2);
- if (exists $dcc{'SEND'}{$who}) {
- &msg($nick, "DCC already active.");
- } else {
- &DEBUG("shm: dcc sending $2 to $1.");
- $conn->new_send($1,$2);
- $dcc{'SEND'}{$who} = time();
- }
- } elsif (/^SET FORKPID (\S+) (\S+)/) {
- $forked{$1}{PID} = $2;
- } elsif (/^DELETE FORK (\S+)$/) {
- delete $forked{$1};
- } elsif (/^EVAL (.*)$/) {
- &DEBUG("evaling '$1'.");
- eval $1;
- } else {
- &DEBUG("shm: unknown msg. ($_)");
- }
+ foreach ( split '\|\|', $shmmsg ) {
+ next if (/^$/);
+ &VERB( "shm: Processing '$_'.", 2 );
+
+ if (/^DCC SEND (\S+) (\S+)$/) {
+ my ( $nick, $file ) = ( $1, $2 );
+ if ( exists $dcc{'SEND'}{$who} ) {
+ &msg( $nick, 'DCC already active.' );
+ }
+ else {
+ &DEBUG("shm: dcc sending $2 to $1.");
+ $conn->new_send( $1, $2 );
+ $dcc{'SEND'}{$who} = time();
+ }
+ }
+ elsif (/^SET FORKPID (\S+) (\S+)/) {
+ $forked{$1}{PID} = $2;
+ }
+ elsif (/^DELETE FORK (\S+)$/) {
+ delete $forked{$1};
+ }
+ elsif (/^EVAL (.*)$/) {
+ &DEBUG("evaling '$1'.");
+ eval $1;
+ }
+ else {
+ &DEBUG("shm: unknown msg. ($_)");
+ }
}
- &shmWrite($shm,'') if ($shmmsg ne '');
+ &shmWrite( $shm, '' ) if ( $shmmsg ne '' );
}
1;
use strict;
use vars qw($message $arg $qWord $verb $lobotomized $who $result $chan
- $conn $msgType $query $talkchannel $ident $memusage);
+ $conn $msgType $query $talkchannel $ident $memusage);
use vars qw(%channels %chanstats %cmdstats %count %forked %ircstats %param
- %cache %mask %userstats);
+ %cache %mask %userstats);
### hooks get added in CommandHooks.pl.
my $chan = lc shift(@_);
my $mode;
- if ($chan eq '') { # all channels.
- my $i = keys %channels;
- my $reply = "I'm on \002$i\002 ".&fixPlural('channel',$i);
- my $tucount = 0; # total user count.
- my $uucount = 0; # unique user count.
- my %chans;
- my @array;
-
- ### line 1.
- foreach (keys %channels) {
- if ( /^\s*$/ or / / ) {
- &status("chanstats: fe channels: chan == NULL.");
- #&ircCheck();
- next;
- }
- next if (/^_default$/);
-
- $chans{$_} = scalar(keys %{ $channels{$_}{''} });
- }
- foreach $chan (sort {$chans{$b} <=> $chans{$a}} keys %chans) {
- push(@array, "$chan/" . $chans{$chan});
- }
- &performStrictReply($reply.": ".join(', ', @array));
-
- ### total user count.
- foreach $chan (keys %channels) {
- $tucount += scalar(keys %{ $channels{$chan}{''} });
- }
-
- ### unique user count.
- my %nicks = ();
- foreach $chan (keys %channels) {
- my $nick;
- foreach $nick (keys %{ $channels{$chan}{''} }) {
- $nicks{$nick}++;
- }
- }
- $uucount = scalar(keys %nicks);
-
- my $chans = scalar(keys %channels);
- &performStrictReply(
- "i've cached \002$tucount\002 ". &fixPlural('user',$tucount).
- ", \002$uucount\002 unique ". &fixPlural('user',$uucount).
- ", distributed over \002$chans\002 ".
- &fixPlural('channel', $chans)."."
- );
- &ircCheck();
-
- return;
+ if ( $chan eq '' ) { # all channels.
+ my $i = keys %channels;
+ my $reply = "I'm on \002$i\002 " . &fixPlural( 'channel', $i );
+ my $tucount = 0; # total user count.
+ my $uucount = 0; # unique user count.
+ my %chans;
+ my @array;
+
+ ### line 1.
+ foreach ( keys %channels ) {
+ if ( /^\s*$/ or / / ) {
+ &status('chanstats: fe channels: chan == NULL.');
+
+ #&ircCheck();
+ next;
+ }
+ next if (/^_default$/);
+
+ $chans{$_} = scalar( keys %{ $channels{$_}{''} } );
+ }
+ foreach $chan ( sort { $chans{$b} <=> $chans{$a} } keys %chans ) {
+ push( @array, "$chan/" . $chans{$chan} );
+ }
+ &performStrictReply( $reply . ': ' . join( ', ', @array ) );
+
+ ### total user count.
+ foreach $chan ( keys %channels ) {
+ $tucount += scalar( keys %{ $channels{$chan}{''} } );
+ }
+
+ ### unique user count.
+ my %nicks = ();
+ foreach $chan ( keys %channels ) {
+ my $nick;
+ foreach $nick ( keys %{ $channels{$chan}{''} } ) {
+ $nicks{$nick}++;
+ }
+ }
+ $uucount = scalar( keys %nicks );
+
+ my $chans = scalar( keys %channels );
+ &performStrictReply( "i've cached \002$tucount\002 "
+ . &fixPlural( 'user', $tucount )
+ . ", \002$uucount\002 unique "
+ . &fixPlural( 'user', $uucount )
+ . ", distributed over \002$chans\002 "
+ . &fixPlural( 'channel', $chans )
+ . '.' );
+ &ircCheck();
+
+ return;
}
# channel specific.
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
+ if ( &validChan($chan) == 0 ) {
+ &msg( $who, "error: invalid channel \002$chan\002" );
+ return;
}
# Step 1:
my @array;
- foreach (sort keys %{ $chanstats{$chan} }) {
- my $int = $chanstats{$chan}{$_};
- next unless ($int);
+ foreach ( sort keys %{ $chanstats{$chan} } ) {
+ my $int = $chanstats{$chan}{$_};
+ next unless ($int);
- push(@array, "\002$int\002 ". &fixPlural($_,$int));
+ push( @array, "\002$int\002 " . &fixPlural( $_, $int ) );
}
- my $reply = "On \002$chan\002, there ".
- &fixPlural('has',scalar(@array)). " been ".
- &IJoin(@array);
+ my $reply =
+ "On \002$chan\002, there "
+ . &fixPlural( 'has', scalar(@array) )
+ . ' been '
+ . &IJoin(@array);
# Step 1b: check channel inconstencies.
- $chanstats{$chan}{'Join'} ||= 0;
- $chanstats{$chan}{'SignOff'} ||= 0;
- $chanstats{$chan}{'Part'} ||= 0;
+ $chanstats{$chan}{'Join'} ||= 0;
+ $chanstats{$chan}{'SignOff'} ||= 0;
+ $chanstats{$chan}{'Part'} ||= 0;
- my $delta_stats = $chanstats{$chan}{'Join'}
- - $chanstats{$chan}{'SignOff'}
- - $chanstats{$chan}{'Part'};
+ my $delta_stats = $chanstats{$chan}{'Join'} - $chanstats{$chan}{'SignOff'} -
+ $chanstats{$chan}{'Part'};
if ($delta_stats) {
- my $total = scalar(keys %{ $channels{$chan}{''} });
- &status("chaninfo: join ~= signoff + part (drift of $delta_stats < $total).");
+ my $total = scalar( keys %{ $channels{$chan}{''} } );
+ &status(
+ "chaninfo: join ~= signoff + part (drift of $delta_stats < $total)."
+ );
- if ($delta_stats > $total) {
- &ERROR("chaninfo: delta_stats exceeds total users.");
- }
+ if ( $delta_stats > $total ) {
+ &ERROR('chaninfo: delta_stats exceeds total users.');
+ }
}
# Step 2:
undef @array;
my $type;
- foreach ('v','o','') {
- my $int = scalar(keys %{ $channels{$chan}{$_} });
- next unless ($int);
+ foreach ( 'v', 'o', '' ) {
+ my $int = scalar( keys %{ $channels{$chan}{$_} } );
+ next unless ($int);
- $type = 'Voice' if ($_ eq 'v');
- $type = 'Opped' if ($_ eq 'o');
- $type = 'Total' if ($_ eq '');
+ $type = 'Voice' if ( $_ eq 'v' );
+ $type = 'Opped' if ( $_ eq 'o' );
+ $type = 'Total' if ( $_ eq '' );
- push(@array,"\002$int\002 $type");
+ push( @array, "\002$int\002 $type" );
}
- $reply .= ". At the moment, ". &IJoin(@array);
+ $reply .= '. At the moment, ' . &IJoin(@array);
# Step 3:
my %new;
- foreach (keys %userstats) {
- next unless (exists $userstats{$_}{'Count'});
- if ($userstats{$_}{'Count'} =~ /^\D+$/) {
- &WARN("userstats{$_}{Count} is non-digit.");
- next;
- }
+ foreach ( keys %userstats ) {
+ next unless ( exists $userstats{$_}{'Count'} );
+ if ( $userstats{$_}{'Count'} =~ /^\D+$/ ) {
+ &WARN("userstats{$_}{Count} is non-digit.");
+ next;
+ }
- $new{$_} = $userstats{$_}{'Count'};
+ $new{$_} = $userstats{$_}{'Count'};
}
# TODO: show top 3 with percentages?
- my($count) = (sort { $new{$b} <=> $new{$a} } keys %new)[0];
+ my ($count) = ( sort { $new{$b} <=> $new{$a} } keys %new )[0];
if ($count) {
- $reply .= ". \002$count\002 has said the most with a total of \002$new{$count}\002 messages";
+ $reply .=
+". \002$count\002 has said the most with a total of \002$new{$count}\002 messages";
}
&performStrictReply("$reply.");
}
sub cmdstats {
my @array;
- if (!scalar(keys %cmdstats)) {
- &performReply("no-one has run any commands yet");
- return;
+ if ( !scalar( keys %cmdstats ) ) {
+ &performReply('no-one has run any commands yet');
+ return;
}
my %countstats;
- foreach (keys %cmdstats) {
- $countstats{ $cmdstats{$_} }{$_} = 1;
+ foreach ( keys %cmdstats ) {
+ $countstats{ $cmdstats{$_} }{$_} = 1;
}
- foreach (sort {$b <=> $a} keys %countstats) {
- my $int = $_;
- next unless ($int);
+ foreach ( sort { $b <=> $a } keys %countstats ) {
+ my $int = $_;
+ next unless ($int);
- foreach (keys %{ $countstats{$int} }) {
- push(@array, "\002$int\002 of $_");
- }
+ foreach ( keys %{ $countstats{$int} } ) {
+ push( @array, "\002$int\002 of $_" );
+ }
}
- &performStrictReply("command usage include ". &IJoin(@array).".");
+ &performStrictReply( 'command usage include ' . &IJoin(@array) . '.' );
}
# Factoid extension info. xk++
my $faqtoid = lc shift(@_);
my $query = '';
- if ($faqtoid =~ /^\-(\S+)(\s+(.*))$/) {
- &msg($who,"error: individual factoid info queries not supported as yet.");
- &msg($who,"it's possible that the factoid mistakenly begins with '-'.");
- return;
+ if ( $faqtoid =~ /^\-(\S+)(\s+(.*))$/ ) {
+ &msg( $who,
+ 'error: individual factoid info queries not supported as yet.' );
+ &msg( $who,
+ "it's possible that the factoid mistakenly begins with '-'." );
+ return;
- $query = lc $1;
- $faqtoid = lc $3;
+ $query = lc $1;
+ $faqtoid = lc $3;
}
- &CmdFactInfo($faqtoid, $query);
+ &CmdFactInfo( $faqtoid, $query );
}
sub factstats {
my $type = shift(@_);
- &Forker('Factoids', sub {
- &performStrictReply( &CmdFactStats($type) );
- } );
+ &Forker(
+ 'Factoids',
+ sub {
+ &performStrictReply( &CmdFactStats($type) );
+ }
+ );
}
sub karma {
- my $target = lc( shift || $who );
- my $karma = &sqlSelect('stats', 'counter',
- { nick => $target, type => 'karma'}) || 0;
+ my $target = lc( shift || $who );
+ my $karma =
+ &sqlSelect( 'stats', 'counter', { nick => $target, type => 'karma' } )
+ || 0;
- if ($karma != 0) {
- &performStrictReply("$target has karma of $karma");
- } else {
- &performStrictReply("$target has neutral karma");
+ if ( $karma != 0 ) {
+ &performStrictReply("$target has karma of $karma");
+ }
+ else {
+ &performStrictReply("$target has neutral karma");
}
}
sub tell {
my $args = shift;
- my ($target, $tell_obj) = ('','');
- my $dont_tell_me = 0;
+ my ( $target, $tell_obj ) = ( '', '' );
+ my $dont_tell_me = 0;
my $reply;
### is this fixed elsewhere?
- $args =~ s/\s+/ /g; # fix up spaces.
- $args =~ s/^\s+|\s+$//g; # again.
+ $args =~ s/\s+/ /g; # fix up spaces.
+ $args =~ s/^\s+|\s+$//g; # again.
# this one catches most of them
- if ($args =~ /^(\S+) (-?)about (.*)$/i) {
- $target = $1;
- $tell_obj = $3;
- $dont_tell_me = ($2) ? 1 : 0;
-
- $tell_obj = $who if ($tell_obj =~ /^(me|myself)$/i);
- $query = $tell_obj;
- } elsif ($args =~ /^(\S+) where (\S+) can (\S+) (.*)$/i) {
- # i'm sure this could all be nicely collapsed
- $target = $1;
- $tell_obj = $4;
- $query = $tell_obj;
-
- } elsif ($args =~ /^(\S+) (what|where) (.*?) (is|are)[.?!]*$/i) {
- $target = $1;
- $qWord = $2;
- $tell_obj = $3;
- $verb = $4;
- $query = "$qWord $verb $tell_obj";
-
- } elsif ($args =~ /^(.*?) to (\S+)$/i) {
- $target = $3;
- $tell_obj = $2;
- $query = $tell_obj;
+ if ( $args =~ /^(\S+) (-?)about (.*)$/i ) {
+ $target = $1;
+ $tell_obj = $3;
+ $dont_tell_me = ($2) ? 1 : 0;
+
+ $tell_obj = $who if ( $tell_obj =~ /^(me|myself)$/i );
+ $query = $tell_obj;
+ }
+ elsif ( $args =~ /^(\S+) where (\S+) can (\S+) (.*)$/i ) {
+
+ # i'm sure this could all be nicely collapsed
+ $target = $1;
+ $tell_obj = $4;
+ $query = $tell_obj;
+
+ }
+ elsif ( $args =~ /^(\S+) (what|where) (.*?) (is|are)[.?!]*$/i ) {
+ $target = $1;
+ $qWord = $2;
+ $tell_obj = $3;
+ $verb = $4;
+ $query = "$qWord $verb $tell_obj";
+
+ }
+ elsif ( $args =~ /^(.*?) to (\S+)$/i ) {
+ $target = $3;
+ $tell_obj = $2;
+ $query = $tell_obj;
}
# check target type. Deny channel targets.
- if ($target !~ /^$mask{nick}$/ or $target =~ /^$mask{chan}$/) {
- &msg($who,"No, $who, I won't. (target invalid?)");
- return;
+ if ( $target !~ /^$mask{nick}$/ or $target =~ /^$mask{chan}$/ ) {
+ &msg( $who, "No, $who, I won't. (target invalid?)" );
+ return;
}
- $target = $talkchannel if ($target =~ /^us$/i);
- $target = $who if ($target =~ /^(me|myself)$/i);
+ $target = $talkchannel if ( $target =~ /^us$/i );
+ $target = $who if ( $target =~ /^(me|myself)$/i );
&status("tell: target = $target, query = $query");
# 'intrusive'.
-# if ($target !~ /^$mask{chan}$/ and !&IsNickInAnyChan($target)) {
-# &msg($who, "No, $target is not in any of my chans.");
-# return;
-# }
+ # if ($target !~ /^$mask{chan}$/ and !&IsNickInAnyChan($target)) {
+ # &msg($who, "No, $target is not in any of my chans.");
+ # return;
+ # }
# self.
- if ($target =~ /^\Q$ident\E$/i) {
- &msg($who, "Isn't that a bit silly?");
- return;
+ if ( $target =~ /^\Q$ident\E$/i ) {
+ &msg( $who, "Isn't that a bit silly?" );
+ return;
}
- my $oldwho = $who;
- my $oldmtype = $msgType;
- $who = $target;
+ my $oldwho = $who;
+ my $oldmtype = $msgType;
+ $who = $target;
my $result = &doQuestion($tell_obj);
- # ^ returns '0' if nothing was found.
- $who = $oldwho;
+
+ # ^ returns '0' if nothing was found.
+ $who = $oldwho;
# no such factoid.
- if (!defined $result || $result =~ /^0?$/) {
- $who = $target;
- $msgType = 'private';
+ if ( !defined $result || $result =~ /^0?$/ ) {
+ $who = $target;
+ $msgType = 'private';
- # support command redirection.
- # recursive cmdHooks aswell :)
- my $done = 0;
- $done++ if &parseCmdHook($tell_obj);
- $message = $tell_obj;
- $done++ unless (&Modules());
+ # support command redirection.
+ # recursive cmdHooks aswell :)
+ my $done = 0;
+ $done++ if &parseCmdHook($tell_obj);
+ $message = $tell_obj;
+ $done++ unless ( &Modules() );
- &VERB("tell: setting old values of who and msgType.",2);
- $who = $oldwho;
- $msgType = $oldmtype;
+ &VERB( 'tell: setting old values of who and msgType.', 2 );
+ $who = $oldwho;
+ $msgType = $oldmtype;
- if ($done) {
- &msg($who, "told $target about CMD '$tell_obj'");
- } else {
- &msg($who, "i dunno what is '$tell_obj'.");
- }
+ if ($done) {
+ &msg( $who, "told $target about CMD '$tell_obj'" );
+ }
+ else {
+ &msg( $who, "i dunno what is '$tell_obj'." );
+ }
- return;
+ return;
}
# success.
&status("tell: <$who> telling $target about $tell_obj.");
- if ($who ne $target) {
- if ($dont_tell_me) {
- &msg($who, "told $target about $tell_obj.");
- } else {
- &msg($who, "told $target about $tell_obj ($result)");
- }
+ if ( $who ne $target ) {
+ if ($dont_tell_me) {
+ &msg( $who, "told $target about $tell_obj." );
+ }
+ else {
+ &msg( $who, "told $target about $tell_obj ($result)" );
+ }
- $reply = "$who wants you to know: $result";
- } else {
- $reply = "telling yourself: $result";
+ $reply = "$who wants you to know: $result";
+ }
+ else {
+ $reply = "telling yourself: $result";
}
- &msg($target, $reply);
+ &msg( $target, $reply );
}
sub countryStats {
- if (exists $cache{countryStats}) {
- &msg($who,"countrystats is already running!");
- return;
+ if ( exists $cache{countryStats} ) {
+ &msg( $who, 'countrystats is already running!' );
+ return;
}
- if ($chan eq '') {
- $chan = $_[0];
+ if ( $chan eq '' ) {
+ $chan = $_[0];
}
- if ($chan eq '') {
- &help('countrystats');
- return;
+ if ( $chan eq '' ) {
+ &help('countrystats');
+ return;
}
$conn->who($chan);
- $cache{countryStats}{chan} = $chan;
- $cache{countryStats}{mtype} = $msgType;
- $cache{countryStats}{who} = $who;
- $cache{on_who_Hack} = 1;
+ $cache{countryStats}{chan} = $chan;
+ $cache{countryStats}{mtype} = $msgType;
+ $cache{countryStats}{who} = $who;
+ $cache{on_who_Hack} = 1;
}
sub do_countrystats {
- $chan = $cache{countryStats}{chan};
- $msgType = $cache{countryStats}{mtype};
- $who = $cache{countryStats}{who};
+ $chan = $cache{countryStats}{chan};
+ $msgType = $cache{countryStats}{mtype};
+ $who = $cache{countryStats}{who};
- my $total = 0;
+ my $total = 0;
my %cstats;
- foreach (keys %{ $cache{nuhInfo} }) {
- my $h = $cache{nuhInfo}{$_}{Host};
+ foreach ( keys %{ $cache{nuhInfo} } ) {
+ my $h = $cache{nuhInfo}{$_}{Host};
- if ($h =~ /^.*\.(\D+)$/) { # host
- $cstats{$1}++;
- } else { # ip
- $cstats{unresolve}++;
- }
- $total++;
+ if ( $h =~ /^.*\.(\D+)$/ ) { # host
+ $cstats{$1}++;
+ }
+ else { # ip
+ $cstats{unresolve}++;
+ }
+ $total++;
}
my %count;
- foreach (keys %cstats) {
- $count{ $cstats{$_} }{$_} = 1;
+ foreach ( keys %cstats ) {
+ $count{ $cstats{$_} }{$_} = 1;
}
my @list;
- foreach (sort {$b <=> $a} keys %count) {
- my $str = join(", ", sort keys %{ $count{$_} });
-# push(@list, "$str ($_)");
- my $perc = sprintf("%.01f", 100 * $_ / $total);
- $perc =~ s/\.0+$//;
- push(@list, "$str ($_, $perc %)");
+ foreach ( sort { $b <=> $a } keys %count ) {
+ my $str = join( ', ', sort keys %{ $count{$_} } );
+
+ # push(@list, "$str ($_)");
+ my $perc = sprintf( '%.01f', 100 * $_ / $total );
+ $perc =~ s/\.0+$//;
+ push( @list, "$str ($_, $perc %)" );
}
# TODO: move this into a scheduler
- $msgType = 'private';
- &performStrictReply( &formListReply(0, "Country Stats ", @list) );
+ $msgType = 'private';
+ &performStrictReply( &formListReply( 0, 'Country Stats ', @list ) );
delete $cache{countryStats};
delete $cache{on_who_Hack};
###
sub userCommands {
+
# conversion: ascii.
- if ($message =~ /^(asci*|chr) (\d+)$/) {
- &DEBUG("ascii/chr called ...");
- return unless (&IsChanConfOrWarn('allowConv'));
+ if ( $message =~ /^(asci*|chr) (\d+)$/ ) {
+ &DEBUG('ascii/chr called ...');
+ return unless ( &IsChanConfOrWarn('allowConv') );
- &DEBUG("ascii/chr called");
+ &DEBUG('ascii/chr called');
- $arg = $2;
- $result = chr($arg);
- $result = 'NULL' if ($arg == 0);
+ $arg = $2;
+ $result = chr($arg);
+ $result = 'NULL' if ( $arg == 0 );
- &performReply( sprintf("ascii %s is '%s'", $arg, $result) );
+ &performReply( sprintf( "ascii %s is '%s'", $arg, $result ) );
- return;
+ return;
}
# conversion: ord.
- if ($message =~ /^ord(\s+(.*))$/) {
- return unless (&IsChanConfOrWarn('allowConv'));
+ if ( $message =~ /^ord(\s+(.*))$/ ) {
+ return unless ( &IsChanConfOrWarn('allowConv') );
- $arg = $2;
+ $arg = $2;
- if (!defined $arg or length $arg != 1) {
- &help('ord');
- return;
- }
+ if ( !defined $arg or length $arg != 1 ) {
+ &help('ord');
+ return;
+ }
- if (ord($arg) < 32) {
- $arg = chr(ord($arg) + 64);
- if ($arg eq chr(64)) {
- $arg = 'NULL';
- } else {
- $arg = '^'.$arg;
- }
- }
+ if ( ord($arg) < 32 ) {
+ $arg = chr( ord($arg) + 64 );
+ if ( $arg eq chr(64) ) {
+ $arg = 'NULL';
+ }
+ else {
+ $arg = '^' . $arg;
+ }
+ }
- &performReply( sprintf("'%s' is ascii %s", $arg, ord $arg) );
- return;
+ &performReply( sprintf( "'%s' is ascii %s", $arg, ord $arg ) );
+ return;
}
# hex.
- if ($message =~ /^hex(\s+(.*))?$/i) {
- return unless (&IsChanConfOrWarn('allowConv'));
- my $arg = $2;
+ if ( $message =~ /^hex(\s+(.*))?$/i ) {
+ return unless ( &IsChanConfOrWarn('allowConv') );
+ my $arg = $2;
- if (!defined $arg) {
- &help('hex');
- return;
- }
+ if ( !defined $arg ) {
+ &help('hex');
+ return;
+ }
- if (length $arg > 80) {
- &msg($who, "Too long.");
- return;
- }
+ if ( length $arg > 80 ) {
+ &msg( $who, 'Too long.' );
+ return;
+ }
- my $retval;
- foreach (split //, $arg) {
- $retval .= sprintf(" %X", ord($_));
- }
+ my $retval;
+ foreach ( split //, $arg ) {
+ $retval .= sprintf( ' %X', ord($_) );
+ }
- &performStrictReply("$arg is$retval");
+ &performStrictReply("$arg is$retval");
- return;
+ return;
}
# crypt.
- if ($message =~ /^crypt\s+(\S*)?\s*(.*)?$/i) {
-&status("crypt: $1:$2:$3");
- if ("$2" ne '') {
- &performStrictReply(crypt($2, $1));
- } else {
- &performStrictReply(&mkcrypt($1));
- }
- return;
+ if ( $message =~ /^crypt\s+(\S*)?\s*(.*)?$/i ) {
+ &status("crypt: $1:$2:$3");
+ if ( "$2" ne '' ) {
+ &performStrictReply( crypt( $2, $1 ) );
+ }
+ else {
+ &performStrictReply( &mkcrypt($1) );
+ }
+ return;
}
# cycle.
- if ($message =~ /^(cycle)(\s+(\S+))?$/i) {
- return unless (&hasFlag('o'));
- my $chan = lc $3;
-
- if ($chan eq '') {
- if ($msgType =~ /public/) {
- $chan = $talkchannel;
- &DEBUG("cycle: setting chan to '$chan'.");
- } else {
- &help('cycle');
- return;
- }
- }
-
- if (&validChan($chan) == 0) {
- &msg($who,"error: invalid channel \002$chan\002");
- return;
- }
-
- &msg($chan, "I'm coming back. (courtesy of $who)");
- &part($chan);
+ if ( $message =~ /^(cycle)(\s+(\S+))?$/i ) {
+ return unless ( &hasFlag('o') );
+ my $chan = lc $3;
+
+ if ( $chan eq '' ) {
+ if ( $msgType =~ /public/ ) {
+ $chan = $talkchannel;
+ &DEBUG("cycle: setting chan to '$chan'.");
+ }
+ else {
+ &help('cycle');
+ return;
+ }
+ }
+
+ if ( &validChan($chan) == 0 ) {
+ &msg( $who, "error: invalid channel \002$chan\002" );
+ return;
+ }
+
+ &msg( $chan, "I'm coming back. (courtesy of $who)" );
+ &part($chan);
### &ScheduleThis(5, 'getNickInUse') if (@_);
- &status("Schedule rejoin in 5secs to $chan by $who.");
- $conn->schedule(5, sub { &joinchan($chan); });
+ &status("Schedule rejoin in 5secs to $chan by $who.");
+ $conn->schedule( 5, sub { &joinchan($chan); } );
- return;
+ return;
}
# reload.
- if ($message =~ /^reload$/i) {
- return unless (&hasFlag('n'));
+ if ( $message =~ /^reload$/i ) {
+ return unless ( &hasFlag('n') );
- &status("USER reload $who");
- &performStrictReply("reloading...");
- my $modules = &reloadAllModules();
- &performStrictReply("reloaded:$modules");
- return;
+ &status("USER reload $who");
+ &performStrictReply('reloading...');
+ my $modules = &reloadAllModules();
+ &performStrictReply("reloaded:$modules");
+ return;
}
# redir.
- if ($message =~ /^redir(\s+(.*))?/i) {
- return unless (&hasFlag('o'));
- my $factoid = $2;
-
- if (!defined $factoid) {
- &help('redir');
- return;
- }
-
- my $val = &getFactInfo($factoid, "factoid_value");
- if (!defined $val or $val eq '') {
- &msg($who, "error: '$factoid' does not exist.");
- return;
- }
- &DEBUG("val => '$val'.");
- my @list = &searchTable('factoids', "factoid_key",
- "factoid_value", "^$val\$");
-
- if (scalar @list == 1) {
- &msg($who, "hrm... '$factoid' is unique.");
- return;
- }
- if (scalar @list > 5) {
- &msg($who, "A bit too many factoids to be redirected, hey?");
- return;
- }
-
- my @redir;
- &status("Redirect '$factoid' (". ($#list) .")...");
- for (@list) {
- my $x = $_;
- next if (/^\Q$factoid\E$/i);
-
- &status(" Redirecting '$_'.");
- my $was = &getFactoid($_);
- if ($was =~ /<REPLY> see/i) {
- &status("warn: not redirecting a redirection.");
- next;
- }
-
- &DEBUG(" was '$was'.");
- push(@redir,$x);
- &setFactInfo($x, "factoid_value", "<REPLY> see $factoid");
- }
- &status("Done.");
-
- &msg($who, &formListReply(0, "'$factoid' is redirected to by '", @redir));
-
- return;
+ if ( $message =~ /^redir(\s+(.*))?/i ) {
+ return unless ( &hasFlag('o') );
+ my $factoid = $2;
+
+ if ( !defined $factoid ) {
+ &help('redir');
+ return;
+ }
+
+ my $val = &getFactInfo( $factoid, 'factoid_value' );
+ if ( !defined $val or $val eq '' ) {
+ &msg( $who, "error: '$factoid' does not exist." );
+ return;
+ }
+ &DEBUG("val => '$val'.");
+ my @list =
+ &searchTable( 'factoids', 'factoid_key', 'factoid_value', "^$val\$" );
+
+ if ( scalar @list == 1 ) {
+ &msg( $who, "hrm... '$factoid' is unique." );
+ return;
+ }
+ if ( scalar @list > 5 ) {
+ &msg( $who, 'A bit too many factoids to be redirected, hey?' );
+ return;
+ }
+
+ my @redir;
+ &status( "Redirect '$factoid' (" . ($#list) . ')...' );
+ for (@list) {
+ my $x = $_;
+ next if (/^\Q$factoid\E$/i);
+
+ &status(" Redirecting '$_'.");
+ my $was = &getFactoid($_);
+ if ( $was =~ /<REPLY> see/i ) {
+ &status('warn: not redirecting a redirection.');
+ next;
+ }
+
+ &DEBUG(" was '$was'.");
+ push( @redir, $x );
+ &setFactInfo( $x, 'factoid_value', "<REPLY> see $factoid" );
+ }
+ &status('Done.');
+
+ &msg( $who,
+ &formListReply( 0, "'$factoid' is redirected to by '", @redir ) );
+
+ return;
}
# rot13 it.
- if ($message =~ /^rot([0-9]*)(\s+(.*))?/i) {
- my $reply = $3;
+ if ( $message =~ /^rot([0-9]*)(\s+(.*))?/i ) {
+ my $reply = $3;
- if (!defined $reply) {
- &help('rot13');
- return;
- }
- my $num = $1 % 26;
- my $upper='ABCDEFGHIJKLMNOPQRSTUVWXYZ';
- my $lower='abcdefghijklmnopqrstuvwxyz';
- my $to=substr($upper,$num).substr($upper,0,$num).substr($lower,$num).substr($lower,0,$num);
- eval "\$reply =~ tr/$upper$lower/$to/;";
+ if ( !defined $reply ) {
+ &help('rot13');
+ return;
+ }
+ my $num = $1 % 26;
+ my $upper = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
+ my $lower = 'abcdefghijklmnopqrstuvwxyz';
+ my $to =
+ substr( $upper, $num )
+ . substr( $upper, 0, $num )
+ . substr( $lower, $num )
+ . substr( $lower, 0, $num );
+ eval "\$reply =~ tr/$upper$lower/$to/;";
- #$reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
- &performStrictReply($reply);
+ #$reply =~ y/A-Za-z/N-ZA-Mn-za-m/;
+ &performStrictReply($reply);
- return;
+ return;
}
# cpustats.
- if ($message =~ /^cpustats$/i) {
- if ($^O !~ /linux/) {
- &ERROR("cpustats: your OS is not supported yet.");
- return;
- }
-
- ### poor method to get info out of file, please fix.
- open(STAT,"/proc/$$/stat");
- my $line = <STAT>;
- chop $line;
- my @data = split(/ /, $line);
- close STAT;
-
- # utime(13) + stime(14).
- my $cpu_usage = sprintf("%.01f", ($data[13]+$data[14]) / 100 );
- # cutime(15) + cstime (16).
- my $cpu_usage2 = sprintf("%.01f", ($data[15]+$data[16]) / 100 );
- my $time = time() - $^T;
- my $raw_perc = $cpu_usage*100/$time;
- my $raw_perc2 = $cpu_usage2*100/$time;
- my $perc;
- my $perc2;
- my $total;
- my $ratio;
-
- if ($raw_perc > 1) {
- $perc = sprintf("%.01f", $raw_perc);
- $perc2 = sprintf("%.01f", $raw_perc2);
- $total = sprintf("%.01f", $raw_perc+$raw_perc2);
- } elsif ($raw_perc > 0.1) {
- $perc = sprintf("%.02f", $raw_perc);
- $perc2 = sprintf("%.02f", $raw_perc2);
- $total = sprintf("%.02f", $raw_perc+$raw_perc2);
- } else { # <=0.1
- $perc = sprintf("%.03f", $raw_perc);
- $perc2 = sprintf("%.03f", $raw_perc2);
- $total = sprintf("%.03f", $raw_perc+$raw_perc2);
- }
- $ratio = sprintf("%.01f", 100*$perc/($perc+$perc2) );
-
- &performStrictReply("Total CPU usage: \002$cpu_usage\002 s ... ".
- "Total used: \002$total\002 % ".
- "(parent/child ratio: $ratio %)"
- );
-
- return;
+ if ( $message =~ /^cpustats$/i ) {
+ if ( $^O !~ /linux/ ) {
+ &ERROR('cpustats: your OS is not supported yet.');
+ return;
+ }
+
+ ### poor method to get info out of file, please fix.
+ open( STAT, "/proc/$$/stat" );
+ my $line = <STAT>;
+ chop $line;
+ my @data = split( / /, $line );
+ close STAT;
+
+ # utime(13) + stime(14).
+ my $cpu_usage = sprintf( '%.01f', ( $data[13] + $data[14] ) / 100 );
+
+ # cutime(15) + cstime (16).
+ my $cpu_usage2 = sprintf( '%.01f', ( $data[15] + $data[16] ) / 100 );
+ my $time = time() - $^T;
+ my $raw_perc = $cpu_usage * 100 / $time;
+ my $raw_perc2 = $cpu_usage2 * 100 / $time;
+ my $perc;
+ my $perc2;
+ my $total;
+ my $ratio;
+
+ if ( $raw_perc > 1 ) {
+ $perc = sprintf( '%.01f', $raw_perc );
+ $perc2 = sprintf( '%.01f', $raw_perc2 );
+ $total = sprintf( '%.01f', $raw_perc + $raw_perc2 );
+ }
+ elsif ( $raw_perc > 0.1 ) {
+ $perc = sprintf( '%.02f', $raw_perc );
+ $perc2 = sprintf( '%.02f', $raw_perc2 );
+ $total = sprintf( '%.02f', $raw_perc + $raw_perc2 );
+ }
+ else { # <=0.1
+ $perc = sprintf( '%.03f', $raw_perc );
+ $perc2 = sprintf( '%.03f', $raw_perc2 );
+ $total = sprintf( '%.03f', $raw_perc + $raw_perc2 );
+ }
+ $ratio = sprintf( '%.01f', 100 * $perc / ( $perc + $perc2 ) );
+
+ &performStrictReply( "Total CPU usage: \002$cpu_usage\002 s ... "
+ . "Total used: \002$total\002 % "
+ . "(parent/child ratio: $ratio %)" );
+
+ return;
}
# ircstats.
- if ($message =~ /^ircstats?$/i) {
- $ircstats{'TotalTime'} ||= 0;
- $ircstats{'OffTime'} ||= 0;
-
- my $count = $ircstats{'ConnectCount'};
- my $format_time = &Time2String(time() - $ircstats{'ConnectTime'});
- my $total_time = time() - $ircstats{'ConnectTime'} +
- $ircstats{'TotalTime'};
- my $reply;
-
- my $connectivity = 100 * ($total_time - $ircstats{'OffTime'}) /
- $total_time;
- my $p = sprintf("%.03f", $connectivity);
- $p =~ s/(\.\d*)0+$/$1/;
- if ($p =~ s/\.0$//) {
- # this should not happen... but why...
- } else {
- $p =~ s/\.$//
- }
-
- if ($total_time != (time() - $ircstats{'ConnectTime'}) ) {
- my $tt_format = &Time2String($total_time);
- &DEBUG("tt_format => $tt_format");
- }
-
- ### RECONNECT COUNT.
- if ($count == 1) { # good.
- $reply = "I'm connected to $ircstats{'Server'} and have been so".
- " for $format_time";
- } else {
- $reply = "Currently I'm hooked up to $ircstats{'Server'} but only".
- " for $format_time. ".
- "I had to reconnect \002$count\002 times.".
- " Connectivity: $p %";
- }
-
- ### REASON.
- my $reason = $ircstats{'DisconnectReason'};
- if (defined $reason) {
- $reply .= ". I was last disconnected for '$reason'.";
- }
-
- &performStrictReply($reply);
-
- return;
+ if ( $message =~ /^ircstats?$/i ) {
+ $ircstats{'TotalTime'} ||= 0;
+ $ircstats{'OffTime'} ||= 0;
+
+ my $count = $ircstats{'ConnectCount'};
+ my $format_time = &Time2String( time() - $ircstats{'ConnectTime'} );
+ my $total_time =
+ time() - $ircstats{'ConnectTime'} + $ircstats{'TotalTime'};
+ my $reply;
+
+ my $connectivity =
+ 100 * ( $total_time - $ircstats{'OffTime'} ) / $total_time;
+ my $p = sprintf( '%.03f', $connectivity );
+ $p =~ s/(\.\d*)0+$/$1/;
+ if ( $p =~ s/\.0$// ) {
+
+ # this should not happen... but why...
+ }
+ else {
+ $p =~ s/\.$//;
+ }
+
+ if ( $total_time != ( time() - $ircstats{'ConnectTime'} ) ) {
+ my $tt_format = &Time2String($total_time);
+ &DEBUG("tt_format => $tt_format");
+ }
+
+ ### RECONNECT COUNT.
+ if ( $count == 1 ) { # good.
+ $reply =
+ "I'm connected to $ircstats{'Server'} and have been so"
+ . " for $format_time";
+ }
+ else {
+ $reply =
+ "Currently I'm hooked up to $ircstats{'Server'} but only"
+ . " for $format_time. "
+ . "I had to reconnect \002$count\002 times."
+ . " Connectivity: $p %";
+ }
+
+ ### REASON.
+ my $reason = $ircstats{'DisconnectReason'};
+ if ( defined $reason ) {
+ $reply .= ". I was last disconnected for '$reason'.";
+ }
+
+ &performStrictReply($reply);
+
+ return;
}
# status.
- if ($message =~ /^statu?s$/i) {
- my $startString = scalar(gmtime $^T);
- my $upString = &Time2String(time() - $^T);
- my ($puser,$psystem,$cuser,$csystem) = times;
- my $factoids = &countKeys('factoids');
- my $forks = 0;
- foreach (keys %forked) {
- $forks += scalar keys %{ $forked{$_} };
- }
- $forks /= 2;
- $count{'Commands'} = 0;
- foreach (keys %cmdstats) {
- $count{'Commands'} += $cmdstats{$_};
- }
-
- &performStrictReply(
- "Since $startString, there have been".
- " \002$count{'Update'}\002 ".
- &fixPlural('modification', $count{'Update'}).
- ", \002$count{'Question'}\002 ".
- &fixPlural('question',$count{'Question'}).
- ", \002$count{'Dunno'}\002 ".
- &fixPlural('dunno',$count{'Dunno'}).
- ", \002$count{'Moron'}\002 ".
- &fixPlural('moron',$count{'Moron'}).
- " and \002$count{'Commands'}\002 ".
- &fixPlural('command',$count{'Commands'}).
- ". I have been awake for $upString this session, and ".
- "currently reference \002$factoids\002 factoids. ".
- "I'm using about \002$memusage\002 ".
- "kB of memory. With \002$forks\002 active ".
- &fixPlural('fork',$forks).
- ". Process time user/system $puser/$psystem child $cuser/$csystem"
- );
-
- return;
+ if ( $message =~ /^statu?s$/i ) {
+ my $startString = scalar( gmtime $^T );
+ my $upString = &Time2String( time() - $^T );
+ my ( $puser, $psystem, $cuser, $csystem ) = times;
+ my $factoids = &countKeys('factoids');
+ my $forks = 0;
+ foreach ( keys %forked ) {
+ $forks += scalar keys %{ $forked{$_} };
+ }
+ $forks /= 2;
+ $count{'Commands'} = 0;
+ foreach ( keys %cmdstats ) {
+ $count{'Commands'} += $cmdstats{$_};
+ }
+
+ &performStrictReply( "Since $startString, there have been"
+ . " \002$count{'Update'}\002 "
+ . &fixPlural( 'modification', $count{'Update'} )
+ . ", \002$count{'Question'}\002 "
+ . &fixPlural( 'question', $count{'Question'} )
+ . ", \002$count{'Dunno'}\002 "
+ . &fixPlural( 'dunno', $count{'Dunno'} )
+ . ", \002$count{'Moron'}\002 "
+ . &fixPlural( 'moron', $count{'Moron'} )
+ . " and \002$count{'Commands'}\002 "
+ . &fixPlural( 'command', $count{'Commands'} )
+ . ". I have been awake for $upString this session, and "
+ . "currently reference \002$factoids\002 factoids. "
+ . "I'm using about \002$memusage\002 "
+ . "kB of memory. With \002$forks\002 active "
+ . &fixPlural( 'fork', $forks )
+ . ". Process time user/system $puser/$psystem child $cuser/$csystem"
+ );
+
+ return;
}
# wantNick. xk++
# FIXME does not try to get nick 'back', just switches nicks
- if ($message =~ /^wantNick\s(.*)?$/i) {
- return unless (&hasFlag('o'));
- my $wantnick = lc $1;
- my $mynick = $conn->nick();
-
- if ($mynick eq $wantnick) {
- &msg($who, "I hope you're right. I'll try anyway (mynick=$mynick, wantnick=$wantnick).");
- }
-
- # fallback check, I guess. needed?
- if (! &IsNickInAnyChan( $wantnick ) ) {
- my $str = "attempting to change nick from $mynick to $wantnick";
- &status($str);
- &msg($who, $str);
- &nick($wantnick);
- return;
- }
-
- # idea from dondelecarlo :)
- # TODO: use cache{nickserv}
- if ($param{'nickServ_pass'}) {
- my $str = "someone is using nick $wantnick; GHOSTing";
- &status($str);
- &msg($who, $str);
- &msg('NickServ', "GHOST $wantnick $param{'nickServ_pass'}");
-
- $conn->schedule(5, sub {
- &status("going to change nick from $mynick to $wantnick after GHOST.");
- &nick($wantnick);
- } );
-
- return;
- }
-
- return;
+ if ( $message =~ /^wantNick\s(.*)?$/i ) {
+ return unless ( &hasFlag('o') );
+ my $wantnick = lc $1;
+ my $mynick = $conn->nick();
+
+ if ( $mynick eq $wantnick ) {
+ &msg( $who,
+"I hope you're right. I'll try anyway (mynick=$mynick, wantnick=$wantnick)."
+ );
+ }
+
+ # fallback check, I guess. needed?
+ if ( !&IsNickInAnyChan($wantnick) ) {
+ my $str = "attempting to change nick from $mynick to $wantnick";
+ &status($str);
+ &msg( $who, $str );
+ &nick($wantnick);
+ return;
+ }
+
+ # idea from dondelecarlo :)
+ # TODO: use cache{nickserv}
+ if ( $param{'nickServ_pass'} ) {
+ my $str = "someone is using nick $wantnick; GHOSTing";
+ &status($str);
+ &msg( $who, $str );
+ &msg( 'NickServ', "GHOST $wantnick $param{'nickServ_pass'}" );
+
+ $conn->schedule(
+ 5,
+ sub {
+ &status(
+"going to change nick from $mynick to $wantnick after GHOST."
+ );
+ &nick($wantnick);
+ }
+ );
+
+ return;
+ }
+
+ return;
}
return 'CONTINUE';
# scalar. MUST BE REDUCED IN SIZE!!!
### TODO: reorder.
use vars qw(
- $bot_misc_dir $bot_pid $bot_base_dir $bot_src_dir
- $bot_data_dir $bot_config_dir $bot_state_dir $bot_run_dir
- $answer $correction_plausible $talkchannel $bot_release
- $statcount $memusage $user $memusageOld $bot_version $dbh
- $shm $host $msg $noreply $conn $irc $learnok $nick $ident
- $force_public_reply $addrchar $userHandle $addressedother
- $floodwho $chan $msgtime $server $firsttime $wingaterun
- $flag_quit $msgType $no_syscall
- $utime_userfile $wtime_userfile $ucount_userfile
- $utime_chanfile $wtime_chanfile $ucount_chanfile
- $pubsize $pubcount $pubtime
- $msgsize $msgcount $msgtime
- $notsize $notcount $nottime
- $running
+ $bot_misc_dir $bot_pid $bot_base_dir $bot_src_dir
+ $bot_data_dir $bot_config_dir $bot_state_dir $bot_run_dir
+ $answer $correction_plausible $talkchannel $bot_release
+ $statcount $memusage $user $memusageOld $bot_version $dbh
+ $shm $host $msg $noreply $conn $irc $learnok $nick $ident
+ $force_public_reply $addrchar $userHandle $addressedother
+ $floodwho $chan $msgtime $server $firsttime $wingaterun
+ $flag_quit $msgType $no_syscall
+ $utime_userfile $wtime_userfile $ucount_userfile
+ $utime_chanfile $wtime_chanfile $ucount_chanfile
+ $pubsize $pubcount $pubtime
+ $msgsize $msgcount $msgtime
+ $notsize $notcount $nottime
+ $running
);
# array.
### hash. MUST BE REDUCED IN SIZE!!!
#
use vars qw(%count %netsplit %netsplitservers %flood %dcc %orig
- %nuh %talkWho %seen %floodwarn %param %dbh %ircPort
- %topic %moduleAge %last %time %mask %file
- %forked %chanconf %channels %cache
+ %nuh %talkWho %seen %floodwarn %param %dbh %ircPort
+ %topic %moduleAge %last %time %mask %file
+ %forked %chanconf %channels %cache
);
# Signals.
-$SIG{'HUP'} = 'restart'; # 1.
-$SIG{'INT'} = 'doExit'; # 2.
-$SIG{'KILL'} = 'doExit'; # 9. DOES NOT WORK. 'man perlipc' for details.
-$SIG{'TERM'} = 'doExit'; # 15.
+$SIG{'HUP'} = 'restart'; # 1.
+$SIG{'INT'} = 'doExit'; # 2.
+$SIG{'KILL'} = 'doExit'; # 9. DOES NOT WORK. 'man perlipc' for details.
+$SIG{'TERM'} = 'doExit'; # 15.
$SIG{'__WARN__'} = 'doWarn';
# initialize variables.
-$last{buflen} = 0;
-$last{say} = '';
-$last{msg} = '';
-$userHandle = "_default";
-$wingaterun = time();
-$firsttime = 1;
-$utime_userfile = 0;
-$wtime_userfile = 0;
+$last{buflen} = 0;
+$last{say} = '';
+$last{msg} = '';
+$userHandle = '_default';
+$wingaterun = time();
+$firsttime = 1;
+$utime_userfile = 0;
+$wtime_userfile = 0;
$ucount_userfile = 0;
-$utime_chanfile = 0;
-$wtime_chanfile = 0;
+$utime_chanfile = 0;
+$wtime_chanfile = 0;
$ucount_chanfile = 0;
-$running = 0;
+$running = 0;
+
### more variables...
+
# static scalar variables.
-$mask{ip} = '(\d+)\.(\d+)\.(\d+)\.(\d+)';
-$mask{host} = '[\d\w\_\-\/]+\.[\.\d\w\_\-\/]+';
-$mask{chan} = '[\#\&]\S*|_default';
-my $isnick1 = 'a-zA-Z\[\]\{\}\_\`\^\|\\\\';
-my $isnick2 = '0-9\-';
-$mask{nick} = "[$isnick1]{1}[$isnick1$isnick2]*";
-$mask{nuh} = '\S*!\S*\@\S*';
-$msgtime = time();
-$msgsize = 0;
-$msgcount = 0;
-$pubtime = 0;
-$pubsize = 0;
-$pubcount = 0;
-$nottime = 0;
-$notsize = 0;
-$notcount = 0;
+$mask{ip} = '(\d+)\.(\d+)\.(\d+)\.(\d+)';
+$mask{host} = '[\d\w\_\-\/]+\.[\.\d\w\_\-\/]+';
+$mask{chan} = '[\#\&]\S*|_default';
+my $isnick1 = 'a-zA-Z\[\]\{\}\_\`\^\|\\\\';
+my $isnick2 = '0-9\-';
+$mask{nick} = "[$isnick1]{1}[$isnick1$isnick2]*";
+$mask{nuh} = '\S*!\S*\@\S*';
+$msgtime = time();
+$msgsize = 0;
+$msgcount = 0;
+$pubtime = 0;
+$pubsize = 0;
+$pubcount = 0;
+$nottime = 0;
+$notsize = 0;
+$notcount = 0;
+
###
-open(VERSION, '<VERSION');
-$bot_release = <VERSION> || "(unknown version)";
+
+open( VERSION, '<VERSION' );
+$bot_release = <VERSION> || '(unknown version)';
chomp($bot_release);
close(VERSION);
-$bot_version = "infobot $bot_release -- $^O";
-$noreply = 'NOREPLY';
+$bot_version = "infobot $bot_release -- $^O";
+$noreply = 'NOREPLY';
##########
### misc commands.
###
sub whatInterface {
- if (!&IsParam('Interface') or $param{'Interface'} =~ /IRC/) {
- return 'IRC';
- } else {
- return 'CLI';
+ if ( !&IsParam('Interface') or $param{'Interface'} =~ /IRC/ ) {
+ return 'IRC';
+ }
+ else {
+ return 'CLI';
}
}
sub doExit {
- my ($sig) = @_;
-
- if (defined $flag_quit) {
- &WARN("doExit: quit already called.");
- return;
- }
- $flag_quit = 1;
-
- if (!defined $bot_pid) { # independent.
- exit 0;
- } elsif ($bot_pid == $$) { # parent.
- &status("parent caught SIG$sig (pid $$).") if (defined $sig);
-
- &status("--- Start of quit.");
- $ident ||= 'infobot'; # lame hack.
-
- &status("Memory Usage: $memusage KiB");
-
- &closePID();
- &closeStats();
- # shutdown IRC and related components.
- if (&whatInterface() =~ /IRC/) {
- &closeDCC();
- &seenFlush();
- &quit($param{'quitMsg'});
- }
- &writeUserFile();
- &writeChanFile();
- &uptimeWriteFile() if (&IsParam('Uptime'));
- &sqlCloseDB();
- &closeSHM($shm);
-
- if (&IsParam('dumpvarsAtExit')) {
- &loadMyModule('DumpVars');
- &dumpallvars();
- }
- &symdumpAll() if (&IsParam('symdumpAtExit'));
- &closeLog();
- &closeSQLDebug() if (&IsParam('SQLDebug'));
-
- &status("--- QUIT.");
- } else { # child.
- &status("child caught SIG$sig (pid $$).");
+ my ($sig) = @_;
+
+ if ( defined $flag_quit ) {
+ &WARN('doExit: quit already called.');
+ return;
+ }
+ $flag_quit = 1;
+
+ if ( !defined $bot_pid ) { # independent.
+ exit 0;
+ }
+ elsif ( $bot_pid == $$ ) { # parent.
+ &status("parent caught SIG$sig (pid $$).") if ( defined $sig );
+
+ &status('--- Start of quit.');
+ $ident ||= 'infobot'; # lame hack.
+
+ &status("Memory Usage: $memusage KiB");
+
+ &closePID();
+ &closeStats();
+
+ # shutdown IRC and related components.
+ if ( &whatInterface() =~ /IRC/ ) {
+ &closeDCC();
+ &seenFlush();
+ &quit( $param{'quitMsg'} );
+ }
+ &writeUserFile();
+ &writeChanFile();
+ &uptimeWriteFile() if ( &IsParam('Uptime') );
+ &sqlCloseDB();
+ &closeSHM($shm);
+
+ if ( &IsParam('dumpvarsAtExit') ) {
+ &loadMyModule('DumpVars');
+ &dumpallvars();
+ }
+ &symdumpAll() if ( &IsParam('symdumpAtExit') );
+ &closeLog();
+ &closeSQLDebug() if ( &IsParam('SQLDebug') );
+
+ &status('--- QUIT.');
+ }
+ else { # child.
+ &status("child caught SIG$sig (pid $$).");
}
exit 0;
$SIG{__WARN__} = sub { warn $_[0]; };
foreach (@_) {
- &WARN("PERL: $_");
+ &WARN("PERL: $_");
}
- $SIG{__WARN__} = 'doWarn'; # ???
+ $SIG{__WARN__} = 'doWarn'; # ???
}
# Usage: &IsParam($param);
sub IsParam {
my $param = $_[0];
- return 0 unless (defined $param);
- return 0 unless (exists $param{$param});
- return 0 unless ($param{$param});
+ return 0 unless ( defined $param );
+ return 0 unless ( exists $param{$param} );
+ return 0 unless ( $param{$param} );
return 0 if $param{$param} =~ /^false$/i;
return 1;
}
# About: gets channels with 'param' enabled. (!!!)
# Return: array of channels
sub ChanConfList {
- my $param = $_[0];
- return unless (defined $param);
- my %chan = &getChanConfList($param);
+ my $param = $_[0];
+ return unless ( defined $param );
+ my %chan = &getChanConfList($param);
- if (exists $chan{_default}) {
- return keys %chanconf;
- } else {
- return keys %chan;
+ if ( exists $chan{_default} ) {
+ return keys %chanconf;
+ }
+ else {
+ return keys %chan;
}
}
# About: gets channels with 'param' enabled, internal use only.
# Return: hash of channels
sub getChanConfList {
- my $param = $_[0];
+ my $param = $_[0];
my %chan;
- return unless (defined $param);
+ return unless ( defined $param );
- foreach (keys %chanconf) {
- my $chan = $_;
- my @array = grep /^$param$/, keys %{ $chanconf{$chan} };
- #&DEBUG("gCCL param => $param, chan => $chan, keys => " . join(':',keys %{ $chanconf{$chan} }) . " array => " . join(':', @array)) if ($param eq 'whatever');
+ foreach ( keys %chanconf ) {
+ my $chan = $_;
+ my @array = grep /^$param$/, keys %{ $chanconf{$chan} };
- next unless (scalar @array);
+#&DEBUG("gCCL param => $param, chan => $chan, keys => " . join(':',keys %{ $chanconf{$chan} }) . ' array => ' . join(':', @array)) if ($param eq 'whatever');
- if (scalar @array > 1) {
- &WARN("multiple items found?");
- }
+ next unless ( scalar @array );
- if ($chanconf{$chan}{$param} eq '0') {
- $chan{$chan} = -1;
- } else {
- $chan{$chan} = 1;
- }
+ if ( scalar @array > 1 ) {
+ &WARN('multiple items found?');
+ }
+
+ if ( $chanconf{$chan}{$param} eq '0' ) {
+ $chan{$chan} = -1;
+ }
+ else {
+ $chan{$chan} = 1;
+ }
}
return %chan;
# About: Check for 'param' on the basis of channel config.
# Return: 1 for enabled, 0 for passive disable, -1 for active disable.
sub IsChanConf {
- my($param) = shift;
+ my ($param) = shift;
# knocked tons of bugs with this! :)
- my $debug = 0; # 1 if ($param eq 'whatever');
+ my $debug = 0; # 1 if ($param eq 'whatever');
- if (!defined $param) {
- &WARN("IsChanConf: param == NULL.");
- return 0;
+ if ( !defined $param ) {
+ &WARN('IsChanConf: param == NULL.');
+ return 0;
}
# these should get moved to your .chan file instead of the .config
# .config items overide any .chan entries
- if (&IsParam($param)) {
- &WARN("ICC: found '$param' option in main config file.");
- return 1;
+ if ( &IsParam($param) ) {
+ &WARN("ICC: found '$param' option in main config file.");
+ return 1;
}
- $chan ||= "_default";
+ $chan ||= '_default';
my $old = $chan;
- if ($chan =~ tr/A-Z/a-z/) {
- &WARN("IsChanConf: lowercased chan. ($old)");
+ if ( $chan =~ tr/A-Z/a-z/ ) {
+ &WARN("IsChanConf: lowercased chan. ($old)");
}
### TODO: VERBOSITY on how chanconf returned 1 or 0 or -1.
- my %chan = &getChanConfList($param);
+ my %chan = &getChanConfList($param);
my $nomatch = 0;
- if (!defined $msgType) {
- $nomatch++;
- } else {
- $nomatch++ if ($msgType eq '');
- $nomatch++ unless ($msgType =~ /^(public|private)$/i);
+ if ( !defined $msgType ) {
+ $nomatch++;
+ }
+ else {
+ $nomatch++ if ( $msgType eq '' );
+ $nomatch++ unless ( $msgType =~ /^(public|private)$/i );
}
+## Please see file perltidy.ERR
### debug purposes only.
-# if ($debug) {
-# &DEBUG("param => $param, msgType => $msgType.");
-# foreach (keys %chan) {
-# &DEBUG(" $_ => $chan{$_}");
-# }
-# }
+ # if ($debug) {
+ # &DEBUG("param => $param, msgType => $msgType.");
+ # foreach (keys %chan) {
+ # &DEBUG(" $_ => $chan{$_}");
+ # }
+ # }
if ($nomatch) {
- if ($chan{$chan}) {
- &DEBUG("ICC: other: $chan{$chan} (_default/$param)") if ($debug);
- } elsif ($chan{_default}) {
- &DEBUG("ICC: other: $chan{_default} (_default/$param)") if ($debug);
- } else {
- &DEBUG("ICC: other: 0 ($param)") if ($debug);
- }
- return $chan{$chan} || $chan{_default} || 0;
- } elsif ($msgType =~ /^(public|private)$/i) {
- if ($chan{$chan}) {
- &DEBUG("ICC: $msgType: $chan{$chan} ($chan/$param)") if ($debug);
- } elsif ($chan{_default}) {
- &DEBUG("ICC: $msgType: $chan{_default} (_default/$param)") if ($debug);
- } else {
- &DEBUG("ICC: $msgType: 0 ($param)") if ($debug);
- }
- return $chan{$chan} || $chan{_default} || 0;
+ if ( $chan{$chan} ) {
+ &DEBUG("ICC: other: $chan{$chan} (_default/$param)") if ($debug);
+ }
+ elsif ( $chan{_default} ) {
+ &DEBUG("ICC: other: $chan{_default} (_default/$param)") if ($debug);
+ }
+ else {
+ &DEBUG("ICC: other: 0 ($param)") if ($debug);
+ }
+ return $chan{$chan} || $chan{_default} || 0;
+ }
+ elsif ( $msgType =~ /^(public|private)$/i ) {
+ if ( $chan{$chan} ) {
+ &DEBUG("ICC: $msgType: $chan{$chan} ($chan/$param)") if ($debug);
+ }
+ elsif ( $chan{_default} ) {
+ &DEBUG("ICC: $msgType: $chan{_default} (_default/$param)")
+ if ($debug);
+ }
+ else {
+ &DEBUG("ICC: $msgType: 0 ($param)") if ($debug);
+ }
+ return $chan{$chan} || $chan{_default} || 0;
}
&DEBUG("ICC: no-match: 0/$param (msgType = $msgType)");
# About: Retrieve value for 'param' value in current/default chan.
# Return: scalar for success, undef for failure.
sub getChanConf {
- my($param,$c) = @_;
+ my ( $param, $c ) = @_;
- if (!defined $param) {
- &WARN("gCC: param == NULL.");
- return 0;
+ if ( !defined $param ) {
+ &WARN('gCC: param == NULL.');
+ return 0;
}
# this looks evil...
- if (0 and !defined $chan) {
- &DEBUG("gCC: ok !chan... doing _default instead.");
+ if ( 0 and !defined $chan ) {
+ &DEBUG('gCC: ok !chan... doing _default instead.');
}
- $c ||= $chan;
- $c ||= "_default";
- $c = "_default" if ($c eq "*"); # FIXME
- my @c = grep /^\Q$c\E$/i, keys %chanconf;
+ $c ||= $chan;
+ $c ||= '_default';
+ $c = '_default' if ( $c eq '*' ); # FIXME
+ my @c = grep /^\Q$c\E$/i, keys %chanconf;
if (@c) {
- if (0 and $c[0] ne $c) {
- &WARN("c ne chan ($c[0] ne $chan)");
- }
- if (!defined $chanconf{$c[0]}{$param} and ($c ne '_default')) {
- return &getChanConf($param, '_default');
- }
- &DEBUG("gCC: $param,$c \"" . $chanconf{$c[0]}{$param} . '"');
- return $chanconf{$c[0]}{$param};
- }
-
- #&DEBUG("gCC: returning _default... " . $chanconf{"_default"}{$param});
- return $chanconf{"_default"}{$param};
+ if ( 0 and $c[0] ne $c ) {
+ &WARN("c ne chan ($c[0] ne $chan)");
+ }
+ if ( !defined $chanconf{ $c[0] }{$param} and ( $c ne '_default' ) ) {
+ return &getChanConf( $param, '_default' );
+ }
+ &DEBUG( "gCC: $param,$c \"" . $chanconf{ $c[0] }{$param} . '"' );
+ return $chanconf{ $c[0] }{$param};
+ }
+
+ #&DEBUG('gCC: returning _default... ' . $chanconf{'_default'}{$param});
+ return $chanconf{'_default'}{$param};
}
sub getChanConfDefault {
- my($what, $default, $chan) = @_;
- $chan ||= "_default";
-
- if (exists $param{$what}) {
- if (!exists $cache{config}{$what}) {
- &status("config ($chan): backward-compatible option: found param{$what} ($param{$what}) instead of chan option");
- $cache{config}{$what} = 1;
- }
-
- return $param{$what};
+ my ( $what, $default, $chan ) = @_;
+ $chan ||= '_default';
+
+ if ( exists $param{$what} ) {
+ if ( !exists $cache{config}{$what} ) {
+ &status(
+"config ($chan): backward-compatible option: found param{$what} ($param{$what}) instead of chan option"
+ );
+ $cache{config}{$what} = 1;
+ }
+
+ return $param{$what};
}
- my $val = &getChanConf($what, $chan);
- return $val if (defined $val);
+ my $val = &getChanConf( $what, $chan );
+ return $val if ( defined $val );
- $param{$what} = $default;
+ $param{$what} = $default;
&status("config ($chan): auto-setting param{$what} = $default");
$cache{config}{$what} = 1;
return $default;
}
-
#####
# Usage: &findChanConf($param);
# About: Retrieve value for 'param' value from any chan.
# Return: scalar for success, undef for failure.
sub findChanConf {
- my($param) = @_;
+ my ($param) = @_;
- if (!defined $param) {
- &WARN("param == NULL.");
- return 0;
+ if ( !defined $param ) {
+ &WARN('param == NULL.');
+ return 0;
}
my $c;
- foreach $c (keys %chanconf) {
- foreach (keys %{ $chanconf{$c} }) {
- next unless (/^$param$/);
+ foreach $c ( keys %chanconf ) {
+ foreach ( keys %{ $chanconf{$c} } ) {
+ next unless (/^$param$/);
- return $chanconf{$c}{$_};
- }
+ return $chanconf{$c}{$_};
+ }
}
return;
sub showProc {
my ($prefix) = $_[0] || '';
- if ($^O eq 'linux') {
- if (!open(IN, "/proc/$$/status")) {
- &ERROR("cannot open '/proc/$$/status'.");
- return;
- }
-
- while (<IN>) {
- $memusage = $1 if (/^VmSize:\s+(\d+) kB/);
- }
- close IN;
-
- } elsif ($^O eq 'netbsd') {
- $memusage = int( (stat "/proc/$$/mem")[7]/1024 );
-
- } elsif ($^O =~ /^(free|open)bsd$/) {
- my @info = split /\s+/, `/bin/ps -l -p $$`;
- $memusage = $info[20];
-
- } else {
- $memusage = 'UNKNOWN';
- return;
- }
-
- if (defined $memusageOld and &IsParam('DEBUG')) {
- # it's always going to be increase.
- my $delta = $memusage - $memusageOld;
- my $str;
- if ($delta == 0) {
- return;
- } elsif ($delta > 500) {
- $str = "MEM:$prefix increased by $delta KiB. (total: $memusage KiB)";
- } elsif ($delta > 0) {
- $str = "MEM:$prefix increased by $delta KiB";
- } else { # delta < 0.
- $delta = -$delta;
- # never knew RSS could decrease, probably Size can't?
- $str = "MEM:$prefix decreased by $delta KiB.";
- }
-
- &status($str);
+ if ( $^O eq 'linux' ) {
+ if ( !open( IN, "/proc/$$/status" ) ) {
+ &ERROR("cannot open '/proc/$$/status'.");
+ return;
+ }
+
+ while (<IN>) {
+ $memusage = $1 if (/^VmSize:\s+(\d+) kB/);
+ }
+ close IN;
+
+ }
+ elsif ( $^O eq 'netbsd' ) {
+ $memusage = int( ( stat "/proc/$$/mem" )[7] / 1024 );
+
+ }
+ elsif ( $^O =~ /^(free|open)bsd$/ ) {
+ my @info = split /\s+/, `/bin/ps -l -p $$`;
+ $memusage = $info[20];
+
+ }
+ else {
+ $memusage = 'UNKNOWN';
+ return;
+ }
+
+ if ( defined $memusageOld and &IsParam('DEBUG') ) {
+
+ # it's always going to be increase.
+ my $delta = $memusage - $memusageOld;
+ my $str;
+ if ( $delta == 0 ) {
+ return;
+ }
+ elsif ( $delta > 500 ) {
+ $str =
+ "MEM:$prefix increased by $delta KiB. (total: $memusage KiB)";
+ }
+ elsif ( $delta > 0 ) {
+ $str = "MEM:$prefix increased by $delta KiB";
+ }
+ else { # delta < 0.
+ $delta = -$delta;
+
+ # never knew RSS could decrease, probably Size can't?
+ $str = "MEM:$prefix decreased by $delta KiB.";
+ }
+
+ &status($str);
}
$memusageOld = $memusage;
}
sub setup {
&showProc(" (\&openLog before)");
- &openLog(); # write, append.
- &status("--- Started logging.");
+ &openLog(); # write, append.
+ &status('--- Started logging.');
# read.
- &loadLang($bot_data_dir. "/infobot.lang");
+ &loadLang( $bot_data_dir . '/infobot.lang' );
&loadIRCServers();
&readUserFile();
&readChanFile();
- &loadMyModulesNow(); # must be after chan file.
+ &loadMyModulesNow(); # must be after chan file.
$shm = &openSHM();
- &openSQLDebug() if (&IsParam('SQLDebug'));
- &sqlOpenDB($param{'DBName'}, $param{'DBType'}, $param{'SQLUser'},
- $param{'SQLPass'});
+ &openSQLDebug() if ( &IsParam('SQLDebug') );
+ &sqlOpenDB(
+ $param{'DBName'}, $param{'DBType'},
+ $param{'SQLUser'}, $param{'SQLPass'}
+ );
&checkTables();
- &status("Setup: ". &countKeys('factoids') ." factoids.");
- &getChanConfDefault('sendPrivateLimitLines', 3, $chan);
- &getChanConfDefault('sendPrivateLimitBytes', 1000, $chan);
- &getChanConfDefault('sendPublicLimitLines', 3, $chan);
- &getChanConfDefault('sendPublicLimitBytes', 1000, $chan);
- &getChanConfDefault('sendNoticeLimitLines', 3, $chan);
- &getChanConfDefault('sendNoticeLimitBytes', 1000, $chan);
+ &status( 'Setup: ' . &countKeys('factoids') . ' factoids.' );
+ &getChanConfDefault( 'sendPrivateLimitLines', 3, $chan );
+ &getChanConfDefault( 'sendPrivateLimitBytes', 1000, $chan );
+ &getChanConfDefault( 'sendPublicLimitLines', 3, $chan );
+ &getChanConfDefault( 'sendPublicLimitBytes', 1000, $chan );
+ &getChanConfDefault( 'sendNoticeLimitLines', 3, $chan );
+ &getChanConfDefault( 'sendNoticeLimitBytes', 1000, $chan );
$param{tempDir} =~ s#\~/#$ENV{HOME}/#;
&status("Initial memory usage: $memusage KiB");
- &status("-------------------------------------------------------");
+ &status('-------------------------------------------------------');
}
sub setupConfig {
$param{'VERBOSITY'} = 1;
- &loadConfig($bot_config_dir."/infobot.config");
+ &loadConfig( $bot_config_dir . '/infobot.config' );
- foreach ( qw(ircNick ircUser ircName DBType tempDir) ) {
- next if &IsParam($_);
- &ERROR("Parameter $_ has not been defined.");
- exit 1;
+ foreach (qw(ircNick ircUser ircName DBType tempDir)) {
+ next if &IsParam($_);
+ &ERROR("Parameter $_ has not been defined.");
+ exit 1;
}
- if ($param{tempDir} =~ s#\~/#$ENV{HOME}/#) {
- &VERB("Fixing up tempDir.",2);
+ if ( $param{tempDir} =~ s#\~/#$ENV{HOME}/# ) {
+ &VERB( 'Fixing up tempDir.', 2 );
}
- if ($param{tempDir} =~ /~/) {
- &ERROR("parameter tempDir still contains tilde.");
- exit 1;
+ if ( $param{tempDir} =~ /~/ ) {
+ &ERROR('parameter tempDir still contains tilde.');
+ exit 1;
}
- if (! -d $param{tempDir}) {
- &status("making $param{tempDir}...");
- mkdir $param{tempDir}, 0755;
+ if ( !-d $param{tempDir} ) {
+ &status("making $param{tempDir}...");
+ mkdir $param{tempDir}, 0755;
}
# static scalar variables.
- $file{utm} = "$bot_state_dir/$param{'ircUser'}.uptime";
- $file{PID} = "$bot_run_dir/$param{'ircUser'}.pid";
+ $file{utm} = "$bot_state_dir/$param{'ircUser'}.uptime";
+ $file{PID} = "$bot_run_dir/$param{'ircUser'}.pid";
}
sub startup {
- if (&IsParam('DEBUG')) {
- &status("enabling debug diagnostics.");
- # I thought disabling this reduced memory usage by 1000 KiB.
- use diagnostics;
+ if ( &IsParam('DEBUG') ) {
+ &status('enabling debug diagnostics.');
+
+ # I thought disabling this reduced memory usage by 1000 KiB.
+ use diagnostics;
}
- $count{'Question'} = 0;
- $count{'Update'} = 0;
- $count{'Dunno'} = 0;
- $count{'Moron'} = 0;
+ $count{'Question'} = 0;
+ $count{'Update'} = 0;
+ $count{'Dunno'} = 0;
+ $count{'Moron'} = 0;
}
sub shutdown {
my ($sig) = @_;
+
# reverse order of &setup().
- &status("--- shutdown called.");
+ &status('--- shutdown called.');
# hack.
- $ident ||= 'infobot';
+ $ident ||= 'infobot';
- if (!&isFileUpdated("$bot_state_dir/infobot.users", $wtime_userfile)) {
- &writeUserFile()
+ if ( !&isFileUpdated( "$bot_state_dir/infobot.users", $wtime_userfile ) ) {
+ &writeUserFile();
}
- if (!&isFileUpdated("$bot_state_dir/infobot.chan", $wtime_chanfile)) {
- &writeChanFile();
+ if ( !&isFileUpdated( "$bot_state_dir/infobot.chan", $wtime_chanfile ) ) {
+ &writeChanFile();
}
&sqlCloseDB();
+
# aswell. TODO: use this in &doExit?
&closeSHM($shm);
&closeLog();
sub restart {
my ($sig) = @_;
- if ($$ == $bot_pid) {
- &status("--- $sig called.");
+ if ( $$ == $bot_pid ) {
+ &status("--- $sig called.");
- ### crappy bug in Net::IRC?
- my $delta = time() - $msgtime;
- &DEBUG("restart: dtime = $delta");
- if (!$conn->connected or time() - $msgtime > 900) {
- &status("reconnecting because of uncaught disconnect \@ ".scalar(gmtime) );
+ ### crappy bug in Net::IRC?
+ my $delta = time() - $msgtime;
+ &DEBUG("restart: dtime = $delta");
+ if ( !$conn->connected or time() - $msgtime > 900 ) {
+ &status( "reconnecting because of uncaught disconnect \@ "
+ . scalar(gmtime) );
### $irc->start;
- &clearIRCVars();
- $conn->connect();
+ &clearIRCVars();
+ $conn->connect();
### return;
- }
+ }
- &ircCheck(); # heh, evil!
+ &ircCheck(); # heh, evil!
- &DCCBroadcast("-HUP called.",'m');
- &shutdown($sig);
- &loadConfig($bot_config_dir."/infobot.config");
- &reloadAllModules() if (&IsParam('DEBUG'));
- &setup();
+ &DCCBroadcast( '-HUP called.', 'm' );
+ &shutdown($sig);
+ &loadConfig( $bot_config_dir . '/infobot.config' );
+ &reloadAllModules() if ( &IsParam('DEBUG') );
+ &setup();
- &status("--- End of $sig.");
- } else {
- &status("$sig called; ignoring restart.");
+ &status("--- End of $sig.");
+ }
+ else {
+ &status("$sig called; ignoring restart.");
}
}
sub loadConfig {
my ($file) = @_;
- if (!open(FILE, $file)) {
- &ERROR("Failed to read configuration file ($file): $!");
- &status("Please read the INSTALL file on how to install and setup this file.");
- exit 0;
+ if ( !open( FILE, $file ) ) {
+ &ERROR("Failed to read configuration file ($file): $!");
+ &status(
+'Please read the INSTALL file on how to install and setup this file.'
+ );
+ exit 0;
}
my $count = 0;
while (<FILE>) {
- chomp;
- next if /^\s*\#/;
- next unless /\S/;
- my ($set,$key,$val) = split(/\s+/, $_, 3);
+ chomp;
+ next if /^\s*\#/;
+ next unless /\S/;
+ my ( $set, $key, $val ) = split( /\s+/, $_, 3 );
- if ($set ne 'set') {
- &status("loadConfig: invalid line '$_'.");
- next;
- }
+ if ( $set ne 'set' ) {
+ &status("loadConfig: invalid line '$_'.");
+ next;
+ }
- # perform variable interpolation
- $val =~ s/(\$(\w+))/$param{$2}/g;
+ # perform variable interpolation
+ $val =~ s/(\$(\w+))/$param{$2}/g;
- $param{$key} = $val;
+ $param{$key} = $val;
- ++$count;
+ ++$count;
}
close FILE;
package main;
eval {
- # This wrapper's sole purpose in life is to keep the dbh connection open.
- package Bloot::DBI;
-
- # These are DBI methods which do not require an active DB
- # connection. [Eg, don't check to see if the database is working
- # by pinging it for these methods.]
- my %no_ping;
- @no_ping{qw(ping err err_str quote disconnect clone)} = (1) x 6;
- sub new {
- my $class = shift;
- my $dbh = shift;
- return undef unless $dbh;
- $class = ref($class) if ref($class);
- my $self = {dbh=>$dbh};
- bless $self, $class;
- return $self;
- }
-
- our $AUTOLOAD;
- sub AUTOLOAD {
- my $method = $AUTOLOAD;
- my $self = shift;
- die "Undefined subroutine $method called" unless defined $self;
- ($method) = $method =~ /([^\:]+)$/;
- unshift @_, $self->{dbh};
- return undef if not defined $self->{dbh};
- goto &{$self->{dbh}->can($method)} if exists $no_ping{$method} and $no_ping{$method};
- my $ping_count = 0;
- while (++$ping_count < 10){
- last if $self->{dbh}->ping;
- $self->{dbh}->disconnect;
- $self->{dbh} = $self->{dbh}->clone;
- }
- if ($ping_count >=10 and not $self->{dbh}->ping){
- &ERROR("Tried real hard but was unable to reconnect");
- return undef;
- }
- $_[0] = $self->{dbh};
- my $coderef = $self->{dbh}->can($method);
- goto &$coderef if defined $coderef;
- # Dumb DBI doesn't have a can method for some
- # functions. Like func.
- shift;
- return eval "\$self->{dbh}->$method(\@_)" or die $@;
- }
- 1;
+
+ # This wrapper's sole purpose in life is to keep the dbh connection open.
+ package Bloot::DBI;
+
+ # These are DBI methods which do not require an active DB
+ # connection. [Eg, don't check to see if the database is working
+ # by pinging it for these methods.]
+ my %no_ping;
+ @no_ping{qw(ping err err_str quote disconnect clone)} = (1) x 6;
+
+ sub new {
+ my $class = shift;
+ my $dbh = shift;
+ return undef unless $dbh;
+ $class = ref($class) if ref($class);
+ my $self = { dbh => $dbh };
+ bless $self, $class;
+ return $self;
+ }
+
+ our $AUTOLOAD;
+
+ sub AUTOLOAD {
+ my $method = $AUTOLOAD;
+ my $self = shift;
+ die "Undefined subroutine $method called" unless defined $self;
+ ($method) = $method =~ /([^\:]+)$/;
+ unshift @_, $self->{dbh};
+ return undef if not defined $self->{dbh};
+ goto &{ $self->{dbh}->can($method) }
+ if exists $no_ping{$method} and $no_ping{$method};
+ my $ping_count = 0;
+
+ while ( ++$ping_count < 10 ) {
+ last if $self->{dbh}->ping;
+ $self->{dbh}->disconnect;
+ $self->{dbh} = $self->{dbh}->clone;
+ }
+ if ( $ping_count >= 10 and not $self->{dbh}->ping ) {
+ &ERROR('Tried real hard but was unable to reconnect');
+ return undef;
+ }
+ $_[0] = $self->{dbh};
+ my $coderef = $self->{dbh}->can($method);
+ goto &$coderef if defined $coderef;
+
+ # Dumb DBI doesn't have a can method for some
+ # functions. Like func.
+ shift;
+ return eval "\$self->{dbh}->$method(\@_)" or die $@;
+ }
+ 1;
};
#####
# &sqlOpenDB($dbname, $dbtype, $sqluser, $sqlpass, $nofail);
sub sqlOpenDB {
- my ($db, $type, $user, $pass, $no_fail) = @_;
+ my ( $db, $type, $user, $pass, $no_fail ) = @_;
+
# this is a mess. someone fix it, please.
- if ($type =~ /^SQLite(2)?$/i) {
- $db = "dbname=$db.sqlite";
- } elsif ($type =~ /^pg/i) {
- $db = "dbname=$db";
- $type = 'Pg';
+ if ( $type =~ /^SQLite(2)?$/i ) {
+ $db = "dbname=$db.sqlite";
+ }
+ elsif ( $type =~ /^pg/i ) {
+ $db = "dbname=$db";
+ $type = 'Pg';
}
- my $dsn = "DBI:$type:$db";
+ my $dsn = "DBI:$type:$db";
my $hoststr = '';
+
# SQLHost should be unset for SQLite
- if (exists $param{'SQLHost'} and $param{'SQLHost'}) {
- # PostgreSQL requires ";" and keyword 'host'. See perldoc Pg -- troubled
- if ($type eq 'Pg') {
- $dsn .= ";host=$param{SQLHost}";
- } else {
- $dsn .= ":$param{SQLHost}";
- }
- $hoststr = " to $param{'SQLHost'}";
+ if ( exists $param{'SQLHost'} and $param{'SQLHost'} ) {
+
+ # PostgreSQL requires ';' and keyword 'host'. See perldoc Pg -- troubled
+ if ( $type eq 'Pg' ) {
+ $dsn .= ";host=$param{SQLHost}";
+ }
+ else {
+ $dsn .= ":$param{SQLHost}";
+ }
+ $hoststr = " to $param{'SQLHost'}";
}
+
# SQLite ignores $user and $pass
- $dbh = Bloot::DBI->new(DBI->connect($dsn, $user, $pass));
+ $dbh = Bloot::DBI->new( DBI->connect( $dsn, $user, $pass ) );
- if ($dbh && !$dbh->err) {
- &status("Opened $type connection$hoststr");
- } else {
- &ERROR("Cannot connect$hoststr.");
- &ERROR("Since $type is not available, shutting down bot!");
- &ERROR( $dbh->errstr ) if ($dbh);
- &closePID();
- &closeSHM($shm);
- &closeLog();
+ if ( $dbh && !$dbh->err ) {
+ &status("Opened $type connection$hoststr");
+ }
+ else {
+ &ERROR("Cannot connect$hoststr.");
+ &ERROR("Since $type is not available, shutting down bot!");
+ &ERROR( $dbh->errstr ) if ($dbh);
+ &closePID();
+ &closeSHM($shm);
+ &closeLog();
- return 0 if ($no_fail);
+ return 0 if ($no_fail);
- exit 1;
+ exit 1;
}
}
#####
# Usage: &sqlQuote($str);
sub sqlQuote {
- return $dbh->quote($_[0]);
+ return $dbh->quote( $_[0] );
}
#####
# Usage: &sqlSelectMany($table, $select, [$where_href], [$other]);
# Return: $sth (Statement handle object)
sub sqlSelectMany {
- my($table, $select, $where_href, $other) = @_;
+ my ( $table, $select, $where_href, $other ) = @_;
my $query = "SELECT $select FROM $table";
my $sth;
- if (!defined $select or $select =~ /^\s*$/) {
- &WARN("sqlSelectMany: select == NULL.");
- return;
+ if ( !defined $select or $select =~ /^\s*$/ ) {
+ &WARN('sqlSelectMany: select == NULL.');
+ return;
}
- if (!defined $table or $table =~ /^\s*$/) {
- &WARN("sqlSelectMany: table == NULL.");
- return;
+ if ( !defined $table or $table =~ /^\s*$/ ) {
+ &WARN('sqlSelectMany: table == NULL.');
+ return;
}
if ($where_href) {
- my $where = &hashref2where($where_href);
- $query .= " WHERE $where" if ($where);
+ my $where = &hashref2where($where_href);
+ $query .= " WHERE $where" if ($where);
}
- $query .= " $other" if ($other);
+ $query .= " $other" if ($other);
- if (!($sth = $dbh->prepare($query))) {
- &ERROR("sqlSelectMany: prepare: $DBI::errstr");
- return;
+ if ( !( $sth = $dbh->prepare($query) ) ) {
+ &ERROR("sqlSelectMany: prepare: $DBI::errstr");
+ return;
}
&SQLDebug($query);
- return if (!$sth->execute);
+ return if ( !$sth->execute );
return $sth;
}
# Note: Suitable for one column returns, that is, one column in $select.
# Todo: Always return array?
sub sqlSelect {
- my $sth = &sqlSelectMany(@_);
- if (!defined $sth) {
- &WARN("sqlSelect failed.");
- return;
+ my $sth = &sqlSelectMany(@_);
+ if ( !defined $sth ) {
+ &WARN('sqlSelect failed.');
+ return;
}
- my @retval = $sth->fetchrow_array;
+ my @retval = $sth->fetchrow_array;
$sth->finish;
- if (scalar @retval > 1) {
- return @retval;
- } elsif (scalar @retval == 1) {
- return $retval[0];
- } else {
- return;
+ if ( scalar @retval > 1 ) {
+ return @retval;
+ }
+ elsif ( scalar @retval == 1 ) {
+ return $retval[0];
+ }
+ else {
+ return;
}
}
# Usage: &sqlSelectColArray($table, $select, [$where_href], [$other]);
# Return: array.
sub sqlSelectColArray {
- my $sth = &sqlSelectMany(@_);
+ my $sth = &sqlSelectMany(@_);
my @retval;
- if (!defined $sth) {
- &WARN("sqlSelect failed.");
- return;
+ if ( !defined $sth ) {
+ &WARN('sqlSelect failed.');
+ return;
}
- while (my @row = $sth->fetchrow_array) {
- push(@retval, $row[0]);
+ while ( my @row = $sth->fetchrow_array ) {
+ push( @retval, $row[0] );
}
$sth->finish;
# Return: no type: $retval{ col1 } = col2;
# Note: does not support $other, yet.
sub sqlSelectColHash {
- my ($table, $select, $where_href, $other, $type) = @_;
- my $sth = &sqlSelectMany($table, $select, $where_href, $other);
- if (!defined $sth) {
- &WARN("sqlSelectColhash failed.");
- return;
+ my ( $table, $select, $where_href, $other, $type ) = @_;
+ my $sth = &sqlSelectMany( $table, $select, $where_href, $other );
+ if ( !defined $sth ) {
+ &WARN('sqlSelectColhash failed.');
+ return;
}
my %retval;
- if (defined $type and $type == 2) {
- &DEBUG("sqlSelectColHash: type 2!");
- while (my @row = $sth->fetchrow_array) {
- $retval{$row[0]} = join(':', $row[1..$#row]);
- }
- &DEBUG("sqlSelectColHash: count => ".scalar(keys %retval) );
-
- } elsif (defined $type and $type == 1) {
- while (my @row = $sth->fetchrow_array) {
- # reverse it to make it easier to count.
- if (scalar @row == 2) {
- $retval{$row[1]}{$row[0]} = 1;
- } elsif (scalar @row == 3) {
- $retval{$row[1]}{$row[0]} = 1;
- }
- # what to do if there's only one or more than 3?
- }
-
- } else {
- while (my @row = $sth->fetchrow_array) {
- $retval{$row[0]} = $row[1];
- }
+ if ( defined $type and $type == 2 ) {
+ &DEBUG('sqlSelectColHash: type 2!');
+ while ( my @row = $sth->fetchrow_array ) {
+ $retval{ $row[0] } = join( ':', $row[ 1 .. $#row ] );
+ }
+ &DEBUG( 'sqlSelectColHash: count => ' . scalar( keys %retval ) );
+
+ }
+ elsif ( defined $type and $type == 1 ) {
+ while ( my @row = $sth->fetchrow_array ) {
+
+ # reverse it to make it easier to count.
+ if ( scalar @row == 2 ) {
+ $retval{ $row[1] }{ $row[0] } = 1;
+ }
+ elsif ( scalar @row == 3 ) {
+ $retval{ $row[1] }{ $row[0] } = 1;
+ }
+
+ # what to do if there's only one or more than 3?
+ }
+
+ }
+ else {
+ while ( my @row = $sth->fetchrow_array ) {
+ $retval{ $row[0] } = $row[1];
+ }
}
$sth->finish;
# Return: $hash{ col } = value;
# Note: useful for returning only one/first row of data.
sub sqlSelectRowHash {
- my $sth = &sqlSelectMany(@_);
- if (!defined $sth) {
- &WARN("sqlSelectRowHash failed.");
- return;
+ my $sth = &sqlSelectMany(@_);
+ if ( !defined $sth ) {
+ &WARN('sqlSelectRowHash failed.');
+ return;
}
- my $retval = $sth->fetchrow_hashref();
+ my $retval = $sth->fetchrow_hashref();
$sth->finish;
if ($retval) {
- return %{ $retval };
- } else {
- return;
+ return %{$retval};
+ }
+ else {
+ return;
}
}
# Usage: &sqlSet($table, $where_href, $data_href);
# Return: 1 for success, undef for failure.
sub sqlSet {
- my ($table, $where_href, $data_href) = @_;
+ my ( $table, $where_href, $data_href ) = @_;
- if (!defined $table or $table =~ /^\s*$/) {
- &WARN("sqlSet: table == NULL.");
- return;
+ if ( !defined $table or $table =~ /^\s*$/ ) {
+ &WARN('sqlSet: table == NULL.');
+ return;
}
- if (!defined $data_href or ref($data_href) ne 'HASH') {
- &WARN("sqlSet: data_href == NULL.");
- return;
+ if ( !defined $data_href or ref($data_href) ne 'HASH' ) {
+ &WARN('sqlSet: data_href == NULL.');
+ return;
}
# any column can be NULL... so just get them all.
- my $k = join(',', keys %{ $where_href } );
- my $result = &sqlSelect($table, $k, $where_href);
-# &DEBUG("result is not defined :(") if (!defined $result);
+ my $k = join( ',', keys %{$where_href} );
+ my $result = &sqlSelect( $table, $k, $where_href );
- # this was hardwired to use sqlUpdate. sqlite does not do inserts on sqlUpdate.
- if (defined $result) {
- &sqlUpdate($table, $data_href, $where_href);
- } else {
- # hack.
- my %hash = %{ $where_href };
- # add data_href values...
- foreach (keys %{ $data_href }) {
- $hash{ $_ } = ${ $data_href }{$_};
- }
+ # &DEBUG('result is not defined :(') if (!defined $result);
- $data_href = \%hash;
- &sqlInsert($table, $data_href);
+ # this was hardwired to use sqlUpdate. sqlite does not do inserts on sqlUpdate.
+ if ( defined $result ) {
+ &sqlUpdate( $table, $data_href, $where_href );
+ }
+ else {
+
+ # hack.
+ my %hash = %{$where_href};
+
+ # add data_href values...
+ foreach ( keys %{$data_href} ) {
+ $hash{$_} = ${$data_href}{$_};
+ }
+
+ $data_href = \%hash;
+ &sqlInsert( $table, $data_href );
}
return 1;
#####
# Usage: &sqlUpdate($table, $data_href, $where_href);
sub sqlUpdate {
- my ($table, $data_href, $where_href) = @_;
+ my ( $table, $data_href, $where_href ) = @_;
- if (!defined $data_href or ref($data_href) ne 'HASH') {
- &WARN("sqlSet: data_href == NULL.");
- return 0;
+ if ( !defined $data_href or ref($data_href) ne 'HASH' ) {
+ &WARN('sqlSet: data_href == NULL.');
+ return 0;
}
my $where = &hashref2where($where_href) if ($where_href);
my $update = &hashref2update($data_href) if ($data_href);
- &sqlRaw('Update', "UPDATE $table SET $update WHERE $where");
+ &sqlRaw( 'Update', "UPDATE $table SET $update WHERE $where" );
return 1;
}
#####
# Usage: &sqlInsert($table, $data_href, $other);
sub sqlInsert {
- my ($table, $data_href, $other) = @_;
- # note: if $other == 1, add 'DELAYED' to function instead.
- # note: ^^^ doesnt actually do anything lol. Need code to s/1/DELAYED/ below -- troubled
+ my ( $table, $data_href, $other ) = @_;
+
+# note: if $other == 1, add 'DELAYED' to function instead.
+# note: ^^^ doesnt actually do anything lol. Need code to s/1/DELAYED/ below -- troubled
- if (!defined $data_href or ref($data_href) ne 'HASH') {
- &WARN("sqlInsert: data_href == NULL.");
- return;
+ if ( !defined $data_href or ref($data_href) ne 'HASH' ) {
+ &WARN('sqlInsert: data_href == NULL.');
+ return;
}
- my ($k_aref, $v_aref) = &hashref2array($data_href);
- my @k = @{ $k_aref };
- my @v = @{ $v_aref };
+ my ( $k_aref, $v_aref ) = &hashref2array($data_href);
+ my @k = @{$k_aref};
+ my @v = @{$v_aref};
- if (!@k or !@v) {
- &WARN("sqlInsert: keys or vals is NULL.");
- return;
+ if ( !@k or !@v ) {
+ &WARN('sqlInsert: keys or vals is NULL.');
+ return;
}
- &sqlRaw("Insert($table)", sprintf(
- "INSERT %s INTO %s (%s) VALUES (%s)",
- ($other || ''), $table, join(',',@k), join(',',@v)
- ) );
+ &sqlRaw(
+ "Insert($table)",
+ sprintf(
+ 'INSERT %s INTO %s (%s) VALUES (%s)',
+ ( $other || '' ),
+ $table,
+ join( ',', @k ),
+ join( ',', @v )
+ )
+ );
return 1;
}
#####
# Usage: &sqlReplace($table, $data_href, [$pkey]);
sub sqlReplace {
- my ($table, $data_href, $pkey) = @_;
+ my ( $table, $data_href, $pkey ) = @_;
- if (!defined $data_href or ref($data_href) ne 'HASH') {
- &WARN("sqlReplace: data_href == NULL.");
- return;
+ if ( !defined $data_href or ref($data_href) ne 'HASH' ) {
+ &WARN('sqlReplace: data_href == NULL.');
+ return;
}
- my ($k_aref, $v_aref) = &hashref2array($data_href);
- my @k = @{ $k_aref };
- my @v = @{ $v_aref };
+ my ( $k_aref, $v_aref ) = &hashref2array($data_href);
+ my @k = @{$k_aref};
+ my @v = @{$v_aref};
- if (!@k or !@v) {
- &WARN("sqlReplace: keys or vals is NULL.");
- return;
+ if ( !@k or !@v ) {
+ &WARN('sqlReplace: keys or vals is NULL.');
+ return;
}
+ if ( $param{'DBType'} =~ /^pgsql$/i ) {
- if ($param{'DBType'} =~ /^pgsql$/i) {
- # OK, heres the scoop. There is currently no REPLACE INTO in Pgsql.
- # However, the bot already seems to search for factoids before insert
- # anyways. Perhaps we could change this to a generic INSERT INTO so
- # we can skip the seperate sql? -- troubled to: TimRiker
- # PGSql syntax: UPDATE table SET key = 'value', key2 = 'value2' WHERE key = 'value'
+# OK, heres the scoop. There is currently no REPLACE INTO in Pgsql.
+# However, the bot already seems to search for factoids before insert
+# anyways. Perhaps we could change this to a generic INSERT INTO so
+# we can skip the seperate sql? -- troubled to: TimRiker
+# PGSql syntax: UPDATE table SET key = 'value', key2 = 'value2' WHERE key = 'value'
-# &sqlRaw("Replace($table)", sprintf(
-# "INSERT INTO %s (%s) VALUES (%s)",
-# $table, join(',',@k), join(',',@v)
-# ));
- &WARN("DEBUG: ($pkey = ) " . sprintf(
- "REPLACE INTO %s (%s) VALUES (%s)",
- $table, join(',',@k), join(',',@v)
- ));
+ # &sqlRaw("Replace($table)", sprintf(
+ # 'INSERT INTO %s (%s) VALUES (%s)',
+ # $table, join(',',@k), join(',',@v)
+ # ));
+ &WARN(
+ "DEBUG: ($pkey = ) "
+ . sprintf(
+ 'REPLACE INTO %s (%s) VALUES (%s)',
+ $table,
+ join( ',', @k ),
+ join( ',', @v )
+ )
+ );
- } else {
- &sqlRaw("Replace($table)", sprintf(
- "REPLACE INTO %s (%s) VALUES (%s)",
- $table, join(',',@k), join(',',@v)
- ));
+ }
+ else {
+ &sqlRaw(
+ "Replace($table)",
+ sprintf(
+ 'REPLACE INTO %s (%s) VALUES (%s)',
+ $table,
+ join( ',', @k ),
+ join( ',', @v )
+ )
+ );
}
return 1;
#####
# Usage: &sqlDelete($table, $where_href);
sub sqlDelete {
- my ($table, $where_href) = @_;
+ my ( $table, $where_href ) = @_;
- if (!defined $where_href or ref($where_href) ne 'HASH') {
- &WARN("sqlDelete: where_href == NULL.");
- return;
+ if ( !defined $where_href or ref($where_href) ne 'HASH' ) {
+ &WARN('sqlDelete: where_href == NULL.');
+ return;
}
- my $where = &hashref2where($where_href);
+ my $where = &hashref2where($where_href);
- &sqlRaw('Delete', "DELETE FROM $table WHERE $where");
+ &sqlRaw( 'Delete', "DELETE FROM $table WHERE $where" );
return 1;
}
# Usage: &sqlRaw($prefix, $query);
# Return: 1 for success, 0 for failure.
sub sqlRaw {
- my ($prefix, $query) = @_;
+ my ( $prefix, $query ) = @_;
my $sth;
- if (!defined $query or $query =~ /^\s*$/) {
- &WARN("sqlRaw: query == NULL.");
- return 0;
+ if ( !defined $query or $query =~ /^\s*$/ ) {
+ &WARN('sqlRaw: query == NULL.');
+ return 0;
}
- if (!($sth = $dbh->prepare($query))) {
- &ERROR("Raw($prefix): !prepare => '$query'");
- return 0;
+ if ( !( $sth = $dbh->prepare($query) ) ) {
+ &ERROR("Raw($prefix): !prepare => '$query'");
+ return 0;
}
&SQLDebug($query);
- if (!$sth->execute) {
- &ERROR("Raw($prefix): !execute => '$query'");
- $sth->finish;
- return 0;
+ if ( !$sth->execute ) {
+ &ERROR("Raw($prefix): !execute => '$query'");
+ $sth->finish;
+ return 0;
}
$sth->finish;
my @retval;
my $sth;
- if (!defined $query or $query =~ /^\s*$/) {
- &WARN("sqlRawReturn: query == NULL.");
- return 0;
+ if ( !defined $query or $query =~ /^\s*$/ ) {
+ &WARN('sqlRawReturn: query == NULL.');
+ return 0;
}
- if (!($sth = $dbh->prepare($query))) {
- &ERROR("RawReturn: !prepare => '$query'");
- return 0;
+ if ( !( $sth = $dbh->prepare($query) ) ) {
+ &ERROR("RawReturn: !prepare => '$query'");
+ return 0;
}
&SQLDebug($query);
- if (!$sth->execute) {
- &ERROR("RawReturn: !execute => '$query'");
- $sth->finish;
- return 0;
+ if ( !$sth->execute ) {
+ &ERROR("RawReturn: !execute => '$query'");
+ $sth->finish;
+ return 0;
}
- while (my @row = $sth->fetchrow_array) {
- push(@retval, $row[0]);
+ while ( my @row = $sth->fetchrow_array ) {
+ push( @retval, $row[0] );
}
$sth->finish;
####################################################################
##### Misc DBI stuff...
#####
-
sub hashref2where {
my ($href) = @_;
- if (!defined $href) {
- &WARN("hashref2where: href == NULL.");
- return;
+ if ( !defined $href ) {
+ &WARN('hashref2where: href == NULL.');
+ return;
}
- if (ref($href) ne 'HASH') {
- &WARN("hashref2where: href is not HASH ref (href => $href)");
- return;
+ if ( ref($href) ne 'HASH' ) {
+ &WARN("hashref2where: href is not HASH ref (href => $href)");
+ return;
}
- my %hash = %{ $href };
- foreach (keys %hash) {
- my $v = $hash{$_};
+ my %hash = %{$href};
+ foreach ( keys %hash ) {
+ my $v = $hash{$_};
- if (s/^-//) { # as is.
- $hash{$_} = $v;
- delete $hash{'-'.$_};
- } else {
- $hash{$_} = &sqlQuote($v);
- }
+ if (s/^-//) { # as is.
+ $hash{$_} = $v;
+ delete $hash{ '-' . $_ };
+ }
+ else {
+ $hash{$_} = &sqlQuote($v);
+ }
}
- return join(' AND ', map { $_."=".$hash{$_} } keys %hash );
+ return join( ' AND ', map { $_ . '=' . $hash{$_} } keys %hash );
}
sub hashref2update {
my ($href) = @_;
- if (ref($href) ne 'HASH') {
- &WARN("hashref2update: href is not HASH ref.");
- return;
+ if ( ref($href) ne 'HASH' ) {
+ &WARN('hashref2update: href is not HASH ref.');
+ return;
}
my %hash;
- foreach (keys %{ $href }) {
- my $k = $_;
- my $v = ${ $href }{$_};
+ foreach ( keys %{$href} ) {
+ my $k = $_;
+ my $v = ${$href}{$_};
- # is there a better way to do this?
- if ($k =~ s/^-//) { # as is.
- 1;
- } else {
- $v = &sqlQuote($v);
- }
+ # is there a better way to do this?
+ if ( $k =~ s/^-// ) { # as is.
+ 1;
+ }
+ else {
+ $v = &sqlQuote($v);
+ }
- $hash{$k} = $v;
+ $hash{$k} = $v;
}
- return join(', ', map { $_."=".$hash{$_} } sort keys %hash);
+ return join( ', ', map { $_ . '=' . $hash{$_} } sort keys %hash );
}
sub hashref2array {
my ($href) = @_;
- if (ref($href) ne 'HASH') {
- &WARN("hashref2update: href is not HASH ref.");
- return;
+ if ( ref($href) ne 'HASH' ) {
+ &WARN('hashref2update: href is not HASH ref.');
+ return;
}
- my(@k, @v);
- foreach (keys %{ $href }) {
- my $k = $_;
- my $v = ${ $href }{$_};
+ my ( @k, @v );
+ foreach ( keys %{$href} ) {
+ my $k = $_;
+ my $v = ${$href}{$_};
- # is there a better way to do this?
- if ($k =~ s/^-//) { # as is.
- 1;
- } else {
- $v = &sqlQuote($v);
- }
+ # is there a better way to do this?
+ if ( $k =~ s/^-// ) { # as is.
+ 1;
+ }
+ else {
+ $v = &sqlQuote($v);
+ }
- push(@k, $k);
- push(@v, $v);
+ push( @k, $k );
+ push( @v, $v );
}
- return (\@k, \@v);
+ return ( \@k, \@v );
}
#####
# Usage: &countKeys($table, [$col]);
sub countKeys {
- my ($table, $col) = @_;
+ my ( $table, $col ) = @_;
$col ||= '*';
- return (&sqlRawReturn("SELECT count($col) FROM $table"))[0];
+ return ( &sqlRawReturn("SELECT count($col) FROM $table") )[0];
}
#####
# Usage: &sumKey($table, $col);
sub sumKey {
- my ($table, $col) = @_;
+ my ( $table, $col ) = @_;
- return (&sqlRawReturn("SELECT sum($col) FROM $table"))[0];
+ return ( &sqlRawReturn("SELECT sum($col) FROM $table") )[0];
}
#####
# Usage: &randKey($table, $select);
sub randKey {
- my ($table, $select) = @_;
- my $rand = int(rand(&countKeys($table)));
- my $query = "SELECT $select FROM $table LIMIT 1 OFFSET $rand";
- if ($param{DBType} =~ /^mysql$/i) {
- # WARN: only newer MySQL supports "LIMIT limit OFFSET offset"
- $query = "SELECT $select FROM $table LIMIT $rand,1";
- }
- my $sth = $dbh->prepare($query);
+ my ( $table, $select ) = @_;
+ my $rand = int( rand( &countKeys($table) ) );
+ my $query = "SELECT $select FROM $table LIMIT 1 OFFSET $rand";
+ if ( $param{DBType} =~ /^mysql$/i ) {
+
+ # WARN: only newer MySQL supports 'LIMIT limit OFFSET offset'
+ $query = "SELECT $select FROM $table LIMIT $rand,1";
+ }
+ my $sth = $dbh->prepare($query);
&SQLDebug($query);
&WARN("randKey($query)") unless $sth->execute;
- my @retval = $sth->fetchrow_array;
+ my @retval = $sth->fetchrow_array;
$sth->finish;
return @retval;
#####
# Usage: &deleteTable($table);
sub deleteTable {
- &sqlRaw("deleteTable($_[0])", "DELETE FROM $_[0]");
+ &sqlRaw( "deleteTable($_[0])", "DELETE FROM $_[0]" );
}
#####
# Usage: &searchTable($table, $select, $key, $str);
# Note: searchTable does sqlQuote.
sub searchTable {
- my($table, $select, $key, $str) = @_;
+ my ( $table, $select, $key, $str ) = @_;
my $origStr = $str;
my @results;
# allow two types of wildcards.
- if ($str =~ /^\^(.*)\$$/) {
- &FIXME("searchTable: can't do \"$str\"");
- $str = $1;
- } else {
- $str .= "%" if ($str =~ s/^\^//);
- $str = "%".$str if ($str =~ s/\$$//);
- $str = "%".$str."%" if ($str eq $origStr); # el-cheapo fix.
+ if ( $str =~ /^\^(.*)\$$/ ) {
+ &FIXME("searchTable: can't do \"$str\"");
+ $str = $1;
+ }
+ else {
+ $str .= '%' if ( $str =~ s/^\^// );
+ $str = '%' . $str if ( $str =~ s/\$$// );
+ $str = '%' . $str . '%' if ( $str eq $origStr ); # el-cheapo fix.
}
$str =~ s/\_/\\_/g;
- $str =~ s/\?/_/g; # '.' should be supported, too.
+ $str =~ s/\?/_/g; # '.' should be supported, too.
$str =~ s/\*/%/g;
+
# end of string fix.
- my $query = "SELECT $select FROM $table WHERE $key LIKE ".
- &sqlQuote($str);
- my $sth = $dbh->prepare($query);
+ my $query = "SELECT $select FROM $table WHERE $key LIKE " . &sqlQuote($str);
+ my $sth = $dbh->prepare($query);
&SQLDebug($query);
- if (!$sth->execute) {
- &WARN("Search($query)");
- $sth->finish;
- return;
+ if ( !$sth->execute ) {
+ &WARN("Search($query)");
+ $sth->finish;
+ return;
}
- while (my @row = $sth->fetchrow_array) {
- push(@results, $row[0]);
+ while ( my @row = $sth->fetchrow_array ) {
+ push( @results, $row[0] );
}
$sth->finish;
}
sub sqlCreateTable {
- my($table, $dbtype) = @_;
- my(@path) = ($bot_data_dir, ".","..","../..");
- my $found = 0;
+ my ( $table, $dbtype ) = @_;
+ my (@path) = ( $bot_data_dir, '.', '..', '../..' );
+ my $found = 0;
my $data;
$dbtype = lc $dbtype;
foreach (@path) {
- my $file = "$_/setup/$dbtype/$table.sql";
- next unless ( -f $file );
-
- open(IN, $file);
- while (<IN>) {
- chop;
- next if $_ =~ /^--/;
- $data .= $_;
- }
+ my $file = "$_/setup/$dbtype/$table.sql";
+ next unless ( -f $file );
+
+ open( IN, $file );
+ while (<IN>) {
+ chop;
+ next if $_ =~ /^--/;
+ $data .= $_;
+ }
- $found++;
- last;
+ $found++;
+ last;
}
- if (!$found) {
- return 0;
- } else {
- &sqlRaw("sqlCreateTable($table)", $data);
- return 1;
+ if ( !$found ) {
+ return 0;
+ }
+ else {
+ &sqlRaw( "sqlCreateTable($table)", $data );
+ return 1;
}
}
my $database_exists = 0;
my %db;
- if ($param{DBType} =~ /^mysql$/i) {
- my $sql = "SHOW DATABASES";
- foreach ( &sqlRawReturn($sql) ) {
- $database_exists++ if ($_ eq $param{'DBName'});
- }
-
- unless ($database_exists) {
- &status("Creating database $param{DBName}...");
- my $query = "CREATE DATABASE $param{DBName}";
- &sqlRaw("create(db $param{DBName})", $query);
- }
-
- # retrieve a list of db's from the server.
- my @tables = map {s/^\`//; s/\`$//; $_;} $dbh->func('_ListTables');
- if ($#tables == -1){
- @tables = $dbh->tables;
+ if ( $param{DBType} =~ /^mysql$/i ) {
+ my $sql = 'SHOW DATABASES';
+ foreach ( &sqlRawReturn($sql) ) {
+ $database_exists++ if ( $_ eq $param{'DBName'} );
}
- &status("Tables: ".join(',',@tables));
- @db{@tables} = (1) x @tables;
- } elsif ($param{DBType} =~ /^SQLite(2)?$/i) {
+ unless ($database_exists) {
+ &status("Creating database $param{DBName}...");
+ my $query = "CREATE DATABASE $param{DBName}";
+ &sqlRaw( "create(db $param{DBName})", $query );
+ }
- # retrieve a list of db's from the server.
- foreach ( &sqlRawReturn("SELECT name FROM sqlite_master WHERE type='table'") ) {
- $db{$_} = 1;
- }
+ # retrieve a list of db's from the server.
+ my @tables = map { s/^\`//; s/\`$//; $_; } $dbh->func('_ListTables');
+ if ( $#tables == -1 ) {
+ @tables = $dbh->tables;
+ }
+ &status( 'Tables: ' . join( ',', @tables ) );
+ @db{@tables} = (1) x @tables;
- # create database not needed for SQLite
+ }
+ elsif ( $param{DBType} =~ /^SQLite(2)?$/i ) {
- } elsif ($param{DBType} =~ /^pgsql$/i) {
- # $sql_showDB = SQL to select the DB list
- # $sql_showTBL = SQL to select all tables for the current connection
+ # retrieve a list of db's from the server.
+ foreach (
+ &sqlRawReturn("SELECT name FROM sqlite_master WHERE type='table'") )
+ {
+ $db{$_} = 1;
+ }
- my $sql_showDB = "SELECT datname FROM pg_database";
- my $sql_showTBL = "SELECT tablename FROM pg_tables \
+ # create database not needed for SQLite
+
+ }
+ elsif ( $param{DBType} =~ /^pgsql$/i ) {
+
+ # $sql_showDB = SQL to select the DB list
+ # $sql_showTBL = SQL to select all tables for the current connection
+
+ my $sql_showDB = 'SELECT datname FROM pg_database';
+ my $sql_showTBL = "SELECT tablename FROM pg_tables \
WHERE schemaname = 'public'";
- foreach ( &sqlRawReturn($sql_showDB) ) {
- $database_exists++ if ($_ eq $param{'DBName'});
- }
+ foreach ( &sqlRawReturn($sql_showDB) ) {
+ $database_exists++ if ( $_ eq $param{'DBName'} );
+ }
- unless ($database_exists) {
- &status("Creating PostgreSQL database $param{'DBName'}");
- &status("(actually, not really, please read the INSTALL file)");
- }
+ unless ($database_exists) {
+ &status("Creating PostgreSQL database $param{'DBName'}");
+ &status('(actually, not really, please read the INSTALL file)');
+ }
- # retrieve a list of db's from the server. This code is from mysql above, please check -- troubled
- my @tables = map {s/^\`//; s/\`$//; $_;} &sqlRawReturn($sql_showTBL);
- if ($#tables == -1){
+# retrieve a list of db's from the server. This code is from mysql above, please check -- troubled
+ my @tables = map { s/^\`//; s/\`$//; $_; } &sqlRawReturn($sql_showTBL);
+ if ( $#tables == -1 ) {
@tables = $dbh->tables;
}
- &status("Tables: ".join(',',@tables));
+ &status( 'Tables: ' . join( ',', @tables ) );
@db{@tables} = (1) x @tables;
}
- foreach ( qw(botmail connections factoids rootwarn seen stats onjoin) ) {
- if (exists $db{$_}) {
- $cache{has_table}{$_} = 1;
- next;
- }
+ foreach (qw(botmail connections factoids rootwarn seen stats onjoin)) {
+ if ( exists $db{$_} ) {
+ $cache{has_table}{$_} = 1;
+ next;
+ }
- &status("checkTables: creating new table $_...");
+ &status("checkTables: creating new table $_...");
- $cache{create_table}{$_} = 1;
+ $cache{create_table}{$_} = 1;
- &sqlCreateTable($_, $param{DBType});
+ &sqlCreateTable( $_, $param{DBType} );
}
}
use vars qw(@backlog);
use vars qw(%param %file %cache);
-$logtime = time();
-$logcount = 0;
-$logrepeat = 0;
-$logold = '';
+$logtime = time();
+$logcount = 0;
+$logrepeat = 0;
+$logold = '';
-$param{VEBOSITY} ||= 1; # lame fix for preload
+$param{VEBOSITY} ||= 1; # lame fix for preload
my %attributes = (
- 'clear' => 0,
- 'reset' => 0,
- 'bold' => 1,
- 'underline' => 4,
- 'underscore' => 4,
- 'blink' => 5,
- 'reverse' => 7,
- 'concealed' => 8,
- 'black' => 30, 'on_black' => 40,
- 'red' => 31, 'on_red' => 41,
- 'green' => 32, 'on_green' => 42,
- 'yellow' => 33, 'on_yellow' => 43,
- 'blue' => 34, 'on_blue' => 44,
- 'magenta' => 35, 'on_magenta' => 45,
- 'cyan' => 36, 'on_cyan' => 46,
- 'white' => 37, 'on_white' => 47
+ 'clear' => 0,
+ 'reset' => 0,
+ 'bold' => 1,
+ 'underline' => 4,
+ 'underscore' => 4,
+ 'blink' => 5,
+ 'reverse' => 7,
+ 'concealed' => 8,
+ 'black' => 30,
+ 'on_black' => 40,
+ 'red' => 31,
+ 'on_red' => 41,
+ 'green' => 32,
+ 'on_green' => 42,
+ 'yellow' => 33,
+ 'on_yellow' => 43,
+ 'blue' => 34,
+ 'on_blue' => 44,
+ 'magenta' => 35,
+ 'on_magenta' => 45,
+ 'cyan' => 36,
+ 'on_cyan' => 46,
+ 'white' => 37,
+ 'on_white' => 47
);
use vars qw($b_black $_black $b_red $_red $b_green $_green
- $b_yellow $_yellow $b_blue $_blue $b_magenta $_magenta
- $b_cyan $_cyan $b_white $_white $_reset $_bold $ob $b);
-
-$b_black = cl('bold black'); $_black = cl('black');
-$b_red = cl('bold red'); $_red = cl('red');
-$b_green = cl('bold green'); $_green = cl('green');
-$b_yellow = cl('bold yellow'); $_yellow = cl('yellow');
-$b_blue = cl('bold blue'); $_blue = cl('blue');
-$b_magenta = cl('bold magenta'); $_magenta = cl('magenta');
-$b_cyan = cl('bold cyan'); $_cyan = cl('cyan');
-$b_white = cl('bold white'); $_white = cl('white');
-$_reset = cl('reset'); $_bold = cl('bold');
-$ob = cl('reset'); $b = cl('bold');
+ $b_yellow $_yellow $b_blue $_blue $b_magenta $_magenta
+ $b_cyan $_cyan $b_white $_white $_reset $_bold $ob $b);
+
+$b_black = cl('bold black');
+$_black = cl('black');
+$b_red = cl('bold red');
+$_red = cl('red');
+$b_green = cl('bold green');
+$_green = cl('green');
+$b_yellow = cl('bold yellow');
+$_yellow = cl('yellow');
+$b_blue = cl('bold blue');
+$_blue = cl('blue');
+$b_magenta = cl('bold magenta');
+$_magenta = cl('magenta');
+$b_cyan = cl('bold cyan');
+$_cyan = cl('cyan');
+$b_white = cl('bold white');
+$_white = cl('white');
+$_reset = cl('reset');
+$_bold = cl('bold');
+$ob = cl('reset');
+$b = cl('bold');
############################################################################
# Implementation (attribute string form)
my @codes = map { split } @_;
my $attribute = '';
foreach (@codes) {
- $_ = lc $_;
- unless (defined $attributes{$_}) { die "Invalid attribute name $_" }
- $attribute .= $attributes{$_} . ';';
+ $_ = lc $_;
+ unless ( defined $attributes{$_} ) { die "Invalid attribute name $_" }
+ $attribute .= $attributes{$_} . ';';
}
chop $attribute;
- ($attribute ne '') ? "\e[${attribute}m" : undef;
+ ( $attribute ne '' ) ? "\e[${attribute}m" : undef;
}
# logging support.
sub openLog {
- return unless (&IsParam('logfile'));
+ return unless ( &IsParam('logfile') );
$file{log} = $param{'logfile'};
my $error = 0;
- my $path = &getPath($file{log});
- while (! -d $path) {
- if ($error) {
- &ERROR("openLog: failed opening log to $file{log}; disabling.");
- delete $param{'logfile'};
- return;
- }
-
- &status("openLog: making $path.");
- last if (mkdir $path, 0755);
- $error++;
+ my $path = &getPath( $file{log} );
+ while ( !-d $path ) {
+ if ($error) {
+ &ERROR("openLog: failed opening log to $file{log}; disabling.");
+ delete $param{'logfile'};
+ return;
+ }
+
+ &status("openLog: making $path.");
+ last if ( mkdir $path, 0755 );
+ $error++;
}
- if (&IsParam('logType') and $param{'logType'} =~ /DAILY/i) {
- my ($day,$month,$year) = (gmtime time())[3,4,5];
- $logDate = sprintf("%04d%02d%02d",$year+1900,$month+1,$day);
- $file{log} .= $logDate;
+ if ( &IsParam('logType') and $param{'logType'} =~ /DAILY/i ) {
+ my ( $day, $month, $year ) = ( gmtime time() )[ 3, 4, 5 ];
+ $logDate = sprintf( '%04d%02d%02d', $year + 1900, $month + 1, $day );
+ $file{log} .= $logDate;
}
- if (open(LOG, ">>$file{log}")) {
- binmode(LOG, ":encoding(UTF-8)");
- &status("Opened logfile $file{log}.");
- LOG->autoflush(1);
- } else {
- &status("Cannot open logfile ($file{log}); not logging: $!");
+ if ( open( LOG, ">>$file{log}" ) ) {
+ binmode( LOG, ':encoding(UTF-8)' );
+ &status("Opened logfile $file{log}.");
+ LOG->autoflush(1);
+ }
+ else {
+ &status("Cannot open logfile ($file{log}); not logging: $!");
}
}
sub closeLog {
+
# lame fix for paramlogfile.
- return unless (&IsParam('logfile'));
- return unless (defined fileno LOG);
+ return unless ( &IsParam('logfile') );
+ return unless ( defined fileno LOG );
close LOG;
&status("Closed logfile ($file{log}).");
# Usage: &compress($file);
sub compress {
my ($file) = @_;
- my @compress = ('/usr/bin/bzip2','/bin/bzip2','/bin/gzip');
+ my @compress = ( '/usr/bin/bzip2', '/bin/bzip2', '/bin/gzip' );
my $okay = 0;
- if (! -f $file) {
- &WARN("compress: file ($file) does not exist.");
- return 0;
+ if ( !-f $file ) {
+ &WARN("compress: file ($file) does not exist.");
+ return 0;
}
if ( -f "$file.gz" or -f "$file.bz2" ) {
- &WARN("compress: file.(gz|bz2) already exists.");
- return 0;
+ &WARN('compress: file.(gz|bz2) already exists.');
+ return 0;
}
foreach (@compress) {
- next unless ( -x $_);
+ next unless ( -x $_ );
- &status("Compressing '$file' with $_.");
- system("$_ $file &");
- $okay++;
- last;
+ &status("Compressing '$file' with $_.");
+ system("$_ $file &");
+ $okay++;
+ last;
}
- if (!$okay) {
- &ERROR("no compress program found.");
- return 0;
+ if ( !$okay ) {
+ &ERROR('no compress program found.');
+ return 0;
}
return 1;
}
sub DEBUG {
- return unless (&IsParam('DEBUG'));
+ return unless ( &IsParam('DEBUG') );
&status("${b_green}!DEBUG!$ob $_[0]");
}
}
sub WARN {
- return unless (&IsParam('WARN'));
+ return unless ( &IsParam('WARN') );
- return if ($_[0] =~ /^PERL: Subroutine \S+ redefined at/);
+ return if ( $_[0] =~ /^PERL: Subroutine \S+ redefined at/ );
&status("${b_yellow}!WARN!$ob $_[0]");
}
}
sub VERB {
- if (!&IsParam('VERBOSITY')) {
- # NOTHING.
- } elsif ($param{'VERBOSITY'} eq '1' and $_[1] <= 1) {
- &status($_[0]);
- } elsif ($param{'VERBOSITY'} eq '2' and $_[1] <= 2) {
- &status($_[0]);
+ if ( !&IsParam('VERBOSITY') ) {
+
+ # NOTHING.
+ }
+ elsif ( $param{'VERBOSITY'} eq '1' and $_[1] <= 1 ) {
+ &status( $_[0] );
+ }
+ elsif ( $param{'VERBOSITY'} eq '2' and $_[1] <= 2 ) {
+ &status( $_[0] );
}
}
sub status {
- my($input) = @_;
+ my ($input) = @_;
my $status;
- if ($input =~ /PERL: Use of uninitialized/) {
- &debug_perl($input);
- return;
+ if ( $input =~ /PERL: Use of uninitialized/ ) {
+ &debug_perl($input);
+ return;
}
- if ($input eq $logold) {
- $logrepeat++;
- return;
+ if ( $input eq $logold ) {
+ $logrepeat++;
+ return;
}
$logold = $input;
+
# if only I had followed how sysklogd does it, heh. lame me. -xk
- if ($logrepeat >= 3) {
- &status("LOG: last message repeated $logrepeat times");
- $logrepeat = 0;
+ if ( $logrepeat >= 3 ) {
+ &status("LOG: last message repeated $logrepeat times");
+ $logrepeat = 0;
}
# if it's not a scalar, attempt to warn and fix.
my $ref = ref $input;
- if (defined $ref and $ref ne '') {
- &WARN("status: 'input' is not scalar ($ref).");
-
- if ($ref eq 'ARRAY') {
- foreach (@$input) {
- &WARN("status: '$_'.");
- }
- }
+ if ( defined $ref and $ref ne '' ) {
+ &WARN("status: 'input' is not scalar ($ref).");
+
+ if ( $ref eq 'ARRAY' ) {
+ foreach (@$input) {
+ &WARN("status: '$_'.");
+ }
+ }
}
# Something is using this w/ NULL.
- if (!defined $input or $input =~ /^\s*$/) {
- $input = "ERROR: Blank status call? HELP HELP HELP";
+ if ( !defined $input or $input =~ /^\s*$/ ) {
+ $input = 'ERROR: Blank status call? HELP HELP HELP';
}
for ($input) {
- s/\n+$//;
- s/\002|\037//g; # bold,video,underline => remove.
+ s/\n+$//;
+ s/\002|\037//g; # bold,video,underline => remove.
}
# does this work?
- if ($input =~ /\n/) {
- foreach (split /\n/, $input) {
- &status($_);
- }
+ if ( $input =~ /\n/ ) {
+ foreach ( split /\n/, $input ) {
+ &status($_);
+ }
}
# pump up the stats.
$statcount++;
# fix style of output if process is child.
- if (defined $bot_pid and $$ != $bot_pid and !defined $statcountfix) {
- $statcount = 1;
- $statcountfix = 1;
+ if ( defined $bot_pid and $$ != $bot_pid and !defined $statcountfix ) {
+ $statcount = 1;
+ $statcountfix = 1;
}
### LOG THROTTLING.
### TODO: move this _after_ printing?
- my $time = time();
- my $reset = 0;
+ my $time = time();
+ my $reset = 0;
# hrm... what is this supposed to achieve? nothing I guess.
- if ($logtime == $time) {
- if ($logcount < 25) { # too high?
- $logcount++;
- } else {
- sleep 1;
- &status("LOG: Throttling.");
- $reset++;
- }
- } else { # $logtime != $time.
- $reset++;
+ if ( $logtime == $time ) {
+ if ( $logcount < 25 ) { # too high?
+ $logcount++;
+ }
+ else {
+ sleep 1;
+ &status('LOG: Throttling.');
+ $reset++;
+ }
+ }
+ else { # $logtime != $time.
+ $reset++;
}
if ($reset) {
- $logtime = $time;
- $logcount = 0;
+ $logtime = $time;
+ $logcount = 0;
}
# Log differently for forked/non-forked output.
if ($statcountfix) {
- $status = "!$statcount! ".$input;
- if ($statcount > 1000) {
- print LOG "ERROR: FORKED PROCESS RAN AWAY; KILLING.\n";
- print LOG "VERB: ".(&Time2String($time - $forkedtime))."\n";
- exit 0;
- }
- } else {
- $status = "[$statcount] ".$input;
- }
-
- if (&IsParam('backlog')) {
- push(@backlog, $status); # append to end.
- shift(@backlog) if (scalar @backlog > $param{'backlog'});
- }
-
- if (&IsParam('VERBOSITY')) {
- if ($statcountfix) {
- printf $_red."!%6d!".$ob." ", $statcount;
- } else {
- printf $_green."[%6d]".$ob." ", $statcount;
- }
-
- # three uberstabs to Derek Moeller. I don't remember why but he
- # deserved it :)
- my $printable = $input;
-
- if ($printable =~ s/^(<\/\S+>) //) {
- # it's me saying something on a channel
- my $name = $1;
- print "$b_yellow$name $printable$ob\n";
- } elsif ($printable =~ s/^(<\S+>) //) {
- # public message on channel.
- my $name = $1;
-
- if ($addressed) {
- print "$b_red$name $printable$ob\n";
- } else {
- print "$b_cyan$name$ob $printable$ob\n";
- }
-
- } elsif ($printable =~ s/^\* (\S+)\/(\S+) //) {
- # public action.
- print "$b_white*$ob $b_cyan$1$ob/$b_blue$2$ob $printable\n";
-
- } elsif ($printable =~ s/^(-\S+-) //) {
- # notice
- print "$_green$1 $printable$ob\n";
-
- } elsif ($printable =~ s/^(\* )?(\[\S+\]) //) {
- # message/private action from someone
- print "$b_white$1$ob" if (defined $1);
- print "$b_red$2 $printable$ob\n";
-
- } elsif ($printable =~ s/^(>\S+<) //) {
- # i'm messaging someone
- print "$b_magenta$1 $printable$ob\n";
-
- } elsif ($printable =~ s/^(enter:|update:|forget:) //) {
- # something that should be SEEN
- print "$b_green$1 $printable$ob\n";
-
- } else {
- print "$printable\n";
- }
-
- } else {
- #print "VERBOSITY IS OFF?\n";
+ $status = "!$statcount! " . $input;
+ if ( $statcount > 1000 ) {
+ print LOG "ERROR: FORKED PROCESS RAN AWAY; KILLING.\n";
+ print LOG 'VERB: ' . ( &Time2String( $time - $forkedtime ) ) . "\n";
+ exit 0;
+ }
+ }
+ else {
+ $status = "[$statcount] " . $input;
+ }
+
+ if ( &IsParam('backlog') ) {
+ push( @backlog, $status ); # append to end.
+ shift(@backlog) if ( scalar @backlog > $param{'backlog'} );
+ }
+
+ if ( &IsParam('VERBOSITY') ) {
+ if ($statcountfix) {
+ printf $_red. '!%6d!' . $ob . ' ', $statcount;
+ }
+ else {
+ printf $_green. '[%6d]' . $ob . ' ', $statcount;
+ }
+
+ # three uberstabs to Derek Moeller. I don't remember why but he
+ # deserved it :)
+ my $printable = $input;
+
+ if ( $printable =~ s/^(<\/\S+>) // ) {
+
+ # it's me saying something on a channel
+ my $name = $1;
+ print "$b_yellow$name $printable$ob\n";
+ }
+ elsif ( $printable =~ s/^(<\S+>) // ) {
+
+ # public message on channel.
+ my $name = $1;
+
+ if ($addressed) {
+ print "$b_red$name $printable$ob\n";
+ }
+ else {
+ print "$b_cyan$name$ob $printable$ob\n";
+ }
+
+ }
+ elsif ( $printable =~ s/^\* (\S+)\/(\S+) // ) {
+
+ # public action.
+ print "$b_white*$ob $b_cyan$1$ob/$b_blue$2$ob $printable\n";
+
+ }
+ elsif ( $printable =~ s/^(-\S+-) // ) {
+
+ # notice
+ print "$_green$1 $printable$ob\n";
+
+ }
+ elsif ( $printable =~ s/^(\* )?(\[\S+\]) // ) {
+
+ # message/private action from someone
+ print "$b_white$1$ob" if ( defined $1 );
+ print "$b_red$2 $printable$ob\n";
+
+ }
+ elsif ( $printable =~ s/^(>\S+<) // ) {
+
+ # i'm messaging someone
+ print "$b_magenta$1 $printable$ob\n";
+
+ }
+ elsif ( $printable =~ s/^(enter:|update:|forget:) // ) {
+
+ # something that should be SEEN
+ print "$b_green$1 $printable$ob\n";
+
+ }
+ else {
+ print "$printable\n";
+ }
+
+ }
+ else {
+
+ #print "VERBOSITY IS OFF?\n";
}
# log the line into a file.
- return unless (&IsParam('logfile'));
- return unless (defined fileno LOG);
+ return unless ( &IsParam('logfile') );
+ return unless ( defined fileno LOG );
# remove control characters from logging to LOGFILE.
for ($input) {
- last if (&IsParam('logColors'));
- s/\e\[[0-9;]+m//g; # escape codes.
- s/[\cA-\c_]//g; # control chars.
+ last if ( &IsParam('logColors') );
+ s/\e\[[0-9;]+m//g; # escape codes.
+ s/[\cA-\c_]//g; # control chars.
}
- $input = "FORK($$) ".$input if ($statcountfix);
+ $input = "FORK($$) " . $input if ($statcountfix);
my $date;
- if (&IsParam('logType') and $param{'logType'} =~ /DAILY/i) {
- $date = sprintf("%02d:%02d.%02d", (gmtime $time)[2,1,0]);
-
- my ($day,$month,$year) = (gmtime $time)[3,4,5];
- my $newlogDate = sprintf("%04d%02d%02d",$year+1900,$month+1,$day);
- if (defined $logDate and $newlogDate != $logDate) {
- &closeLog();
- &compress( $file{log} );
- &openLog();
- }
- } else {
- $date = $time;
+ if ( &IsParam('logType') and $param{'logType'} =~ /DAILY/i ) {
+ $date = sprintf( '%02d:%02d.%02d', ( gmtime $time )[ 2, 1, 0 ] );
+
+ my ( $day, $month, $year ) = ( gmtime $time )[ 3, 4, 5 ];
+ my $newlogDate =
+ sprintf( '%04d%02d%02d', $year + 1900, $month + 1, $day );
+ if ( defined $logDate and $newlogDate != $logDate ) {
+ &closeLog();
+ &compress( $file{log} );
+ &openLog();
+ }
+ }
+ else {
+ $date = $time;
}
printf LOG "%s %s\n", $date, $input;
sub debug_perl {
my ($str) = @_;
- return unless ($str =~ /^WARN: Use of uninitialized value .* at (\S+) line (\d+)/);
- my ($file,$line) = ($1,$2);
- if (!open(IN,$file)) {
- &status("WARN: cannot open $file: $!");
- return;
+ return
+ unless (
+ $str =~ /^WARN: Use of uninitialized value .* at (\S+) line (\d+)/ );
+ my ( $file, $line ) = ( $1, $2 );
+ if ( !open( IN, $file ) ) {
+ &status("WARN: cannot open $file: $!");
+ return;
}
- binmode(IN, ":encoding(UTF-8)");
+ binmode( IN, ':encoding(UTF-8)' );
# TODO: better filename.
- open(OUT, ">>debug.log");
- binmode(OUT, ":encoding(UTF-8)");
+ open( OUT, '>>debug.log' );
+ binmode( OUT, ':encoding(UTF-8)' );
print OUT "DEBUG: $str\n";
# note: cannot call external functions because SIG{} does not allow us to.
my $i;
while (<IN>) {
- chop;
- $i++;
- # bleh. this tries to duplicate status().
- # TODO: statcountfix
- # TODO: rename to log_*someshit*
- if ($i == $line) {
- my $msg = "$file: $i:!$_";
- printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
- print OUT "DEBUG: $msg\n";
- $statcount++;
- next;
- }
- if ($i+3 > $line && $i-3 < $line) {
- my $msg = "$file: $i: $_";
- printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
- print OUT "DEBUG: $msg\n";
- $statcount++;
- }
+ chop;
+ $i++;
+
+ # bleh. this tries to duplicate status().
+ # TODO: statcountfix
+ # TODO: rename to log_*someshit*
+ if ( $i == $line ) {
+ my $msg = "$file: $i:!$_";
+ printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
+ print OUT "DEBUG: $msg\n";
+ $statcount++;
+ next;
+ }
+ if ( $i + 3 > $line && $i - 3 < $line ) {
+ my $msg = "$file: $i: $_";
+ printf "%s[%6d]%s %s\n", $_green, $statcount, $ob, $msg;
+ print OUT "DEBUG: $msg\n";
+ $statcount++;
+ }
}
close IN;
close OUT;
}
sub openSQLDebug {
- if (!open(SQLDEBUG, ">>$param{'SQLDebug'}")) {
- &ERROR("Cannot open ($param{'SQLDebug'}): $!");
- delete $param{'SQLDebug'};
- return 0;
+ if ( !open( SQLDEBUG, ">>$param{'SQLDebug'}" ) ) {
+ &ERROR("Cannot open ($param{'SQLDebug'}): $!");
+ delete $param{'SQLDebug'};
+ return 0;
}
- binmode(SQLDEBUG, ":encoding(UTF-8)");
+ binmode( SQLDEBUG, ':encoding(UTF-8)' );
&status("Opened SQL Debug file: $param{'SQLDebug'}");
return 1;
}
sub SQLDebug {
- return unless (&IsParam('SQLDebug'));
+ return unless ( &IsParam('SQLDebug') );
- return unless (fileno SQLDEBUG);
+ return unless ( fileno SQLDEBUG );
- print SQLDEBUG $_[0]."\n";
+ print SQLDEBUG $_[0] . "\n";
}
1;
### REQUIRED MODULES.
###
-eval "use IO::Socket";
+eval 'use IO::Socket';
if ($@) {
- &ERROR("no IO::Socket?");
+ &ERROR('no IO::Socket?');
exit 1;
}
-&showProc(" (IO::Socket)");
+&showProc(' (IO::Socket)');
### THIS IS NOT LOADED ON RELOAD :(
my @myModulesLoadNow;
my @myModulesReloadNot;
+
BEGIN {
- @myModulesLoadNow = ('Topic', 'Uptime', 'News', 'RootWarn', 'DumpVars2', 'botmail', 'OnJoin');
- @myModulesReloadNot = ('IRC/Irc.pl','IRC/Schedulers.pl');
+ @myModulesLoadNow = (
+ 'Topic', 'Uptime', 'News', 'RootWarn',
+ 'DumpVars2', 'botmail', 'OnJoin'
+ );
+ @myModulesReloadNot = ( 'IRC/Irc.pl', 'IRC/Schedulers.pl' );
}
sub loadCoreModules {
my @mods = &getPerlFiles($bot_src_dir);
- &status("Loading CORE modules...");
+ &status('Loading CORE modules...');
- foreach (sort @mods) {
- my $mod = "$bot_src_dir/$_";
+ foreach ( sort @mods ) {
+ my $mod = "$bot_src_dir/$_";
- eval "require \"$mod\"";
- if ($@) {
- &ERROR("lCM => $@");
- &shutdown();
- exit 1;
- }
+ eval "require \"$mod\"";
+ if ($@) {
+ &ERROR("lCM => $@");
+ &shutdown();
+ exit 1;
+ }
- $moduleAge{$mod} = (stat $mod)[9];
- &showProc(" ($_)") if (&IsParam('DEBUG'));
+ $moduleAge{$mod} = ( stat $mod )[9];
+ &showProc(" ($_)") if ( &IsParam('DEBUG') );
}
}
sub loadDBModules {
my $f;
+
# TODO: use function to load module.
- if ($param{'DBType'} =~ /^(mysql|SQLite(2)?|pgsql)$/i) {
- eval "use DBI";
- if ($@) {
- &ERROR("No support for DBI::" . $param{'DBType'} . ", exiting!");
- exit 1;
- }
- &status("Loading " . $param{'DBType'} . " support.");
- $f = "$bot_src_dir/dbi.pl";
- require $f;
- $moduleAge{$f} = (stat $f)[9];
-
- &showProc(" (DBI::" . $param{'DBType'} . ")");
- } else {
- &WARN("DB support DISABLED.");
- return;
+ if ( $param{'DBType'} =~ /^(mysql|SQLite(2)?|pgsql)$/i ) {
+ eval 'use DBI';
+ if ($@) {
+ &ERROR( 'No support for DBI::' . $param{'DBType'} . ', exiting!' );
+ exit 1;
+ }
+ &status( 'Loading ' . $param{'DBType'} . ' support.' );
+ $f = "$bot_src_dir/dbi.pl";
+ require $f;
+ $moduleAge{$f} = ( stat $f )[9];
+
+ &showProc( ' (DBI::' . $param{'DBType'} . ')' );
+ }
+ else {
+ &WARN('DB support DISABLED.');
+ return;
}
}
sub loadFactoidsModules {
- if (!&IsParam('factoids')) {
- &status("Factoid support DISABLED.");
- return;
+ if ( !&IsParam('factoids') ) {
+ &status('Factoid support DISABLED.');
+ return;
}
- &status("Loading Factoids modules...");
+ &status('Loading Factoids modules...');
foreach ( &getPerlFiles("$bot_src_dir/Factoids") ) {
- my $mod = "$bot_src_dir/Factoids/$_";
+ my $mod = "$bot_src_dir/Factoids/$_";
- eval "require \"$mod\"";
- if ($@) {
- &ERROR("lFM: $@");
- exit 1;
- }
+ eval "require \"$mod\"";
+ if ($@) {
+ &ERROR("lFM: $@");
+ exit 1;
+ }
- $moduleAge{$mod} = (stat $mod)[9];
- &showProc(" ($_)") if (&IsParam('DEBUG'));
+ $moduleAge{$mod} = ( stat $mod )[9];
+ &showProc(" ($_)") if ( &IsParam('DEBUG') );
}
}
sub loadIRCModules {
my ($interface) = &whatInterface();
- if ($interface =~ /IRC/) {
- &status("Loading IRC modules...");
-
- eval "use Net::IRC";
- if ($@) {
- &ERROR("libnet-irc-perl is not installed!");
- exit 1;
- }
- &showProc(" (Net::IRC)");
- } else {
- &status("IRC support DISABLED.");
- # disabling forking. Why?
- #$param{forking} = 0;
- #$param{noSHM} = 1;
+ if ( $interface =~ /IRC/ ) {
+ &status('Loading IRC modules...');
+
+ eval 'use Net::IRC';
+ if ($@) {
+ &ERROR('libnet-irc-perl is not installed!');
+ exit 1;
+ }
+ &showProc(' (Net::IRC)');
+ }
+ else {
+ &status('IRC support DISABLED.');
+
+ # disabling forking. Why?
+ #$param{forking} = 0;
+ #$param{noSHM} = 1;
}
foreach ( &getPerlFiles("$bot_src_dir/$interface") ) {
- my $mod = "$bot_src_dir/$interface/$_";
-
- # hrm... use another config option besides DEBUG to display
- # change in memory usage.
- &status("Loading Modules \"$mod\"") if (!&IsParam('DEBUG'));
- eval "require \"$mod\"";
- if ($@) {
- &ERROR("require \"$mod\" => $@");
- &shutdown();
- exit 1;
- }
-
- $moduleAge{$mod} = (stat $mod)[9];
- &showProc(" ($_)") if (&IsParam('DEBUG'));
+ my $mod = "$bot_src_dir/$interface/$_";
+
+ # hrm... use another config option besides DEBUG to display
+ # change in memory usage.
+ &status("Loading Modules \"$mod\"") if ( !&IsParam('DEBUG') );
+ eval "require \"$mod\"";
+ if ($@) {
+ &ERROR("require \"$mod\" => $@");
+ &shutdown();
+ exit 1;
+ }
+
+ $moduleAge{$mod} = ( stat $mod )[9];
+ &showProc(" ($_)") if ( &IsParam('DEBUG') );
}
}
my $loaded = 0;
my $total = 0;
- &status("Loading MyModules...");
+ &status('Loading MyModules...');
foreach (@myModulesLoadNow) {
- $total++;
- if (!defined $_) {
- &WARN("mMLN: null element.");
- next;
- }
-
- if (!&IsParam($_) and &IsChanConf($_) <= 0 and !&getChanConfList($_)) {
- &DEBUG("loadMyModuleNow: $_ (2) not loaded.");
- next;
- }
-
- &loadMyModule($_);
- $loaded++;
+ $total++;
+ if ( !defined $_ ) {
+ &WARN('mMLN: null element.');
+ next;
+ }
+
+ if ( !&IsParam($_) and &IsChanConf($_) <= 0 and !&getChanConfList($_) )
+ {
+ &DEBUG("loadMyModuleNow: $_ (2) not loaded.");
+ next;
+ }
+
+ &loadMyModule($_);
+ $loaded++;
}
&status("Module: Runtime: Loaded/Total [$loaded/$total]");
sub reloadAllModules {
my $retval = '';
- &VERB("Module: reloading all.",2);
+ &VERB( 'Module: reloading all.', 2 );
# Reload version and save
- open(VERSION,"<VERSION");
- $bot_release = <VERSION> || "(unknown version)";
+ open( VERSION, '<VERSION' );
+ $bot_release = <VERSION> || '(unknown version)';
chomp($bot_release);
- $bot_version = "infobot $bot_release -- $^O";
+ $bot_version = "infobot $bot_release -- $^O";
close(VERSION);
# obscure usage of map and regex :)
- foreach (map { s/.*?\/?src/src/; $_ } keys %moduleAge) {
- $retval .= &reloadModule($_);
+ foreach ( map { s/.*?\/?src/src/; $_ } keys %moduleAge ) {
+ $retval .= &reloadModule($_);
}
- &VERB("Module: reloading done.",2);
+ &VERB( 'Module: reloading done.', 2 );
return $retval;
}
### rename to modulesReload?
sub reloadModule {
- my ($mod) = @_;
- my $file = (grep /\/$mod/, keys %INC)[0];
+ my ($mod) = @_;
+ my $file = ( grep /\/$mod/, keys %INC )[0];
my $retval = '';
# don't reload if it's not our module.
- if ($mod =~ /::/ or $mod !~ /pl$/) {
- &VERB("Not reloading $mod.",3);
- return $retval;
+ if ( $mod =~ /::/ or $mod !~ /pl$/ ) {
+ &VERB( "Not reloading $mod.", 3 );
+ return $retval;
}
- if (!defined $file) {
- &WARN("rM: Cannot reload $mod since it was not loaded anyway.");
- return $retval;
+ if ( !defined $file ) {
+ &WARN("rM: Cannot reload $mod since it was not loaded anyway.");
+ return $retval;
}
- if (! -f $file) {
- &ERROR("rM: file '$file' does not exist?");
- return $retval;
+ if ( !-f $file ) {
+ &ERROR("rM: file '$file' does not exist?");
+ return $retval;
}
- if (grep /$mod/, @myModulesReloadNot) {
- &DEBUG("rM: should not reload $mod");
- return $retval;
+ if ( grep /$mod/, @myModulesReloadNot ) {
+ &DEBUG("rM: should not reload $mod");
+ return $retval;
}
- my $age = (stat $file)[9];
+ my $age = ( stat $file )[9];
- if (!exists $moduleAge{$file}) {
- &DEBUG("Looks like $file was not loaded; fixing.");
- } else {
- return $retval if ($age == $moduleAge{$file});
+ if ( !exists $moduleAge{$file} ) {
+ &DEBUG("Looks like $file was not loaded; fixing.");
+ }
+ else {
+ return $retval if ( $age == $moduleAge{$file} );
- if ($age < $moduleAge{$file}) {
- &WARN("rM: we're not gonna downgrade '$file'; use touch.");
- &DEBUG("age => $age, mA{$file} => $moduleAge{$file}");
- return $retval;
- }
+ if ( $age < $moduleAge{$file} ) {
+ &WARN("rM: we're not gonna downgrade '$file'; use touch.");
+ &DEBUG("age => $age, mA{$file} => $moduleAge{$file}");
+ return $retval;
+ }
- my $dc = &Time2String($age - $moduleAge{$file});
- my $ago = &Time2String(time() - $moduleAge{$file});
+ my $dc = &Time2String( $age - $moduleAge{$file} );
+ my $ago = &Time2String( time() - $moduleAge{$file} );
- &VERB("Module: delta change: $dc",2);
- &VERB("Module: ago: $ago",2);
+ &VERB( "Module: delta change: $dc", 2 );
+ &VERB( "Module: ago: $ago", 2 );
}
&status("Module: Loading $mod...");
delete $INC{$file};
- eval "require \"$file\""; # require or use?
+ eval "require \"$file\""; # require or use?
if (@$) {
- &DEBUG("rM: failure: @$ ");
- } else {
- my $basename = $file;
- $basename =~ s/^.*\///;
- &status("Module: reloaded $basename");
- $retval = " $basename";
- $moduleAge{$file} = $age;
+ &DEBUG("rM: failure: @$ ");
+ }
+ else {
+ my $basename = $file;
+ $basename =~ s/^.*\///;
+ &status("Module: reloaded $basename");
+ $retval = " $basename";
+ $moduleAge{$file} = $age;
}
return $retval;
}
my %perlModulesMissing = ();
sub loadPerlModule {
- return 0 if (exists $perlModulesMissing{$_[0]});
- &reloadModule($_[0]);
- return 1 if (exists $perlModulesLoaded{$_[0]});
+ return 0 if ( exists $perlModulesMissing{ $_[0] } );
+ &reloadModule( $_[0] );
+ return 1 if ( exists $perlModulesLoaded{ $_[0] } );
eval "use $_[0]";
if ($@) {
- &WARN("Module: $_[0] is not installed!");
- $perlModulesMissing{$_[0]} = 1;
- return 0;
- } else {
- $perlModulesLoaded{$_[0]} = 1;
- &status("Loaded $_[0]");
- &showProc(" ($_[0])");
- return 1;
+ &WARN("Module: $_[0] is not installed!");
+ $perlModulesMissing{ $_[0] } = 1;
+ return 0;
+ }
+ else {
+ $perlModulesLoaded{ $_[0] } = 1;
+ &status("Loaded $_[0]");
+ &showProc(" ($_[0])");
+ return 1;
}
}
sub loadMyModule {
my ($modulename) = @_;
- if (!defined $modulename) {
- &WARN("loadMyModule: module is NULL.");
- return 0;
+ if ( !defined $modulename ) {
+ &WARN('loadMyModule: module is NULL.');
+ return 0;
}
my $modulefile = "$bot_src_dir/Modules/$modulename.pl";
# call reloadModule() which checks age of file and reload.
- if (grep /\/$modulename$/, keys %INC) {
- &reloadModule($modulename);
- return 1; # depend on reloadModule?
+ if ( grep /\/$modulename$/, keys %INC ) {
+ &reloadModule($modulename);
+ return 1; # depend on reloadModule?
}
- if (! -f $modulefile) {
- &ERROR("lMM: module ($modulename) does not exist.");
- if ($$ == $bot_pid) { # parent.
- &shutdown() if (defined $shm and defined $dbh);
- } else { # child.
- &DEBUG("b4 delfork 1");
- &delForked($modulename);
- }
-
- exit 1;
+ if ( !-f $modulefile ) {
+ &ERROR("lMM: module ($modulename) does not exist.");
+ if ( $$ == $bot_pid ) { # parent.
+ &shutdown() if ( defined $shm and defined $dbh );
+ }
+ else { # child.
+ &DEBUG('b4 delfork 1');
+ &delForked($modulename);
+ }
+
+ exit 1;
}
eval "require \"$modulefile\"";
if ($@) {
- &ERROR("cannot load my module: $modulename");
- if ($bot_pid != $$) { # child.
- &DEBUG("b4 delfork 2");
- &delForked($modulename);
- exit 1;
- }
-
- return 0;
- } else {
- $moduleAge{$modulefile} = (stat $modulefile)[9];
-
- &status("Loaded $modulename");
- &showProc(" ($modulename)");
- return 1;
+ &ERROR("cannot load my module: $modulename");
+ if ( $bot_pid != $$ ) { # child.
+ &DEBUG('b4 delfork 2');
+ &delForked($modulename);
+ exit 1;
+ }
+
+ return 0;
+ }
+ else {
+ $moduleAge{$modulefile} = ( stat $modulefile )[9];
+
+ &status("Loaded $modulename");
+ &showProc(" ($modulename)");
+ return 1;
}
}
$no_timehires = 0;
-eval "use Time::HiRes qw(gettimeofday tv_interval)";
+eval 'use Time::HiRes qw(gettimeofday tv_interval)';
if ($@) {
- &WARN("No Time::HiRes?");
+ &WARN('No Time::HiRes?');
$no_timehires = 1;
}
-&showProc(" (Time::HiRes)");
+&showProc(' (Time::HiRes)');
sub AUTOLOAD {
- if (!defined $AUTOLOAD and defined $::AUTOLOAD) {
- &DEBUG("AUTOLOAD: hrm.. ::AUTOLOAD defined!");
+ if ( !defined $AUTOLOAD and defined $::AUTOLOAD ) {
+ &DEBUG('AUTOLOAD: hrm.. ::AUTOLOAD defined!');
}
- return unless (defined $AUTOLOAD);
- return if ($AUTOLOAD =~ /__/); # internal.
+ return unless ( defined $AUTOLOAD );
+ return if ( $AUTOLOAD =~ /__/ ); # internal.
- my $str = join(', ', @_);
- my ($package, $filename, $line) = caller;
+ my $str = join( ', ', @_ );
+ my ( $package, $filename, $line ) = caller;
&ERROR("UNKNOWN FUNCTION CALLED: $AUTOLOAD ($str) $filename line $line");
$AUTOLOAD =~ s/^(\S+):://g;
}
sub getPerlFiles {
- my($dir) = @_;
+ my ($dir) = @_;
- if (!opendir(DIR, $dir)) {
- &ERROR("Cannot open source directory ($dir): $!");
- exit 1;
+ if ( !opendir( DIR, $dir ) ) {
+ &ERROR("Cannot open source directory ($dir): $!");
+ exit 1;
}
my @mods;
- while (defined(my $file = readdir DIR)) {
- next unless $file =~ /\.pl$/;
- next unless $file =~ /^[A-Z]/;
- push(@mods, $file);
+ while ( defined( my $file = readdir DIR ) ) {
+ next unless $file =~ /\.pl$/;
+ next unless $file =~ /^[A-Z]/;
+ push( @mods, $file );
}
closedir DIR;
projects / infobot.git / commitdiff