Known bugs that should be dealt with soon as possible:
+ * Multiple nick per server is in need of some testing and make be
+ incomplete or buggy in some parts of the bot
+
* Older CMD: foo's cannot be used or removed. Must be removed manually from
the database with SQL
+1.5.4
+=====
+* scripts/insertDB.pl
+- renamed to factpack.pl
+- should work properly now (needs testing)
+
+* Updates to DebianExtra.pl:
+- use soap for bug_info
+- totally replace do_id with the copy from DebianBugs.pl
+- fix ||= typo
+- fix url->uri typo
+- fix -> typo
+- add some more debugging code to the do_id code
+- remove useless bug =>
+- disable debugging output of the soap object returned
+- soap returns multiple bugs in a single shot
+- use strftime on the date
+
+* check for and use of old blootbot.(users|chan) files
+
+* Retired the old broken W3Search module in favour of a working Google search
+
+* Removed +W3Search in infobot.chan, added +Google (don't forget to update your
+configs)
+
+
+1.5.3
+=====
+
+* New maxVolunteerLength to govern max size of non addressed replies
+
+* Cleaned up some of the regex code for what the bot considers a question
+
+* Fixed an obscure and undocumented variable that was disabling "query?"
+questions in non addressed mode
+
+* Fixed bug in babelfish module due to site/html changes
+
+* Added chanset and help for verstats to allow disabling of command to prevent abuse
+
+* Fixed verstats to warn the channel about who involked the command and bug that
+was causing the output to go to random channels due to loss of variable scope
+
+* Added infobot client to verstats and cleaned up a few other client regex
+
+* Fixed talkok bug with 'how are you' statement
+
1.5.2
=====
# $Id$
+Q: What are factpacks and how do I install them?
+A: A factpack is a partial database of factoids that you can import into
+ your configured infobot by running the script called "factpack.pl".
+
+ # IMPORTANT: Run from the bots base directory!
+ eg: ./scripts/factpack.pl /path/to/areacodes.fact
+
+Q: Can I remove a fact pack I have installed?
+A: Yes, but at the moment, you need to manually use SQL commands in your
+ favorite SQL program. The "created_by" field in the factoids will be
+ set to the filename of the fact pack you installed. For example, if
+ you installed the "areacodes.fact" file, "created_by" would be set to
+ "areacodes.fact". The SQL to remove the above example would be:
+
+ sql> DELETE FROM factoids WHERE created_by = 'areacodes.fact';
+
+Q: Where can I download some existing fact packs?
+A: As of yet, the fact packs aren't available in SVN. You can try the
+ original infobot web site at:
+
+ http://www.infobot.org/factpacks/
+
+ NOTE: The import script can't yet handle compressed files, so you must
+ extract the factpacks in advance.
+
+Q: How can I make my own fact packs?
+A: The syntax is pretty basic. You just need a plain text file that has
+ one key/value pair per line. Comment lines begin with a "#" character
+ and are ignored, as are blank lines. Extra whitespace around key/value
+ pairs should hopefully be stripped out as well. A few example lines from
+ the areacodes.fact file:
+
+ # Sample comment here
+ area code 011 => the International Access Code
+ area code 201 => Hackensack, Morristown and Newark, New Jersey
+ area code 202 => Washington, District of Columbia
+
+
Q: The bot exits after I run 'factstats testing' or 'kernel' or anything
that uses fork(). Is this a bug in the bot?
A: No, this is not a bug in the bot but rather Net::IRC. A cheap hack is
to edit /usr/lib/perl5/Net/IRC/Connection.pm, search for DESTROY, and
comment out '$self->quit();'
-A: Apply the patches in the patches/ directory.
Q: I notice that, in the bot logs, the bot attempts to close all current
- -------------
- -- Patches --
- -------------
-
-- apply *.patch patches inside patches/
- - cd /usr/lib/perl5/WWW/Search
- - patch -p0 < WWW::Search::Google.patch
-
-- alternatively, move the files from patches/
- - mv patches/Google.pm /usr/lib/perl5/WWW/Search/
-
-
-Net::IRC DCC CHAT
------------------
-Unfortunately, Net::IRC 0.70 has buggy code that does not detect DCC CHAT
-properly. to patch:
- - cd /usr/share/perl5/Net/IRC/
- - cat ~bot/patches/Net_IRC_Connection_pm.patch | patch -p0
-
-
-
-
----------------
-- PostgreSQL --
----------------
Kevin Lenzo <lenzo@cs.cmu.edu>, which is now officially rebranded back to
infobot! The basis of infobot is still there but _many_ wild features have
been added. Along the way, many issues were spotted in the original
-infobot source and fixed in this version. Many new bugs have been added as well
+infobot source and fixed in this version. Many new bugs have been added as well.
Thanks to kevin for bringing infobot in the first place.
FEATURES
* Additional information stored with factoids. (factinfo)
- * Wide range of statistics for Bot, Factoids, IRC, Debian.
+ * Wide range of statistics for Bot, Factoids, IRC, Debian
(status, factstats, ircstats, chanstats, cmdstats)
- * Advanced topic management. (the first cool feature)
- * Improved factoid search, allowing search by key or value.
+ * Advanced topic management
+ * Improved factoid search, allowing search by key or value
* Freshmeat support (freshmeat.net)
- * Debian Contents and Packages, search and info.
- * ChanServ/NickServ (OPN) support.
- * WWW-Search (eg: google for BLAH)
- * Slashdot, Kernel and Freshmeat auto-update announcements.
- * Units conversion (provided by external module, Units-Module)
+ * Debian Contents and Packages, search and info
+ * ChanServ/NickServ (freenode) support
+ * WWW-Search (eg: google for BLAH) (NOTE: Currently broken)
+ * Slashdot, Kernel, RSS and Freshmeat auto-update announcements
+ * Units conversion (provided by external "units" program)
DESIGN
- - Modularity. Ability to disable IRC or Factoid support.
+ - Modularity. Ability to disable IRC or Factoid support
- Funky pseudo Module autoloader support
- - Eleet Forker() function
-
-
-IMPROVEMENTS
- * log file is not opened and closed for each line of data
- => unblocked logging is used.
- * seen data is not flushed for each public message on IRC
- => caching and flushing over an interval is used.
+ - Modules called via Forker() to avoid blocking
+ - Non blocking logs
+ - Seen data periodicaly flushed for efficiency
HISTORY
test all modifications properly (and extensively). Suggestions are
welcomed.
- gp@OPN is currently working on a C version of infobot or
-blootbot, not based on the above source base. Core factoid code and
-mysql support works - but that is it.
-
MODIFICATIONS
All modifications are that of the blootbot author unless otherwise
UNTESTED:
- - user statistics shown by 'seen'. bug in this?
+ - user statistics shown by 'seen'.
- User Information Services.
- new wingate caching/file-read code.
- disabling IRC/factoid support code.
- - PG supports need to be worked and thoroughly tested.
+ - PGSql support needs to be more thoroughly tested.
CONTRIBUTIONS
development stages. Bashing of modifications courtesy of larne, irq, lilo
and \broken.
- mu@OPN for the SAR (=~ s///) and Topic history patch.
+ mu@freenode for the SAR (=~ s///) and Topic history patch.
someone emailed me a patch to fix up telnet but I accidently
deleted the message together with the patch after replying to the guy. I
hope to get that same guy to re-send me the patch...
- MbM@OPN sent a patch to clean up behaviour of factoids
+ MbM@freenode sent a patch to clean up behaviour of factoids
(adding, removing, modifying). Thanks.
+++ /dev/null
-See INSTALL file on how to install the bot.
-
-Quick usage instructions:
--------------------------
-
-DCC CHAT:
-.+chan #chan
-.chanset #chan +autojoin
-.chanset +autojoin
-.chanunset -autojoin
-.chanset -autojoin
-
-for list of configuration options, run:
- perl scripts/findparam.pl
-
-
-# vim:ts=4:sw=4:expandtab:tw=80
If we missed you from this list, drop us a line and we will be sure to give
credit where it is due.
+#People
+-------
+
+Brett Cave (Google search)
#perl@freenode.net
------------------
mmap__
jagerman
+#infobot@freenode.net
+---------------------
+quin - many thanks for ctcp version bug help
+
# vim:ts=4:sw=4:expandtab:tw=80
+Other TODO items may be listed on sourceforge. Please access it from the
+website or this link:
+
+ http://sourceforge.net/tracker/?group_id=2241
+
+
TODO:
- - Normalize the SQL tables a little better to reduce size and increase speed
- - Keep the Changelog, TODO and BUGS files up to date. Clean things up a bit
- - rename ^[+-] commands
- remind - like this and others: http://jibble.org/reminderbot/
- kill SHM and and move to a pipe
- add CIA like support - http://cia.navi.cx/
- add &checkSet() or &_chanset();
- attempt to move userDCC to hooks.
- need to modify parseCmdHooks for user flags?
- - make timers below 5 or 10 mins non-random values.
- create a .csv import/export program
--- EFFORT 1.
- make IRC/Schedulers.pl work 100%.
- intervals must be multiple of the smallest one otherwise
auto-fixed.
- make intervals chan-specific
- need to store info in $sched{$what}{$chan} =
time(); when last run or next run?
-
-Other TODO items may be listed on sourceforge. Please access it from the
-website or this link:
-http://sourceforge.net/pm/task.php?group_id=2241
-
-----------------------------------------------------
------------- FUTURE, NON-IMPORTANT
- <greycat> ~country ua
- - <irq_w> xk: add it :) and my imdb feature :)
- - <greycat> xk: and ~bugs :)
- - "HACKING" text file, documentation of where things start,
+ <irq_w> xk: add it :) and my imdb feature :)
+ <greycat> xk: and ~bugs :)
+ - "HACKING" text file, documentation of where things start,
what "core" or reuseable functions are used and what for.
- web interface
- on join message - customizeable, option.
-# Revised: 20071016
+# Revised: 20090320
# Author: Tim Riker <Tim@Rikers.org>
+# Contributors: Simon C., Tim M., others (see AUTHORS)
###
# Special entry
freshmeat: U: ## <query>
freshmeat: E: ## infobot
+google: D: What Is: Google Search frontend
+google: D: Configuration: "chanset [_default or channelname] +Google"
+google: U: ## google <query>
+google: E: ## google infobot
+
hex: D: Convert ascii to hex
hex: U: ## <string>
hex: E: ## carrot
userdel: U: ## <user>
userdel: E: ## SomeAccount
+verstats: D: Commnd to CTCP VERSION the specified channel for client statistics
+verstats: U: ## <channel>
+verstats: E: ## #infobot
+verstats: E: < infobot> IRC Client versions for #infobot (2): unknown/cloak - 3 (75%) ;; irssi - 1 (25%).
+
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
+Dict
+Exchange
+Factoids
+ +Google
+HTTPDtype
+Kernel
+Math
+Topic
+Units
+UserInfo
- +W3Search
+Weather
+Zippy
addressCharacter ~
maxListReplyCount 15
maxListReplyLength 400
+md5
- minVolunteerLength 50
+ minVolunteerLength 2
+ maxVolunteerLength 512
+nickometer
+pager
+piglatin
+spell
+tell
+upsidedown
+ +verstats
+wikipedia
+wtf
+zfi
#####
# Basic IRC info
#####
+# NOTE: If you would like multiple nick support, use the following format:
+# set ircNick nick1,nick2,nick3
set ircNick infobot
set ircUser infobot
set ircName infobot experimental bot
--- /dev/null
+#!/usr/bin/perl -w
+
+$| = 1;
+
+use strict;
+use File::Basename;
+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
+);
+
+
+# Check for arguments
+if ( !scalar @ARGV ) {
+ print "Usage: $0 <pack1.fact> [<pack2.fact> <pack2.fact> ...]\n";
+ print "Example: $0 areacodes.fact usazips.fact\n";
+ exit 1;
+}
+
+
+# set any $bot_*_dir var's
+$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 = $$;
+
+require "$bot_src_dir/logger.pl";
+require "$bot_src_dir/core.pl";
+require "$bot_src_dir/modules.pl";
+
+# Initialize enough to get DB access
+&setupConfig();
+&loadCoreModules();
+&loadDBModules();
+&loadFactoidsModules();
+&setup();
+
+if ( !scalar @ARGV ) {
+ print "Usage: $0 <pack1.fact> [<pack2.fact> <pack2.fact> ...]\n";
+ print "Example: $0 areacodes.fact usazips.fact\n";
+ exit 0;
+}
+
+foreach (@ARGV) {
+ next unless ( -f $_ );
+ my $file = $_;
+
+ open( IN, $file ) or die "error: cannot open $file\n";
+ print "Opened $file for input...\n";
+
+ print "inserting... ";
+ while (<IN>) {
+ chomp;
+ next if /^#/;
+ next unless (/=>/);
+
+ # Split into "key => value" pairs
+ my ($key, $value) = split(/=>/,$_,2);
+
+ # Strip extra begin/end whitespace
+ $key =~ s/^\s*(.*?)\s*$/$1/;
+ $value =~ s/^\s*(.*?)\s*$/$1/;
+
+ # convert tabs
+ $key =~ s/\t/ /g;
+ $value =~ s/\t/ /g;
+
+ # The key needs to be lower case to match query case
+ $key = lc $key;
+
+ ### TODO: check if it already exists. if so, don't add.
+ ### TODO: combine 2 setFactInfo's into single
+ &setFactInfo( $key, "factoid_value", $value );
+ &setFactInfo( $key, "created_by", basename($file) );
+ print ":: $key ";
+ }
+
+ close IN;
+}
+print "...Done!\n";
+
+# vim:ts=4:sw=4:expandtab:tw=80
+++ /dev/null
-#!/usr/bin/perl -w
-
-$| = 1;
-
-use strict;
-
-require "src/core.pl";
-require "src/logger.pl";
-require "src/modules.pl";
-require "src/Factoids/DBCommon.pl";
-
-&loadConfig( $bot_config_dir . "/infobot.config" );
-&loadDBModules();
-
-unless (@_) {
- print "hrm.. usage\n";
- exit 0;
-}
-
-foreach (@_) {
- next unless ( -f $_ );
-
- open( IN, $_ ) or die "error: cannot open $_\n";
- print "Opened $_ for input...\n";
-
- print "inserting... ";
- while (<IN>) {
- next unless (/^(.*?) => (.*)$/);
-
- ### TODO: check if it already exists. if so, don't add.
- &setFactInfo( $1, "factoid_value", $2 );
- print ":: $1 ";
- }
-
- close IN;
-}
-
-# vim:ts=4:sw=4:expandtab:tw=80
return;
}
- # google searching. Simon++
- my $w3search_regex = 'google';
+ # google searching -- thanks Brett Cave
if ( $message =~
- /^(?:search\s+)?($w3search_regex)\s+(?:for\s+)?['"]?(.*?)["']?\s*\?*$/i
+ /^(\s+)?google\s+['"]?(.*?)["']?\s*\?*$/i
)
{
- return unless ( &IsChanConfOrWarn('W3Search') );
+ return unless ( &IsChanConfOrWarn('Google') );
- &Forker( 'W3Search', sub { &W3Search::W3Search( $1, $2 ); } );
+ &Forker( 'Google', sub { &Google::GoogleSearch( $2 ); } );
- $cmdstats{'W3Search'}++;
+ $cmdstats{'Google'}++;
return;
}
return;
}
- &msg( $who, "Sending CTCP VERSION to $chan; results in 60s." );
- $conn->ctcp( 'VERSION', $chan );
+ &msg( $who, "Sending CTCP VERSION to $chan; results in 60s." );
+ &msg( $chan, "WARNING: $who has forced me to CTCP VERSION the channel!" );
+
+ # Workaround for bug in Net::Irc, provided by quin@freenode. Details at:
+ # http://rt.cpan.org/Public/Bug/Display.html?id=11421
+ # $conn->ctcp( 'VERSION', $chan );
+ $conn->sl("PRIVMSG $chan :\001VERSION\001");
+
$cache{verstats}{chan} = $chan;
$cache{verstats}{who} = $who;
$cache{verstats}{msgType} = $msgType;
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?
}
# hack. this is one major downside to scheduling.
- $chan = $c;
- &performStrictReply(
+ &msg($c,
&formListReply( 0, "IRC Client versions for $c ", @list ) );
# clean up not-needed data structures.
last unless ( scalar @vernicktodo );
my $n = shift(@vernicktodo);
- $conn->ctcp( 'VERSION', $n );
+ #$conn->ctcp( 'VERSION', $n );
+ # See do_verstats $conn->sl for explantaion
+ $conn->sl("PRIVMSG $n :\001VERSION\001");
}
return unless ( scalar @vernicktodo );
&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' ) );
+&addCmdHook('verstats', ('CODEREF' => 'do_verstats', 'Identifier' => 'verstats', 'Help' => 'verstats', 'Cmdstats' => 'verstats') );
&addCmdHook('Weather', ('CODEREF' => 'Weather::Weather', 'Identifier' => 'Weather', 'Help' => 'weather', 'Cmdstats' => 'Weather', 'Forker' => 1, 'Module' => 'Weather') );
&addCmdHook('wiki(pedia)?', ('CODEREF' => 'wikipedia::wikipedia', 'Identifier' => 'wikipedia', 'Cmdstats' => 'wikipedia', 'Forker' => 1, 'Help' => 'wikipedia', 'Module' => 'wikipedia') );
&addCmdHook('wtf', ('CODEREF' => 'wtf::query', 'Identifier' => 'wtf', 'Cmdstats' => 'wtf', 'Forker' => 1, 'Help' => 'wtf', 'Module' => 'wtf') );
# 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.
+ / \Q$ident\E$/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;
$rhs =~ /( \Q$ident\E's|\Q$ident\E's )/i and last; # ownership.
# duplication.
- $rhs =~ /^\Q$lhs /i and last;
+ $rhs =~ /^\Q$lhs\E /i and last;
last if ( $rhs =~ /^is /i and / is$/ );
$valid++;
for ($question) {
# fix the string.
- s/^hey([, ]+)where/where/i;
+ s/^where is //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/^whois //i; # Must match ^, else factoids with "whois" anywhere break
+ s/^who is //i;
+ s/^what is (a|an)?//i;
+ s/^how do i //i;
+ s/^where can i (find|get|download)//i;
+ s/^how about //i;
s/ da / the /ig;
# clear the string of useless words.
local ($query) = @_;
local ($reply) = '';
local $finalQMark = $query =~ s/\?+\s*$//;
- $finalQMark += $query =~ s/\?\s*$//;
$query =~ s/^\s+|\s+$//g;
if ( !defined $query or $query =~ /^\s*$/ ) {
if ( !$addressed ) {
return '' unless ($finalQMark);
- return '' unless &IsChanConf('minVolunteerLength') > 0;
- return '' if ( length $query < &::getChanConf('minVolunteerLength') );
+ return ''
+ if (
+ length $query <
+ &::getChanConfDefault( 'minVolunteerLength', 2, $chan ) or
+ $param{'addressing'} =~ m/require/i );
+ return ''
+ if (
+ length $query >
+ &::getChanConfDefault( 'maxVolunteerLength', 512, $chan ) or
+ $param{'addressing'} =~ m/require/i );
}
else {
### TODO: this should be caught in Process.pl?
if ( $in =~ /(^|\s)(is|are)(\s|$)/i ) {
my ( $lhs, $mhs, $rhs ) = ( $`, $&, $' );
+ # Quit if they are over the limits. Check done here since Core.pl calls
+ # this mid sub and Question.pl needs its own check as well. NOTE: $in is
+ # used in this place since lhs and rhs are really undefined for unwanted
+ # teaching. Mainly, the "is" could be anywhere within a 510 byte or so
+ # block of text, so the total size was choosen since the sole purpose of
+ # this logic is to not hammer the db with pointless factoids that were
+ # only meant to be general conversation.
+ return ''
+ if (
+ length $in <
+ &::getChanConfDefault( 'minVolunteerLength', 2, $chan ) or
+ $param{'addressing'} =~ m/require/i ) and not $addressed;
+ return ''
+ if (
+ length $in >
+ &::getChanConfDefault( 'maxVolunteerLength', 512, $chan ) or
+ $param{'addressing'} =~ m/require/i ) and not $addressed;
+
# allows factoid arguments to be updated. -lear.
$lhs =~ s/^(cmd: )?(.*)/$1||'' . lc $2/e;
"Connecting to port $port of server $server ($resolve) as $mynick ..."
);
$args{'Nick'} = $mynick;
+ $args{'Username'} = $mynick;
$conns{$mynick} = $irc->newconn(%args);
if ( !defined $conns{$mynick} ) {
&ERROR('IRC: connection failed.');
$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 )
+ $conns{$mynick}->add_global_handler( "001", \&on_connected )
; # on_connect.
$conns{$mynick}->add_global_handler( 433, \&on_nick_taken );
$conns{$mynick}->add_global_handler( 439, \&on_targettoofast );
my ( $chan, $key ) = @_;
$key ||= &getChanConf( 'chankey', $chan );
$key ||= '';
+ my $mynick = $conn->nick();
# forgot for about 2 years to implement channel keys when moving
# over to Net::IRC...
}
#} else {
- &status("joining $b_blue$chan $key$ob");
+ &status("$mynick joining $b_blue$chan $key$ob");
return if ( $conn->join( $chan, $key ) );
return if ( &validChan($chan) );
&DEBUG("on_ison: x1 = '$x1', x2 => '$x2'");
}
-sub on_endofmotd {
+sub on_connected {
$conn = shift(@_);
# update IRCStats.
}
push( @vernick, $nick );
+ &DEBUG("on_crversion: Got '$ver' from $nick");
+
if ( $ver =~ /bitchx/i ) {
$ver{bitchx}{$nick} = $ver;
}
- elsif ( $ver =~ /xc\!|xchat/i ) {
+ elsif ( $ver =~ /infobot/i ) {
+ $ver{infobot}{$nick} = $ver;
+
+ }
+ elsif ( $ver =~ /(xc\!|xchat)/i ) {
$ver{xchat}{$nick} = $ver;
}
$ver{irssi}{$nick} = $ver;
}
- elsif ( $ver =~ /epic|(Third Eye)/i ) {
+ elsif ( $ver =~ /(epic|Third Eye)/i ) {
$ver{epic}{$nick} = $ver;
}
- elsif ( $ver =~ /ircII|PhoEniX/i ) {
+ elsif ( $ver =~ /(ircII|PhoEniX)/i ) {
$ver{ircII}{$nick} = $ver;
}
elsif ( $ver =~ /mirc/i ) {
-
- # &DEBUG("verstats: mirc: $nick => '$ver'.");
+ # Apparently, mIRC gets the reply as "VERSION " and doesnt like the
+ # space, so mirc matching is considered bugged.
$ver{mirc}{$nick} = $ver;
- # ok... then we get to the lesser known/used clients.
}
elsif ( $ver =~ /ircle/i ) {
$ver{ircle}{$nick} = $ver;
$conn = $conns{$_};
my $mynick = $conn->nick();
&DEBUG("ircCheck for $_");
- my @join =
- &getJoinChans(900)
- ; # Display with min of 900sec delay between redisplay
+ # Display with min of 900sec delay between redisplay
+ # FIXME: should only use 900sec when we are on the LAST %conns
+ my @join = &getJoinChans(900);
if ( scalar @join ) {
&FIXME( 'ircCheck: found channels to join! ' . join( ',', @join ) );
&joinNextChan();
--- /dev/null
+#
+# UserDCC.pl: User Commands, DCC CHAT.
+# Author: dms
+# Version: v0.2 (20010119)
+# Created: 20000707 (from UserExtra.pl)
+#
+
+use strict;
+
+use vars qw(%users %ignore %sched %bans %mask %cache %channels %param
+ %chanconf %dcc);
+use vars qw($who $chan $message $msgType $user $chnick $conn $ident
+ $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!");
+
+ return;
+ }
+
+ # who.
+ 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.");
+
+ return;
+ }
+
+ ### for those users with enough flags.
+
+ if ( $message =~ /^tellme(\s+(.*))?$/i ) {
+ my $args = $2;
+ if ( $args =~ /^\s*$/ ) {
+ &help('tellme');
+ return;
+ }
+
+ my $result = &doQuestion($args);
+ &performStrictReply($result);
+
+ 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;
+ }
+
+ # opme.
+ if ( $message =~ /^opme(\s+($mask{chan}))?$/i ) {
+ return unless ( &hasFlag('o') );
+ return unless ( &hasFlag('A') );
+
+ my $chan = $2;
+
+ if ( $chan eq '' ) {
+ &help('4op');
+ return;
+ }
+
+ # can this be exploited?
+ rawout("MODE $chan +o $who");
+
+ 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;
+ }
+
+ # dump variables.
+ if ( $message =~ /^dumpvars$/i ) {
+ return unless ( &hasFlag('o') );
+ return unless ( &IsParam('DumpVars') );
+
+ &status("Dumping all variables...");
+ &dumpallvars();
+
+ return;
+ }
+
+ # dump variables ][.
+ if ( $message =~ /^symdump$/i ) {
+ return unless ( &hasFlag('o') );
+ return unless ( &IsParam('DumpVars2') );
+
+ &status("Dumping all variables...");
+ &symdumpAllFile();
+
+ return;
+ }
+
+ # kick.
+ if ( $message =~ /^kick(\s+(.*?))$/ ) {
+ return unless ( &hasFlag('o') );
+
+ my $arg = $2;
+
+ 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 ( &IsNickInChan( $nick, $chan ) == 0 ) {
+ &msg( $who, "$nick is not in $chan." );
+ return;
+ }
+
+ &kick( $nick, $chan, $reason );
+
+ return;
+ }
+
+ # mode.
+ if ( $message =~ /^mode(\s+(.*))?$/ ) {
+ return unless ( &hasFlag('n') );
+ my ( $chan, $mode ) = split /\s+/, $2, 2;
+
+ if ( $chan eq '' ) {
+ &help('mode');
+ 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;
+ }
+
+ &mode( $chan, $mode );
+
+ 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;
+ }
+
+ # 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;
+ }
+
+ # 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;
+ }
+
+ # 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;
+ }
+
+ # 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;
+ }
+
+ # say.
+ if ( $message =~ s/^say\s+(\S+)\s+(.*)// ) {
+ return unless ( &hasFlag('o') );
+ my ( $chan, $msg ) = ( lc $1, $2 );
+
+ &DEBUG("chan => '$1', msg => '$msg'.");
+
+ &msg( $chan, $msg );
+
+ return;
+ }
+
+ # do.
+ if ( $message =~ s/^do\s+(\S+)\s+(.*)// ) {
+ return unless ( &hasFlag('o') );
+ my ( $chan, $msg ) = ( lc $1, $2 );
+
+ &DEBUG("chan => '$1', msg => '$msg'.");
+
+ &action( $chan, $msg );
+
+ return;
+ }
+
+ # die.
+ if ( $message =~ /^die$/ ) {
+ return unless ( &hasFlag('n') );
+
+ &doExit();
+
+ &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;
+ }
+
+ # 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();
+ }
+ }
+
+ # reload.
+ if ( $message =~ /^reload$/i ) {
+ return unless ( &hasFlag('n') );
+
+ &status("USER reload $who");
+ &performStrictReply("reloading...");
+ &reloadAllModules();
+ &performStrictReply("reloaded.");
+
+ 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;
+ }
+
+ # rehash.
+ if ( $message =~ /^rehash$/ ) {
+ return unless ( &hasFlag('n') );
+
+ &msg( $who, "rehashing..." );
+ &restart('REHASH');
+ &status("USER rehash $who");
+ &msg( $who, 'rehashed' );
+
+ return;
+ }
+
+ #####
+ ##### USER//CHAN SPECIFIC CONFIGURATION COMMANDS
+ #####
+
+ if ( $message =~ /^chaninfo(\s+(.*))?$/ ) {
+ my @args = split /[\s\t]+/, $2; # hrm.
+
+ if ( scalar @args != 1 ) {
+ &help('chaninfo');
+ 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.");
+
+ 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|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 ( scalar @args != 1 ) {
+ &help('newpass');
+ return;
+ }
+
+ my $u = &getUser($who);
+ my $crypt = &mkcrypt( $args[0] );
+
+ &performStrictReply("Set your passwd to '$crypt'");
+ $users{$u}{PASS} = $crypt;
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ return;
+ }
+
+ if ( $message =~ /^chpass(\s+(.*))?$/ ) {
+ my (@args) = split /[\s\t]+/, $2 || '';
+
+ if ( !scalar @args ) {
+ &help('chpass');
+ 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;
+ }
+
+ if ( scalar @args == 1 ) {
+
+ # del pass.
+ if ( !&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i ) {
+ &performStrictReply("cannot remove passwd of others.");
+ return;
+ }
+
+ if ( !exists $users{$u}{PASS} ) {
+ &performStrictReply("$u does not have pass set anyway.");
+ return;
+ }
+
+ &performStrictReply("Deleted pass from $u.");
+
+ $utime_userfile = time();
+ $ucount_userfile++;
+
+ delete $users{$u}{PASS};
+
+ return;
+ }
+
+ my $crypt = &mkcrypt( $args[1] );
+ &performStrictReply("Set $u's passwd to '$crypt'");
+ $users{$u}{PASS} = $crypt;
+
+ $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 =~ /^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 =~ /^(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 =~ /^(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 '$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 =~ /^banlist(\s+(.*))?$/ ) {
+ my $arg = $2;
+
+ 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("End of bans.");
+ &performStrictReply("END of bans.");
+
+ return;
+ }
+
+ if ( $message =~ /^save$/ ) {
+ return unless ( &hasFlag('o') );
+
+ &writeUserFile();
+ &writeChanFile();
+ &performStrictReply('saved user and chan files');
+
+ return;
+ }
+
+ ### ALIASES.
+ $message =~ s/^addignore/+ignore/;
+ $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+(.*))?$/ ) {
+ 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;
+ }
+
+ # 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;
+ }
+
+ # quite a cool hack: reply in DCC CHAT.
+ $msgType = 'chat' if ( exists $dcc{'CHAT'}{$who} );
+
+ my $done = 0;
+ $done++ if &parseCmdHook($message);
+ $done++ unless ( &Modules() );
+
+ if ($done) {
+ &DEBUG("running non DCC CHAT command inside DCC CHAT!");
+ return;
+ }
+
+ return 'REPLY';
+}
+
+1;
+
+# vim:ts=4:sw=4:expandtab:tw=80
'stats',
'counter',
{
- nick => $type,
- type => 'cmdstats',
+ 'nick' => $type,
+ 'type' => 'cmdstats',
}
);
my $z = 0;
&sqlSet(
'stats',
- { 'nick' => $type },
{
- type => 'cmdstats',
- 'time' => time(),
- counter => $i,
+ 'nick' => $type,
+ 'type' => 'cmdstats',
+ },
+ {
+ 'time' => time(),
+ 'counter' => $i,
}
);
}
--- /dev/null
+# W3Search drastically altered back to GoogleSearch as Search::Google
+# was deprecated and requires a key that google no longer provides.
+# This new module uses REST::Google::Search
+# Modified by db <db@cave.za.net> 12-01-2008.
+#
+# Usage: 'chanset _default +Google' in query window with your bot
+# to enable it in all channels
+# /msg botnick google <query> OR <addressCharacter>google <query> to use
+
+package Google;
+
+use strict;
+
+my $maxshow = 5;
+
+sub GoogleSearch {
+ my ( $what, $type ) = @_;
+ # $where set to official google colors ;)
+ my $where = "\00312G\0034o\0038o\00312g\0033l\0034e\003";
+ my $retval = "$where can't find \002$what\002";
+ my $Search;
+ my $referer = "irc://$::server/$::chan/$::who";
+
+ return unless &::loadPerlModule("REST::Google::Search");
+
+ &::DEBUG( "Google::GoogleSearch->referer = $referer" );
+ &::status( "Google::GoogleSearch> Searching Google for: $what");
+ REST::Google::Search->http_referer( $referer );
+ $Search = REST::Google::Search->new( q => $what );
+
+ if ( !defined $Search ) {
+ &::msg( $::who, "$where is invalid search." );
+ &::WARN( "Google::GoogleSearch> $::who generated an invalid search: $where");
+ return;
+ }
+
+ if ( $Search->responseStatus != 200 ) {
+ &::msg( $::who, "http error returned." );
+ &::WARN( "Google::GoogleSearch> http error returned: $Search->responseStatus");
+ return;
+ }
+
+ # No results found
+ if ( not $Search->responseData->results ) {
+ &::DEBUG( "Google::GoogleSearch> $retval" );
+ &::msg( $::who, $retval);
+ return;
+ }
+
+ my $data = $Search->responseData;
+ my $cursor = $data->cursor;
+ my @results = $data->results;
+ my $count;
+
+ $retval = "$where says \"\002$what\002\" is at ";
+ foreach my $r (@results) {
+ my $url = $r->url;
+
+ # Returns a string with each %XX sequence replaced with the actual byte
+ # (octet). From URI::Escape uri_unescape()
+ $url =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+
+ $retval .= " \002or\002 " if ( $count > 0 );
+ $retval .= $url;
+ last if ++$count >= $maxshow; # Only seems to return max of 4?
+ }
+
+ &::performStrictReply($retval);
+}
+
+1;
+
+# vim:ts=4:sw=4:expandtab:tw=80
+# Local Variables:
+# mode: cperl
+# tab-width: 4
+# fill-column: 80
+# indent-tabs-mode: nil
+# End:
+++ /dev/null
-#
-# UserDCC.pl: User Commands, DCC CHAT.
-# Author: dms
-# Version: v0.2 (20010119)
-# Created: 20000707 (from UserExtra.pl)
-#
-
-use strict;
-
-use vars qw(%users %ignore %sched %bans %mask %cache %channels %param
- %chanconf %dcc);
-use vars qw($who $chan $message $msgType $user $chnick $conn $ident
- $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!");
-
- return;
- }
-
- # who.
- 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.");
-
- return;
- }
-
- ### for those users with enough flags.
-
- if ( $message =~ /^tellme(\s+(.*))?$/i ) {
- my $args = $2;
- if ( $args =~ /^\s*$/ ) {
- &help('tellme');
- return;
- }
-
- my $result = &doQuestion($args);
- &performStrictReply($result);
-
- 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;
- }
-
- # opme.
- if ( $message =~ /^opme(\s+($mask{chan}))?$/i ) {
- return unless ( &hasFlag('o') );
- return unless ( &hasFlag('A') );
-
- my $chan = $2;
-
- if ( $chan eq '' ) {
- &help('4op');
- return;
- }
-
- # can this be exploited?
- rawout("MODE $chan +o $who");
-
- 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;
- }
-
- # dump variables.
- if ( $message =~ /^dumpvars$/i ) {
- return unless ( &hasFlag('o') );
- return unless ( &IsParam('DumpVars') );
-
- &status("Dumping all variables...");
- &dumpallvars();
-
- return;
- }
-
- # dump variables ][.
- if ( $message =~ /^symdump$/i ) {
- return unless ( &hasFlag('o') );
- return unless ( &IsParam('DumpVars2') );
-
- &status("Dumping all variables...");
- &symdumpAllFile();
-
- return;
- }
-
- # kick.
- if ( $message =~ /^kick(\s+(.*?))$/ ) {
- return unless ( &hasFlag('o') );
-
- my $arg = $2;
-
- 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 ( &IsNickInChan( $nick, $chan ) == 0 ) {
- &msg( $who, "$nick is not in $chan." );
- return;
- }
-
- &kick( $nick, $chan, $reason );
-
- return;
- }
-
- # mode.
- if ( $message =~ /^mode(\s+(.*))?$/ ) {
- return unless ( &hasFlag('n') );
- my ( $chan, $mode ) = split /\s+/, $2, 2;
-
- if ( $chan eq '' ) {
- &help('mode');
- 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;
- }
-
- &mode( $chan, $mode );
-
- 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;
- }
-
- # 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;
- }
-
- # 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;
- }
-
- # 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;
- }
-
- # 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;
- }
-
- # say.
- if ( $message =~ s/^say\s+(\S+)\s+(.*)// ) {
- return unless ( &hasFlag('o') );
- my ( $chan, $msg ) = ( lc $1, $2 );
-
- &DEBUG("chan => '$1', msg => '$msg'.");
-
- &msg( $chan, $msg );
-
- return;
- }
-
- # do.
- if ( $message =~ s/^do\s+(\S+)\s+(.*)// ) {
- return unless ( &hasFlag('o') );
- my ( $chan, $msg ) = ( lc $1, $2 );
-
- &DEBUG("chan => '$1', msg => '$msg'.");
-
- &action( $chan, $msg );
-
- return;
- }
-
- # die.
- if ( $message =~ /^die$/ ) {
- return unless ( &hasFlag('n') );
-
- &doExit();
-
- &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;
- }
-
- # 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();
- }
- }
-
- # reload.
- if ( $message =~ /^reload$/i ) {
- return unless ( &hasFlag('n') );
-
- &status("USER reload $who");
- &performStrictReply("reloading...");
- &reloadAllModules();
- &performStrictReply("reloaded.");
-
- 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;
- }
-
- # rehash.
- if ( $message =~ /^rehash$/ ) {
- return unless ( &hasFlag('n') );
-
- &msg( $who, "rehashing..." );
- &restart('REHASH');
- &status("USER rehash $who");
- &msg( $who, 'rehashed' );
-
- return;
- }
-
- #####
- ##### USER//CHAN SPECIFIC CONFIGURATION COMMANDS
- #####
-
- if ( $message =~ /^chaninfo(\s+(.*))?$/ ) {
- my @args = split /[\s\t]+/, $2; # hrm.
-
- if ( scalar @args != 1 ) {
- &help('chaninfo');
- 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.");
-
- 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|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 ( scalar @args != 1 ) {
- &help('newpass');
- return;
- }
-
- my $u = &getUser($who);
- my $crypt = &mkcrypt( $args[0] );
-
- &performStrictReply("Set your passwd to '$crypt'");
- $users{$u}{PASS} = $crypt;
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- return;
- }
-
- if ( $message =~ /^chpass(\s+(.*))?$/ ) {
- my (@args) = split /[\s\t]+/, $2 || '';
-
- if ( !scalar @args ) {
- &help('chpass');
- 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;
- }
-
- if ( scalar @args == 1 ) {
-
- # del pass.
- if ( !&IsFlag('n') and $who !~ /^\Q$verifyUser\E$/i ) {
- &performStrictReply("cannot remove passwd of others.");
- return;
- }
-
- if ( !exists $users{$u}{PASS} ) {
- &performStrictReply("$u does not have pass set anyway.");
- return;
- }
-
- &performStrictReply("Deleted pass from $u.");
-
- $utime_userfile = time();
- $ucount_userfile++;
-
- delete $users{$u}{PASS};
-
- return;
- }
-
- my $crypt = &mkcrypt( $args[1] );
- &performStrictReply("Set $u's passwd to '$crypt'");
- $users{$u}{PASS} = $crypt;
-
- $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 =~ /^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 =~ /^(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 =~ /^(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 '$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 =~ /^banlist(\s+(.*))?$/ ) {
- my $arg = $2;
-
- 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("End of bans.");
- &performStrictReply("END of bans.");
-
- return;
- }
-
- if ( $message =~ /^save$/ ) {
- return unless ( &hasFlag('o') );
-
- &writeUserFile();
- &writeChanFile();
- &performStrictReply('saved user and chan files');
-
- return;
- }
-
- ### ALIASES.
- $message =~ s/^addignore/+ignore/;
- $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+(.*))?$/ ) {
- 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;
- }
-
- # 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;
- }
-
- # quite a cool hack: reply in DCC CHAT.
- $msgType = 'chat' if ( exists $dcc{'CHAT'}{$who} );
-
- my $done = 0;
- $done++ if &parseCmdHook($message);
- $done++ unless ( &Modules() );
-
- if ($done) {
- &DEBUG("running non DCC CHAT command inside DCC CHAT!");
- return;
- }
-
- return 'REPLY';
-}
-
-1;
-
-# vim:ts=4:sw=4:expandtab:tw=80
+++ /dev/null
-# WWWSearch backend, with queries updating the is-db (optionally)
-# Uses WWW::Search::Google and WWW::Search
-# originally Google.pl, drastically altered.
-
-package W3Search;
-
-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);
-$W3Search_regex = join '|', @W3Search_engines;
-
-my $maxshow = 5;
-
-sub W3Search {
- 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;
- }
-
- return unless &::loadPerlModule("WWW::Search");
-
- eval { $Search = new WWW::Search( $where, agent_name => 'Mozilla/4.5' ); };
-
- 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,
- }
- );
- $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;
- }
-
- &::performStrictReply($retval);
-}
-
-1;
-
-# vim:ts=4:sw=4:expandtab:tw=80
use strict;
my $no_babelfish;
-my $url = 'http://babelfish.av.com/tr';
+#my $url = 'http://babelfish.av.com/tr';
+my $url = 'http://babelfish.yahoo.com/translate_txt';
BEGIN {
eval "use URI::Escape"; # utility functions for encoding the
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->header('Accept-Language' => 'en-us');
+ $req->header('Accept-Charset' => 'UTF-8,*');
$req->content_type('application/x-www-form-urlencoded');
return translate( $phrase, "${from}_${to}", $req, $ua );
if ( $res->is_success ) {
my $html = $res->content;
- # This method subject to change with the whims of Altavista's design
- # staff.
+ # This method subject to change with the whims of Babelfish design staff.
($translated) = $html;
-
- $translated =~ s/<[^>]*>//sg;
+ # strip page head
+ $translated =~ s/.*<\/head>//sg;
+ # clean before doc-body
+ $translated =~ s/.*<div id="doc-body"[^>]*>//sg;
+ # clean after first form
+ $translated =~ s/<\/form>.*//sg;
+ # convert back to spaces
$translated =~ s/ / /sg;
+ &::DEBUG("================================\n$translated\n========================\n");
+ # strip up to result
+ $translated =~ s/.*<div id="result">//sg;
+ # strip rest of page
+ $translated =~ s/<\/div.*//sg;
+ # strip all markup
+ $translated =~ s/<[^>]*>/ /sg;
+ # \n to space
+ $translated =~ s/[\n\r\t]/ /g;
+ # strip leading whitespace
+ $translated =~ s/^\s+//sg;
+ # strip trailing whitespace
+ $translated =~ s/\s+$//sg;
+ # strip multiple whitespace
$translated =~ s/\s+/ /sg;
- #&::DEBUG("$translated\n===remove <attributes>\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/\n/ /g;
-
- # FIXME: should we do unicode->iso (no. use utf8!)
+ # FIXME: any entities to utf8?
}
else {
$translated = ":("; # failure
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";
- }
-}
-
1;
# vim:ts=4:sw=4:expandtab:tw=80
my $turned = '';
my $tlength = 0;
+ # add reverse mappings
+ foreach my $up (keys %updown) {
+ $updown{$updown{$up}} = $up if ! exists $updown{$updown{$up}};
+ }
+
for my $char ( $str =~ /(\X)/g ) {
+#print STDERR "str=\"$str\" char=\"$char\"\n";
if ( exists $updown{$char} ) {
my $t = $updown{$char};
$t = $missing if !length($t);
&::performStrictReply( turnedstr( $message ) );
}
+#binmode(STDERR, "encoding(UTF-8)");
+#print STDERR turnedstr("upsidedown ɟǝpɔqɐabcdef") . "\n";
1;
# vim:ts=4:sw=4:expandtab:tw=80
--- /dev/null
+# This is a transitional file
+#package POE::Component::IRC::Common;
+package src::PoCiCommon;
+
+use strict;
+use warnings;
+
+our $VERSION = '5.18';
+
+require Exporter;
+use base qw(Exporter);
+our @EXPORT_OK = qw(
+ u_irc l_irc parse_mode_line parse_ban_mask matches_mask matches_mask_array
+ parse_user irc_ip_get_version irc_ip_is_ipv4 irc_ip_is_ipv6 has_color
+ has_formatting strip_color strip_formatting NORMAL BOLD UNDERLINE REVERSE
+ WHITE BLACK DARK_BLUE DARK_GREEN RED BROWN PURPLE ORANGE YELLOW LIGHT_GREEN
+ TEAL CYAN LIGHT_BLUE MAGENTA DARK_GREY LIGHT_GREY
+);
+our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] );
+
+my ($ERROR, $ERRNO);
+
+use constant {
+ NORMAL => "\x0f",
+
+ # formatting
+ BOLD => "\x02",
+ UNDERLINE => "\x1f",
+ REVERSE => "\x16",
+ ITALIC => "\x1d",
+ FIXED => "\x11",
+
+ # mIRC colors
+ WHITE => "\x0300",
+ BLACK => "\x0301",
+ DARK_BLUE => "\x0302",
+ DARK_GREEN => "\x0303",
+ RED => "\x0304",
+ BROWN => "\x0305",
+ PURPLE => "\x0306",
+ ORANGE => "\x0307",
+ YELLOW => "\x0308",
+ LIGHT_GREEN => "\x0309",
+ TEAL => "\x0310",
+ CYAN => "\x0311",
+ LIGHT_BLUE => "\x0312",
+ MAGENTA => "\x0313",
+ DARK_GREY => "\x0314",
+ LIGHT_GREY => "\x0315",
+};
+
+sub u_irc {
+ my $value = shift || return;
+ my $type = shift || 'rfc1459';
+ $type = lc $type;
+
+ if ( $type eq 'ascii' ) {
+ $value =~ tr/a-z/A-Z/;
+ }
+ elsif ( $type eq 'strict-rfc1459' ) {
+ $value =~ tr/a-z{}|/A-Z[]\\/;
+ }
+ else {
+ $value =~ tr/a-z{}|^/A-Z[]\\~/;
+ }
+
+ return $value;
+}
+
+sub l_irc {
+ my $value = shift || return;
+ my $type = shift || 'rfc1459';
+ $type = lc $type;
+
+ if ( $type eq 'ascii' ) {
+ $value =~ tr/A-Z/a-z/;
+ }
+ elsif ( $type eq 'strict-rfc1459' ) {
+ $value =~ tr/A-Z[]\\/a-z{}|/;
+ }
+ else {
+ $value =~ tr/A-Z[]\\~/a-z{}|^/;
+ }
+
+ return $value;
+}
+
+sub parse_mode_line {
+ my @args = @_;
+
+ my $chanmodes = [qw(beI k l imnpstaqr)];
+ my $statmodes = 'ov';
+ my $hashref = { };
+ my $count = 0;
+
+ while (my $arg = shift @args) {
+ if ( ref $arg eq 'ARRAY' ) {
+ $chanmodes = $arg;
+ next;
+ }
+ elsif ( ref $arg eq 'HASH' ) {
+ $statmodes = join '', keys %{ $arg };
+ next;
+ }
+ elsif ( $arg =~ /^(\+|-)/ or $count == 0 ) {
+ my $action = '+';
+ for my $char ( split (//,$arg) ) {
+ if ($char eq '+' or $char eq '-') {
+ $action = $char;
+ }
+ else {
+ push @{ $hashref->{modes} }, $action . $char;
+ }
+
+ if ($char =~ /[$statmodes$chanmodes->[0]$chanmodes->[1]]/) {
+ push @{ $hashref->{args} }, shift @args;
+ }
+
+ if ($action eq '+' && $char =~ /[$chanmodes->[2]]/) {
+ push @{ $hashref->{args} }, shift @args;
+ }
+ }
+ }
+ else {
+ push @{ $hashref->{args} }, $arg;
+ }
+ $count++;
+ }
+
+ return $hashref;
+}
+
+sub parse_ban_mask {
+ my $arg = shift || return;
+
+ $arg =~ s/\x2a{2,}/\x2a/g;
+ my @ban;
+ my $remainder;
+ if ($arg !~ /\x21/ and $arg =~ /\x40/) {
+ $remainder = $arg;
+ }
+ else {
+ ($ban[0], $remainder) = split /\x21/, $arg, 2;
+ }
+
+ $remainder =~ s/\x21//g if defined $remainder;
+ @ban[1..2] = split(/\x40/, $remainder, 2) if defined $remainder;
+ $ban[2] =~ s/\x40//g if defined $ban[2];
+
+ for my $i (1..2) {
+ $ban[$i] = '*' if !$ban[$i];
+ }
+
+ return $ban[0] . '!' . $ban[1] . '@' . $ban[2];
+}
+
+sub matches_mask_array {
+ my ($masks, $matches, $mapping) = @_;
+
+ return if !$masks || !$matches;
+ return if ref $masks ne 'ARRAY';
+ return if ref $matches ne 'ARRAY';
+ my $ref = { };
+
+ for my $mask ( @{ $masks } ) {
+ for my $match ( @{ $matches } ) {
+ if ( matches_mask($mask, $match, $mapping) ) {
+ push @{ $ref->{ $mask } }, $match;
+ }
+ }
+ }
+
+ return $ref;
+}
+
+sub matches_mask {
+ my ($mask,$match,$mapping) = @_;
+
+ return if !$mask || !$match;
+ $mask = parse_ban_mask($mask);
+ $mask =~ s/\x2A+/\x2A/g;
+
+ my $umask = quotemeta u_irc( $mask, $mapping );
+ $umask =~ s/\\\*/[\x01-\xFF]{0,}/g;
+ $umask =~ s/\\\?/[\x01-\xFF]{1,1}/g;
+ $match = u_irc $match, $mapping;
+
+ return 1 if $match =~ /^$umask$/;
+ return;
+}
+
+sub parse_user {
+ my $user = shift || return;
+ my ($n, $u, $h) = split /[!@]/, $user;
+ return ($n, $u, $h) if wantarray();
+ return $n;
+}
+
+sub has_color {
+ my $string = shift;
+ return 1 if $string =~ /[\x03\x04]/;
+ return;
+}
+
+sub has_formatting {
+ my $string = shift;
+ return 1 if $string =~/[\x02\x1f\x16\x1d\x11]/;
+ return;
+}
+
+sub strip_color {
+ my $string = shift;
+
+ # mIRC colors
+ $string =~ s/\x03(?:,\d{1,2}|\d{1,2}(?:,\d{1,2})?)?//g;
+ $string =~ s/\x0f//g;
+
+ # RGB colors supported by some clients
+ $string =~ s/\x04[0-9a-fA-F]{0,6}//ig;
+
+ return $string;
+}
+
+sub strip_formatting {
+ my $string = shift;
+ $string =~ s/[\x0f\x02\x1f\x16\x1d\x11]//g;
+ return $string;
+}
+
+#------------------------------------------------------------------------------
+# Subroutine ip_get_version
+# Purpose : Get an IP version
+# Params : IP address
+# Returns : 4, 6, 0(don't know)
+sub irc_ip_get_version {
+ my $ip = shift || return;
+
+ # If the address does not contain any ':', maybe it's IPv4
+ return 4 if $ip !~ /:/ && irc_ip_is_ipv4($ip);
+
+ # Is it IPv6 ?
+ return 6 if irc_ip_is_ipv6($ip);
+
+ return;
+}
+
+#------------------------------------------------------------------------------
+# Subroutine ip_is_ipv4
+# Purpose : Check if an IP address is version 4
+# Params : IP address
+# Returns : 1 (yes) or 0 (no)
+sub irc_ip_is_ipv4 {
+ my $ip = shift || return;
+
+ # Check for invalid chars
+ if ($ip !~ /^[\d\.]+$/) {
+ $ERROR = "Invalid chars in IP $ip";
+ $ERRNO = 107;
+ return;
+ }
+
+ if ($ip =~ /^\./) {
+ $ERROR = "Invalid IP $ip - starts with a dot";
+ $ERRNO = 103;
+ return;
+ }
+
+ if ($ip =~ /\.$/) {
+ $ERROR = "Invalid IP $ip - ends with a dot";
+ $ERRNO = 104;
+ return;
+ }
+
+ # Single Numbers are considered to be IPv4
+ return 1 if $ip =~ /^(\d+)$/ && $1 < 256;
+
+ # Count quads
+ my $n = ($ip =~ tr/\./\./);
+
+ # IPv4 must have from 1 to 4 quads
+ if ($n <= 0 || $n > 4) {
+ $ERROR = "Invalid IP address $ip";
+ $ERRNO = 105;
+ return;
+ }
+
+ # Check for empty quads
+ if ($ip =~ /\.\./) {
+ $ERROR = "Empty quad in IP address $ip";
+ $ERRNO = 106;
+ return;
+ }
+
+ for my $quad (split /\./, $ip) {
+ # Check for invalid quads
+ if ($quad < 0 || $quad >= 256) {
+ $ERROR = "Invalid quad in IP address $ip - $_";
+ $ERRNO = 107;
+ return;
+ }
+ }
+ return 1;
+}
+
+#------------------------------------------------------------------------------
+# Subroutine ip_is_ipv6
+# Purpose : Check if an IP address is version 6
+# Params : IP address
+# Returns : 1 (yes) or 0 (no)
+sub irc_ip_is_ipv6 {
+ my $ip = shift || return;
+
+ # Count octets
+ my $n = ($ip =~ tr/:/:/);
+ return if ($n <= 0 || $n >= 8);
+
+ # $k is a counter
+ my $k;
+
+ for my $octet (split /:/, $ip) {
+ $k++;
+
+ # Empty octet ?
+ next if $octet eq '';
+
+ # Normal v6 octet ?
+ next if $octet =~ /^[a-f\d]{1,4}$/i;
+
+ # Last octet - is it IPv4 ?
+ if ($k == $n + 1) {
+ next if (ip_is_ipv4($octet));
+ }
+
+ $ERROR = "Invalid IP address $ip";
+ $ERRNO = 108;
+ return;
+ }
+
+ # Does the IP address start with : ?
+ if ($ip =~ m/^:[^:]/) {
+ $ERROR = "Invalid address $ip (starts with :)";
+ $ERRNO = 109;
+ return;
+ }
+
+ # Does the IP address finish with : ?
+ if ($ip =~ m/[^:]:$/) {
+ $ERROR = "Invalid address $ip (ends with :)";
+ $ERRNO = 110;
+ return;
+ }
+
+ # Does the IP address have more than one '::' pattern ?
+ if ($ip =~ s/:(?=:)//g > 1) {
+ $ERROR = "Invalid address $ip (More than one :: pattern)";
+ $ERRNO = 111;
+ return;
+ }
+
+ return 1;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+src::PoCiCommon - provides a set of common functions for the
+infobot suite. Code originally from POE::Component::IRC::Common.
+
+=head1 SYNOPSIS
+
+ use strict;
+ use warnings;
+
+ use src::PoCiCommon qw( :ALL );
+
+ my $nickname = '^Lame|BOT[moo]';
+ my $uppercase_nick = u_irc( $nickname );
+ my $lowercase_nick = l_irc( $nickname );
+
+ my $mode_line = 'ov+b-i Bob sue stalin*!*@*';
+ my $hashref = parse_mode_line( $mode_line );
+
+ my $banmask = 'stalin*';
+ my $full_banmask = parse_ban_mask( $banmask );
+
+ if ( matches_mask( $full_banmask, 'stalin!joe@kremlin.ru' ) ) {
+ print "EEK!";
+ }
+
+ if ( has_color($message) ) {
+ print 'COLOR CODE ALERT!";
+ }
+
+ my $results_hashref = matches_mask_array( \@masks, \@items_to_match_against );
+
+ my $nick = parse_user( 'stalin!joe@kremlin.ru' );
+ my ($nick, $user, $host) = parse_user( 'stalin!joe@kremlin.ru' );
+
+=head1 DESCRIPTION
+
+src::PoCiCommon provides a set of common functions for the infobot suite.
+Original code from POE::Component::IRC::Common. There are included functions
+for uppercase and lowercase nicknames/channelnames and for parsing mode lines
+and ban masks.
+
+=head1 CONSTANTS
+
+Use the following constants to add formatting and mIRC color codes to IRC
+messages.
+
+Normal text:
+
+ NORMAL
+
+Formatting:
+
+ BOLD
+ UNDERLINE
+ REVERSE
+ ITALIC
+ FIXED
+
+Colors:
+
+ WHITE
+ BLACK
+ DARK_BLUE
+ DARK_GREEN
+ RED
+ BROWN
+ PURPLE
+ ORANGE
+ YELLOW
+ LIGHT_GREEN
+ TEAL
+ CYAN
+ LIGHT_BLUE
+ MAGENTA
+ DARK_GREY
+ LIGHT_GREY
+
+Individual formatting codes can be cancelled with their corresponding constant,
+but you can also cancel all of them at once with C<NORMAL>. To cancel the effect
+of previous color codes, you must use C<NORMAL>. which of course has the side
+effect of cancelling the effect of all previous formatting codes as well.
+
+ $irc->yield('This word is ' . YELLOW . 'yellow' . NORMAL
+ . ' while this word is ' . BOLD . 'bold' . BOLD);
+
+ $irc->yield(UNDERLINE . BOLD . 'This sentence is both underlined and bold.'
+ . NORMAL);
+
+
+
+=head1 FUNCTIONS
+
+=head2 C<u_irc>
+
+Takes one mandatory parameter, a string to convert to IRC uppercase, and one
+optional parameter, the casemapping of the ircd ( which can be 'rfc1459',
+'strict-rfc1459' or 'ascii'. Default is 'rfc1459' ). Returns the IRC uppercase
+equivalent of the passed string.
+
+=head2 C<l_irc>
+
+Takes one mandatory parameter, a string to convert to IRC lowercase, and one
+optional parameter, the casemapping of the ircd ( which can be 'rfc1459',
+'strict-rfc1459' or 'ascii'. Default is 'rfc1459' ). Returns the IRC lowercase
+equivalent of the passed string.
+
+=head2 C<parse_mode_line>
+
+Takes a list representing an IRC mode line. Returns a hashref. If the modeline
+couldn't be parsed the hashref will be empty. On success the following keys
+will be available in the hashref:
+
+ 'modes', an arrayref of normalised modes;
+ 'args', an arrayref of applicable arguments to the modes;
+
+Example:
+
+ my $hashref = parse_mode_line( 'ov+b-i', 'Bob', 'sue', 'stalin*!*@*' );
+
+ # $hashref will be:
+ {
+ modes => [ '+o', '+v', '+b', '-i' ],
+ args => [ 'Bob', 'sue', 'stalin*!*@*' ],
+ }
+
+=head2 C<parse_ban_mask>
+
+Takes one parameter, a string representing an IRC ban mask. Returns a
+normalised full banmask.
+
+Example:
+
+ $fullbanmask = parse_ban_mask( 'stalin*' );
+
+ # $fullbanmask will be: 'stalin*!*@*';
+
+=head2 C<matches_mask>
+
+Takes two parameters, a string representing an IRC mask ( it'll be processed
+with parse_ban_mask() to ensure that it is normalised ) and something to match
+against the IRC mask, such as a nick!user@hostname string. Returns a true
+value if they match, a false value otherwise. Optionally, one may pass the
+casemapping (see L<C<u_irc()>|/"u_irc">), as this function uses C<u_irc()>
+internally.
+
+=head2 C<matches_mask_array>
+
+Takes two array references, the first being a list of strings representing
+IRC masks, the second a list of somethings to test against the masks. Returns
+an empty hashref if there are no matches. Otherwise, the keys will be the
+masks matched, each value being an arrayref of the strings that matched it.
+Optionally, one may pass the casemapping (see L<C<u_irc()>|/"u_irc">), as
+this function uses C<u_irc()> internally.
+
+=head2 C<parse_user>
+
+Takes one parameter, a string representing a user in the form
+nick!user@hostname. In a scalar context it returns just the nickname.
+In a list context it returns a list consisting of the nick, user and hostname,
+respectively.
+
+=head2 C<has_color>
+
+Takes one parameter, a string of IRC text. Returns 1 if it contains any IRC
+color codes, 0 otherwise. Useful if you want your bot to kick users for
+(ab)using colors. :)
+
+=head2 C<has_formatting>
+
+Takes one parameter, a string of IRC text. Returns 1 if it contains any IRC
+formatting codes, 0 otherwise.
+
+=head2 C<strip_color>
+
+Takes one paramter, a string of IRC text. Returns the string stripped of all
+IRC color codes. Due to the fact that both color and formatting codes can
+be cancelled with the same character, this might strip more than you hoped for
+if the string contains both color and formatting codes. Stripping both will
+always do what you expect it to.
+
+=head2 C<strip_formatting>
+
+Takes one paramter, a string of IRC text. Returns the string stripped of all
+IRC formatting codes. Due to the fact that both color and formatting codes can
+be cancelled with the same character, this might strip more than you hoped for
+if the string contains both color and formatting codes. Stripping both will
+always do what you expect it to.
+
+=head2 C<irc_ip_get_version>
+
+Try to guess the IP version of an IP address.
+
+Params: IP address
+Returns: 4, 6, 0(unable to determine)
+
+C<$version = ip_get_version ($ip)>
+
+=head2 C<irc_ip_is_ipv4>
+
+Check if an IP address is of type 4.
+
+Params: IP address
+Returns: 1 (yes) or 0 (no)
+
+C<ip_is_ipv4($ip) and print "$ip is IPv4";>
+
+=head2 C<irc_ip_is_ipv6>
+
+Check if an IP address is of type 6.
+
+Params: IP address
+Returns: 1 (yes) or 0 (no)
+
+ ip_is_ipv6($ip) && print "$ip is IPv6";
+
+=head1 AUTHOR
+
+Dan 'troubled' McGrath
+
+This whole module is shamelessly 'borrowed' from L<POE::Component::IRC::Common>
+by Chris 'BinGOs' Williams
+
+=head1 SEE ALSO
+
+L<POE::Component::IRC::Common>
+
+L<POE::Component::IRC|POE::Component::IRC>
+
+L<Net::IP|Net::IP>
+
+=cut
$learnok = 1 if ($addressed);
if ( $param{'learn'} =~ /^HUNGRY$/i ) {
$learnok = 1;
- $addrchar = 1;
- $talkok = 1;
+ #FIXME: why can we talk if we just want to learn?
+ #$addrchar = 1;
+ #$talkok = 1;
}
&shmFlush(); # hack.
}
# greetings.
- if ( $message =~ /how (the hell )?are (ya|you)( doin\'?g?)?\?*$/ ) {
+ if ( $message =~ /how (the hell )?are (ya|you)( doin\'?g?)?\?*$/ && $talkok ) {
&performReply( &getRandom( keys %{ $lang{'howareyou'} } ) );
return;
# allow administration of bot via messages (default is DCC CHAT only)
if ( &IsFlag('A') ) {
- &loadMyModule('UserDCC');
+ # UserDCC.pl should autoload now from IRC/. Remove if desired
+ #&loadMyModule('UserDCC');
$er = &userDCC();
if ( !defined $er ) {
return 'SOMETHING 2';
#
use strict;
+use utf8;
use vars qw($statcount $bot_pid $forkedtime $statcountfix $addressed);
use vars qw($logDate $logold $logcount $logtime $logrepeat $running);
# logging support.
sub openLog {
+ binmode( STDOUT, ':encoding(UTF-8)' );
return unless ( &IsParam('logfile') );
$file{log} = $param{'logfile'};
projects / infobot.git / commitdiff