From 9b472795d26cd93d1bb58488ef60a062f5237295 Mon Sep 17 00:00:00 2001 From: Janik Kleinhoff Date: Thu, 24 Sep 2015 01:32:11 +0000 Subject: Rework module paths --- Net/IRC.pm | 759 ------------------ Net/IRC/Connection.pm | 1691 --------------------------------------- Net/IRC/DCC.pm | 808 ------------------- Net/IRC/Event.pm | 873 -------------------- Net/IRC/EventQueue.pm | 73 -- Net/IRC/EventQueue/Entry.pm | 40 - lib/ASM/Classes.pm | 514 ++++++++++++ lib/ASM/Commander.pm | 61 ++ lib/ASM/DB.pm | 323 ++++++++ lib/ASM/Event.pm | 887 ++++++++++++++++++++ lib/ASM/Inspect.pm | 101 +++ lib/ASM/Log.pm | 112 +++ lib/ASM/Services.pm | 69 ++ lib/ASM/Util.pm | 297 +++++++ lib/ASM/XML.pm | 69 ++ lib/Net/IRC.pm | 759 ++++++++++++++++++ lib/Net/IRC/Connection.pm | 1691 +++++++++++++++++++++++++++++++++++++++ lib/Net/IRC/DCC.pm | 808 +++++++++++++++++++ lib/Net/IRC/Event.pm | 873 ++++++++++++++++++++ lib/Net/IRC/EventQueue.pm | 73 ++ lib/Net/IRC/EventQueue/Entry.pm | 40 + meta.pl | 26 +- modules/classes.pl | 514 ------------ modules/command.pl | 61 -- modules/event.pl | 887 -------------------- modules/inspect.pl | 101 --- modules/log.pl | 112 --- modules/mysql.pl | 323 -------- modules/services.pl | 69 -- modules/util.pl | 297 ------- modules/xml.pl | 69 -- 31 files changed, 6692 insertions(+), 6688 deletions(-) delete mode 100644 Net/IRC.pm delete mode 100644 Net/IRC/Connection.pm delete mode 100644 Net/IRC/DCC.pm delete mode 100644 Net/IRC/Event.pm delete mode 100644 Net/IRC/EventQueue.pm delete mode 100644 Net/IRC/EventQueue/Entry.pm create mode 100644 lib/ASM/Classes.pm create mode 100644 lib/ASM/Commander.pm create mode 100644 lib/ASM/DB.pm create mode 100644 lib/ASM/Event.pm create mode 100644 lib/ASM/Inspect.pm create mode 100644 lib/ASM/Log.pm create mode 100644 lib/ASM/Services.pm create mode 100644 lib/ASM/Util.pm create mode 100644 lib/ASM/XML.pm create mode 100644 lib/Net/IRC.pm create mode 100644 lib/Net/IRC/Connection.pm create mode 100644 lib/Net/IRC/DCC.pm create mode 100644 lib/Net/IRC/Event.pm create mode 100644 lib/Net/IRC/EventQueue.pm create mode 100644 lib/Net/IRC/EventQueue/Entry.pm delete mode 100644 modules/classes.pl delete mode 100644 modules/command.pl delete mode 100644 modules/event.pl delete mode 100644 modules/inspect.pl delete mode 100644 modules/log.pl delete mode 100644 modules/mysql.pl delete mode 100644 modules/services.pl delete mode 100644 modules/util.pl delete mode 100644 modules/xml.pl diff --git a/Net/IRC.pm b/Net/IRC.pm deleted file mode 100644 index 9e39458..0000000 --- a/Net/IRC.pm +++ /dev/null @@ -1,759 +0,0 @@ -##################################################################### -# # -# Net::IRC -- Object-oriented Perl interface to an IRC server # -# # -# IRC.pm: A nifty little wrapper that makes your life easier. # -# # -# Copyright (c) 1997 Greg Bacon & Dennis Taylor. # -# All rights reserved. # -# # -# This module is free software; you can redistribute or # -# modify it under the terms of Perl's Artistic License. # -# # -##################################################################### -# $Id: IRC.pm,v 1.10 2004/04/30 18:02:51 jmuhlich Exp $ - - -package Net::IRC; - -BEGIN { require 5.004; } # needs IO::* and $coderef->(@args) syntax - -use Net::IRC::Connection; -use Net::IRC::EventQueue; -use IO::Select; -use Carp; - - -# grab the drop-in replacement for time() from Time::HiRes, if it's available -BEGIN { - Time::HiRes->import('time') if eval "require Time::HiRes"; -} - - -use strict; -use vars qw($VERSION); - -$VERSION = "0.80"; - -sub new { - my $proto = shift; - - my $self = { - '_conn' => [], - '_connhash' => {}, - '_error' => IO::Select->new(), - '_debug' => 0, - '_schedulequeue' => new Net::IRC::EventQueue(), - '_outputqueue' => new Net::IRC::EventQueue(), - '_read' => IO::Select->new(), - '_timeout' => 1, - '_write' => IO::Select->new(), - }; - - bless $self, $proto; - - return $self; -} - -sub outputqueue { - my $self = shift; - return $self->{_outputqueue}; -} - -sub schedulequeue { - my $self = shift; - return $self->{_schedulequeue}; -} - -# Front end to addfh(), below. Sets it to read by default. -# Takes at least 1 arg: an object to add to the select loop. -# (optional) a flag string to pass to addfh() (see below) -sub addconn { - my ($self, $conn) = @_; - - $self->addfh( $conn->socket, $conn->can('parse'), ($_[2] || 'r'), $conn); -} - -# Adds a filehandle to the select loop. Tasty and flavorful. -# Takes 3 args: a filehandle or socket to add -# a coderef (can be undef) to pass the ready filehandle to for -# user-specified reading/writing/error handling. -# (optional) a string with r/w/e flags, similar to C's fopen() syntax, -# except that you can combine flags (i.e., "rw"). -# (optional) an object that the coderef is a method of -sub addfh { - my ($self, $fh, $code, $flag, $obj) = @_; - my ($letter); - - die "Not enough arguments to IRC->addfh()" unless defined $code; - - if ($flag) { - foreach $letter (split(//, lc $flag)) { - if ($letter eq 'r') { - $self->{_read}->add( $fh ); - } elsif ($letter eq 'w') { - $self->{_write}->add( $fh ); - } elsif ($letter eq 'e') { - $self->{_error}->add( $fh ); - } - } - } else { - $self->{_read}->add( $fh ); - } - - $self->{_connhash}->{$fh} = [ $code, $obj ]; -} - -# Sets or returns the debugging flag for this object. -# Takes 1 optional arg: a new boolean value for the flag. -sub debug { - my $self = shift; - - if (@_) { - $self->{_debug} = $_[0]; - } - return $self->{_debug}; -} - -# Goes through one iteration of the main event loop. Useful for integrating -# other event-based systems (Tk, etc.) with Net::IRC. -# Takes no args. -sub do_one_loop { - my $self = shift; - my ($ev, $sock, $time, $nexttimer, $timeout); - my (undef, undef, undef, $caller) = caller(1); - - $time = time(); # no use calling time() all the time. - - if(!$self->outputqueue->is_empty) { - my $outputevent = undef; - while(defined($outputevent = $self->outputqueue->head) - && $outputevent->time <= $time) { - $outputevent = $self->outputqueue->dequeue(); - $outputevent->content->{coderef}->(@{$outputevent->content->{args}}); - } - $nexttimer = $self->outputqueue->head->time if !$self->outputqueue->is_empty(); - } - - # we don't want to bother waiting on input or running - # scheduled events if we're just flushing the output queue - # so we bail out here - return if $caller eq 'Net::IRC::flush_output_queue'; - - # Check the queue for scheduled events to run. - if(!$self->schedulequeue->is_empty) { - my $scheduledevent = undef; - while(defined($scheduledevent = $self->schedulequeue->head) && $scheduledevent->time <= $time) { - $scheduledevent = $self->schedulequeue->dequeue(); - $scheduledevent->content->{coderef}->(@{$scheduledevent->content->{args}}); - } - if(!$self->schedulequeue->is_empty() - && $nexttimer - && $self->schedulequeue->head->time < $nexttimer) { - $nexttimer = $self->schedulequeue->head->time; - } - } - - # Block until input arrives, then hand the filehandle over to the - # user-supplied coderef. Look! It's a freezer full of government cheese! - - if ($nexttimer) { - $timeout = $nexttimer - $time < $self->{_timeout} - ? $nexttimer - $time : $self->{_timeout}; - } else { - $timeout = $self->{_timeout}; - } - foreach $ev (IO::Select->select($self->{_read}, - $self->{_write}, - $self->{_error}, - $timeout)) { - foreach $sock (@{$ev}) { - my $conn = $self->{_connhash}->{$sock}; - $conn or next; - - # $conn->[0] is a code reference to a handler sub. - # $conn->[1] is optionally an object which the - # handler sub may be a method of. - - $conn->[0]->($conn->[1] ? ($conn->[1], $sock) : $sock); - } - } -} - -sub flush_output_queue { - my $self = shift; - - while(!$self->outputqueue->is_empty()) { - $self->do_one_loop(); - } -} - -# Creates and returns a new Connection object. -# Any args here get passed to Connection->connect(). -sub newconn { - my $self = shift; - my $conn = Net::IRC::Connection->new($self, @_); - - return if $conn->error; - return $conn; -} - -# Takes the args passed to it by Connection->schedule()... see it for details. -sub enqueue_scheduled_event { - my $self = shift; - my $time = shift; - my $coderef = shift; - my @args = @_; - - return $self->schedulequeue->enqueue($time, { coderef => $coderef, args => \@args }); -} - -# Takes a scheduled event ID to remove from the queue. -# Returns the deleted coderef, if you actually care. -sub dequeue_scheduled_event { - my ($self, $id) = @_; - $self->schedulequeue->dequeue($id); -} - -# Takes the args passed to it by Connection->schedule()... see it for details. -sub enqueue_output_event { - my $self = shift; - my $time = shift; - my $coderef = shift; - my @args = @_; - - return $self->outputqueue->enqueue($time, { coderef => $coderef, args => \@args }); -} - -# Takes a scheduled event ID to remove from the queue. -# Returns the deleted coderef, if you actually care. -sub dequeue_output_event { - my ($self, $id) = @_; - $self->outputqueue->dequeue($id); -} - -# Front-end for removefh(), below. -# Takes 1 arg: a Connection (or DCC or whatever) to remove. -sub removeconn { - my ($self, $conn) = @_; - - $self->removefh( $conn->socket ); -} - -# Given a filehandle, removes it from all select lists. You get the picture. -sub removefh { - my ($self, $fh) = @_; - - $self->{_read}->remove( $fh ); - $self->{_write}->remove( $fh ); - $self->{_error}->remove( $fh ); - delete $self->{_connhash}->{$fh}; -} - -# Begin the main loop. Wheee. Hope you remembered to set up your handlers -# first... (takes no args, of course) -sub start { - my $self = shift; - - while (1) { - $self->do_one_loop(); - } -} - -# Sets or returns the current timeout, in seconds, for the select loop. -# Takes 1 optional arg: the new value for the timeout, in seconds. -# Fractional timeout values are just fine, as per the core select(). -sub timeout { - my $self = shift; - - if (@_) { $self->{_timeout} = $_[0] } - return $self->{_timeout}; -} - -1; - - -__END__ - - -=head1 NAME - -Net::IRC - DEAD SINCE 2004 Perl interface to the Internet Relay Chat protocol - -=head1 USE THESE INSTEAD - -This module has been abandoned and is no longer developed. This release serves -only to warn current and future users about this and to direct them to supported -and actively-developed libraries for connecting Perl to IRC. Most new users will -want to use L, whereas more advanced users will appreciate the -flexibility offered by L. We understand that porting code -to a new framework can be difficult. Please stop by #perl on irc.freenode.net -and we'll be happy to help you out with bringing your bots into the modern era. - -=head1 SYNOPSIS - - use Net::IRC; - - $irc = new Net::IRC; - $conn = $irc->newconn(Nick => 'some_nick', - Server => 'some.irc.server.com', - Port => 6667, - Ircname => 'Some witty comment.'); - $irc->start; - -=head1 DESCRIPTION - -This module has been abandoned and deprecated since 2004. The original authors -have moved onto L and more modern techniques. This -distribution is not maintained and only uploaded to present successively louder -"don't use this" warnings to those unaware. - -Welcome to Net::IRC, a work in progress. First intended to be a quick tool -for writing an IRC script in Perl, Net::IRC has grown into a comprehensive -Perl implementation of the IRC protocol (RFC 1459), developed by several -members of the EFnet IRC channel #perl, and maintained in channel #net-irc. - -There are 4 component modules which make up Net::IRC: - -=over - -=item * - -Net::IRC - -The wrapper for everything else, containing methods to generate -Connection objects (see below) and a connection manager which does an event -loop on all available filehandles. Sockets or files which are readable (or -writable, or whatever you want it to select() for) get passed to user-supplied -handler subroutines in other packages or in user code. - -=item * - -Net::IRC::Connection - -The big time sink on this project. Each Connection instance is a -single connection to an IRC server. The module itself contains methods for -every single IRC command available to users (Net::IRC isn't designed for -writing servers, for obvious reasons), methods to set, retrieve, and call -handler functions which the user can set (more on this later), and too many -cute comments. Hey, what can I say, we were bored. - -=item * - -Net::IRC::Event - -Kind of a struct-like object for storing info about things that the -IRC server tells you (server responses, channel talk, joins and parts, et -cetera). It records who initiated the event, who it affects, the event -type, and any other arguments provided for that event. Incidentally, the -only argument passed to a handler function. - -=item * - -Net::IRC::DCC - -The analogous object to Connection.pm for connecting, sending and -retrieving with the DCC protocol. Instances of DCC.pm are invoked from -Cnew_{send,get,chat}> in the same way that -Cnewconn> invokes Cnew>. This will make more -sense later, we promise. - -=back - -The central concept that Net::IRC is built around is that of handlers -(or hooks, or callbacks, or whatever the heck you feel like calling them). -We tried to make it a completely event-driven model, a la Tk -- for every -conceivable type of event that your client might see on IRC, you can give -your program a custom subroutine to call. But wait, there's more! There are -3 levels of handler precedence: - -=over - -=item * - -Default handlers - -Considering that they're hardwired into Net::IRC, these won't do -much more than the bare minimum needed to keep the client listening on the -server, with an option to print (nicely formatted, of course) what it hears -to whatever filehandles you specify (STDOUT by default). These get called -only when the user hasn't defined any of his own handlers for this event. - -=item * - -User-definable global handlers - -The user can set up his own subroutines to replace the default -actions for I IRC connection managed by your program. These only get -invoked if the user hasn't set up a per-connection handler for the same -event. - -=item * - -User-definable per-connection handlers - -Simple: this tells a single connection what to do if it gets an event of -this type. Supersedes global handlers if any are defined for this event. - -=back - -And even better, you can choose to call your custom handlers before -or after the default handlers instead of replacing them, if you wish. In -short, it's not perfect, but it's about as good as you can get and still be -documentable, given the sometimes horrendous complexity of the IRC protocol. - - -=head1 GETTING STARTED - -=head2 Initialization - -To start a Net::IRC script, you need two things: a Net::IRC object, and a -Net::IRC::Connection object. The Connection object does the dirty work of -connecting to the server; the IRC object handles the input and output for it. -To that end, say something like this: - - use Net::IRC; - - $irc = new Net::IRC; - - $conn = $irc->newconn(Nick => 'some_nick', - Server => 'some.irc.server.com'); - -...or something similar. Acceptable parameters to newconn() are: - -=over - -=item * - -Nick - -The nickname you'll be known by on IRC, often limited to a maximum of 9 -letters. Acceptable characters for a nickname are C<[\w{}[]\`^|-]>. If -you don't specify a nick, it defaults to your username. - -=item * - -Server - -The IRC server to connect to. There are dozens of them across several -widely-used IRC networks, but the oldest and most popular is EFNet (Eris -Free Net), home to #perl. See http://www.irchelp.org/ for lists of -popular servers, or ask a friend. - -=item * - -Port - -The port to connect to this server on. By custom, the default is 6667. - -=item * - -Username - -On systems not running identd, you can set the username for your user@host -to anything you wish. Note that some IRC servers won't allow connections from -clients which don't run identd. - -=item * - -Ircname - -A short (maybe 60 or so chars) piece of text, originally intended to display -your real name, which people often use for pithy quotes and URLs. Defaults to -the contents of your GECOS field. - -=item * - -Password - -If the IRC server you're trying to write a bot for is -password-protected, no problem. Just say "C 'foo'>" and -you're set. - -=item * - -SSL - -If you wish to connect to an irc server which is using SSL, set this to a -true value. Ie: "C 1>". - -=back - -=head2 Handlers - -Once that's over and done with, you need to set up some handlers if you want -your bot to do anything more than sit on a connection and waste resources. -Handlers are references to subroutines which get called when a specific event -occurs. Here's a sample handler sub: - - # What to do when the bot successfully connects. - sub on_connect { - my $self = shift; - - print "Joining #IRC.pm..."; - $self->join("#IRC.pm"); - $self->privmsg("#IRC.pm", "Hi there."); - } - -The arguments to a handler function are always the same: - -=over - -=item $_[0]: - -The Connection object that's calling it. - -=item $_[1]: - -An Event object (see below) that describes what the handler is responding to. - -=back - -Got it? If not, see the examples in the irctest script that came with this -distribution. Anyhow, once you've defined your handler subroutines, you need -to add them to the list of handlers as either a global handler (affects all -Connection objects) or a local handler (affects only a single Connection). To -do so, say something along these lines: - - $self->add_global_handler('376', \&on_connect); # global - $self->add_handler('msg', \&on_msg); # local - -376, incidentally, is the server number for "end of MOTD", which is an event -that the server sends to you after you're connected. See Event.pm for a list -of all possible numeric codes. The 'msg' event gets called whenever someone -else on IRC sends your client a private message. For a big list of possible -events, see the B section in the documentation for -Net::IRC::Event. - -=head2 Getting Connected - -When you've set up all your handlers, the following command will put your -program in an infinite loop, grabbing input from all open connections and -passing it off to the proper handlers: - - $irc->start; - -Note that new connections can be added and old ones dropped from within your -handlers even after you call this. Just don't expect any code below the call -to C to ever get executed. - -If you're tying Net::IRC into another event-based module, such as perl/Tk, -there's a nifty C method provided for your convenience. Calling -C<$irc-Edo_one_loop()> runs through the IRC.pm event loop once, hands -all ready filehandles over to the appropriate handler subs, then returns -control to your program. - -=head1 METHOD DESCRIPTIONS - -This section contains only the methods in IRC.pm itself. Lists of the -methods in Net::IRC::Connection, Net::IRC::Event, or Net::IRC::DCC are in -their respective modules' documentation; just C -(or Event or DCC or whatever) to read them. Functions take no arguments -unless otherwise specified in their description. - -By the way, expect Net::IRC to use AutoLoader sometime in the future, once -it becomes a little more stable. - -=over - -=item * - -addconn() - -Adds the specified object's socket to the select loop in C. -This is mostly for the use of Connection and DCC objects (and for pre-0.5 -compatibility)... for most (read: all) purposes, you can just use C, -described below. - -Takes at least 1 arg: - -=over - -=item 0. - -An object whose socket needs to be added to the select loop - -=item 1. - -B A string consisting of one or more of the letters r, w, and e. -Passed directly to C... see the description below for more info. - -=back - -=item * - -addfh() - -This sub takes a user's socket or filehandle and a sub to handle it with and -merges it into C's list of select()able filehandles. This makes -integration with other event-based systems (Tk, for instance) a good deal -easier than in previous releases. - -Takes at least 2 args: - -=over - -=item 0. - -A socket or filehandle to monitor - -=item 1. - -A reference to a subroutine. When C determines that the filehandle -is ready, it passes the filehandle to this (presumably user-supplied) sub, -where you can read from it, write to it, etc. as your script sees fit. - -=item 2. - -B A string containing any combination of the letters r, w or e -(standing for read, write, and error, respectively) which determines what -conditions you're expecting on that filehandle. For example, this line -select()s $fh (a filehandle, of course) for both reading and writing: - - $irc->addfh( $fh, \&callback, "rw" ); - -=back - -=item * - -do_one_loop() - -Cs on all open filehandles and passes any ready ones to the -appropriate handler subroutines. Also responsible for executing scheduled -events from Cschedule()> on time. - -=item * - -new() - -A fairly vanilla constructor which creates and returns a new Net::IRC object. - -=item * - -newconn() - -Creates and returns a new Connection object. All arguments are passed straight -to Cnew()>; examples of common arguments can be -found in the B or B sections. - -=item * - -removeconn() - -Removes the specified object's socket from C's list of -select()able filehandles. This is mostly for the use of Connection and DCC -objects (and for pre-0.5 compatibility)... for most (read: all) purposes, -you can just use C, described below. - -Takes 1 arg: - -=over - -=item 0. - -An object whose socket or filehandle needs to be removed from the select loop - -=back - -=item * - -removefh() - -This method removes a given filehandle from C's list of -selectable filehandles. - -Takes 1 arg: - -=over - -=item 0. - -A socket or filehandle to remove - -=back - -=item * - -start() - -Starts an infinite event loop which repeatedly calls C to -read new events from all open connections and pass them off to any -applicable handlers. - -=item * - -timeout() - -Sets or returns the current C timeout for the main event loop, in -seconds (fractional amounts allowed). See the documentation for the -C function for more info. - -Takes 1 optional arg: - -=over - -=item 0. - -B A new value for the C timeout for this IRC object. - -=back - -=item * - -flush_output_queue() - -Flushes any waiting messages in the output queue if pacing is enabled. This -method will not return until the output queue is empty. - -=over - -=back - -=head1 AUTHORS - -=over - -=item * - -Conceived and initially developed by Greg Bacon Egbacon@adtran.comE -and Dennis Taylor Edennis@funkplanet.comE. - -=item * - -Ideas and large amounts of code donated by Nat "King" Torkington -Egnat@frii.comE. - -=item * - -Currently being hacked on, hacked up, and worked over by the members of the -Net::IRC developers mailing list. For details, see -http://www.execpc.com/~corbeau/irc/list.html . - -=back - -=head1 URL - -Up-to-date source and information about the Net::IRC project can be found at -http://www.sourceforge.net/projects/net-irc/ . - -=head1 SEE ALSO - -=over - -=item * - -perl(1). - -=item * - -RFC 1459: The Internet Relay Chat Protocol - -=item * - -http://www.irchelp.org/, home of fine IRC resources. - -=back - -=cut - - diff --git a/Net/IRC/Connection.pm b/Net/IRC/Connection.pm deleted file mode 100644 index 6918bda..0000000 --- a/Net/IRC/Connection.pm +++ /dev/null @@ -1,1691 +0,0 @@ -##################################################################### -# # -# Net::IRC -- Object-oriented Perl interface to an IRC server # -# # -# Connection.pm: The basic functions for a simple IRC connection # -# # -# # -# Copyright (c) 2001 Pete Sergeant, Greg Bacon & Dennis Taylor. # -# All rights reserved. # -# # -# This module is free software; you can redistribute or # -# modify it under the terms of Perl's Artistic License. # -# # -##################################################################### - -package Net::IRC::Connection; - -use Net::IRC::Event; -use Net::IRC::DCC; -use IO::Socket; -use IO::Socket::INET; -use Symbol; -use Carp; -use Data::Dumper; - -# all this junk below just to conditionally load a module -# sometimes even perl is braindead... - -eval 'use Time::HiRes qw(time)'; -if(!$@) { - sub time (); - use subs 'time'; - require Time::HiRes; - Time::HiRes->import('time'); -} - -use strict; - -use vars ( - '$AUTOLOAD', -); - - -# The names of the methods to be handled by &AUTOLOAD. -my %autoloaded = ( 'ircname' => undef, - 'port' => undef, - 'username' => undef, - 'socket' => undef, - 'verbose' => undef, - 'parent' => undef, - 'hostname' => undef, - 'pacing' => undef, - 'ssl' => undef, - ); - -# This hash will contain any global default handlers that the user specifies. - -my %_udef = (); - -# Creates a new IRC object and assigns some default attributes. -sub new { - my $proto = shift; - - my $self = { # obvious defaults go here, rest are user-set - _debug => $_[0]->{_debug}, - _port => 6667, - # Evals are for non-UNIX machines, just to make sure. - _username => eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "japh", - _ircname => $ENV{IRCNAME} || eval { (getpwuid($>))[6] } || "Just Another Perl Hacker", - _nick => $ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "WankerBot", - _ignore => {}, - _handler => {}, - _verbose => 0, # Is this an OK default? - _parent => shift, - _frag => '', - _connected => 0, - _maxlinelen => 510, # The RFC says we shouldn't exceed this. - _lastsl => 0, - _pacing => 0, # no pacing by default - _ssl => 0, # no ssl by default - _format => { 'default' => "[%f:%t] %m <%d>", }, - _rx => 0, - _tx => 0, - }; - - bless $self, $proto; - # do any necessary initialization here - $self->connect(@_) if @_; - - return $self; -} - -# Takes care of the methods in %autoloaded -# Sets specified attribute, or returns its value if called without args. -sub AUTOLOAD { - my $self = @_; ## can't modify @_ for goto &name - my $class = ref $self; ## die here if !ref($self) ? - my $meth; - - # -- #perl was here! -- - # absolute power corrupts absolutely, but it's a helluva lot - # of fun. - # =) - - ($meth = $AUTOLOAD) =~ s/^.*:://; ## strip fully qualified portion - - unless (exists $autoloaded{$meth}) { - croak "No method called \"$meth\" for $class object."; - } - - eval <{"_$meth"}; - - \$self->{"_$meth"} = shift; - - return \$old; - } - else { - return \$self->{"_$meth"}; - } -} -EOSub - - # no reason to play this game every time - goto &$meth; -} - -# This sub is the common backend to add_handler and add_global_handler -# -sub _add_generic_handler { - my ($self, $event, $ref, $rp, $hash_ref, $real_name) = @_; - my $ev; - my %define = ( "replace" => 0, "before" => 1, "after" => 2 ); - - unless (@_ >= 3) { - croak "Not enough arguments to $real_name()"; - } - unless (ref($ref) eq 'CODE') { - croak "Second argument of $real_name isn't a coderef"; - } - - # Translate REPLACE, BEFORE and AFTER. - if (not defined $rp) { - $rp = 0; - } elsif ($rp =~ /^\D/) { - $rp = $define{lc $rp} || 0; - } - - foreach $ev (ref $event eq "ARRAY" ? @{$event} : $event) { - # Translate numerics to names - if ($ev =~ /^\d/) { - $ev = Net::IRC::Event->trans($ev); - unless ($ev) { - carp "Unknown event type in $real_name: $ev"; - return; - } - } - - $hash_ref->{lc $ev} = [ $ref, $rp ]; - } - return 1; -} - -# This sub will assign a user's custom function to a particular event which -# might be received by any Connection object. -# Takes 3 args: the event to modify, as either a string or numeric code -# If passed an arrayref, the array is assumed to contain -# all event names which you want to set this handler for. -# a reference to the code to be executed for the event -# (optional) A value indicating whether the user's code should replace -# the built-in handler, or be called with it. Possible values: -# 0 - Replace the built-in handlers entirely. (the default) -# 1 - Call this handler right before the default handler. -# 2 - Call this handler right after the default handler. -# These can also be referred to by the #define-like strings in %define. -sub add_global_handler { - my ($self, $event, $ref, $rp) = @_; - return $self->_add_generic_handler($event, $ref, $rp, \%_udef, 'add_global_handler'); -} - -# This sub will assign a user's custom function to a particular event which -# this connection might receive. Same args as above. -sub add_handler { - my ($self, $event, $ref, $rp) = @_; - return $self->_add_generic_handler($event, $ref, $rp, $self->{_handler}, 'add_handler'); -} - -# Hooks every event we know about... -sub add_default_handler { - my ($self, $ref, $rp) = @_; - foreach my $eventtype (keys(%Net::IRC::Event::_names)) { - $self->_add_generic_handler($eventtype, $ref, $rp, $self->{_handler}, 'add_default_handler'); - } - return 1; -} - -# Why do I even bother writing subs this simple? Sends an ADMIN command. -# Takes 1 optional arg: the name of the server you want to query. -sub admin { - my $self = shift; # Thank goodness for AutoLoader, huh? - # Perhaps we'll finally use it soon. - - $self->sl("ADMIN" . ($_[0] ? " $_[0]" : "")); -} - -# Toggles away-ness with the server. Optionally takes an away message. -sub away { - my $self = shift; - $self->sl("AWAY" . ($_[0] ? " :$_[0]" : "")); -} - -# Attempts to connect to the specified IRC (server, port) with the specified -# (nick, username, ircname). Will close current connection if already open. -sub connect { - my $self = shift; - my ($password, $sock); - - if (@_) { - my (%arg) = @_; - - $self->hostname($arg{'LocalAddr'}) if exists $arg{'LocalAddr'}; - $password = $arg{'Password'} if exists $arg{'Password'}; - $self->nick($arg{'Nick'}) if exists $arg{'Nick'}; - $self->port($arg{'Port'}) if exists $arg{'Port'}; - $self->server($arg{'Server'}) if exists $arg{'Server'}; - $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'}; - $self->username($arg{'Username'}) if exists $arg{'Username'}; - $self->pacing($arg{'Pacing'}) if exists $arg{'Pacing'}; - $self->ssl($arg{'SSL'}) if exists $arg{'SSL'}; - } - - # Lots of error-checking claptrap first... - unless ($self->server) { - unless ($ENV{IRCSERVER}) { - croak "No server address specified in connect()"; - } - $self->server( $ENV{IRCSERVER} ); - } - unless ($self->nick) { - $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) } - || $ENV{USER} || $ENV{LOGNAME} || "WankerBot"); - } - unless ($self->port) { - $self->port($ENV{IRCPORT} || 6667); - } - unless ($self->ircname) { - $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] } - || "Just Another Perl Hacker"); - } - unless ($self->username) { - $self->username(eval { scalar getpwuid($>) } || $ENV{USER} - || $ENV{LOGNAME} || "japh"); - } - - # Now for the socket stuff... - if ($self->connected) { - $self->quit("Changing servers"); - } - - if($self->ssl) { - require IO::Socket::SSL; - - $self->socket(IO::Socket::SSL->new(PeerAddr => $self->server, - PeerPort => $self->port, - Proto => "tcp", - LocalAddr => $self->hostname, - )); - } else { - - $self->socket(IO::Socket::INET->new(PeerAddr => $self->server, - PeerPort => $self->port, - Proto => "tcp", - LocalAddr => $self->hostname, - )); - } - - if(!$self->socket) { - carp (sprintf "Can't connect to %s:%s!", - $self->server, $self->port); - $self->error(1); - return; - } - - # Send a PASS command if they specified a password. According to - # the RFC, we should do this as soon as we connect. - if (defined $password) { - $self->sl("PASS $password"); - } - - # Now, log in to the server... - unless ($self->sl('NICK ' . $self->nick()) and - $self->sl(sprintf("USER %s %s %s :%s", - $self->username(), - "foo.bar.com", - $self->server(), - $self->ircname()))) { - carp "Couldn't send introduction to server: $!"; - $self->error(1); - $! = "Couldn't send NICK/USER introduction to " . $self->server; - return; - } - - $self->{_connected} = 1; - $self->parent->addconn($self); -} - -# Returns a boolean value based on the state of the object's socket. -sub connected { - my $self = shift; - - return ( $self->{_connected} and $self->socket() ); -} - -# Sends a CTCP request to some hapless victim(s). -# Takes at least two args: the type of CTCP request (case insensitive) -# the nick or channel of the intended recipient(s) -# Any further args are arguments to CLIENTINFO, ERRMSG, or ACTION. -sub ctcp { - my ($self, $type, $target) = splice @_, 0, 3; - $type = uc $type; - - unless ($target) { - croak "Not enough arguments to ctcp()"; - } - - if ($type eq "PING") { - unless ($self->sl("PRIVMSG $target :\001PING " . int(time) . "\001")) { - carp "Socket error sending $type request in ctcp()"; - return; - } - } elsif (($type eq "CLIENTINFO" or $type eq "ACTION") and @_) { - unless ($self->sl("PRIVMSG $target :\001$type " . - CORE::join(" ", @_) . "\001")) { - carp "Socket error sending $type request in ctcp()"; - return; - } - } elsif ($type eq "ERRMSG") { - unless (@_) { - carp "Not enough arguments to $type in ctcp()"; - return; - } - unless ($self->sl("PRIVMSG $target :\001ERRMSG " . - CORE::join(" ", @_) . "\001")) { - carp "Socket error sending $type request in ctcp()"; - return; - } - } else { - unless ($self->sl("PRIVMSG $target :\001$type " . - CORE::join(" ",@_) . "\001")) { - carp "Socket error sending $type request in ctcp()"; - return; - } - } -} - -# Sends replies to CTCP queries. Simple enough, right? -# Takes 2 args: the target person or channel to send a reply to -# the text of the reply -sub ctcp_reply { - my $self = shift; - - $self->notice($_[0], "\001" . $_[1] . "\001"); -} - - -# Sets or returns the debugging flag for this object. -# Takes 1 optional arg: a new boolean value for the flag. -sub debug { - my $self = shift; - if (@_) { - $self->{_debug} = $_[0]; - } - return $self->{_debug}; -} - - -# Dequotes CTCP messages according to ctcp.spec. Nothing special. -# Then it breaks them into their component parts in a flexible, ircII- -# compatible manner. This is not quite as trivial. Oh, well. -# Takes 1 arg: the line to be dequoted. -sub dequote { - my $line = shift; - my ($order, @chunks) = (0, ()); # CHUNG! CHUNG! CHUNG! - - # Filter misplaced \001s before processing... (Thanks, Tom!) - substr($line, rindex($line, "\001"), 1) = '\\a' - unless ($line =~ tr/\001//) % 2 == 0; - - # Thanks to Abigail (abigail@fnx.com) for this clever bit. - if (index($line, "\cP") >= 0) { # dequote low-level \n, \r, ^P, and \0. - my (%h) = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP"); - $line =~ s/\cP([nr0\cP])/$h{$1}/g; - } - $line =~ s/\\([^\\a])/$1/g; # dequote unnecessarily quoted characters. - - # If true, it's in odd order... ctcp commands start with first chunk. - $order = 1 if index($line, "\001") == 0; - @chunks = map { s/\\\\/\\/g; $_ } (split /\cA/, $line); - - return ($order, @chunks); -} - -# Standard destructor method for the GC routines. (HAHAHAH! DIE! DIE! DIE!) -sub DESTROY { - my $self = shift; - $self->handler("destroy", "nobody will ever use this"); - $self->quit(); - # anything else? -} - - -# Disconnects this Connection object cleanly from the server. -# Takes at least 1 arg: the format and args parameters to Event->new(). -sub disconnect { - my $self = shift; - - $self->{_connected} = 0; - $self->parent->removeconn($self); - $self->socket( undef ); - $self->handler(Net::IRC::Event->new( "disconnect", - $self->server, - '', - @_ )); -} - - -# Tells IRC.pm if there was an error opening this connection. It's just -# for sane error passing. -# Takes 1 optional arg: the new value for $self->{'iserror'} -sub error { - my $self = shift; - - $self->{'iserror'} = $_[0] if @_; - return $self->{'iserror'}; -} - -# Lets the user set or retrieve a format for a message of any sort. -# Takes at least 1 arg: the event whose format you're inquiring about -# (optional) the new format to use for this event -sub format { - my ($self, $ev) = splice @_, 0, 2; - - unless ($ev) { - croak "Not enough arguments to format()"; - } - - if (@_) { - $self->{'_format'}->{$ev} = $_[0]; - } else { - return ($self->{'_format'}->{$ev} || - $self->{'_format'}->{'default'}); - } -} - -# Calls the appropriate handler function for a specified event. -# Takes 2 args: the name of the event to handle -# the arguments to the handler function -sub handler { - my ($self, $event) = splice @_, 0, 2; - - unless (defined $event) { - croak 'Too few arguments to Connection->handler()'; - } - - # Get name of event. - my $ev; - if (ref $event) { - $ev = $event->type; - } elsif (defined $event) { - $ev = $event; - $event = Net::IRC::Event->new($event, '', '', ''); - } else { - croak "Not enough arguments to handler()"; - } - - print STDERR "Trying to handle event '$ev'.\n" if $self->{_debug}; - - my $handler = undef; - if (exists $self->{_handler}->{$ev}) { - $handler = $self->{_handler}->{$ev}; - } elsif (exists $_udef{$ev}) { - $handler = $_udef{$ev}; - } else { - return $self->_default($event, @_); - } - - my ($code, $rp) = @{$handler}; - - # If we have args left, try to call the handler. - if ($rp == 0) { # REPLACE - &$code($self, $event, @_); - } elsif ($rp == 1) { # BEFORE - &$code($self, $event, @_); - $self->_default($event, @_); - } elsif ($rp == 2) { # AFTER - $self->_default($event, @_); - &$code($self, $event, @_); - } else { - confess "Bad parameter passed to handler(): rp=$rp"; - } - - warn "Handler for '$ev' called.\n" if $self->{_debug}; - - return 1; -} - -# Lets a user set hostmasks to discard certain messages from, or (if called -# with only 1 arg), show a list of currently ignored hostmasks of that type. -# Takes 2 args: type of ignore (public, msg, ctcp, etc) -# (optional) [mask(s) to be added to list of specified type] -sub ignore { - my $self = shift; - - unless (@_) { - croak "Not enough arguments to ignore()"; - } - - if (@_ == 1) { - if (exists $self->{_ignore}->{$_[0]}) { - return @{ $self->{_ignore}->{$_[0]} }; - } else { - return (); - } - } elsif (@_ > 1) { # code defensively, remember... - my $type = shift; - - # I moved this part further down as an Obsessive Efficiency - # Initiative. It shouldn't be a problem if I do _parse right... - # ... but those are famous last words, eh? - unless (grep {$_ eq $type} - qw(public msg ctcp notice channel nick other all)) { - carp "$type isn't a valid type to ignore()"; - return; - } - - if ( exists $self->{_ignore}->{$type} ) { - push @{$self->{_ignore}->{$type}}, @_; - } else { - $self->{_ignore}->{$type} = [ @_ ]; - } - } -} - - -# Yet Another Ridiculously Simple Sub. Sends an INFO command. -# Takes 1 optional arg: the name of the server to query. -sub info { - my $self = shift; - - $self->sl("INFO" . ($_[0] ? " $_[0]" : "")); -} - - -# Invites someone to an invite-only channel. Whoop. -# Takes 2 args: the nick of the person to invite -# the channel to invite them to. -# I hate the syntax of this command... always seemed like a protocol flaw. -sub invite { - my $self = shift; - - unless (@_ > 1) { - croak "Not enough arguments to invite()"; - } - - $self->sl("INVITE $_[0] $_[1]"); -} - -# Checks if a particular nickname is in use. -# Takes at least 1 arg: nickname(s) to look up. -sub ison { - my $self = shift; - - unless (@_) { - croak 'Not enough args to ison().'; - } - - $self->sl("ISON " . CORE::join(" ", @_)); -} - -# Joins a channel on the current server if connected, eh?. -# Corresponds to /JOIN command. -# Takes 2 args: name of channel to join -# optional channel password, for +k channels -sub join { - my $self = shift; - - unless ( $self->connected ) { - carp "Can't join() -- not connected to a server"; - return; - } - - unless (@_) { - croak "Not enough arguments to join()"; - } - - return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : "")); - -} - -# Takes at least 2 args: the channel to kick the bastard from -# the nick of the bastard in question -# (optional) a parting comment to the departing bastard -sub kick { - my $self = shift; - - unless (@_ > 1) { - croak "Not enough arguments to kick()"; - } - return $self->sl("KICK $_[0] $_[1]" . ($_[2] ? " :$_[2]" : "")); -} - -# Gets a list of all the servers that are linked to another visible server. -# Takes 2 optional args: it's a bitch to describe, and I'm too tired right -# now, so read the RFC. -sub links { - my ($self) = (shift, undef); - - $self->sl("LINKS" . (scalar(@_) ? " " . CORE::join(" ", @_[0,1]) : "")); -} - - -# Requests a list of channels on the server, or a quick snapshot of the current -# channel (the server returns channel name, # of users, and topic for each). -sub list { - my $self = shift; - - $self->sl("LIST " . CORE::join(",", @_)); -} - -# Sends a request for some server/user stats. -# Takes 1 optional arg: the name of a server to request the info from. -sub lusers { - my $self = shift; - - $self->sl("LUSERS" . ($_[0] ? " $_[0]" : "")); -} - -# Gets and/or sets the max line length. The value previous to the sub -# call will be returned. -# Takes 1 (optional) arg: the maximum line length (in bytes) -sub maxlinelen { - my $self = shift; - - my $ret = $self->{_maxlinelen}; - - $self->{_maxlinelen} = shift if @_; - - return $ret; -} - -# Sends an action to the channel/nick you specify. It's truly amazing how -# many IRCers have no idea that /me's are actually sent via CTCP. -# Takes 2 args: the channel or nick to bother with your witticism -# the action to send (e.g., "weed-whacks billn's hand off.") -sub me { - my $self = shift; - - $self->ctcp("ACTION", $_[0], $_[1]); -} - -# Change channel and user modes (this one is easy... the handler is a bitch.) -# Takes at least 1 arg: the target of the command (channel or nick) -# (optional) the mode string (i.e., "-boo+i") -# (optional) operands of the mode string (nicks, hostmasks, etc.) -sub mode { - my $self = shift; - - unless (@_ >= 1) { - croak "Not enough arguments to mode()"; - } - $self->sl("MODE $_[0] " . CORE::join(" ", @_[1..$#_])); -} - -# Sends a MOTD command to a server. -# Takes 1 optional arg: the server to query (defaults to current server) -sub motd { - my $self = shift; - - $self->sl("MOTD" . ($_[0] ? " $_[0]" : "")); -} - -# Requests the list of users for a particular channel (or the entire net, if -# you're a masochist). -# Takes 1 or more optional args: name(s) of channel(s) to list the users from. -sub names { - my $self = shift; - - $self->sl("NAMES " . CORE::join(",", @_)); - -} # Was this the easiest sub in the world, or what? - -# Creates and returns a DCC CHAT object, analogous to IRC.pm's newconn(). -# Takes at least 1 arg: An Event object for the DCC CHAT request. -# OR A list or listref of args to be passed to new(), -# consisting of: -# - A boolean value indicating whether or not -# you're initiating the CHAT connection. -# - The nick of the chattee -# - The address to connect to -# - The port to connect on -sub new_chat { - my $self = shift; - my ($init, $nick, $address, $port); - - if (ref($_[0]) =~ /Event/) { - # If it's from an Event object, we can't be initiating, right? - ($init, undef, undef, undef, $address, $port) = (0, $_[0]->args); - $nick = $_[0]->nick; - - } elsif (ref($_[0]) eq "ARRAY") { - ($init, $nick, $address, $port) = @{$_[0]}; - } else { - ($init, $nick, $address, $port) = @_; - } - - Net::IRC::DCC::CHAT->new($self, $init, $nick, $address, $port); -} - -# Creates and returns a DCC GET object, analogous to IRC.pm's newconn(). -# Takes at least 1 arg: An Event object for the DCC SEND request. -# OR A list or listref of args to be passed to new(), -# consisting of: -# - The nick of the file's sender -# - The name of the file to receive -# - The address to connect to -# - The port to connect on -# - The size of the incoming file -# For all of the above, an extra argument should be added at the end: -# An open filehandle to save the incoming file into, -# in globref, FileHandle, or IO::* form. -# If you wish to do a DCC RESUME, specify the offset in bytes that you -# want to start downloading from as the last argument. -sub new_get { - my $self = shift; - my ($nick, $name, $address, $port, $size, $offset, $handle); - - if (ref($_[0]) =~ /Event/) { - (undef, undef, $name, $address, $port, $size) = $_[0]->args; - $nick = $_[0]->nick; - $handle = $_[1] if defined $_[1]; - } elsif (ref($_[0]) eq "ARRAY") { - ($nick, $name, $address, $port, $size) = @{$_[0]}; - $handle = $_[1] if defined $_[1]; - } else { - ($nick, $name, $address, $port, $size, $handle) = @_; - } - - unless (defined $handle and ref $handle and - (ref $handle eq "GLOB" or $handle->can('print'))) - { - carp ("Filehandle argument to Connection->new_get() must be ". - "a glob reference or object"); - return; # is this behavior OK? - } - - my $dcc = Net::IRC::DCC::GET->new( $self, $nick, $address, $port, $size, - $name, $handle, $offset ); - - $self->parent->addconn($dcc) if $dcc; - return $dcc; -} - -# Creates and returns a DCC SEND object, analogous to IRC.pm's newconn(). -# Takes at least 2 args: The nickname of the person to send to -# The name of the file to send -# (optional) The blocksize for the connection (default 1k) -sub new_send { - my $self = shift; - my ($nick, $filename, $blocksize); - - if (ref($_[0]) eq "ARRAY") { - ($nick, $filename, $blocksize) = @{$_[0]}; - } else { - ($nick, $filename, $blocksize) = @_; - } - - Net::IRC::DCC::SEND->new($self, $nick, $filename, $blocksize); -} - -# Selects nick for this object or returns currently set nick. -# No default; must be set by user. -# If changed while the object is already connected to a server, it will -# automatically try to change nicks. -# Takes 1 arg: the nick. (I bet you could have figured that out...) -sub nick { - my $self = shift; - - if (@_) { - $self->{'_nick'} = shift; - if ($self->connected) { - return $self->sl("NICK " . $self->{'_nick'}); - } - } else { - return $self->{'_nick'}; - } -} - -# Sends a notice to a channel or person. -# Takes 2 args: the target of the message (channel or nick) -# the text of the message to send -# The message will be chunked if it is longer than the _maxlinelen -# attribute, but it doesn't try to protect against flooding. If you -# give it too much info, the IRC server will kick you off! -sub notice { - my ($self, $to) = splice @_, 0, 2; - - unless (@_) { - croak "Not enough arguments to notice()"; - } - - my ($buf, $length, $line) = (CORE::join("", @_), $self->{_maxlinelen}); - - while(length($buf) > 0) { - ($line, $buf) = unpack("a$length a*", $buf); - $self->sl("NOTICE $to :$line"); - } -} - -# Makes you an IRCop, if you supply the right username and password. -# Takes 2 args: Operator's username -# Operator's password -sub oper { - my $self = shift; - - unless (@_ > 1) { - croak "Not enough arguments to oper()"; - } - - $self->sl("OPER $_[0] $_[1]"); -} - -# This function splits apart a raw server line into its component parts -# (message, target, message type, CTCP data, etc...) and passes it to the -# appropriate handler. Takes no args, really. -sub parse { - my ($self) = shift; - my ($from, $type, $message, @stuff, $itype, $ev, @lines, $line); - - if (defined ($self->ssl ? - $self->socket->read($line, 10240) : - $self->socket->recv($line, 10240, 0)) - and - (length($self->{_frag}) + length($line)) > 0) { - # grab any remnant from the last go and split into lines - $self->{_rx} += length($line); - my $chunk = $self->{_frag} . $line; - @lines = split /\012/, $chunk; - - # if the last line was incomplete, pop it off the chunk and - # stick it back into the frag holder. - $self->{_frag} = (substr($chunk, -1) ne "\012" ? pop @lines : ''); - - } else { - # um, if we can read, i say we should read more than 0 - # besides, recv isn't returning undef on closed - # sockets. getting rid of this connection... - $self->disconnect('error', 'Connection reset by peer'); - return; - } - - PARSELOOP: foreach $line (@lines) { - - # Clean the lint filter every 2 weeks... - $line =~ s/[\012\015]+$//; - next unless $line; - - print STDERR "<<< $line\n" if $self->{_debug}; - - $::lastline = $line; #this is so __WARN__ can print the last line received on IRC. - # Like the RFC says: "respond as quickly as possible..." - if ($line =~ /^PING/) { - $ev = (Net::IRC::Event->new( "ping", - $self->server, - $self->nick, - "serverping", # FIXME? - substr($line, 5) - )); - - # Had to move this up front to avoid a particularly pernicious bug. - } elsif ($line =~ /^NOTICE/) { - $ev = Net::IRC::Event->new( "snotice", - $self->server, - '', - 'server', - (split /:/, $line, 2)[1] ); - - - # Spurious backslashes are for the benefit of cperl-mode. - # Assumption: all non-numeric message types begin with a letter - } elsif ($line =~ /^:? - (?:[][}{\w\\\`^|\-]+? # The nick (valid nickname chars) - ! # The nick-username separator - .+? # The username - \@)? # Umm, duh... - \S+ # The hostname - \s+ # Space between mask and message type - [A-Za-z] # First char of message type - [^\s:]+? # The rest of the message type - /x) # That ought to do it for now... - { - $line = substr $line, 1 if $line =~ /^:/; - - # Patch submitted for v.0.72 - # Fixes problems with IPv6 hostnames. - # ($from, $line) = split ":", $line, 2; - ($from, $line) = $line =~ /^(?:|)(\S+\s+[^:]+):?(.*)/; - - ($from, $type, @stuff) = split /\s+/, $from; - $type = lc $type; - # This should be fairly intuitive... (cperl-mode sucks, though) - - # The order of this was changed by AfterDeath because a \x01 in a geco fucked shit up - if ($type eq "join" or $type eq "part" or - $type eq "mode" or $type eq "topic" or - $type eq "kick") { - $itype = "channel"; - } elsif (defined $line and index($line, "\001") == 0) { #originally >=0. Hopefully this will fuck less shit up. -# print Dumper($from, $type, \@stuff, $line); - $itype = "ctcp"; - unless ($type eq "notice") { - $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg"); - } - } elsif ($type eq "privmsg") { - $itype = $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg"); - } elsif ($type eq "notice") { - $itype = "notice"; - } elsif ($type eq "nick") { - $itype = "nick"; - } else { - $itype = "other"; - } - - # This goes through the list of ignored addresses for this message - # type and drops out of the sub if it's from an ignored hostmask. - - study $from; - foreach ( $self->ignore($itype), $self->ignore("all") ) { - $_ = quotemeta; s/\\\*/.*/g; - next PARSELOOP if $from =~ /$_/i; - } - - # It used to look a lot worse. Here was the original version... - # the optimization above was proposed by Silmaril, for which I am - # eternally grateful. (Mine still looks cooler, though. :) - - # return if grep { $_ = join('.*', split(/\\\*/, - # quotemeta($_))); /$from/ } - # ($self->ignore($type), $self->ignore("all")); - - # Add $line to @stuff for the handlers - push @stuff, $line if defined $line; - - # Now ship it off to the appropriate handler and forget about it. - if ( $itype eq "ctcp" ) { # it's got CTCP in it! - $self->parse_ctcp($type, $from, $stuff[0], $line); - next; - - } elsif ($type eq "public" or $type eq "msg" or - $type eq "notice" or $type eq "mode" or - $type eq "join" or $type eq "part" or - $type eq "topic" or $type eq "invite" ) { - - $ev = Net::IRC::Event->new( $type, - $from, - shift(@stuff), - $type, - @stuff, - ); - } elsif ($type eq "quit" or $type eq "nick") { - - $ev = Net::IRC::Event->new( $type, - $from, - $from, - $type, - @stuff, - ); - } elsif ($type eq "kick") { - - $ev = Net::IRC::Event->new( $type, - $from, - $stuff[1], - $type, - @stuff[0,2..$#stuff], - ); - - } elsif ($type eq "kill") { - $ev = Net::IRC::Event->new($type, - $from, - '', - $type, - $line); # Ahh, what the hell. - } elsif ($type eq "wallops") { - $ev = Net::IRC::Event->new($type, - $from, - '', - $type, - $line); - } elsif ($type eq "account") { #these next 3 event hooks added by AfterDeath - $ev = Net::IRC::Event->new($type, - $from, - '', - $type, - @stuff); - } elsif ($type eq "cap") { - $ev = Net::IRC::Event->new($type, - $from, - '', - $type, - @stuff); - } elsif ($type eq "pong") { - $ev = Net::IRC::Event->new($type, - $from, - $self->{nick}, - 'server', - $stuff[1]); - } else { - carp "Unknown event type: $type"; - } - } - elsif ($line =~ /^:? # Here's Ye Olde Numeric Handler! - \S+? # the servername (can't assume RFC hostname) - \s+? # Some spaces here... - \d+? # The actual number - \b/x # Some other crap, whatever... - ) { - $ev = $self->parse_num($line); - - } elsif ($line =~ /^:(\w+) MODE \1 /) { - $ev = Net::IRC::Event->new( 'umode', - $self->server, - $self->nick, - 'server', - substr($line, index($line, ':', 1) + 1)); - - } elsif ($line =~ /^:? # Here's Ye Olde Server Notice handler! - .+? # the servername (can't assume RFC hostname) - \s+? # Some spaces here... - NOTICE # The server notice - \b/x # Some other crap, whatever... - ) { - $ev = Net::IRC::Event->new( 'snotice', - $self->server, - '', - 'server', - (split /\s+/, $line, 3)[2] ); - - - } elsif ($line =~ /^ERROR/) { - if ($line =~ /^ERROR :Closing [Ll]ink/) { # is this compatible? - - $ev = 'done'; - $self->disconnect( 'error', ($line =~ /(.*)/) ); - - } else { - $ev = Net::IRC::Event->new( "error", - $self->server, - '', - 'error', - (split /:/, $line, 2)[1]); - } - } elsif ($line =~ /^Closing [Ll]ink/) { - $ev = 'done'; - $self->disconnect( 'error', ($line =~ /(.*)/) ); - - } - - if ($ev) { - - # We need to be able to fall through if the handler has - # already been called (i.e., from within disconnect()). - - $self->handler($ev) unless $ev eq 'done'; - - } else { - # If it gets down to here, it's some exception I forgot about. - carp "Funky parse case: $line\n"; - } - } -} - -# The backend that parse() sends CTCP requests off to. Pay no attention -# to the camel behind the curtain. -# Takes 4 arguments: the type of message -# who it's from -# the first bit of stuff -# the line from the server. -sub parse_ctcp { - my ($self, $type, $from, $stuff, $line) = @_; - - my ($one, $two); - my ($odd, @foo) = (&dequote($line)); - - while (($one, $two) = (splice @foo, 0, 2)) { - - ($one, $two) = ($two, $one) if $odd; - - my ($ctype) = $one =~ /^(\w+)\b/; - my $prefix = undef; - if ($type eq 'notice') { - $prefix = 'cr'; - } elsif ($type eq 'public' or - $type eq 'msg' ) { - $prefix = 'c'; - } else { - carp "Unknown CTCP type: $type"; - return; - } - - if ($prefix) { - my $handler = $prefix . lc $ctype; # unit. value prob with $ctype - - $one =~ s/^$ctype //i; # strip the CTCP type off the args - $self->handler(Net::IRC::Event->new( $handler, $from, $stuff, - $handler, $one )); - } - - $self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two)) - if $two; - } - return 1; -} - -# Does special-case parsing for numeric events. Separate from the rest of -# parse() for clarity reasons (I can hear Tkil gasping in shock now. :-). -# Takes 1 arg: the raw server line -sub parse_num { - my ($self, $line) = @_; - - # Figlet protection? This seems to be a bit closer to the RFC than - # the original version, which doesn't seem to handle :trailers quite - # correctly. - - my ($from, $type, $stuff) = split(/\s+/, $line, 3); - my ($blip, $space, $other, @stuff); - while ($stuff) { - ($blip, $space, $other) = split(/(\s+)/, $stuff, 2); - $space = "" unless $space; - $other = "" unless $other; # Thanks to jack velte... - if ($blip =~ /^:/) { - push @stuff, $blip . $space . $other; - last; - } else { - push @stuff, $blip; - $stuff = $other; - } - } - - $from = substr $from, 1 if $from =~ /^:/; - - return Net::IRC::Event->new( $type, - $from, - '', - 'server', - @stuff ); -} - -# Helps you flee those hard-to-stand channels. -# Takes at least one arg: name(s) of channel(s) to leave. -sub part { - my $self = shift; - - unless (@_) { - croak "No arguments provided to part()"; - } - $self->sl("PART " . CORE::join(",", @_)); # "A must!" -} - - -# Tells what's on the other end of a connection. Returns a 2-element list -# consisting of the name on the other end and the type of connection. -# Takes no args. -sub peer { - my $self = shift; - - return ($self->server(), "IRC connection"); -} - - -# Prints a message to the defined error filehandle(s). -# No further description should be necessary. -sub printerr { - shift; - print STDERR @_, "\n"; -} - -# Prints a message to the defined output filehandle(s). -sub print { - shift; - print STDOUT @_, "\n"; -} - -# Sends a message to a channel or person. -# Takes 2 args: the target of the message (channel or nick) -# the text of the message to send -# Don't use this for sending CTCPs... that's what the ctcp() function is for. -# The message will be chunked if it is longer than the _maxlinelen -# attribute, but it doesn't try to protect against flooding. If you -# give it too much info, the IRC server will kick you off! -sub privmsg { - my ($self, $to) = splice @_, 0, 2; - - unless (@_) { - croak 'Not enough arguments to privmsg()'; - } - - my $buf = CORE::join '', @_; - my $length = $self->{_maxlinelen} - 80 - length($to); - my $line; - - if (ref($to) =~ /^(GLOB|IO::Socket)/) { - while(length($buf) > 0) { - ($line, $buf) = unpack("a$length a*", $buf); - send($to, $line . "\012", 0); - } - } else { - while(length($buf) > 0) { - ($line, $buf) = unpack("a$length a*", $buf); - if (ref $to eq 'ARRAY') { - $self->sl("PRIVMSG ", CORE::join(',', @$to), " :$line"); - } else { - $self->sl("PRIVMSG $to :$line"); - } - } - } -} - - -# Closes connection to IRC server. (Corresponding function for /QUIT) -# Takes 1 optional arg: parting message, defaults to "Leaving" by custom. -sub quit { - my $self = shift; - - # Do any user-defined stuff before leaving - $self->handler("leaving"); - - unless ( $self->connected ) { return (1) } - - # Why bother checking for sl() errors now, after all? :) - # We just send the QUIT command and leave. The server will respond with - # a "Closing link" message, and parse() will catch it, close the - # connection, and throw a "disconnect" event. Neat, huh? :-) - - $self->sl("QUIT :" . (defined $_[0] ? $_[0] : "Leaving")); - - # since the quit sends a line to the server, we need to flush the - # output queue to make sure it gets there so the disconnect - $self->parent->flush_output_queue(); - - return 1; -} - -# As per the RFC, ask the server to "re-read and process its configuration -# file." Your server may or may not take additional arguments. Generally -# requires IRCop status. -sub rehash { - my $self = shift; - $self->sl("REHASH" . CORE::join(" ", @_)); -} - - -# As per the RFC, "force a server restart itself." (Love that RFC.) -# Takes no arguments. If it succeeds, you will likely be disconnected, -# but I assume you already knew that. This sub is too simple... -sub restart { - my $self = shift; - $self->sl("RESTART"); -} - -# Schedules an event to be executed after some length of time. -# Takes at least 2 args: the number of seconds to wait until it's executed -# a coderef to execute when time's up -# Any extra args are passed as arguments to the user's coderef. -sub schedule { - my $self = shift; - my $time = shift; - my $coderef = shift; - - unless($coderef) { - croak 'Not enough arguments to Connection->schedule()'; - } - unless(ref($coderef) eq 'CODE') { - croak 'Second argument to schedule() isn\'t a coderef'; - } - - $time += time; - $self->parent->enqueue_scheduled_event($time, $coderef, $self, @_); -} - -sub schedule_output_event { - my $self = shift; - my $time = shift; - my $coderef = shift; - - unless($coderef) { - croak 'Not enough arguments to Connection->schedule()'; - } - unless(ref($coderef) eq 'CODE') { - croak 'Second argument to schedule() isn\'t a coderef'; - } - - $time += time; - $self->parent->enqueue_output_event($time, $coderef, $self, @_); -} - -# Lets J. Random IRCop connect one IRC server to another. How uninteresting. -# Takes at least 1 arg: the name of the server to connect your server with -# (optional) the port to connect them on (default 6667) -# (optional) the server to connect to arg #1. Used mainly by -# servers to communicate with each other. -sub sconnect { - my $self = shift; - - unless (@_) { - croak "Not enough arguments to sconnect()"; - } - $self->sl("CONNECT " . CORE::join(" ", @_)); -} - -# Sets/changes the IRC server which this instance should connect to. -# Takes 1 arg: the name of the server (see below for possible syntaxes) -# ((syntaxen? syntaxi? syntaces?)) -sub server { - my ($self) = shift; - - if (@_) { - # cases like "irc.server.com:6668" - if (index($_[0], ':') > 0) { - my ($serv, $port) = split /:/, $_[0]; - if ($port =~ /\D/) { - carp "$port is not a valid port number in server()"; - return; - } - $self->{_server} = $serv; - $self->port($port); - - # cases like ":6668" (buried treasure!) - } elsif (index($_[0], ':') == 0 and $_[0] =~ /^:(\d+)/) { - $self->port($1); - - # cases like "irc.server.com" - } else { - $self->{_server} = shift; - } - return (1); - - } else { - return $self->{_server}; - } -} - - -# sends a raw IRC line to the server, possibly with pacing -sub sl { - my $self = shift; - my $line = CORE::join '', @_; - - unless (@_) { - croak "Not enough arguments to sl()"; - } - - if (! $self->pacing) { - return $self->sl_real($line); - } - - # calculate how long to wait before sending this line - my $time = time; - if ($time - $self->{_lastsl} > $self->pacing) { - $self->{_lastsl} = $time; - } else { - $self->{_lastsl} += $self->pacing; - } - my $seconds = $self->{_lastsl} - $time; - - ### DEBUG DEBUG DEBUG - if ($self->{_debug}) { - print "S-> $seconds $line\n"; - } - - $self->schedule_output_event($seconds, \&sl_real, $line); -} - - -# Sends a raw IRC line to the server. -# Corresponds to the internal sirc function of the same name. -# Takes 1 arg: string to send to server. (duh. :) -sub sl_real { - my $self = shift; - my $line = shift; - - unless ($line) { - croak "Not enough arguments to sl_real()"; - } - - ### DEBUG DEBUG DEBUG - if ($self->{_debug}) { - print ">>> $line\n"; - } - - # RFC compliance can be kinda nice... - my $rv = $self->ssl ? - $self->socket->print("$line\015\012") : - $self->socket->send("$line\015\012", 0); - unless ($rv) { - $self->handler("sockerror"); - return; - } - $self->{_tx} += (length($line) + 2); - return $rv; -} - -# Tells any server that you're an oper on to disconnect from the IRC network. -# Takes at least 1 arg: the name of the server to disconnect -# (optional) a comment about why it was disconnected -sub squit { - my $self = shift; - - unless (@_) { - croak "Not enough arguments to squit()"; - } - - $self->sl("SQUIT $_[0]" . ($_[1] ? " :$_[1]" : "")); -} - -# Gets various server statistics for the specified host. -# Takes at least 2 arg: the type of stats to request [chiklmouy] -# (optional) the server to request from (default is current server) -sub stats { - my $self = shift; - - unless (@_) { - croak "Not enough arguments passed to stats()"; - } - - $self->sl("STATS $_[0]" . ($_[1] ? " $_[1]" : "")); -} - -# If anyone still has SUMMON enabled, this will implement it for you. -# If not, well...heh. Sorry. First arg mandatory: user to summon. -# Second arg optional: a server name. -sub summon { - my $self = shift; - - unless (@_) { - croak "Not enough arguments passed to summon()"; - } - - $self->sl("SUMMON $_[0]" . ($_[1] ? " $_[1]" : "")); -} - -# Requests timestamp from specified server. Easy enough, right? -# Takes 1 optional arg: a server name/mask to query -# renamed to not collide with things... -- aburke -sub timestamp { - my ($self, $serv) = (shift, undef); - - $self->sl("TIME" . ($_[0] ? " $_[0]" : "")); -} - -# Sends request for current topic, or changes it to something else lame. -# Takes at least 1 arg: the channel whose topic you want to screw around with -# (optional) the new topic you want to impress everyone with -sub topic { - my $self = shift; - - unless (@_) { - croak "Not enough arguments to topic()"; - } - - # Can you tell I've been reading the Nethack source too much? :) - $self->sl("TOPIC $_[0]" . ($_[1] ? " :$_[1]" : "")); -} - -# Sends a trace request to the server. Whoop. -# Take 1 optional arg: the server or nickname to trace. -sub trace { - my $self = shift; - - $self->sl("TRACE" . ($_[0] ? " $_[0]" : "")); -} - -# This method submitted by Dave Schmitt . Thanks, Dave! -sub unignore { - my $self = shift; - - croak "Not enough arguments to unignore()" unless @_; - - if (@_ == 1) { - if (exists $self->{_ignore}->{$_[0]}) { - return @{ $self->{_ignore}->{$_[0]} }; - } else { - return (); - } - } elsif (@_ > 1) { # code defensively, remember... - my $type = shift; - - # I moved this part further down as an Obsessive Efficiency - # Initiative. It shouldn't be a problem if I do _parse right... - # ... but those are famous last words, eh? - unless (grep {$_ eq $type} - qw(public msg ctcp notice channel nick other all)) { - carp "$type isn't a valid type to unignore()"; - return; - } - - if ( exists $self->{_ignore}->{$type} ) { - # removes all specifed entries ala _Perl_Cookbook_ recipe 4.7 - my @temp = @{$self->{_ignore}->{$type}}; - @{$self->{_ignore}->{$type}}= (); - my %seen = (); - foreach my $item (@_) { $seen{$item}=1 } - foreach my $item (@temp) { - push(@{$self->{_ignore}->{$type}}, $item) - unless ($seen{$item}); - } - } else { - carp "no ignore entry for $type to remove"; - } - } -} - - -# Requests userhost info from the server. -# Takes at least 1 arg: nickname(s) to look up. -sub userhost { - my $self = shift; - - unless (@_) { - croak 'Not enough args to userhost().'; - } - - $self->sl("USERHOST " . CORE::join (" ", @_)); -} - -# Sends a users request to the server, which may or may not listen to you. -# Take 1 optional arg: the server to query. -sub users { - my $self = shift; - - $self->sl("USERS" . ($_[0] ? " $_[0]" : "")); -} - -# Asks the IRC server what version and revision of ircd it's running. Whoop. -# Takes 1 optional arg: the server name/glob. (default is current server) -sub version { - my $self = shift; - - $self->sl("VERSION" . ($_[0] ? " $_[0]" : "")); -} - -# Sends a message to all opers on the network. Hypothetically. -# Takes 1 arg: the text to send. -sub wallops { - my $self = shift; - - unless ($_[0]) { - croak 'No arguments passed to wallops()'; - } - - $self->sl("WALLOPS :" . CORE::join("", @_)); -} - -# Asks the server about stuff, you know. Whatever. Pass the Fritos, dude. -# Takes 2 optional args: the bit of stuff to ask about -# an "o" (nobody ever uses this...) -sub who { - my $self = shift; - - # Obfuscation! - $self->sl("WHO" . (@_ ? " @_" : "")); -} - -# If you've gotten this far, you probably already know what this does. -# Takes at least 1 arg: nickmasks or channels to /whois -sub whois { - my $self = shift; - - unless (@_) { - croak "Not enough arguments to whois()"; - } - return $self->sl("WHOIS " . CORE::join(",", @_)); -} - -# Same as above, in the past tense. -# Takes at least 1 arg: nick to do the /whowas on -# (optional) max number of hits to display -# (optional) server or servermask to query -sub whowas { - my $self = shift; - - unless (@_) { - croak "Not enough arguments to whowas()"; - } - return $self->sl("WHOWAS $_[0]" . ($_[1] ? " $_[1]" : "") . - (($_[1] && $_[2]) ? " $_[2]" : "")); -} - -# This sub executes the default action for an event with no user-defined -# handlers. It's all in one sub so that we don't have to make a bunch of -# separate anonymous subs stuffed in a hash. -sub _default { - my ($self, $event) = @_; - my $verbose = $self->verbose; - - # Users should only see this if the programmer (me) fucked up. - unless ($event) { - croak "You EEEEEDIOT!!! Not enough args to _default()!"; - } - - # Reply to PING from server as quickly as possible. - if ($event->type eq "ping") { - $self->sl("PONG " . (CORE::join ' ', $event->args)); - - } elsif ($event->type eq "disconnect") { - - # I violate OO tenets. (It's consensual, of course.) - unless (keys %{$self->parent->{_connhash}} > 0) { - die "No active connections left, exiting...\n"; - } - } - - return 1; -} - -1; - - -__END__ - -=head1 NAME - -Net::IRC::Connection - Object-oriented interface to a single IRC connection - -=head1 SYNOPSIS - -Hard hat area: This section under construction. - -=head1 DESCRIPTION - -This documentation is a subset of the main Net::IRC documentation. If -you haven't already, please "perldoc Net::IRC" before continuing. - -Net::IRC::Connection defines a class whose instances are individual -connections to a single IRC server. Several Net::IRC::Connection objects may -be handled simultaneously by one Net::IRC object. - -=head1 METHOD DESCRIPTIONS - -This section is under construction, but hopefully will be finally written up -by the next release. Please see the C script and the source for -details about this module. - -=head1 AUTHORS - -Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and -Dennis Taylor Edennis@funkplanet.comE. - -Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. - -Currently being hacked on, hacked up, and worked over by the members of the -Net::IRC developers mailing list. For details, see -http://www.execpc.com/~corbeau/irc/list.html . - -=head1 URL - -Up-to-date source and information about the Net::IRC project can be found at -http://netirc.betterbox.net/ . - -=head1 SEE ALSO - -=over - -=item * - -perl(1). - -=item * - -RFC 1459: The Internet Relay Chat Protocol - -=item * - -http://www.irchelp.org/, home of fine IRC resources. - -=back - -=cut - diff --git a/Net/IRC/DCC.pm b/Net/IRC/DCC.pm deleted file mode 100644 index eccbba3..0000000 --- a/Net/IRC/DCC.pm +++ /dev/null @@ -1,808 +0,0 @@ -##################################################################### -# # -# Net::IRC -- Object-oriented Perl interface to an IRC server # -# # -# DCC.pm: An object for Direct Client-to-Client connections. # -# # -# Copyright (c) 1997 Greg Bacon & Dennis Taylor. # -# All rights reserved. # -# # -# This module is free software; you can redistribute or # -# modify it under the terms of Perl's Artistic License. # -# # -##################################################################### -# $Id: DCC.pm,v 1.1.1.1 2002/11/14 17:32:15 jmuhlich Exp $ - -package Net::IRC::DCC; - -use strict; - - - -# --- #perl was here! --- -# -# The comments scattered throughout this module are excerpts from a -# log saved from one particularly surreal night on #perl. Ahh, the -# trials of being young, single, and drunk... -# -# --------------------- -# \merlyn has offered the shower to a randon guy he met in a bar. -# fimmtiu: Shower? -# \petey raises an eyebrow at \merlyn -# \merlyn: but he seems like a nice trucker guy... -# archon: you offered to shower with a random guy? - - -# Methods that can be shared between the various DCC classes. -package Net::IRC::DCC::Connection; - -use Carp; -use Socket; # need inet_ntoa... -use strict; - -sub fixaddr { - my ($address) = @_; - - chomp $address; # just in case, sigh. - if ($address =~ /^\d+$/) { - return inet_ntoa(pack "N", $address); - } elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) { - return $address; - } elsif ($address =~ tr/a-zA-Z//) { # Whee! Obfuscation! - return inet_ntoa(((gethostbyname($address))[4])[0]); - } else { - return; - } -} - -sub bytes_in { - return shift->{_bin}; -} - -sub bytes_out { - return shift->{_bout}; -} - -sub nick { - return shift->{_nick}; -} - -sub socket { - return shift->{_socket}; -} - -sub time { - return time - shift->{_time}; -} - -sub debug { - return shift->{_debug}; -} - -# Changes here 1998-04-01 by MJD -# Optional third argument `$block'. -# If true, don't break the input into lines... just process it in blocks. -sub _getline { - my ($self, $sock, $block) = @_; - my ($input, $line); - my $frag = $self->{_frag}; - - if (defined $sock->recv($input, 10240)) { - $frag .= $input; - if (length($frag) > 0) { - - warn "Got ". length($frag) ." bytes from $sock\n" - if $self->{_debug}; - - if ($block) { # Block mode (GET) - return $input; - - } else { # Line mode (CHAT) - # We're returning \n's 'cause DCC's need 'em - my @lines = split /\012/, $frag, -1; - $lines[-1] .= "\012"; - $self->{_frag} = ($frag !~ /\012$/) ? pop @lines : ''; - return (@lines); - } - } - else { - # um, if we can read, i say we should read more than 0 - # besides, recv isn't returning undef on closed - # sockets. getting rid of this connection... - - warn "recv() received 0 bytes in _getline, closing connection.\n" - if $self->{_debug}; - - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_parent}->parent->removefh($sock); - $self->{_socket}->close; - $self->{_fh}->close if $self->{_fh}; - return; - } - } else { - # Error, lets scrap this connection - - warn "recv() returned undef, socket error in _getline()\n" - if $self->{_debug}; - - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_parent}->parent->removefh($sock); - $self->{_socket}->close; - $self->{_fh}->close if $self->{_fh}; - return; - } -} - -sub DESTROY { - my $self = shift; - - # Only do the Disconnection Dance of Death if the socket is still - # live. Duplicate dcc_close events would be a Bad Thing. - - if ($self->{_socket}->opened) { - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - close $self->{_fh} if $self->{_fh}; - $self->{_parent}->{_parent}->parent->removeconn($self); - } - -} - -sub peer { - return ( $_[0]->{_nick}, "DCC " . $_[0]->{_type} ); -} - -# -- #perl was here! -- -# orev: hehe... -# Silmaril: to, not with. -# archon: heheh -# tmtowtdi: \merlyn will be hacked to death by a psycho -# archon: yeah, but with is much more amusing - - -# Connection handling GETs -package Net::IRC::DCC::GET; - -use IO::Socket; -use Carp; -use strict; - -@Net::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection); - -sub new { - - my ($class, $container, $nick, $address, - $port, $size, $filename, $handle, $offset) = @_; - my ($sock, $fh); - - # get the address into a dotted quad - $address = &Net::IRC::DCC::Connection::fixaddr($address); - return if $port < 1024 or not defined $address or $size < 1; - - $fh = defined $handle ? $handle : IO::File->new(">$filename"); - - unless(defined $fh) { - carp "Can't open $filename for writing: $!"; - $sock = new IO::Socket::INET( Proto => "tcp", - PeerAddr => "$address:$port" ) and - $sock->close(); - return; - } - - binmode $fh; # I love this next line. :-) - ref $fh eq 'GLOB' ? select((select($fh), $|++)[0]) : $fh->autoflush(1); - - $sock = new IO::Socket::INET( Proto => "tcp", - PeerAddr => "$address:$port" ); - - if (defined $sock) { - $container->handler(Net::IRC::Event->new('dcc_open', - $nick, - $sock, - 'get', - 'get', $sock)); - - } else { - carp "Can't connect to $address: $!"; - close $fh; - return; - } - - $sock->autoflush(1); - - my $self = { - _bin => defined $offset ? $offset : 0, # bytes recieved so far - _bout => 0, # Bytes we've sent - _connected => 1, - _debug => $container->debug, - _fh => $fh, # FileHandle we will be writing to. - _filename => $filename, - _frag => '', - _nick => $nick, # Nick of person on other end - _parent => $container, - _size => $size, # Expected size of file - _socket => $sock, # Socket we're reading from - _time => time, - _type => 'GET', - }; - - bless $self, $class; - - return $self; -} - -# -- #perl was here! -- -# \merlyn: we were both ogling a bartender named arley -# \merlyn: I mean carle -# \merlyn: carly -# Silmaril: man merlyn -# Silmaril: you should have offered HER the shower. -# \petey: all three of them? - -sub parse { - my ($self) = shift; - - my $line = $self->_getline($_[0], 'BLOCKS'); - - next unless defined $line; - unless(print {$self->{_fh}} $line) { - carp ("Error writing to " . $self->{_filename} . ": $!"); - close $self->{_fh}; - $self->{_parent}->parent->removeconn($self); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; - } - - $self->{_bin} += length($line); - - - # confirm the packet we've just recieved - unless ( $self->{_socket}->send( pack("N", $self->{_bin}) ) ) { - carp "Error writing to DCC GET socket: $!"; - close $self->{_fh}; - $self->{_parent}->parent->removeconn($self); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; - } - - $self->{_bout} += 4; - - # The file is done. - # If we close the socket, the select loop gets screwy because - # it won't remove its reference to the socket. - if ( $self->{_size} and $self->{_size} <= $self->{_bin} ) { - close $self->{_fh}; - $self->{_parent}->parent->removeconn($self); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; - } - - $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', - $self->{_nick}, - $self, - $self->{_type}, - $self )); -} - -sub filename { - return shift->{_filename}; -} - -sub size { - return shift->{_size}; -} - -sub close { - my ($self, $sock) = @_; - $self->{_fh}->close; - $self->{_parent}->parent->removeconn($self); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; -} - -# -- #perl was here! -- -# \merlyn: I can't type... she created a numbner of very good drinks -# \merlyn: She's still at work -# \petey resists mentioning that there's "No manual entry -# for merlyn." -# Silmaril: Haven't you ever seen swingers? -# \merlyn: she's off tomorrow... will meet me at the bar at 9:30 -# Silmaril: AWWWWwwww yeeeaAAHH. -# archon: waka chica waka chica - - -# Connection handling SENDs -package Net::IRC::DCC::SEND; -@Net::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection); - -use IO::File; -use IO::Socket; -use Carp; -use strict; - -sub new { - - my ($class, $container, $nick, $filename, $blocksize) = @_; - my ($size, $port, $fh, $sock, $select); - - $blocksize ||= 1024; - - # Shell-safe DCC filename stuff. Trying to prank-proof this - # module is rather difficult. - $filename =~ tr/a-zA-Z.+0-9=&()[]%\-\\\/:,/_/c; - $fh = new IO::File $filename; - - unless (defined $fh) { - carp "Couldn't open $filename for reading: $!"; - return; - } - - binmode $fh; - $fh->seek(0, SEEK_END); - $size = $fh->tell; - $fh->seek(0, SEEK_SET); - - $sock = new IO::Socket::INET( Proto => "tcp", - Listen => 1); - - unless (defined $sock) { - carp "Couldn't open DCC SEND socket: $!"; - $fh->close; - return; - } - - $container->ctcp('DCC SEND', $nick, $filename, - unpack("N",inet_aton($container->hostname())), - $sock->sockport(), $size); - - $sock->autoflush(1); - - my $self = { - _bin => 0, # Bytes we've recieved thus far - _blocksize => $blocksize, - _bout => 0, # Bytes we've sent - _debug => $container->debug, - _fh => $fh, # FileHandle we will be reading from. - _filename => $filename, - _frag => '', - _nick => $nick, - _parent => $container, - _size => $size, # Size of file - _socket => $sock, # Socket we're writing to - _time => 0, # This gets set by Accept->parse() - _type => 'SEND', - }; - - bless $self, $class; - - $sock = Net::IRC::DCC::Accept->new($sock, $self); - - unless (defined $sock) { - carp "Error in accept: $!"; - $fh->close; - return; - } - - return $self; -} - -# -- #perl was here! -- -# fimmtiu: So a total stranger is using your shower? -# \merlyn: yes... a total stranger is using my hotel shower -# Stupid coulda sworn \merlyn was married... -# \petey: and you have a date. -# fimmtiu: merlyn isn't married. -# \petey: not a bad combo...... -# \merlyn: perhaps a adate -# \merlyn: not maerried -# \merlyn: not even sober. --) - -sub parse { - my ($self, $sock) = @_; - my $size = ($self->_getline($sock, 1))[0]; - my $buf; - - # i don't know how useful this is, but let's stay consistent - $self->{_bin} += 4; - - unless (defined $size) { - # Dang! The other end unexpectedly canceled. - carp (($self->peer)[1] . " connection to " . - ($self->peer)[0] . " lost"); - $self->{_fh}->close; - $self->{_parent}->parent->removefh($sock); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; - } - - $size = unpack("N", $size); - - if ($size >= $self->{_size}) { - - if ($self->{_debug}) { - warn "Other end acknowledged entire file ($size >= ", - $self->{_size}, ")"; - } - # they've acknowledged the whole file, we outtie - $self->{_fh}->close; - $self->{_parent}->parent->removeconn($self); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; - } - - # we're still waiting for acknowledgement, - # better not send any more - return if $size < $self->{_bout}; - - unless (defined $self->{_fh}->read($buf,$self->{_blocksize})) { - - if ($self->{_debug}) { - warn "Failed to read from source file in DCC SEND!"; - } - $self->{_fh}->close; - $self->{_parent}->parent->removeconn($self); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; - } - - unless($self->{_socket}->send($buf)) { - - if ($self->{_debug}) { - warn "send() failed horribly in DCC SEND" - } - $self->{_fh}->close; - $self->{_parent}->parent->removeconn($self); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; - } - - $self->{_bout} += length($buf); - - $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', - $self->{_nick}, - $self, - $self->{_type}, - $self )); - - return 1; -} - -# -- #perl was here! -- -# fimmtiu: Man, merlyn, you must be drunk to type like that. :) -# \merlyn: too many longislands. -# \merlyn: she made them strong -# archon: it's a plot -# \merlyn: not even a good amoun tof coke -# archon: she's in league with the guy in your shower -# archon: she gets you drunk and he takes your wallet! - - -# handles CHAT connections -package Net::IRC::DCC::CHAT; -@Net::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection); - -use IO::Socket; -use Carp; -use strict; - -sub new { - - my ($class, $container, $type, $nick, $address, $port) = @_; - my ($sock, $self); - - if ($type) { - # we're initiating - - $sock = new IO::Socket::INET( Proto => "tcp", - Listen => 1); - - unless (defined $sock) { - carp "Couldn't open DCC CHAT socket: $!"; - return; - } - - $sock->autoflush(1); - $container->ctcp('DCC CHAT', $nick, 'chat', - unpack("N",inet_aton($container->hostname)), - $sock->sockport()); - - $self = { - _bin => 0, # Bytes we've recieved thus far - _bout => 0, # Bytes we've sent - _connected => 1, - _debug => $container->debug, - _frag => '', - _nick => $nick, # Nick of the client on the other end - _parent => $container, - _socket => $sock, # Socket we're reading from - _time => 0, # This gets set by Accept->parse() - _type => 'CHAT', - }; - - bless $self, $class; - - $sock = Net::IRC::DCC::Accept->new($sock, $self); - - unless (defined $sock) { - carp "Error in DCC CHAT connect: $!"; - return; - } - - } else { # we're connecting - - $address = &Net::IRC::DCC::Connection::fixaddr($address); - return if $port < 1024 or not defined $address; - - $sock = new IO::Socket::INET( Proto => "tcp", - PeerAddr => "$address:$port"); - - if (defined $sock) { - $container->handler(Net::IRC::Event->new('dcc_open', - $nick, - $sock, - 'chat', - 'chat', $sock)); - } else { - carp "Error in DCC CHAT connect: $!"; - return; - } - - $sock->autoflush(1); - - $self = { - _bin => 0, # Bytes we've recieved thus far - _bout => 0, # Bytes we've sent - _connected => 1, - _nick => $nick, # Nick of the client on the other end - _parent => $container, - _socket => $sock, # Socket we're reading from - _time => time, - _type => 'CHAT', - }; - - bless $self, $class; - - $self->{_parent}->parent->addfh($self->socket, - $self->can('parse'), 'r', $self); - } - - return $self; -} - -# -- #perl was here! -- -# \merlyn: tahtd be coole -# KTurner bought the camel today, so somebody can afford one -# more drink... ;) -# tmtowtdi: I've heard of things like this... -# \merlyn: as an experience. that is. -# archon: i can think of cooler things (; -# \merlyn: I don't realiy have that mch in my wallet. - -sub parse { - my ($self, $sock) = @_; - - foreach my $line ($self->_getline($sock)) { - return unless defined $line; - - $self->{_bin} += length($line); - - return undef if $line eq "\012"; - $self->{_bout} += length($line); - - $self->{_parent}->handler(Net::IRC::Event->new('chat', - $self->{_nick}, - $self->{_socket}, - 'chat', - $line)); - - $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', - $self->{_nick}, - $self, - $self->{_type}, - $self )); - } -} - -# Sends a message to a channel or person. -# Takes 2 args: the target of the message (channel or nick) -# the text of the message to send -sub privmsg { - my ($self) = shift; - - unless (@_) { - croak 'Not enough arguments to privmsg()'; - } - - # Don't send a CR over DCC CHAT -- it's not wanted. - $self->socket->send(join('', @_) . "\012"); -} - - -# -- #perl was here! -- -# \merlyn: this girl carly at the bar is aBABE -# archon: are you sure? you don't sound like you're in a condition to -# judge such things (; -# *** Stupid has set the topic on channel #perl to \merlyn is shit-faced -# with a trucker in the shower. -# tmtowtdi: uh, yeah... -# \merlyn: good topic - - -# Sockets waiting for accept() use this to shoehorn into the select loop. -package Net::IRC::DCC::Accept; - -@Net::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection); -use Carp; -use Socket; # we use a lot of Socket functions in parse() -use strict; - - -sub new { - my ($class, $sock, $parent) = @_; - my ($self); - - $self = { _debug => $parent->debug, - _nonblock => 1, - _socket => $sock, - _parent => $parent, - _type => 'accept', - }; - - bless $self, $class; - - # Tkil's gonna love this one. :-) But what the hell... it's safe to - # assume that the only thing initiating DCCs will be Connections, right? - # Boy, we're not built for extensibility, I guess. Someday, I'll clean - # all of the things like this up. - $self->{_parent}->{_parent}->parent->addconn($self); - return $self; -} - -sub parse { - my ($self) = shift; - my ($sock); - - $sock = $self->{_socket}->accept; - $self->{_parent}->{_socket} = $sock; - $self->{_parent}->{_time} = time; - - if ($self->{_parent}->{_type} eq 'SEND') { - # ok, to get the ball rolling, we send them the first packet. - my $buf; - unless (defined $self->{_parent}->{_fh}-> - read($buf, $self->{_parent}->{_blocksize})) { - return; - } - unless (defined $sock->send($buf)) { - $sock->close; - $self->{_parent}->{_fh}->close; - $self->{_parent}->{_parent}->parent->removefh($sock); - $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', - $self->{_nick}, - $self->{_socket}, - $self->{_type})); - $self->{_socket}->close; - return; - } - } - - $self->{_parent}->{_parent}->parent->addconn($self->{_parent}); - $self->{_parent}->{_parent}->parent->removeconn($self); - - $self->{_parent}->{_parent}->handler(Net::IRC::Event-> - new('dcc_open', - $self->{_parent}->{_nick}, - $self->{_parent}->{_socket}, - $self->{_parent}->{_type}, - $self->{_parent}->{_type}, - $self->{_parent}->{_socket}) - ); -} - - - -1; - - -__END__ - -=head1 NAME - -Net::IRC::DCC - Object-oriented interface to a single DCC connection - -=head1 SYNOPSIS - -Hard hat area: This section under construction. - -=head1 DESCRIPTION - -This documentation is a subset of the main Net::IRC documentation. If -you haven't already, please "perldoc Net::IRC" before continuing. - -Net::IRC::DCC defines a few subclasses that handle DCC CHAT, GET, and SEND -requests for inter-client communication. DCC objects are created by -Cnew_{chat,get,send}()> in much the same way that -Cnewconn()> creates a new connection object. - -=head1 METHOD DESCRIPTIONS - -This section is under construction, but hopefully will be finally written up -by the next release. Please see the C script and the source for -details about this module. - -=head1 AUTHORS - -Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and -Dennis Taylor Edennis@funkplanet.comE. - -Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. - -Currently being hacked on, hacked up, and worked over by the members of the -Net::IRC developers mailing list. For details, see -http://www.execpc.com/~corbeau/irc/list.html . - -=head1 URL - -Up-to-date source and information about the Net::IRC project can be found at -http://netirc.betterbox.net/ . - -=head1 SEE ALSO - -=over - -=item * - -perl(1). - -=item * - -RFC 1459: The Internet Relay Chat Protocol - -=item * - -http://www.irchelp.org/, home of fine IRC resources. - -=back - -=cut diff --git a/Net/IRC/Event.pm b/Net/IRC/Event.pm deleted file mode 100644 index 3359a2f..0000000 --- a/Net/IRC/Event.pm +++ /dev/null @@ -1,873 +0,0 @@ -##################################################################### -# # -# Net::IRC -- Object-oriented Perl interface to an IRC server # -# # -# Event.pm: The basic data type for any IRC occurrence. # -# # -# Copyright (c) 2001 Pete Sergeant, Greg Bacon & Dennis Taylor. # -# All rights reserved. # -# # -# This module is free software; you can redistribute or # -# modify it under the terms of Perl's Artistic License. # -# # -##################################################################### - -# there used to be lots of cute little log quotes from #perl in here -# -# they're gone now because they made working on this already crappy -# code even more annoying... 'HI!!! I'm from #perl and so I don't -# write understandable, maintainable code!!! You see, i'm a perl -# badass, so I try to be as obscure as possible in everything I do!' -# -# Well, welcome to the real world, guys, where code needs to be -# maintainable and sane. - -package Net::IRC::Event; - -use strict; -our %_names; - -# Constructor method for Net::IRC::Event objects. -# Takes at least 4 args: the type of event -# the person or server that initiated the event -# the recipient(s) of the event, as arrayref or scalar -# the name of the format string for the event -# (optional) any number of arguments provided by the event -sub new { - my $class = shift; - my $type = shift; - my $from = shift; - my $to = shift; - my $format = shift; - my $args = \@_; - - my $self = { - 'type' => $type, - 'from' => undef, - 'to' => ref($to) eq 'ARRAY' ? $to : [ $to ], - 'format' => $format, - 'args' => [], - }; - - bless $self, $class; - - if ($self->type !~ /\D/) { - $self->type($self->trans($self->type)); - } else { - $self->type(lc($self->type)); - } - - $self->from($from); # sets nick, user, and host - $self->args($args); # strips colons from args - - return $self; -} - -# Sets or returns an argument list for this event. -# Takes any number of args: the arguments for the event. -sub args { - my $self = shift; - my $args = shift; - - if($args) { - my (@q, $i, $ct) = @{$args}; # This line is solemnly dedicated to \mjd. - - $self->{'args'} = [ ]; - while (@q) { - $i = shift @q; - next unless defined $i; - - if ($i =~ /^:/ and $ct) { # Concatenate :-args. - $i = join ' ', (substr($i, 1), @q); - push @{$self->{'args'}}, $i; - last; - } - push @{$self->{'args'}}, $i; - $ct++; - } - } - - return @{$self->{'args'}}; -} - -# Dumps the contents of an event to STDERR so you can see what's inside. -# Takes no args. -sub dump { - my ($self, $arg, $counter) = (shift, undef, 0); # heh heh! - - printf STDERR "TYPE: %-30s FORMAT: %-30s\n", $self->type, $self->format; - print STDERR "FROM: ", $self->from, "\n"; - print STDERR "TO: ", join(", ", @{$self->to}), "\n"; - foreach $arg ($self->args) { - print "Arg ", $counter++, ": ", $arg, "\n"; - } -} - -# Sets or returns the format string for this event. -# Takes 1 optional arg: the new value for this event's "format" field. -sub format { - my $self = shift; - - $self->{'format'} = $_[0] if @_; - return $self->{'format'}; -} - -# Sets or returns the originator of this event -# Takes 1 optional arg: the new value for this event's "from" field. -sub from { - my $self = shift; - my @part; - - if (@_) { - # avoid certain irritating and spurious warnings from this line... - { local $^W; - @part = split /[\@!]/, $_[0], 3; - } - - $self->nick(defined $part[0] ? $part[0] : ''); - $self->user(defined $part[1] ? $part[1] : ''); - $self->host(defined $part[2] ? $part[2] : ''); - defined $self->user ? - $self->userhost($self->user . '@' . $self->host) : - $self->userhost($self->host); - $self->{'from'} = $_[0]; - } - - return $self->{'from'}; -} - -# Sets or returns the hostname of this event's initiator -# Takes 1 optional arg: the new value for this event's "host" field. -sub host { - my $self = shift; - - $self->{'host'} = $_[0] if @_; - return $self->{'host'}; -} - -# Sets or returns the nick of this event's initiator -# Takes 1 optional arg: the new value for this event's "nick" field. -sub nick { - my $self = shift; - - $self->{'nick'} = $_[0] if @_; - return $self->{'nick'}; -} - -# Sets or returns the recipient list for this event -# Takes any number of args: this event's list of recipients. -sub to { - my $self = shift; - - $self->{'to'} = [ @_ ] if @_; - return wantarray ? @{$self->{'to'}} : $self->{'to'}; -} - -# Sets or returns the type of this event -# Takes 1 optional arg: the new value for this event's "type" field. -sub type { - my $self = shift; - - $self->{'type'} = $_[0] if @_; - return $self->{'type'}; -} - -# Sets or returns the username of this event's initiator -# Takes 1 optional arg: the new value for this event's "user" field. -sub user { - my $self = shift; - - $self->{'user'} = $_[0] if @_; - return $self->{'user'}; -} - -# Just $self->user plus '@' plus $self->host, for convenience. -sub userhost { - my $self = shift; - - $self->{'userhost'} = $_[0] if @_; - return $self->{'userhost'}; -} - -#added by AfterDeath. Use this to reply to channel messages in channel, but private messages to the nick that sent it. -sub replyto { - my $self = shift; - if ($self->{to}->[0] =~ /^[+@#&%]/) { - return $self->{to}->[0]; - } else { - return $self->{nick}; - } -} - -# Simple sub for translating server numerics to their appropriate names. -# Takes one arg: the number to be translated. -sub trans { - shift if (ref($_[0]) || $_[0]) =~ /^Net::IRC/; - my $ev = shift; - - return (exists $_names{$ev} ? $_names{$ev} : undef); -} - -%_names = ( - # suck! these aren't treated as strings -- - # 001 ne 1 for the purpose of hash keying, apparently. - '001' => "welcome", - '002' => "yourhost", - '003' => "created", - '004' => "myinfo", - '005' => "map", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 - '006' => "mapmore", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 - '007' => "mapend", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 - '008' => "snomask", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 - '009' => "statmemtot", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 - '010' => "statmem", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 - - 200 => "tracelink", - 201 => "traceconnecting", - 202 => "tracehandshake", - 203 => "traceunknown", - 204 => "traceoperator", - 205 => "traceuser", - 206 => "traceserver", - 208 => "tracenewtype", - 209 => "traceclass", - 211 => "statslinkinfo", - 212 => "statscommands", - 213 => "statscline", - 214 => "statsnline", - 215 => "statsiline", - 216 => "statskline", - 217 => "statsqline", - 218 => "statsyline", - 219 => "endofstats", - 220 => "statsbline", # UnrealIrcd, Hendrik Frenzel - 221 => "umodeis", - 222 => "sqline_nick", # UnrealIrcd, Hendrik Frenzel - 223 => "statsgline", # UnrealIrcd, Hendrik Frenzel - 224 => "statstline", # UnrealIrcd, Hendrik Frenzel - 225 => "statseline", # UnrealIrcd, Hendrik Frenzel - 226 => "statsnline", # UnrealIrcd, Hendrik Frenzel - 227 => "statsvline", # UnrealIrcd, Hendrik Frenzel - 231 => "serviceinfo", - 232 => "endofservices", - 233 => "service", - 234 => "servlist", - 235 => "servlistend", - 241 => "statslline", - 242 => "statsuptime", - 243 => "statsoline", - 244 => "statshline", - 245 => "statssline", # Reserved, Kajetan@Hinner.com, 17/10/98 - 246 => "statstline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 247 => "statsgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 -### TODO: need numerics to be able to map to multiple strings -### 247 => "statsxline", # UnrealIrcd, Hendrik Frenzel - 248 => "statsuline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 249 => "statsdebug", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98 - 250 => "luserconns", # 1998-03-15 -- tkil - 251 => "luserclient", - 252 => "luserop", - 253 => "luserunknown", - 254 => "luserchannels", - 255 => "luserme", - 256 => "adminme", - 257 => "adminloc1", - 258 => "adminloc2", - 259 => "adminemail", - 261 => "tracelog", - 262 => "endoftrace", # 1997-11-24 -- archon - 263 => "rpl_tryagain", - 265 => "n_local", # 1997-10-16 -- tkil - 266 => "n_global", # 1997-10-16 -- tkil - 271 => "silelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 272 => "endofsilelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 275 => "statsdline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 280 => "glist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 281 => "endofglist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 290 => "helphdr", # UnrealIrcd, Hendrik Frenzel - 291 => "helpop", # UnrealIrcd, Hendrik Frenzel - 292 => "helptlr", # UnrealIrcd, Hendrik Frenzel - 293 => "helphlp", # UnrealIrcd, Hendrik Frenzel - 294 => "helpfwd", # UnrealIrcd, Hendrik Frenzel - 295 => "helpign", # UnrealIrcd, Hendrik Frenzel - - 300 => "none", - 301 => "away", - 302 => "userhost", - 303 => "ison", - 304 => "rpl_text", # Bahamut IRCD - 305 => "unaway", - 306 => "nowaway", - 307 => "userip", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 308 => "rulesstart", # UnrealIrcd, Hendrik Frenzel - 309 => "endofrules", # UnrealIrcd, Hendrik Frenzel - 310 => "whoishelp", # (July01-01)Austnet Extension, found by Andypoo - 311 => "whoisuser", - 312 => "whoisserver", - 313 => "whoisoperator", - 314 => "whowasuser", - 315 => "endofwho", - 316 => "whoischanop", - 317 => "whoisidle", - 318 => "endofwhois", - 319 => "whoischannels", - 320 => "whoisvworld", # (July01-01)Austnet Extension, found by Andypoo - 321 => "liststart", - 322 => "list", - 323 => "listend", - 324 => "channelmodeis", - 328 => "channelurlis", - 329 => "channelcreate", # 1997-11-24 -- archon - 331 => "notopic", - 332 => "topic", - 333 => "topicinfo", # 1997-11-24 -- archon - 334 => "listusage", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 335 => "whoisbot", # UnrealIrcd, Hendrik Frenzel - 341 => "inviting", - 342 => "summoning", - 346 => "invitelist", # UnrealIrcd, Hendrik Frenzel - 347 => "endofinvitelist", # UnrealIrcd, Hendrik Frenzel - 348 => "exlist", # UnrealIrcd, Hendrik Frenzel - 349 => "endofexlist", # UnrealIrcd, Hendrik Frenzel - 351 => "version", - 352 => "whoreply", - 353 => "namreply", - 354 => "whospcrpl", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 361 => "killdone", - 362 => "closing", - 363 => "closeend", - 364 => "links", - 365 => "endoflinks", - 366 => "endofnames", - 367 => "banlist", - 368 => "endofbanlist", - 369 => "endofwhowas", - 371 => "info", - 372 => "motd", - 373 => "infostart", - 374 => "endofinfo", - 375 => "motdstart", - 376 => "endofmotd", - 377 => "motd2", # 1997-10-16 -- tkil - 378 => "austmotd", # (July01-01)Austnet Extension, found by Andypoo - 379 => "whoismodes", # UnrealIrcd, Hendrik Frenzel - 381 => "youreoper", - 382 => "rehashing", - 383 => "youreservice", # UnrealIrcd, Hendrik Frenzel - 384 => "myportis", - 385 => "notoperanymore", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98 - 386 => "qlist", # UnrealIrcd, Hendrik Frenzel - 387 => "endofqlist", # UnrealIrcd, Hendrik Frenzel - 388 => "alist", # UnrealIrcd, Hendrik Frenzel - 389 => "endofalist", # UnrealIrcd, Hendrik Frenzel - 391 => "time", - 392 => "usersstart", - 393 => "users", - 394 => "endofusers", - 395 => "nousers", - 396 => "hosthidden", - - 401 => "nosuchnick", - 402 => "nosuchserver", - 403 => "nosuchchannel", - 404 => "cannotsendtochan", - 405 => "toomanychannels", - 406 => "wasnosuchnick", - 407 => "toomanytargets", - 408 => "nosuchservice", # UnrealIrcd, Hendrik Frenzel - 409 => "noorigin", - 411 => "norecipient", - 412 => "notexttosend", - 413 => "notoplevel", - 414 => "wildtoplevel", - 416 => "querytoolong", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 421 => "unknowncommand", - 422 => "nomotd", - 423 => "noadmininfo", - 424 => "fileerror", - 425 => "noopermotd", # UnrealIrcd, Hendrik Frenzel - 431 => "nonicknamegiven", - 432 => "erroneusnickname", # This iz how its speld in thee RFC. - 433 => "nicknameinuse", - 434 => "norules", # UnrealIrcd, Hendrik Frenzel - 435 => "serviceconfused", # UnrealIrcd, Hendrik Frenzel - 436 => "nickcollision", - 437 => "bannickchange", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 438 => "nicktoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 439 => "targettoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 440 => "servicesdown", # Bahamut IRCD - 441 => "usernotinchannel", - 442 => "notonchannel", - 443 => "useronchannel", - 444 => "nologin", - 445 => "summondisabled", - 446 => "usersdisabled", - 447 => "nonickchange", # UnrealIrcd, Hendrik Frenzel - 451 => "notregistered", - 455 => "hostilename", # UnrealIrcd, Hendrik Frenzel - 459 => "nohiding", # UnrealIrcd, Hendrik Frenzel - 460 => "notforhalfops", # UnrealIrcd, Hendrik Frenzel - 461 => "needmoreparams", - 462 => "alreadyregistered", - 463 => "nopermforhost", - 464 => "passwdmismatch", - 465 => "yourebannedcreep", # I love this one... - 466 => "youwillbebanned", - 467 => "keyset", - 468 => "invalidusername", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 469 => "linkset", # UnrealIrcd, Hendrik Frenzel - 470 => "linkchannel", # UnrealIrcd, Hendrik Frenzel - 471 => "channelisfull", - 472 => "unknownmode", - 473 => "inviteonlychan", - 474 => "bannedfromchan", - 475 => "badchannelkey", - 476 => "badchanmask", - 477 => "needreggednick", # Bahamut IRCD - 478 => "banlistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 479 => "secureonlychannel", # pircd -### TODO: see above todo -### 479 => "linkfail", # UnrealIrcd, Hendrik Frenzel - 480 => "cannotknock", # UnrealIrcd, Hendrik Frenzel - 481 => "noprivileges", - 482 => "chanoprivsneeded", - 483 => "cantkillserver", - 484 => "ischanservice", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 485 => "killdeny", # UnrealIrcd, Hendrik Frenzel - 486 => "htmdisabled", # UnrealIrcd, Hendrik Frenzel - 489 => "secureonlychan", # UnrealIrcd, Hendrik Frenzel - 491 => "nooperhost", - 492 => "noservicehost", - - 501 => "umodeunknownflag", - 502 => "usersdontmatch", - - 511 => "silelistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 513 => "nosuchgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 513 => "badping", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 - 518 => "noinvite", # UnrealIrcd, Hendrik Frenzel - 519 => "admonly", # UnrealIrcd, Hendrik Frenzel - 520 => "operonly", # UnrealIrcd, Hendrik Frenzel - 521 => "listsyntax", # UnrealIrcd, Hendrik Frenzel - 524 => "operspverify", # UnrealIrcd, Hendrik Frenzel - - 600 => "rpl_logon", # Bahamut IRCD - 601 => "rpl_logoff", # Bahamut IRCD - 602 => "rpl_watchoff", # UnrealIrcd, Hendrik Frenzel - 603 => "rpl_watchstat", # UnrealIrcd, Hendrik Frenzel - 604 => "rpl_nowon", # Bahamut IRCD - 605 => "rpl_nowoff", # Bahamut IRCD - 606 => "rpl_watchlist", # UnrealIrcd, Hendrik Frenzel - 607 => "rpl_endofwatchlist", # UnrealIrcd, Hendrik Frenzel - 610 => "mapmore", # UnrealIrcd, Hendrik Frenzel - 640 => "rpl_dumping", # UnrealIrcd, Hendrik Frenzel - 641 => "rpl_dumprpl", # UnrealIrcd, Hendrik Frenzel - 642 => "rpl_eodump", # UnrealIrcd, Hendrik Frenzel - - 716 => "rpl_ignored", - - 728 => "quietlist", - 729 => "quietlistend", - 999 => "numericerror", # Bahamut IRCD - 'pong' => "pong", - ); - - -1; - - -__END__ - -=head1 NAME - -Net::IRC::Event - A class for passing event data between subroutines - -=head1 SYNOPSIS - -None yet. These docs are under construction. - -=head1 DESCRIPTION - -This documentation is a subset of the main Net::IRC documentation. If -you haven't already, please "perldoc Net::IRC" before continuing. - -Net::IRC::Event defines a standard interface to the salient information for -just about any event your client may witness on IRC. It's about as close as -we can get in Perl to a struct, with a few extra nifty features thrown in. - -=head1 METHOD DESCRIPTIONS - -This section is under construction, but hopefully will be finally written up -by the next release. Please see the C script and the source for -details about this module. - -=head1 LIST OF EVENTS - -Net::IRC is an entirely event-based system, which takes some getting used to -at first. To interact with the IRC server, you tell Net::IRC's server -connection to listen for certain events and activate your own subroutines when -they occur. Problem is, this doesn't help you much if you don't know what to -tell it to look for. Below is a list of the possible events you can pass to -Net::IRC, along with brief descriptions of each... hope this helps. - -=head2 Common events - -=over - -=item * - -nick - -The "nick" event is triggered when the client receives a NICK message, meaning -that someone on a channel with the client has changed eir nickname. - -=item * - -quit - -The "quit" event is triggered upon receipt of a QUIT message, which means that -someone on a channel with the client has disconnected. - -=item * - -join - -The "join" event is triggered upon receipt of a JOIN message, which means that -someone has entered a channel that the client is on. - -=item * - -part - -The "part" event is triggered upon receipt of a PART message, which means that -someone has left a channel that the client is on. - -=item * - -mode - -The "mode" event is triggered upon receipt of a MODE message, which means that -someone on a channel with the client has changed the channel's parameters. - -=item * - -topic - -The "topic" event is triggered upon receipt of a TOPIC message, which means -that someone on a channel with the client has changed the channel's topic. - -=item * - -kick - -The "kick" event is triggered upon receipt of a KICK message, which means that -someone on a channel with the client (or possibly the client itself!) has been -forcibly ejected. - -=item * - -public - -The "public" event is triggered upon receipt of a PRIVMSG message to an entire -channel, which means that someone on a channel with the client has said -something aloud. - -=item * - -msg - -The "msg" event is triggered upon receipt of a PRIVMSG message which is -addressed to one or more clients, which means that someone is sending the -client a private message. (Duh. :-) - -=item * - -notice - -The "notice" event is triggered upon receipt of a NOTICE message, which means -that someone has sent the client a public or private notice. (Is that -sufficiently vague?) - -=item * - -ping - -The "ping" event is triggered upon receipt of a PING message, which means that -the IRC server is querying the client to see if it's alive. Don't confuse this -with CTCP PINGs, explained later. - -=item * - -other - -The "other" event is triggered upon receipt of any number of unclassifiable -miscellaneous messages, but you're not likely to see it often. - -=item * - -invite - -The "invite" event is triggered upon receipt of an INVITE message, which means -that someone is permitting the client's entry into a +i channel. - -=item * - -kill - -The "kill" event is triggered upon receipt of a KILL message, which means that -an IRC operator has just booted your sorry arse offline. Seeya! - -=item * - -disconnect - -The "disconnect" event is triggered when the client loses its -connection to the IRC server it's talking to. Don't confuse it with -the "leaving" event. (See below.) - -=item * - -leaving - -The "leaving" event is triggered just before the client deliberately -closes a connection to an IRC server, in case you want to do anything -special before you sign off. - -=item * - -umode - -The "umode" event is triggered when the client changes its personal mode flags. - -=item * - -error - -The "error" event is triggered when the IRC server complains to you about -anything. Sort of the evil twin to the "other" event, actually. - -=back - -=head2 CTCP Requests - -=over - -=item * - -cping - -The "cping" event is triggered when the client receives a CTCP PING request -from another user. See the irctest script for an example of how to properly -respond to this common request. - -=item * - -cversion - -The "cversion" event is triggered when the client receives a CTCP VERSION -request from another client, asking for version info about its IRC client -program. - -=item * - -csource - -The "csource" event is triggered when the client receives a CTCP SOURCE -request from another client, asking where it can find the source to its -IRC client program. - -=item * - -ctime - -The "ctime" event is triggered when the client receives a CTCP TIME -request from another client, asking for the local time at its end. - -=item * - -cdcc - -The "cdcc" event is triggered when the client receives a DCC request of any -sort from another client, attempting to establish a DCC connection. - -=item * - -cuserinfo - -The "cuserinfo" event is triggered when the client receives a CTCP USERINFO -request from another client, asking for personal information from the client's -user. - -=item * - -cclientinfo - -The "cclientinfo" event is triggered when the client receives a CTCP CLIENTINFO -request from another client, asking for whatever the hell "clientinfo" means. - -=item * - -cerrmsg - -The "cerrmsg" event is triggered when the client receives a CTCP ERRMSG -request from another client, notifying it of a protocol error in a preceding -CTCP communication. - -=item * - -cfinger - -The "cfinger" event is triggered when the client receives a CTCP FINGER -request from another client. How to respond to this should best be left up -to your own moral stance. - -=item * - -caction - -The "caction" event is triggered when the client receives a CTCP ACTION -message from another client. I should hope you're getting the hang of how -Net::IRC handles CTCP requests by now... - -=back - -=head2 CTCP Responses - -=over - -=item * - -crping - -The "crping" event is triggered when the client receives a CTCP PING response -from another user. See the irctest script for an example of how to properly -respond to this common event. - -=item * - -crversion - -The "crversion" event is triggered when the client receives a CTCP VERSION -response from another client. - -=item * - -crsource - -The "crsource" event is triggered when the client receives a CTCP SOURCE -response from another client. - -=item * - -crtime - -The "crtime" event is triggered when the client receives a CTCP TIME -response from another client. - -=item * - -cruserinfo - -The "cruserinfo" event is triggered when the client receives a CTCP USERINFO -response from another client. - -=item * - -crclientinfo - -The "crclientinfo" event is triggered when the client receives a CTCP -CLIENTINFO response from another client. - -=item * - -crfinger - -The "crfinger" event is triggered when the client receives a CTCP FINGER -response from another client. I'm not even going to consider making a joke -about this one. - -=back - -=head2 DCC Events - -=over - -=item * - -dcc_open - -The "dcc_open" event is triggered when a DCC connection is established between -the client and another client. - -=item * - -dcc_update - -The "dcc_update" event is triggered when any data flows over a DCC connection. -Useful for doing things like monitoring file transfer progress, for instance. - -=item * - -dcc_close - -The "dcc_close" event is triggered when a DCC connection closes, whether from -an error or from natural causes. - -=item * - -chat - -The "chat" event is triggered when the person on the other end of a DCC CHAT -connection sends you a message. Think of it as the private equivalent of "msg", -if you will. - -=back - -=head2 Numeric Events - -=over - -=item * - -There's a whole lot of them, and they're well-described elsewhere. Please see -the IRC RFC (1495, at http://cs-ftp.bu.edu/pub/irc/support/IRC_RFC ) for a -detailed description, or the Net::IRC::Event.pm source code for a quick list. - -=back - -=head1 AUTHORS - -Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and -Dennis Taylor Edennis@funkplanet.comE. - -Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. - -Currently being hacked on, hacked up, and worked over by the members of the -Net::IRC developers mailing list. For details, see -http://www.execpc.com/~corbeau/irc/list.html . - -=head1 URL - -Up-to-date source and information about the Net::IRC project can be found at -http://netirc.betterbox.net/ . - -=head1 SEE ALSO - -=over - -=item * - -perl(1). - -=item * - -RFC 1459: The Internet Relay Chat Protocol - -=item * - -http://www.irchelp.org/, home of fine IRC resources. - -=back - -=cut - diff --git a/Net/IRC/EventQueue.pm b/Net/IRC/EventQueue.pm deleted file mode 100644 index fdb7b44..0000000 --- a/Net/IRC/EventQueue.pm +++ /dev/null @@ -1,73 +0,0 @@ -package Net::IRC::EventQueue; - -use Net::IRC::EventQueue::Entry; - -use strict; - -sub new { - my $class = shift; - - my $self = { - 'queue' => {}, - }; - - bless $self, $class; -} - -sub queue { - my $self = shift; - return $self->{'queue'}; -} - -sub enqueue { - my $self = shift; - my $time = shift; - my $content = shift; - - my $entry = new Net::IRC::EventQueue::Entry($time, $content); - $self->queue->{$entry->id} = $entry; - return $entry->id; -} - -sub dequeue { - my $self = shift; - my $event = shift; - my $result; - - if(!$event) { # we got passed nothing, so return the first event - $event = $self->head(); - delete $self->queue->{$event->id}; - $result = $event; - } elsif(!ref($event)) { # we got passed an id - $result = $self->queue->{$event}; - delete $self->queue->{$event}; - } else { # we got passed an actual event object - ref($event) eq 'Net::IRC::EventQueue::Entry' - or die "Cannot delete event type of " . ref($event) . "!"; - - $result = $self->queue->{$event->id}; - delete $self->queue->{$event->id}; - } - - return $result; -} - -sub head { - my $self = shift; - - return undef if $self->is_empty; - - no warnings; # because we want to numerically sort strings... - my $headkey = (sort {$a <=> $b} (keys(%{$self->queue})))[0]; - use warnings; - - return $self->queue->{$headkey}; -} - -sub is_empty { - my $self = shift; - - return keys(%{$self->queue}) ? 0 : 1; -} - -1; diff --git a/Net/IRC/EventQueue/Entry.pm b/Net/IRC/EventQueue/Entry.pm deleted file mode 100644 index 94a3802..0000000 --- a/Net/IRC/EventQueue/Entry.pm +++ /dev/null @@ -1,40 +0,0 @@ -package Net::IRC::EventQueue::Entry; - -use strict; - -my $id = 0; - -sub new { - my $class = shift; - my $time = shift; - my $content = shift; - - my $self = { - 'time' => $time, - 'content' => $content, - 'id' => "$time:" . $id++, - }; - - bless $self, $class; - return $self; -} - -sub id { - my $self = shift; - return $self->{'id'}; -} - -sub time { - my $self = shift; - $self->{'time'} = $_[0] if @_; - return $self->{'time'}; -} - -sub content { - my $self = shift; - $self->{'content'} = $_[0] if @_; - return $self->{'content'}; -} - -1; - diff --git a/lib/ASM/Classes.pm b/lib/ASM/Classes.pm new file mode 100644 index 0000000..1054f63 --- /dev/null +++ b/lib/ASM/Classes.pm @@ -0,0 +1,514 @@ +package ASM::Classes; + +use strict; +use warnings; +use Text::LevenshteinXS qw(distance); +use Data::Dumper; +use Regexp::Wildcards; +use Carp qw(cluck); + +my %sf = (); + +sub new +{ + my $module = shift; + my $self = {}; + my $tbl = { + "strbl" => \&strbl, + "strblnew" => \&strblnew, + "dnsbl" => \&dnsbl, + "floodqueue" => \&floodqueue, + "floodqueue2" => \&floodqueue2, + "nickspam" => \&nickspam, + "splitflood" => \&splitflood, + "advsplitflood" => \&advsplitflood, + "re" => \&re, + "nick" => \&nick, + "ident" => \&ident, + "host" => \&host, + "gecos" => \&gecos, + "nuhg" => \&nuhg, + "levenflood" => \&levenflood, + "proxy" => \&proxy, + "nickbl" => \&nickbl, + "nickfuzzy" => \&nickfuzzy, + "asciiflood" => \&asciiflood, + "joinmsgquit" => \&joinmsgquit, + "garbagemeter" => \&garbagemeter, + "cyclebotnet" => \&cyclebotnet, + "banevade" => \&banevade, + "urlcrunch" => \&urlcrunch + }; + $self->{ftbl} = $tbl; + bless($self); + return $self; +} + +sub garbagemeter { + my ($chk, $id, $event, $chan, $rev) = @_; + my @cut = split(/:/, $chk->{content}); + my $limit = int($cut[0]); + my $timeout = int($cut[1]); + my $threshold = int($cut[2]); + my $threshold2 = int($cut[3]); + my $wordcount = 0; + my $line = $event->{args}->[0]; + return 0 unless ($line =~ /^[A-Za-z: ]+$/); + my @words = split(/ /, $line); + return 0 unless ((scalar @words) >= $threshold2); + foreach my $word (@words) { + if (defined($::wordlist{lc $word})) { + $wordcount += 1; + } + return 0 if ($wordcount >= $threshold); + } + return 1 if ( flood_add( $chan, $id, 0, $timeout ) == $limit ); + return 0; +} + +sub joinmsgquit +{ + my ($chk, $id, $event, $chan, $rev) = @_; + my $time = $chk->{content}; +##STATE + $chan = lc $chan; #don't know if this is necessary but I'm trying to track down some mysterious state tracking corruption + return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{jointime}); + return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{msgtime}); + return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{jointime}) > $time); + return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{msgtime}) > $time); + return 1; +} + +sub urlcrunch +{ + my ($chk, $id, $event, $chan, $response) = @_; + return 0 unless defined($response); + return 0 unless ref($response); + return 0 unless defined($response->{_previous}); + return 0 unless defined($response->{_previous}->{_headers}); + return 0 unless defined($response->{_previous}->{_headers}->{location}); + if ($response->{_previous}->{_headers}->{location} =~ /$chk->{content}/i) { + return 1; + } + return 0; +} + +sub check +{ + my $self = shift; + my $item = shift; + return $self->{ftbl}->{$item}->(@_); +} + +sub nickbl +{ + my ($chk, $id, $event, $chan, $rev) = @_; + my $match = lc $event->{nick}; + foreach my $line (@::nick_blacklist) { + if ($line eq $match) { + return 1; + } + } + return 0; +} + +sub banevade +{ + my ($chk, $id, $event, $chan, $rev) = @_; + my $ip = ASM::Util->getNickIP($event->{nick}); + return 0 unless defined($ip); + if (defined($::sc{lc $chan}{ipbans}{$ip})) { + return 1; + } + return 0; +} + +sub proxy +{ + my ($chk, $id, $event, $chan, $rev) = @_; + if (defined($rev) and ($rev =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)\./)) { + if (defined($::proxies{"$4.$3.$2.$1"})) { + return 1; + } + } + return 0; +} + +my %ls = (); +sub levenflood +{ + my ($chk, $id, $event, $chan) = @_; + my $text; + if ($event->{type} =~ /^(public|notice|part|caction)$/) { + $text = $event->{args}->[0]; + } + return 0 unless ( defined($text) && (length($text) >= 30) ); + if ( ! defined($ls{$chan}) ) { + $ls{$chan} = [ $text ]; + return 0; + } + my @leven = @{$ls{$chan}}; + my $ret = 0; + if ( $#leven >= 5 ) { + my $mx = 0; + foreach my $item ( @leven ) { + next unless length($text) eq length($item); + my $tld = distance($text, $item); + if ($tld <= 4) { + $mx = $mx + 1; + } + } + if ($mx >= 5) { + $ret = 1; + } + } + push(@leven, $text); + shift @leven if $#leven > 10; + $ls{$chan} = \@leven; + return $ret; +} + +sub nickfuzzy +{ + my ($chk, $id, $event, $chan) = @_; + my $nick = $event->{nick}; + $nick = $event->{args}->[0] if ($event->{type} eq 'nick'); + my ($fuzzy, $match) = split(/:/, $chk->{content}); + my @nicks = split(/,/, $match); + foreach my $item (@nicks) { + if (distance(lc $nick, lc $item) <= $fuzzy) { + return 1; + } + } + return 0; +} + +sub dnsbl +{ + my ($chk, $id, $event, $chan, $rev) = @_; +# return unless index($event->{host}, '/') == -1; +# hopefully getting rid of this won't cause shit to assplode +# but I'm getting rid of it so it can detect cgi:irc shit +# return 0; + if (defined $rev) { + ASM::Util->dprint("Querying $rev$chk->{content}", "dnsbl"); + #cluck "Calling gethostbyname in dnsbl"; + my $iaddr = gethostbyname( "$rev$chk->{content}" ); + my @dnsbl = unpack( 'C4', $iaddr ) if defined $iaddr; + my $strip; + if (@dnsbl) { + $strip = sprintf("%s.%s.%s.%s", @dnsbl); + ASM::Util->dprint("found host (rev $rev) in $chk->{content} - $strip", 'dnsbl'); + } + if ((@dnsbl) && (defined($::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}))) { + $::lastlookup=$::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content}; + ASM::Util->dprint("chk->content: $chk->{content}", 'dnsbl'); + ASM::Util->dprint("strip: $strip", 'dnsbl'); + ASM::Util->dprint("result: " . $::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content}, 'dnsbl'); + $::sn{lc $event->{nick}}->{dnsbl} = 1; + # lol really icky hax + return $::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content}; + } + } + return 0; +} + +sub floodqueue2 { + my ($chk, $id, $event, $chan, $rev) = @_; + my @cut = split(/:/, $chk->{content}); + + my $cvt = Regexp::Wildcards->new(type => 'jokers'); + my $hit = 0; + foreach my $mask ( keys %{$::sc{lc $chan}{quiets}}) { + if ($mask !~ /^\$/) { + my @div = split(/\$/, $mask); + my $regex = $cvt->convert($div[0]); + if (lc $event->{from} =~ lc $regex) { + $hit = 1; + } + } elsif ( (defined($::sn{lc $event->{nick}}{account})) && ($mask =~ /^\$a:(.*)/)) { + my @div = split(/\$/, $mask); + my $regex = $cvt->convert($div[0]); + if (lc ($::sn{lc $event->{nick}}{account}) =~ lc $regex) { + $hit = 1; + } + } + } + return 0 unless $hit; + + return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[1]) ) == int($cut[0]) ); + return 0; +} + +sub floodqueue { + my ($chk, $id, $event, $chan, $rev) = @_; + my @cut = split(/:/, $chk->{content}); + return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[1]) ) == int($cut[0]) ); + return 0; +} + +sub asciiflood { + my ($chk, $id, $event, $chan, $rev) = @_; + my @cut = split(/:/, $chk->{content}); + return 0 if (length($event->{args}->[0]) < $cut[0]); + return 0 if ($event->{args}->[0] =~ /[A-Za-z0-9]/); + return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[2]) ) == int($cut[1]) ); + return 0; +} + +sub cyclebotnet +{ + my ($chk, $id, $event, $chan, $rev) = @_; + my ($cycletime, $queueamt, $queuetime) = split(/:/, $chk->{content}); + $chan = lc $chan; #don't know if this is necessary but I'm trying to track down some mysterious state tracking corruption + return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{jointime}); + return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{jointime}) > int($cycletime)); + return 1 if ( flood_add( $chan, $id, "cycle", int($queuetime)) == int($queueamt) ); + return 0; +} + +sub nickspam { + my ($chk, $id, $event, $chan) = @_; + my @cut = split(/:/, $chk->{content}); + if ( length $event->{args}->[0] >= int($cut[0]) ) { + my %users = %{$::sc{lc $chan}->{users}}; + my %x = map { $_=>$_ } keys %users; + my @uniq = grep( $x{$_}, split( /[^a-zA-Z0-9_\\|`[\]{}^-]+/ , lc $event->{args}->[0]) ); + return 1 if ( @uniq >= int($cut[1]) ); + } + return 0; +} + +my %cf=(); +my %bs=(); +my $cfc = 0; +sub process_cf +{ + foreach my $nid ( keys %cf ) { + foreach my $xchan ( keys %{$cf{$nid}} ) { + next if $xchan eq 'timeout'; + foreach my $host ( keys %{$cf{$nid}{$xchan}} ) { + next unless defined $cf{$nid}{$xchan}{$host}[0]; + while ( time >= $cf{$nid}{$xchan}{$host}[0] + $cf{$nid}{'timeout'} ) { + shift ( @{$cf{$nid}{$xchan}{$host}} ); + if ( (scalar @{$cf{$nid}{$xchan}{$host}}) == 0 ) { + delete $cf{$nid}{$xchan}{$host}; + last; + } +# last if ( $#{ $cf{$nid}{$xchan}{$host} } == 0 ); +# shift ( @{$cf{$nid}{$xchan}{$host}} ); + } + } + } + } +} + +sub splitflood { + my ($chk, $id, $event, $chan) = @_; + my $text; + my @cut = split(/:/, $chk->{content}); + $cf{$id}{timeout}=int($cut[1]); + if ($event->{type} =~ /^(public|notice|part|caction)$/) { + $text=$event->{args}->[0]; + } + return unless defined($text); + # a bit ugly but this should avoid alerting on spammy bot commands + # give them the benefit of the doubt if they talked before ... but not too recently + # if we didn't see them join, assume they did talk at some point + my $msgtime = $::sc{$chan}{users}{lc $event->{nick}}{msgtime} // 0; + $msgtime ||= 1 if !$::sc{$chan}{users}{lc $event->{nick}}{jointime}; + return if $text =~ /^[^\w\s]+\w+\s*$/ && $msgtime && ($msgtime + 2 * $cf{$id}{timeout}) < time; +# return unless length($text) >= 10; + if (defined($bs{$id}{$text}) && (time <= $bs{$id}{$text} + 600)) { + return 1; + } + push( @{$cf{$id}{$chan}{$text}}, time ); + while ( time >= $cf{$id}{$chan}{$text}[0] + $cf{$id}{'timeout'} ) { + last if ( $#{$cf{$id}{$chan}{$text}} == 0 ); + shift ( @{$cf{$id}{$chan}{$text}} ); + } + $cfc = $cfc + 1; + if ( $cfc >= 100 ) { + $cfc = 0; + process_cf(); + } + if ( scalar @{$cf{$id}{$chan}{$text}} == int($cut[0]) ) { + $bs{$id}{$text} = time unless length($text) < 10; + return 1; + } + return 0; +} + +sub advsplitflood { + my ($chk, $id, $event, $chan) = @_; + my $text; + my @cut = split(/:/, $chk->{content}); + $cf{$id}{timeout}=int($cut[1]); + if ($event->{type} =~ /^(public|notice|part|caction)$/) { + $text=$event->{args}->[0]; + } + return unless defined($text); + $text=~s/^\d*(.*)\d*$/$1/; + return unless length($text) >= 10; + if (defined($bs{$id}{$text}) && (time <= $bs{$id}{$text} + 600)) { + return 1; + } + push( @{$cf{$id}{$chan}{$text}}, time ); + while ( time >= $cf{$id}{$chan}{$text}[0] + $cf{$id}{'timeout'} ) { + last if ( $#{$cf{$id}{$chan}{$text}} == 0 ); + shift ( @{$cf{$id}{$chan}{$text}} ); + } + $cfc = $cfc + 1; + if ( $cfc >= 100 ) { + $cfc = 0; + process_cf(); + } + if ( scalar @{$cf{$id}{$chan}{$text}} == int($cut[0]) ) { + $bs{$id}{$text} = time; + return 1; + } + return 0; +} + +sub re { + my ($chk, $id, $event, $chan) = @_; + my $match = $event->{args}->[0]; + $match = $event->{nick} if ($event->{type} eq 'join'); + return 1 if ($match =~ /$chk->{content}/); + return 0; +} + +sub strbl { + my ($chk, $id, $event, $chan) = @_; + my $match = lc $event->{args}->[0]; + foreach my $line (@::string_blacklist) { + my $xline = lc $line; + my $idx = index $match, $xline; + if ( $idx != -1 ) { + return 1; + } + } + return 0; +} + +sub strblnew { + my ($chk, $xid, $event, $chan) = @_; + my $match = lc $event->{args}->[0]; + foreach my $id (keys %{$::blacklist->{string}}) { + my $line = lc $::blacklist->{string}->{$id}->{content}; + my $idx = index $match, $line; + if ( $idx != -1 ) { + my $setby = $::blacklist->{string}->{$id}->{setby}; + $setby = substr($setby, 0, 1) . "\x02\x02" . substr($setby, 1); + return defined($::blacklist->{string}->{$id}->{reason}) ? + "id $id added by $setby because $::blacklist->{string}->{$id}->{reason}" : + "id $id added by $setby for no reason"; + } + } + return 0; +} + +sub nick { + my ($chk, $id, $event, $chan) = @_; + if ( lc $event->{nick} eq lc $chk->{content} ) { + return 1; + } + return 0; +} + +sub ident { + my ( $chk, $id, $event, $chan) = @_; + if ( lc $event->{user} eq lc $chk->{content} ) { + return 1; + } + return 0; +} + +sub host { + my ( $chk, $id, $event, $chan) = @_; + if ( lc $event->{host} eq lc $chk->{content} ) { + return 1; + } + return 0; +} + +sub gecos { + my ( $chk, $id, $event, $chan) = @_; + if ( lc $::sn{lc $event->{nick}}->{gecos} eq lc $chk->{content} ) { + return 1; + } + return 0; +} + +sub nuhg { + my ( $chk, $id, $event, $chan) = @_; + return 0 unless defined($::sn{lc $event->{nick}}->{gecos}); + my $match = $event->{from} . '!' . $::sn{lc $event->{nick}}->{gecos}; + return 1 if ($match =~ /$chk->{content}/); + return 0; +} + +sub invite { + my ( $chk, $id, $event, $chan) = @_; + return 1; +} + +my $sfc = 0; + +sub flood_add +{ + my ( $chan, $id, $host, $to ) = @_; + push( @{$sf{$id}{$chan}{$host}}, time ); + while ( time >= $sf{$id}{$chan}{$host}[0] + $to ) { + last if ( $#{ $sf{$id}{$chan}{$host} } == 0 ); + shift( @{$sf{$id}{$chan}{$host}} ); + } + $sf{$id}{'timeout'} = $to; + $sfc = $sfc + 1; + if ($sfc > 100) { + $sfc = 0; + flood_process(); + } +# return $#{ @{$sf{$id}{$chan}{$host}}}+1; + return scalar @{$sf{$id}{$chan}{$host}}; +} + +sub flood_process +{ + for my $id ( keys %sf ) { + for my $chan ( keys %{$sf{$id}} ) { + next if $chan eq 'timeout'; + for my $host ( keys %{$sf{$id}{$chan}} ) { + next unless defined $sf{$id}{$chan}{$host}[0]; + while ( time >= $sf{$id}{$chan}{$host}[0] + $sf{$id}{'timeout'} ) { + shift ( @{$sf{$id}{$chan}{$host}} ); + if ( (scalar @{$sf{$id}{$chan}{$host}}) == 0 ) { + delete $sf{$id}{$chan}{$host}; + last; + } +# last if ( $#{ $sf{$id}{$chan}{$host} } == 0 ); +# shift ( @{$sf{$id}{$chan}{$host}} ); + } + } + } + } +} + +sub dump +{ + #%sf, %ls, %cf, %bs + open(FH, ">", "sf.txt"); + print FH Dumper(\%sf); + close(FH); + open(FH, ">", "ls.txt"); + print FH Dumper(\%ls); + close(FH); + open(FH, ">", "cf.txt"); + print FH Dumper(\%cf); + close(FH); + open(FH, ">", "bs.txt"); + print FH Dumper(\%bs); + close(FH); +} + +1; diff --git a/lib/ASM/Commander.pm b/lib/ASM/Commander.pm new file mode 100644 index 0000000..aa79f4d --- /dev/null +++ b/lib/ASM/Commander.pm @@ -0,0 +1,61 @@ +package ASM::Commander; + +use warnings; +use strict; +use IO::All; +use POSIX qw(strftime); +use Data::Dumper; +use URI::Escape; + +sub new +{ + my $module = shift; + my $self = {}; + bless($self); + return $self; +} + +sub command +{ + my ($self, $conn, $event) = @_; + my $args = $event->{args}->[0]; + my $from = $event->{from}; + my $cmd = $args; + my $d1; + my $nick = lc $event->{nick}; + my $acct = lc $::sn{$nick}->{account}; +# return 0 unless (ASM::Util->speak($event->{to}->[0])); + foreach my $command ( @{$::commands->{command}} ) + { + my $fail = 0; + unless ( (ASM::Util->speak($event->{to}->[0])) ) { + next unless (defined($command->{nohush}) && ($command->{nohush} eq "nohush")); + } + if (defined($command->{flag})) { #If the command is restricted, + if (!defined($::users->{person}->{$acct})) { #make sure the requester has an account + $fail = 1; + } + elsif (!defined($::users->{person}->{$acct}->{flags})) { #make sure the requester has flags defined + $fail = 1; + } + elsif (!(grep {$_ eq $command->{flag}} split('', $::users->{person}->{$acct}->{flags}))) { #make sure the requester has the needed flags + $fail = 1; + } + } + if ($cmd=~/$command->{cmd}/) { + ASM::Util->dprint("$event->{from} told me: $cmd", "commander"); + if (!ASM::Util->notRestricted($nick, "nocommands")) { + $fail = 1; + } + if ($fail == 1) { + $conn->privmsg($nick, "You don't have permission to use that command, or you're not signed into nickserv."); + } else { + eval $command->{content}; + warn $@ if $@; + } + last; + } + } +} + +1; diff --git a/lib/ASM/DB.pm b/lib/ASM/DB.pm new file mode 100644 index 0000000..86a1c78 --- /dev/null +++ b/lib/ASM/DB.pm @@ -0,0 +1,323 @@ +package ASM::DB; + +use warnings; +use strict; +use DBI; +use Data::Dumper; + +sub new { + my $module = shift; + my ($db, $host, $port, $user, $pass, $table, $actiontable, $dblog) = @_; + my $self = {}; + $self->{DBH} = DBI->connect("DBI:mysql:database=$db;host=$host;port=$port", $user, $pass); + $self->{DBH_LOG} = DBI->connect("DBI:mysql:database=$dblog;host=$host;port=$port", $user, $pass); + $self->{DBH}->{mysql_auto_reconnect} = 1; + $self->{DBH_LOG}->{mysql_auto_reconnect} = 1; + $self->{TABLE} = $table; + $self->{ACTIONTABLE} = $actiontable; + bless($self); + return $self; +} + +#sub sql_connect +#{ +# $::dbh = DBI->connect("DBI:mysql:database=$::mysql->{db};host=$::mysql->{host};port=$::mysql->{port}", +# $::mysql->{user}, $::mysql->{pass}); +# $::dbh->{mysql_auto_reconnect} = 1; +#} + +sub raw +{ + my $self = shift; + my ($conn, $tgt, $dbh, $qry) = @_; + my $sth = $dbh->prepare($qry); + $sth->execute; + my $names = $sth->{'NAME'}; + my $numFields = $sth->{'NUM_OF_FIELDS'}; + my $string = ""; + for (my $i = 0; $i < $numFields; $i++) { + $string = $string . sprintf("%s%s", $i ? "," : "", $$names[$i]); + } + $conn->privmsg($tgt, $string); + while (my $ref = $sth->fetchrow_arrayref) { + $string = ""; + for (my $i = 0; $i < $numFields; $i++) { + $string = $string . sprintf("%s%s", $i ? "," : "", $$ref[$i]); + } + $conn->privmsg($tgt, $string); + } +} + +sub record +{ + my $self = shift; + my ($channel, $nick, $user, $host, $gecos, $level, $id, $reason) = @_; + $gecos //= "NOT_DEFINED"; + + my $dbh = $self->{DBH}; + $dbh->do("INSERT INTO $self->{TABLE} (channel, nick, user, host, gecos, level, id, reason) VALUES (" . + $dbh->quote($channel) . ", " . $dbh->quote($nick) . ", " . $dbh->quote($user) . + ", " . $dbh->quote($host) . ", " . $dbh->quote($gecos) . ", " . $dbh->quote($level) . ", " . + $dbh->quote($id) . ", " . $dbh->quote($reason) . ");"); +} + +sub actionlog +{ + my ($self, $event, $modedata1, $modedata2) = @_; + my $dbh = $self->{DBH}; + my ($action, $reason, $channel, + $nick, $user, $host, $gecos, $account, $ip, + $bynick, $byuser, $byhost, $bygecos, $byaccount); + + if ($event->{type} eq 'mode') { + $action = $modedata1; + $nick = $modedata2; + $channel = lc $event->{to}->[0]; + $bynick = $event->{nick}; + $byuser = $event->{user}; + $byhost = $event->{host}; + } elsif ($event->{type} eq 'quit') { + my $quitmsg = $event->{args}->[0]; + if ($quitmsg =~ /^Killed \((\S+) \((.*)\)\)$/) { + $bynick = $1; + $reason = $2 unless ($2 eq ''); + return if ($reason =~ /Nickname regained by services/); + $action = 'kill'; + } elsif ($quitmsg =~ /^K-Lined$/) { + $action = 'k-line'; + } else { + return; #quit not forced/tracked + } + $nick = $event->{nick}; + $user = $event->{user}; + $host = $event->{host}; + } elsif (($event->{type} eq 'part') && ($event->{args}->[0] =~ /^requested by (\S+) \((.*)\)/)) { + $bynick = $1; + $reason = $2 unless (lc $reason eq lc $event->{nick}); + $action = 'remove'; + $nick = $event->{nick}; + $user = $event->{user}; + $host = $event->{host}; + $channel = $event->{to}->[0]; + } elsif ($event->{type} eq 'kick') { + $action = 'kick'; + $bynick = $event->{nick}; + $byuser = $event->{user}; + $byhost = $event->{host}; + $reason = $event->{args}->[1] unless ($event->{args}->[1] eq $event->{to}->[0]); + $nick = $event->{to}->[0]; + $channel = $event->{args}->[0]; + } + return unless defined($action); +# $bynick = lc $bynick if defined $bynick; #we will lowercase the NUHGA info later. + if ( (defined($bynick)) && (defined($::sn{lc $bynick})) ) { #we have the nick taking the action available, fill in missing NUHGA info + $byuser //= $::sn{lc $bynick}{user}; + $byhost //= $::sn{lc $bynick}{host}; + $bygecos //= $::sn{lc $bynick}{gecos}; + $byaccount //= $::sn{lc $bynick}{account}; + if (($byaccount eq '0') or ($byaccount eq '*')) { + $byaccount = undef; + } + } +# $nick = lc $nick if defined $nick; + if ( (defined($nick)) && (defined($::sn{lc $nick})) ) { #this should always be true, else something has gone FUBAR + $user //= $::sn{lc $nick}{user}; + $host //= $::sn{lc $nick}{host}; + $gecos //= $::sn{lc $nick}{gecos}; + $account //= $::sn{lc $nick}{account}; + if (($account eq '0') or ($account eq '*')) { + $account = undef; + } + $ip = ASM::Util->getNickIP(lc $nick); + } +# my ($action, $reason, $channel, +# $nick, $user, $host, $gecos, $account, $ip +# $bynick, $byuser, $byhost, $bygecos, $byaccount); +#Now, time to escape/NULLify everything + $action = $dbh->quote($action); + if (defined($reason)) { $reason = $dbh->quote($reason); } else { $reason = 'NULL'; } +## removed lc's from everything except IP + if (defined($channel)) { $channel = $dbh->quote($channel); } else { $channel = 'NULL'; } + + if (defined($nick)) { $nick = $dbh->quote($nick); } else { $nick = 'NULL'; } + if (defined($user)) { $user = $dbh->quote($user); } else { $user = 'NULL'; } + if (defined($host)) { $host = $dbh->quote($host); } else { $host = 'NULL'; } + if (defined($gecos)) { $gecos = $dbh->quote($gecos); } else { $gecos = 'NULL'; } + if (defined($account)) { $account = $dbh->quote($account); } else { $account = 'NULL'; } + if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; } + + if (defined($bynick)) { $bynick = $dbh->quote($bynick); } else { $bynick = 'NULL'; } + if (defined($byuser)) { $byuser = $dbh->quote($byuser); } else { $byuser = 'NULL'; } + if (defined($byhost)) { $byhost = $dbh->quote($byhost); } else { $byhost = 'NULL'; } + if (defined($bygecos)) { $bygecos = $dbh->quote($bygecos); } else { $bygecos = 'NULL'; } + if (defined($byaccount)) { $byaccount = $dbh->quote($byaccount); } else { $byaccount = 'NULL'; } + my $sqlstr = "INSERT INTO $self->{ACTIONTABLE} " . + "(action, reason, channel, " . + "nick, user, host, gecos, account, ip, " . + "bynick, byuser, byhost, bygecos, byaccount)" . + " VALUES " . + "($action, $reason, $channel, " . + "$nick, $user, $host, $gecos, $account, $ip, " . + "$bynick, $byuser, $byhost, $bygecos, $byaccount);"; + ASM::Util->dprint( $sqlstr, 'mysql' ); + $dbh->do( $sqlstr ); + return $dbh->last_insert_id(undef, undef, $self->{ACTIONTABLE}, undef); +# $::sn{ow} looks like: +#$VAR1 = { +# "account" => "afterdeath", +# "gecos" => "William Athanasius Heimbigner", +# "user" => "icxcnika", +# "mship" => [ +# "#baadf00d", +# "#antispammeta-debug", +# "#antispammeta" +# ], +# "host" => "freenode/weird-exception/network-troll/afterdeath" +# }; + +} + +#FIXME: This function is shit. Also, it doesn't work like I want it to with mode. +sub logg +{ + my $self = shift; + my ($event) = @_; + my $dbh = $self->{DBH_LOG}; + my $table = $event->{type}; + $table = 'action' if ($table eq 'caction'); + $table = 'privmsg' if ($table eq 'public'); + return if (($table eq 'action') or ($table eq 'privmsg')); #Disabling logging of privmsg stuffs to mysql. no point. + my $realtable = $table; + $realtable = 'joins' if $realtable eq 'join'; #mysql doesn't like a table named join + my $string = 'INSERT INTO `' . $realtable . '` ('; +## begin saner code for this function + if ($table eq 'quit') { + $string = 'INSERT INTO `quit` (nick, user, host, geco, ip, account, content1) VALUES (' . + $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' . + $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ','; + my $ip = ASM::Util->getNickIP(lc $event->{nick}, $event->{host}); + if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; } + my $account = $::sn{lc $event->{nick}}->{account}; + if (!defined($account) or ($account eq '0') or ($account eq '*')) { + $account = 'NULL'; + } else { + $account = $dbh->quote($account); + } + $string = $string . $ip . ',' . $account . ',' . $dbh->quote($event->{args}->[0]) . ');'; + $dbh->do($string); + ASM::Util->dprint($string, 'mysql'); + return; + } elsif ($table eq 'part') { + $string = 'INSERT INTO `part` (channel, nick, user, host, geco, ip, account, content1) VALUES (' . + $dbh->quote($event->{to}->[0]) . ',' . + $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' . + $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ','; + my $ip = ASM::Util->getNickIP(lc $event->{nick}, $event->{host}); + if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; } + my $account = $::sn{lc $event->{nick}}->{account}; + if (!defined($account) or ($account eq '0') or ($account eq '*')) { + $account = 'NULL'; + } else { + $account = $dbh->quote($account); + } + $string = $string . $ip . ',' . $account . ',' . $dbh->quote($event->{args}->[0]) . ');'; + $dbh->do($string); + ASM::Util->dprint($string, 'mysql'); + return; + } elsif ($table eq 'kick') { + $string = 'INSERT INTO `kick` (channel, nick, user, host, geco, ip, account, ' . + 'victim_nick, victim_user, victim_host, victim_geco, victim_ip, victim_account, content1) VALUES (' . + $dbh->quote($event->{args}->[0]) . ',' . + $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' . + $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ','; + my $ip = ASM::Util->getNickIP(lc $event->{nick}); + if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; } + my $account = $::sn{lc $event->{nick}}->{account}; + if (($account eq '0') or ($account eq '*')) { $account = 'NULL'; } else { $account = $dbh->quote($account); } + $string = $string . $ip . ',' . $account; + $string = $string . ', ' . $dbh->quote($event->{to}->[0]); + $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{user}); + $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{host}); + $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{gecos}); + my $vic_ip = ASM::Util->getNickIP(lc $event->{to}->[0]); + if (defined($vic_ip)) { $vic_ip = $dbh->quote($vic_ip); } else { $vic_ip = 'NULL'; } + my $vic_account = $::sn{lc $event->{to}->[0]}->{account}; + if (($vic_account eq '0') or ($vic_account eq '*')) { $vic_account = 'NULL'; } else { $vic_account = $dbh->quote($vic_account); } + $string = $string . ', ' . $vic_ip . ',' . $vic_account . ',' . $dbh->quote($event->{args}->[1]) . ');'; + $dbh->do($string); + ASM::Util->dprint($string, 'mysql'); + return; + } +## end saner code for this function + if (($table ne 'nick') && ($table ne 'quit')) { + $string = $string . 'channel, '; + } + $string = $string . 'nick, user, host, geco'; + if (($table ne 'join') && ($table ne 'kick')) { + $string = $string . ', content1'; + } + if ($table eq 'mode') { + $string = $string . ', content2'; + } + if ($table eq 'kick') { + $string = $string . ', victim_nick, victim_user, victim_host, victim_geco, content1'; + } + $string = $string . ') VALUES ('; + if (($table ne 'nick') && ($table ne 'quit') && ($table ne 'kick')) { + $string = $string . $dbh->quote($event->{to}->[0]) . ", "; + } + if ($table eq 'kick') { + $string = $string . $dbh->quote($event->{args}->[0]) . ", "; + } + my $geco = $::sn{lc $event->{nick}}->{gecos}; + $string = $string . $dbh->quote($event->{nick}) . ", " . $dbh->quote($event->{user}) . ", " . + $dbh->quote($event->{host}) . ", " . $dbh->quote($geco); + if (($table ne 'join') && ($table ne 'kick')) { + $string = $string. ', ' . $dbh->quote($event->{args}->[0]); + } + if ($table eq 'kick') { + $string = $string . ', ' . $dbh->quote($event->{to}->[0]); + $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{user}); + $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{host}); + $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{gecos}); + $string = $string . ', ' . $dbh->quote($event->{args}->[1]); + } + if ($table eq 'mode') { + $string = $string . ', ' . $dbh->quote($event->{args}->[1]); + } + $string = $string . ');'; +# ASM::Util->dprint($string, "mysql"); + $dbh->do($string); +} + +sub query +{ + my $self = shift; + my ($channel, $nick, $user, $host) = @_; + my $dbh = $self->{DBH}; + $channel = $dbh->quote($channel); + $nick = $dbh->quote($nick); + $user = $dbh->quote($user); + $host = $dbh->quote($host); + + $nick =~ s/\*/%/g; + $nick =~ s/_/\\_/g; + $nick =~ s/\?/_/g; + + $user =~ s/\*/%/g; + $user =~ s/_/\\_/g; + $user =~ s/\?/_/g; + + $host =~ s/\*/%/g; + $host =~ s/_/\\_/g; + $host =~ s/\?/_/g; + my $sth = $dbh->prepare("SELECT * from $self->{TABLE} WHERE channel like $channel and nick like $nick and user like $user and host like $host;"); + $sth->execute; + my $i = 0; + while (my $ref = $sth->fetchrow_arrayref) { + $i++; + } + return $i; +} + +1; diff --git a/lib/ASM/Event.pm b/lib/ASM/Event.pm new file mode 100644 index 0000000..e6f4c23 --- /dev/null +++ b/lib/ASM/Event.pm @@ -0,0 +1,887 @@ +package ASM::Event; +use warnings; +use strict; + +use Data::Dumper; +use Text::LevenshteinXS qw(distance); +use IO::All; +use POSIX qw(strftime); +use Regexp::Wildcards; +use HTTP::Request; + +sub cs { + my ($chan) = @_; + $chan = lc $chan; + $chan =~ s/^[@+]//; + return $::channels->{channel}->{$chan} if ( defined($::channels->{channel}->{$chan}) ); + return $::channels->{channel}->{default}; +} + +sub maxlen { + my ($a, $b) = @_; + my ($la, $lb) = (length($a), length($b)); + return $la if ($la > $lb); + return $lb; +} + +sub new +{ + my $module = shift; + my ($conn, $inspector) = @_; + my $self = {}; + $self->{CONN} = $conn; + $self->{INSPECTOR} = $inspector; + ASM::Util->dprint('Installing handler routines...', 'startup'); + $conn->add_default_handler(\&blah); + $conn->add_handler('bannedfromchan', \&on_bannedfromchan); + $conn->add_handler('mode', \&on_mode); + $conn->add_handler('join', \&on_join); + $conn->add_handler('part', \&on_part); + $conn->add_handler('quit', \&on_quit); + $conn->add_handler('nick', \&on_nick); + $conn->add_handler('notice', \&on_notice); + $conn->add_handler('caction', \&on_public); + $conn->add_handler('msg', \&on_msg); + $conn->add_handler('namreply', \&on_names); + $conn->add_handler('endofnames', \&on_names); + $conn->add_handler('public', \&on_public); + $conn->add_handler('376', \&on_connect); + $conn->add_handler('topic', \&irc_topic); + $conn->add_handler('topicinfo', \&irc_topic); + $conn->add_handler('nicknameinuse', \&on_errnickinuse); + $conn->add_handler('bannickchange', \&on_bannickchange); + $conn->add_handler('kick', \&on_kick); + $conn->add_handler('cping', \&on_ctcp); + $conn->add_handler('cversion', \&on_ctcp); + $conn->add_handler('csource', \&on_ctcp_source); + $conn->add_handler('ctime', \&on_ctcp); + $conn->add_handler('cdcc', \&on_ctcp); + $conn->add_handler('cuserinfo', \&on_ctcp); + $conn->add_handler('cclientinfo', \&on_ctcp); + $conn->add_handler('cfinger', \&on_ctcp); + $conn->add_handler('354', \&on_whoxreply); + $conn->add_handler('315', \&on_whoxover); + $conn->add_handler('263', \&on_whofuckedup); + $conn->add_handler('account', \&on_account); + $conn->add_handler('ping', \&on_ping); + $conn->add_handler('banlist', \&on_banlist); + $conn->add_handler('dcc_open', \&dcc_open); + $conn->add_handler('chat', \&on_dchat); + $conn->add_handler('channelmodeis', \&on_channelmodeis); + $conn->add_handler('quietlist', \&on_quietlist); + $conn->add_handler('pong', \&on_pong); + $conn->add_handler('statsdebug', \&on_statsdebug); + $conn->add_handler('endofstats', \&on_endofstats); + $conn->add_handler('channelurlis', \&on_channelurlis); + $conn->add_handler('480', \&on_jointhrottled); + $conn->add_handler('invite', \&blah); # This doesn't need to be fancy; I just need it to go through inspect + bless($self); + return $self; +} + +my $clearstatsp = 1; +my %statsp = (); +my %oldstatsp = (); + +sub on_jointhrottled +{ + my ($conn, $event) = @_; + my $chan = $event->{args}->[1]; + ASM::Util->dprint("$event->{nick}: $chan: $event->{args}->[2]", 'snotice'); + if ($event->{args}->[2] =~ /throttle exceeded, try again later/) { + $conn->schedule(5, sub { $conn->join($chan); }); + } +} + +sub on_statsdebug +{ + my ($conn, $event) = @_; + my ($char, $line) = ($event->{args}->[1], $event->{args}->[2]); + if ($char eq 'p') { + if ($clearstatsp) { + $clearstatsp = 0; + %oldstatsp = %statsp; + %statsp = (); + } + if ($line =~ /^(\d+) staff members$/) { + #this is the end of the report + } else { + my ($nick, $userhost) = split(" ", $line); + $userhost =~ s/\((.*)\)/$1/; + my ($user, $host) = split("@", $userhost); + $statsp{$nick}= [$user, $host]; + } + } +} + +sub on_endofstats +{ + my ($conn, $event) = @_; + if ($event->{args}->[1] eq 'p') { + $clearstatsp=1; + my $tmp = Dumper(\%statsp); chomp $tmp; + if ( join(',', sort(keys %oldstatsp)) ne join(',', sort(keys %statsp)) ) { + open(FH, '>>', 'statsplog.txt'); + say FH strftime('%F %T ', gmtime) . join(',', sort(keys %statsp)); + close(FH); + ASM::Util->dprint(join(",", keys %statsp), 'statsp'); + } + # $event->{args}->[2] == "End of /STATS report" + #end of /stats p + } +} + +my $lagcycles = 0; +my $pongcount = 0; + +sub on_pong +{ + my ($conn, $event) = @_; + alarm 120; + $conn->schedule( 30, sub { $conn->sl("PING :" . time); } ); + ASM::Util->dprint('Pong? ... Ping!', 'pingpong'); + my $lag = time - $event->{args}->[0]; + my @changes = $::fm->scan(); + if (@changes) { + if ($::settingschanged) { + $::settingschanged = 0; + } else { + $conn->privmsg($::settings->{masterchan}, "Config files changed, auto rehash triggered. Check console for possible errors."); + ASM::XML->readXML(); + my @strbl = io('string_blacklist.txt')->getlines; + chomp @strbl; + @::string_blacklist = @strbl; + } + } + if ($lag > 1) { + ASM::Util->dprint("Latency: $lag", 'latency'); + } + if (($pongcount % 3) == 0) { #easiest way to do something roughly every 90 seconds + $conn->sl('STATS p'); + } + if ((time - $::starttime) < 240 ) { + return; #we don't worry about lag if we've just started up and are still syncing etc. + } + if (($lag > 2) && ($lag < 5)) { + $conn->privmsg( $::settings->{masterchan}, "Warning: I'm currently lagging by $lag seconds."); + } + if ($lag >= 5) { + $lagcycles++; + if ($lagcycles >= 3) { + $conn->quit("Automatic restart triggered due to persistent lag. Freenode staff: If this is happening too frequently, please " . + "set a nickserv freeze on my account, and once my connection is stable, unfreeze the account and /kill me to tri" . + "gger a reconnect."); + } else { + $conn->privmsg( $::settings->{masterchan}, "Warning: I'm currently lagging by $lag seconds. This marks heavy lag cycle " . + "$lagcycles - automatic restart will be triggered after 3 lag cycles." ); + } + } + if (($lag <= 5) && ($lagcycles > 0)) { + $lagcycles--; +# $conn->privmsg( $::settings->{masterchan}, "Warning: Heavy lag cycle count has been reduced to $lagcycles" ); + ASM::Util->dprint('$lag = ' . $lag . '; $lagcycles = ' . $lagcycles, 'latency'); + } +} + +sub on_dchat +{ + my ($conn, $event) = @_; + ASM::Util->dprint(Dumper($event), 'dcc'); + if ( #(lc $event->{nick} eq 'afterdeath') && + ($event->{args}->[0] ne '')) { + my $msg = $event->{args}->[0]; + if ($msg =~ /^SPY (.*)/) { + my $chan = $1; + $::spy{lc $chan} = $event->{to}[0]; + } elsif ($msg =~ /^STOPSPY (.*)/) { + delete $::spy{lc $1}; + } elsif ($msg =~ /^RETRIEVE (\S+)/) { + my $chan = lc $1; + my $out = $event->{to}[0]; + my @time = ($::settings->{log}->{zone} eq 'local') ? localtime : gmtime; + say $out 'Retrieving ' . "$::settings->{log}->{dir}${chan}/${chan}" . strftime($::settings->{log}->{filefmt}, @time); + open(FHX, "$::settings->{log}->{dir}${chan}/${chan}" . strftime($::settings->{log}->{filefmt}, @time)); + while () { + print $out $_; + } + close FHX; + } + #lols we gots a chat message! :D + } +} + +sub on_ping +{ + my ($conn, $event) = @_; + $conn->sl("PONG " . $event->{args}->[0]); +# alarm 200; + ASM::Util->dprint('Ping? Pong!', 'pingpong'); +# ASM::Util->dprint(Dumper($event), 'pingpong'); +} + +sub on_account +{ + my ($conn, $event) = @_; + $::sn{lc $event->{nick}}{account} = lc $event->{args}->[0]; +} + +sub on_connect { + my ($conn, $event) = @_; # need to check for no services + $conn->sl("MODE $event->{args}->[0] +Q"); + if (lc $event->{args}->[0] ne lc $::settings->{nick}) { + ASM::Util->dprint('Attempting to regain my main nick', 'startup'); + $conn->privmsg( 'NickServ@services.', "regain $::settings->{nick} $::settings->{pass}" ); + } + $conn->sl('CAP REQ :extended-join multi-prefix account-notify'); #god help you if you try to use this bot off freenode +} + +sub on_join { + my ($conn, $event) = @_; + my $nick = lc $event->{nick}; + my $chan = lc $event->{to}->[0]; + my $rate; +# alarm 200; + if ( lc $conn->{_nick} eq lc $nick) { + $::sc{$chan} = {}; + mkdir($::settings->{log}->{dir} . $chan); + $::synced{$chan} = 0; + unless ( @::syncqueue ) { + $conn->sl('who ' . $chan . ' %tcnuhra,314'); + $conn->sl('mode ' . $chan); + $conn->sl('mode ' . $chan . ' bq'); + } + push @::syncqueue, $chan; + } + $::sc{$chan}{users}{$nick} = {}; + $::sc{$chan}{users}{$nick}{hostmask} = $event->{userhost}; + $::sc{$chan}{users}{$nick}{op} = 0; + $::sc{$chan}{users}{$nick}{voice} = 0; + $::sc{$chan}{users}{$nick}{jointime} = time; + $::sc{$chan}{users}{$nick}{msgtime} = 0; + if (defined($::sn{$nick})) { + my @mship = (); + if (defined($::sn{$nick}->{mship})) { + @mship = @{$::sn{$nick}->{mship}}; + } + @mship = (@mship, $chan); + $::sn{$nick}->{mship} = \@mship; + } else { + $::sn{$nick} = {}; + $::sn{$nick}->{mship} = [ $chan ]; + } + $::sn{$nick}->{dnsbl} = 0; + $::sn{$nick}->{netsplit} = 0; + $::sn{$nick}->{gecos} = $event->{args}->[1]; + $::sn{$nick}->{user} = $event->{user}; + $::sn{$nick}->{host} = $event->{host}; + $::sn{$nick}->{account} = lc $event->{args}->[0]; + $::db->logg($event) if defined $::db; + $::log->logg( $event ); + $::inspector->inspect( $conn, $event ) unless $::netsplit; +} + +sub on_part +{ + my ($conn, $event) = @_; + my $nick = lc $event->{nick}; + my $chan = lc $event->{to}->[0]; + $::log->logg( $event ); + $::db->logg( $event ) if defined $::db; + if (defined $::db and $event->{args}->[0] =~ /^requested by/) { + my $idx = $::db->actionlog( $event); + $::log->sqlIncident($chan, $idx) if $idx; + } +# "to" => [ "#antispammeta" ], +# "args" => [ "requested by ow (test)" ], +# "nick" => "aoregcdu", + $::inspector->inspect( $conn, $event ); + if (defined($::sn{$nick}) && defined($::sn{$nick}->{mship})) { + my @mship = @{$::sn{$nick}->{mship}}; + @mship = grep { lc $_ ne $chan } @mship; + if ( @mship ) { + $::sn{$nick}->{mship} = \@mship; + } else { + delete($::sn{$nick}); + } + } + if ( lc $conn->{_nick} eq $nick ) + { + delete( $::sc{$chan} ); + on_byechan($chan); + } + else + { + delete( $::sc{$chan}{users}{$nick} ); + } +} + +sub on_msg +{ + my ($conn, $event) = @_; + $::commander->command($conn, $event); + ASM::Util->dprint($event->{from} . " - " . $event->{args}->[0], 'msg'); + if ((ASM::Util->notRestricted($event->{nick}, "nomsgs")) && ($event->{args}->[0] !~ /^;;/)) { +# disabled by DL 130513 due to spammer abuse +# $conn->privmsg($::settings->{masterchan}, $event->{from} . ' told me: ' . $event->{args}->[0]); + } +} + +sub on_public +{ + my ($conn, $event) = @_; +# alarm 200; + my $chan = lc $event->{to}[0]; + $chan =~ s/^[+@]//; + $::log->logg( $event ); + $::db->logg( $event ) if defined $::db; + if ($event->{args}->[0] =~ /(https?:\/\/bitly.com\/\w+|https?:\/\/bit.ly\/\w+|https?:\/\/j.mp\/\w+|https?:\/\/tinyurl.com\/\w+)/i) { + my $reqid = $::async->add( HTTP::Request->new( GET => $1 ) ); + $::httpRequests{$reqid} = $event; + my ($response, $id) = $::async->wait_for_next_response( 1 ); + if (defined($response)) { + on_httpResponse($conn, $id, $response); + } + else { $conn->schedule( 1, sub { checkHTTP($conn); } ); } + } + $::inspector->inspect( $conn, $event ); + $::commander->command( $conn, $event ); + $::sc{$chan}{users}{lc $event->{nick}}{msgtime} = time; +} + +sub checkHTTP +{ + my ($conn) = @_; + my ($response, $id) = $::async->next_response(); + if (defined ($response)) { + on_httpResponse($conn, $id, $response); + } + $conn->schedule( 1, sub { checkHTTP($conn); } ); +} + +sub on_httpResponse +{ + my ($conn, $id, $response) = @_; + my $event = $::httpRequests{$id}; + delete $::httpRequests{$id}; + $::inspector->inspect( $conn, $event, $response ); +} +# if ($response->{_previous}->{_headers}->{location} =~ /^https?:\/\/bitly.com\/a\/warning/) + +sub on_notice +{ + my ($conn, $event) = @_; + return if ( $event->{to}->[0] eq '$*' ); # if this is a global notice FUCK THAT SHIT + $::log->logg( $event ); + $::db->logg( $event ) if defined $::db; + $::inspector->inspect( $conn, $event ); + $::services->doServices($conn, $event); +} + +sub on_errnickinuse +{ + my ($conn, $event) = @_; + $_ = ${$::settings->{altnicks}}[rand @{$::settings->{altnicks}}]; + ASM::Util->dprint("Nick is in use, trying $_", 'startup'); + $conn->nick($_); +} + +sub on_bannickchange +{ + my ($conn, $event) = @_; + $_ = ${$::settings->{altnicks}}[rand @{$::settings->{altnicks}}]; + ASM::Util->dprint("Nick is in use, trying $_", 'startup'); + $conn->nick($_); +} + +sub on_quit +{ + my ($conn, $event) = @_; + my @channels=(); + for ( keys %::sc ) { + push ( @channels, lc $_ ) if delete $::sc{lc $_}{users}{lc $event->{nick}}; + } + $event->{to} = \@channels; + if (defined $::db) { + my $idx = $::db->actionlog($event); + $::log->sqlIncident( join(',', @channels), $idx ) if $idx; + $::db->logg( $event ); + } + $::log->logg( $event ); + + if (($::netsplit == 0) && ($event->{args}->[0] eq "*.net *.split") && (lc $event->{nick} ne 'chanserv')) { #special, netsplit situation + $conn->privmsg($::settings->{masterchan}, "Entering netsplit mode - JOIN and QUIT inspection will be disabled for 60 minutes"); + $::netsplit = 1; + $conn->schedule(60*60, sub { $::netsplit = 0; $conn->privmsg($::settings->{masterchan}, 'Returning to regular operation'); }); + } + $::inspector->inspect( $conn, $event ) unless $::netsplit; + #ugh. Repurge some shit, hopefully this will fix some stuff where things are going wrong + foreach my $chan ( keys %::sc ) { + delete $::sc{$chan}{users}{lc $event->{nick}}; + } + delete($::sn{lc $event->{nick}}); +} + +sub blah +{ + my ($self, $event) = @_; + ASM::Util->dprint(Dumper($event), 'misc'); + $::inspector->inspect($self, $event); +} + +sub irc_users +{ + my ( $channel, @users ) = @_; + for (@users) + { + my ( $op, $voice ); + $op = 0; $voice = 0; + $op = 1 if s/^\@//; + $voice = 1 if s/^\+//; + $::sc{lc $channel}{users}{lc $_} = {}; + $::sc{lc $channel}{users}{lc $_}{op} = $op; + $::sc{lc $channel}{users}{lc $_}{voice} = $voice; + $::sc{lc $channel}{users}{lc $_}{jointime} = 0; + } +} + +sub on_names { + my ($conn, $event) = @_; + irc_users( $event->{args}->[2], split(/ /, $event->{args}->[3]) ) if ($event->{type} eq 'namreply'); +} + +sub irc_topic { + my ($conn, $event) = @_; + if ($event->{format} eq 'server') + { + my $chan = lc $event->{args}->[1]; + if ($event->{type} eq 'topic') + { + $::sc{$chan}{topic}{text} = $event->{args}->[2]; + } + elsif ($event->{type} eq 'topicinfo') + { + $::sc{$chan}{topic}{time} = $event->{args}->[3]; + $::sc{$chan}{topic}{by} = $event->{args}->[2]; + } + } + else + { + if ($event->{type} eq 'topic') + { + my $chan = lc $event->{to}->[0]; + $::sc{$chan}{topic}{text} = $event->{args}->[0]; + $::sc{$chan}{topic}{time} = time; + $::sc{$chan}{topic}{by} = $event->{from}; + } + $::log->logg($event); + $::db->logg( $event ) if defined $::db; + $::inspector->inspect($conn, $event); + } +} + +sub on_nick { + my ($conn, $event) = @_; + my @channels=(); + my $oldnick = lc $event->{nick}; + my $newnick = lc $event->{args}->[0]; + foreach my $chan ( keys %::sc ) + { + $chan = lc $chan; + if ( defined $::sc{$chan}{users}{$oldnick} ) + { + if ($oldnick ne $newnick) { #otherwise a nick change where they're only + #changing the case of their nick means that + #ASM forgets about them. + $::sc{$chan}{users}{$newnick} = $::sc{$chan}{users}{$oldnick}; + delete( $::sc{$chan}{users}{$oldnick} ); + } + push ( @channels, $chan ); + } + } + + # unfortunately Net::IRC sucks at IRC so we have to implement this ourselves + if ($oldnick eq lc $conn->{_nick}) { + $conn->{_nick} = $event->{args}[0]; + } + + $::sn{$newnick} = $::sn{$oldnick} if ($oldnick ne $newnick); + $::db->logg( $event ) if defined $::db; + delete( $::sn{$oldnick}) if ($oldnick ne $newnick); + $event->{to} = \@channels; + $::log->logg($event); + # Well, the nick change actually was done from the old nick ... but + # by the time we process it, they already changed nicks. Therefore + # we'll pretend it's the *new* nick that generated the event. + $event->{nick} = $event->{args}[0]; + $::inspector->inspect($conn, $event); +} + +sub on_kick { + my ($conn, $event) = @_; + if (lc $event->{to}->[0] eq lc $::settings->{nick}) { + $conn->privmsg($::settings->{masterchan}, "I've been kicked from " . $event->{args}->[0] . ": " . $event->{args}->[1]); +# $conn->join($event->{args}->[0]); + } + my $nick = lc $event->{to}->[0]; + my $chan = lc $event->{args}->[0]; + $::log->logg( $event ); + if (defined $::db) { + $::db->logg( $event ); + my $idx = $::db->actionlog($event); + $::log->sqlIncident($chan, $idx) if $idx; + } + if (defined($::sn{$nick}) && defined($::sn{$nick}->{mship})) { + my @mship = @{$::sn{$nick}->{mship}}; + @mship = grep { lc $_ ne $chan } @mship; + if ( @mship ) { + $::sn{$nick}->{mship} = \@mship; + } else { + delete($::sn{$nick}); + } + } + if ( lc $conn->{_nick} eq $nick ) + { + delete( $::sc{lc $event->{args}->[0]} ); + on_byechan(lc $event->{to}->[0]); + } + else + { + delete( $::sc{lc $event->{args}->[0]}{users}{$nick} ); + } +} + +sub parse_modes +{ + my ( $n ) = @_; + my @args = @{$n}; + my @modes = split '', shift @args; + my @new_modes=(); + my $t; + foreach my $c ( @modes ) { + if (($c eq '-') || ($c eq '+')) { + $t=$c; + } + else { #eIbq,k,flj,CFLMPQcgimnprstz + if ($t eq '+') { + if ( grep( /[eIbqkfljov]/,($c) ) ) { #modes that take args WHEN BEING ADDED + push (@new_modes, [$t.$c, shift @args]); + } + elsif ( grep( /[CFLMPQcgimnprstz]/, ($c) ) ) { + push (@new_modes, [$t.$c]); + } + else { + die "Unknown mode $c !\n"; + } + } else { + if ( grep( /[eIbqov]/,($c) ) ) { #modes that take args WHEN BEING REMOVED + push (@new_modes, [$t.$c, shift @args]); + } + elsif ( grep( /[CFLMPQcgimnprstzkflj]/, ($c) ) ) { + push (@new_modes, [$t.$c]); + } + else { + die "Unknown mode $c !\n"; + } + } + } + } + return \@new_modes; +} + +sub on_channelmodeis +{ + my ($conn, $event) = @_; + my $chan = lc $event->{args}->[1]; + my @temp = @{$event->{args}}; + shift @temp; shift @temp; + my @modes = @{parse_modes(\@temp)}; + foreach my $line ( @modes ) { + my @ex = @{$line}; + my ($what, $mode) = split (//, $ex[0]); + if ($what eq '+') { + if (defined($ex[1])) { + push @{$::sc{$chan}{modes}}, $mode . ' ' . $ex[1]; + } else { + push @{$::sc{$chan}{modes}}, $mode; + } + } else { + my @modes = grep {!/^$mode/} @{$::sc{$chan}{modes}}; + $::sc{$chan}{modes} = \@modes; + } + } +} + +sub whoGotHit +{ + my ($chan, $mask) = @_; + my $cvt = Regexp::Wildcards->new(type => 'jokers'); + my @affected = (); + if ($mask !~ /^\$/) { + my @div = split(/\$/, $mask); + my $regex = $cvt->convert($div[0]); + foreach my $nick (keys %::sn) { + next unless defined($::sn{$nick}{user}); + if (lc ($nick.'!'.$::sn{$nick}{user}.'@'.$::sn{$nick}{host}) =~ /^$regex$/i) { + push @affected, $nick if defined($::sc{$chan}{users}{$nick}); + } + } + } elsif ($mask =~ /^\$a:(.*)/) { + my @div = split(/\$/, $1); + my $regex = $cvt->convert($div[0]); + foreach my $nick (keys %::sn) { + next unless defined($::sn{$nick}{account}); + if (lc ($::sn{$nick}{account}) =~ /^$regex$/i) { + push @affected, $nick if defined($::sc{$chan}{users}{$nick}); + } + } + } + return @affected; +} + +sub on_mode +{ + my ($conn, $event) = @_; + my $chan = lc $event->{to}->[0]; +# holy shit, I feel so bad doing this +# I have no idea how or why Net::IRC fucks up modes if they've got a ':' in one of the args +# but you do what you must... + my @splitted = split(/ /, $::lastline); shift @splitted; shift @splitted; shift @splitted; + $event->{args}=\@splitted; + if ($chan =~ /^#/) { + my @modes = @{parse_modes($event->{args})}; + ASM::Util->dprint(Dumper(\@modes), 'misc'); + foreach my $line ( @modes ) { + my @ex = @{$line}; + + if ( $ex[0] eq '+o' ) { $::sc{$chan}{users}{lc $ex[1]}{op} = 1; } + elsif ( $ex[0] eq '-o' ) { $::sc{$chan}{users}{lc $ex[1]}{op} = 0; } + elsif ( $ex[0] eq '+v' ) { $::sc{$chan}{users}{lc $ex[1]}{voice} = 1; } + elsif ( $ex[0] eq '-v' ) { $::sc{$chan}{users}{lc $ex[1]}{voice} = 0; } + + elsif ( $ex[0] eq '+b' ) { + $::sc{$chan}{bans}{$ex[1]} = { bannedBy => $event->{from}, bannedOn => time }; + if (lc $event->{nick} !~ /^(floodbot)/) { #ignore the ubuntu floodbots 'cause they quiet people a lot + my @affected = whoGotHit($chan, $ex[1]); + if ( defined($::db) && (@affected) && (scalar @affected <= 4) ) { + foreach my $victim (@affected) { + my $idx = $::db->actionlog($event, 'ban', $victim); + $::log->sqlIncident( $chan, $idx ) if $idx; + } + } + if ($ex[1] =~ /^\*\!\*\@(.*)$/) { + my $ip = ASM::Util->getHostIP($1); + $::sc{$chan}{ipbans}{$ip} = { bannedBy => $event->{from}, bannedOn => time } if defined($ip); + } + } + } + elsif ( $ex[0] eq '-b' ) { + delete $::sc{$chan}{bans}{$ex[1]}; + if ($ex[1] =~ /^\*\!\*\@(.*)$/) { + my $ip = ASM::Util->getHostIP($1); + delete $::sc{$chan}{ipbans}{$ip} if defined($ip); + } + } + + elsif ( $ex[0] eq '+q' ) { + $::sc{$chan}{quiets}{$ex[1]} = { bannedBy => $event->{from}, bannedOn => time }; + if (lc $event->{nick} !~ /^(floodbot)/) { + my @affected = whoGotHit($chan, $ex[1]); + if ( defined($::db) && (@affected) && (scalar @affected <= 4) ) { + foreach my $victim (@affected) { + my $idx = $::db->actionlog($event, 'quiet', $victim); + $::log->sqlIncident( $chan, $idx ) if $idx; + } + } + if ($ex[1] =~ /^\*\!\*\@(.*)$/) { + my $ip = ASM::Util->getHostIP($1); + $::sc{$chan}{ipquiets}{$ip} = { bannedBy => $event->{from}, bannedOn => time } if defined($ip); + } + } + } + elsif ( $ex[0] eq '-q' ) { + delete $::sc{$chan}{quiets}{$ex[1]}; + if ($ex[1] =~ /^\*\!\*\@(.*)$/) { + my $ip = ASM::Util->getHostIP($1); + delete $::sc{$chan}{ipquiets}{$ip} if defined($ip); + } + } + + else { + my ($what, $mode) = split (//, $ex[0]); + if ($what eq '+') { + if (defined($ex[1])) { push @{$::sc{$chan}{modes}}, $mode . ' ' . $ex[1]; } + else { push @{$::sc{$chan}{modes}}, $mode; } + } else { + my @modes = grep {!/^$mode/} @{$::sc{$chan}{modes}}; + $::sc{$chan}{modes} = \@modes; + } + if ( ($ex[0] eq '+r') && (! defined($::watchRegged{$chan})) ) { + $::watchRegged{$chan} = 1; + $conn->schedule(60*45, sub { checkRegged($conn, $chan); }); + } + } + } + $::log->logg($event); + } +} + +sub checkRegged +{ + my ($conn, $chan) = @_; + if (grep {/^r/} @{$::sc{$chan}{modes}} + and not ((defined($::channels->{channel}{$chan}{monitor})) and ($::channels->{channel}{$chan}{monitor} eq "no")) ) + { + my $tgt = $chan; + my $risk = "debug"; + my $hilite=ASM::Util->commaAndify(ASM::Util->getAlert($tgt, $risk, 'hilights')); + my $txtz ="\x03" . $::RCOLOR{$::RISKS{$risk}} . "\u$risk\x03 risk threat [\x02$chan\x02] - channel appears to still be +r after 45 minutes; ping $hilite !att-$chan-$risk"; + my @tgts = ASM::Util->getAlert($tgt, $risk, 'msgs'); + ASM::Util->sendLongMsg($conn, \@tgts, $txtz) + } + delete $::watchRegged{$chan}; +} + +sub on_banlist +{ + my ($conn, $event) = @_; + my ($me, $chan, $ban, $banner, $bantime) = @{$event->{args}}; + $::sc{lc $chan}{bans}{$ban} = { bannedBy => $banner, bannedOn => $bantime }; + if ($ban =~ /^\*\!\*\@((([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9]))$/) { + # ASM::Util->dprint("banlist hostname $ban $1", 'sync'); + my $ip = ASM::Util->getHostIP($1); + $::sc{lc $chan}{ipbans}{$ip} = { bannedBy => $banner, bannedOn => $bantime } if defined($ip); + } +} + +sub on_quietlist +{ + my ($conn, $event) = @_; + my ($me, $chan, $mode, $ban, $banner, $bantime) = @{$event->{args}}; + $::sc{lc $chan}{quiets}{$ban} = { bannedBy => $banner, bannedOn => $bantime }; + if ($ban =~ /^\*\!\*\@((([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9]))$/) { + # ASM::Util->dprint("quietlist hostname $ban $1", 'sync'); + my $ip = ASM::Util->getHostIP($1); + $::sc{lc $chan}{ipquiets}{$ip} = { bannedBy => $banner, bannedOn => $bantime } if defined($ip); + } +} + +sub on_channelurlis +{ + my ($conn, $event) = @_; + $::sc{lc $event->{args}->[1]}{url} = $event->{args}->[2]; +} + +sub on_ctcp +{ + my ($conn, $event) = @_; + my $acct = lc $::sn{lc $event->{nick}}->{account}; + ASM::Util->dprint(Dumper($event), 'ctcp'); + if (($event->{type} eq 'cdcc') && + (defined($::users->{person}->{$acct})) && + (defined($::users->{person}->{$acct}->{flags})) && + (grep {$_ eq 'c'} split('', $::users->{person}->{$acct}->{flags}))) { + ASM::Util->dprint(Dumper($event), 'dcc'); + my @spit = split(/ /, $event->{args}->[0]); + if (($spit[0] eq 'CHAT') && ($spit[1] eq 'CHAT')) { + $::chat = Net::IRC::DCC::CHAT->new($conn, 0, lc $event->{nick}, $spit[2], $spit[3]); + } + } else { + $::inspector->inspect($conn, $event); + } +} + +sub dcc_open +{ + my ($conn, $event) = @_; + $::dsock{lc $event->{nick}} = $event->{args}->[1]; +} + +sub on_ctcp_source +{ + my ($conn, $event) = @_; + $conn->ctcp_reply($event->{nick}, 'SOURCE https://gitlab.devlabs.linuxassist.net/asm/antispammeta/'); +} + +sub on_whoxreply +{ + my ($conn, $event) = @_; + return unless $event->{args}->[1] eq '314'; + my ($tgt, $magic, $chan, $user, $host, $nick, $account, $gecos) = @{$event->{args}}; + $nick = lc $nick; $chan = lc $chan; + if (!defined $::sn{lc $nick}) { + $::sn{$nick} = {}; + $::sn{$nick}->{mship} = [$chan]; + } else { + $::sn{$nick}->{mship} = [grep { lc $_ ne $chan } @{$::sn{$nick}->{mship}}]; + push @{$::sn{$nick}->{mship}}, $chan; + } + $::sn{$nick}->{gecos} = $gecos; + $::sn{$nick}->{user} = $user; + $::sn{$nick}->{host} = $host; + $::sn{$nick}->{account} = lc $account; +} + +sub on_whoxover +{ + my ($conn, $event) = @_; + my $chan = pop @::syncqueue; + $::synced{lc $event->{args}->[1]} = 1; + if (defined($chan) ){ + $conn->sl('who ' . $chan . ' %tcnuhra,314'); + $conn->sl('mode ' . $chan); + $conn->sl('mode ' . $chan . ' bq'); + } else { + my $size = `ps -p $$ h -o size`; + my $cputime = `ps -p $$ h -o time`; + chomp $size; chomp $cputime; + my ($tx, $rx); + if ($conn->{_tx}/1024 > 1024) { + $tx = sprintf("%.2fMB", $conn->{_tx}/(1024*1024)); + } else { + $tx = sprintf("%.2fKB", $conn->{_tx}/1024); + } + if ($conn->{_rx}/1024 > 1024) { + $rx = sprintf("%.2fMB", $conn->{_rx}/(1024*1024)); + } else { + $rx = sprintf("%.2fKB", $conn->{_rx}/1024); + } + $conn->privmsg($::settings->{masterchan}, "Finished syncing after " . (time - $::starttime) . " seconds. " . + "I'm tracking " . (scalar (keys %::sn)) . " nicks" . + " across " . (scalar (keys %::sc)) . " tracked channels." . + " I'm using " . $size . "KB of RAM" . + ", have used " . $cputime . " of CPU time" . + ", have sent $tx of data, and received $rx of data."); + my %x = (); + foreach my $c (@{$::settings->{autojoins}}) { $x{$c} = 1; } + foreach my $cx (keys %::sc) { delete $x{$cx}; } + if (scalar (keys %x)) { + $conn->privmsg($::settings->{masterchan}, "Syncing appears to have failed for " . ASM::Util->commaAndify(keys %x)); + } + } +} + +sub on_whofuckedup +{ + my ($conn, $event) = @_; + ASM::Util->dprint('on_whofuckedup called!', 'sync'); + if ($event->{args}->[1] eq "STATS") { +#most likely this is getting called because we did stats p too often. +#unfortunately the server doesn't let us know what exactly we called stats for. +#anyways, we don't need to do anything for this + } else { #dunno why it got called, print the data and I'll add a handler for it. + ASM::Util->dprint(Dumper($event), 'sync'); + } +} + +sub on_bannedfromchan { + my ($conn, $event) = @_; + ASM::Util->dprint("I'm banned from " . $event->{args}->[1] . "... attempting to unban myself", 'startup'); + $conn->privmsg('ChanServ', "unban $event->{args}->[1]"); +} + +sub on_byechan { + my ($chan) = @_; + #TODO do del event stuff +} + +return 1; diff --git a/lib/ASM/Inspect.pm b/lib/ASM/Inspect.pm new file mode 100644 index 0000000..df515dc --- /dev/null +++ b/lib/ASM/Inspect.pm @@ -0,0 +1,101 @@ +package ASM::Inspect; +use warnings; +use strict; +use feature qw(say); + +use Data::Dumper; +#use List::Util qw(first); +use String::Interpolate qw(interpolate); +use Carp qw(cluck); + +%::ignored = (); +sub new +{ + my $module = shift; + my $self = {}; + bless($self); + return $self; +} + +sub inspect { + our ($self, $conn, $event, $response) = @_; + my (%aonx, %dct, $rev, $chan, $id); + %aonx=(); %dct=(); $chan=""; $id=""; + my (@dnsbl, @uniq); + my ($match, $txtz, $iaddr); + my @override = []; + my $nick = lc $event->{nick}; + my $xresult; + return if (index($nick, ".") != -1); + if ( $event->{host} =~ /gateway\/web\// ) { + if ( $event->{user} =~ /([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})/ ) { + $rev = sprintf("%d.%d.%d.%d.", hex($4), hex($3), hex($2), hex($1)); + } + } + if ( (!defined($rev)) && ($event->{type} eq 'join') ) { +# Only doing DNS lookups for join events will mean that DNSBL will break if we try to do it on something other than joins, +# But it also means we cut back on the DNS lookups by a metric shitton + $iaddr = gethostbyname($event->{host}) if ($event->{host} !~ /\//); + $rev = join('.', reverse(unpack('C4', $iaddr))).'.' if (defined $iaddr); + } + ## NB: isn't there a better way to do this with grep, somehow? + %aonx = %{$::rules->{event}}; + foreach $chan ( @{$event->{to}} ) { + # don't do anything for channels we haven't synced yet + # because we can't yet respect stuff like notrigger for these + next unless $::synced{lc $chan}; + next unless $chan =~ /^#/; + next if ((defined($::channels->{channel}->{$chan}->{monitor})) and ($::channels->{channel}->{$chan}->{monitor} eq "no")); + foreach $id (keys %aonx) { + next unless ( grep { $event->{type} eq $_ } split(/[,:; ]+/, $aonx{$id}{type}) ); + if (defined($response)) { + if ($aonx{$id}{class} ne 'urlcrunch') { next; } #don't run our regular checks if this is being called from a URL checking function + else { $xresult = $::classes->check($aonx{$id}{class}, $aonx{$id}, $id, $event, $chan, $response); } + } + else { + $xresult = $::classes->check($aonx{$id}{class}, $aonx{$id}, $id, $event, $chan, $rev); # this is another bad hack done for dnsbl-related stuff + } + next unless (defined($xresult)) && ($xresult ne 0); + ASM::Util->dprint(Dumper($xresult), 'inspector'); + $dct{$id} = $aonx{$id}; + $dct{$id}{xresult} = $xresult; + } + } + foreach ( keys %dct ) { + if ( defined $dct{$_}{override} ) { + push( @override, split( /[ ,;]+/, $dct{$_}{override} ) ); + } + } + delete $dct{$_} foreach @override; + my $evcontent = $event->{args}->[0]; + my $evhost = $event->{host}; + foreach $chan (@{$event->{to}}) { + foreach $id ( keys %dct ) { + return unless (ASM::Util->notRestricted($nick, "notrigger") && ASM::Util->notRestricted($nick, "no$id")); + $xresult = $dct{$id}{xresult}; + my $nicereason = interpolate($dct{$id}{reason}); + if (defined $::db) { + $::db->record($chan, $event->{nick}, $event->{user}, $event->{host}, $::sn{lc $event->{nick}}->{gecos}, $dct{$id}{risk}, $id, $nicereason); + } + $txtz = "\x03" . $::RCOLOR{$::RISKS{$dct{$id}{risk}}} . "\u$dct{$id}{risk}\x03 risk threat [\x02$chan\x02] - ". + "\x02$event->{nick}\x02 - ${nicereason}; ping "; + $txtz = $txtz . ASM::Util->commaAndify(ASM::Util->getAlert(lc $chan, $dct{$id}{risk}, 'hilights')) if (ASM::Util->getAlert(lc $chan, $dct{$id}{risk}, 'hilights')); + $txtz = $txtz . ' !att-' . $chan . '-' . $dct{$id}{risk}; + if ($id eq 'last_measure_regex') { #TODO: Note that this is another example of things that shouldn't be hardcoded, but are. + + } + if ( + (!(defined($::ignored{$chan}) && ($::ignored{$chan} >= $::RISKS{$dct{$id}{risk}}))) || + (($::pacealerts == 0) && ($dct{$id}{risk} eq 'info')) + ) { + my @tgts = ASM::Util->getAlert($chan, $dct{$id}{risk}, 'msgs'); + ASM::Util->sendLongMsg($conn, \@tgts, $txtz); + $conn->schedule(45, sub { delete($::ignored{$chan}) if $::ignored{$chan} == $::RISKS{$dct{$id}{risk}} }); + $::ignored{$chan} = $::RISKS{$dct{$id}{risk}}; + } + $::log->incident($chan, "$chan: $dct{$id}{risk} risk: $event->{nick} - $nicereason\n"); + } + } +} + +1; diff --git a/lib/ASM/Log.pm b/lib/ASM/Log.pm new file mode 100644 index 0000000..c2a2b72 --- /dev/null +++ b/lib/ASM/Log.pm @@ -0,0 +1,112 @@ +package ASM::Log; + +use warnings; +use strict; + +#use IO::All; +use POSIX qw(strftime); + +sub new +{ + my $module = shift; + my $config = shift; + my $self = {}; + $self->{CONFIG} = $config; + $self->{backlog} = {}; + bless($self); + return $self; +} + +sub incident +{ + my $self = shift; + my ($chan, $header) = @_; + $chan = lc $chan; + open(FH, '>>', 'dctlog.txt'); + print FH $header; + if (defined($self->{backlog}->{$chan})) { + print FH join('', @{$self->{backlog}->{$chan}}); + } + print FH "\n\n"; + close(FH); +} + +#writes out the backlog to a file which correlates to ASM's SQL actionlog table +sub sqlIncident +{ + my $self = shift; + my ($channel, $index) = @_; + $channel = lc $channel; + my @chans = split(/,/, $channel); + open(FH, '>', $self->{CONFIG}->{actiondir} . $index . '.txt'); + foreach my $chan (@chans) { + if (defined($self->{backlog}->{$chan})) { + say FH "$chan"; + say FH join('', @{$self->{backlog}->{$chan}}); + } + } + close(FH); +} + +sub logg +{ + my $self = shift; + my ($event) = @_; + my $cfg = $self->{CONFIG}; + my @chans = @{$event->{to}}; + @chans = ( $event->{args}->[0] ) if ($event->{type} eq 'kick'); + my @time = ($cfg->{zone} eq 'local') ? localtime : gmtime; + foreach my $chan ( @chans ) + { + $chan = lc $chan; + next if ($chan eq '$$*'); + $chan =~ s/^[@+]//; + if ($chan eq '*') { + ASM::Util->dprint("$event->{nick}: $event->{args}->[0]", 'snotice'); + next; + } + my $path = ">>$cfg->{dir}${chan}/${chan}" . strftime($cfg->{filefmt}, @time); + $_ = ''; + $_ = "<$event->{nick}> $event->{args}->[0]" if $event->{type} eq 'public'; + $_ = "*** $event->{nick} has joined $chan" if $event->{type} eq 'join'; + $_ = "*** $event->{nick} has left $chan ($event->{args}->[0])" if $event->{type} eq 'part'; + $_ = "* $event->{nick} $event->{args}->[0]" if $event->{type} eq 'caction'; + $_ = "*** $event->{nick} is now known as $event->{args}->[0]" if $event->{type} eq 'nick'; + $_ = "*** $event->{nick} has quit ($event->{args}->[0])" if $event->{type} eq 'quit'; + $_ = "*** $event->{to}->[0] was kicked by $event->{nick}" if $event->{type} eq 'kick'; + $_ = "-$event->{nick}- $event->{args}->[0]" if $event->{type} eq 'notice'; + $_ = "*** $event->{nick} sets mode: " . join(" ",@{$event->{args}}) if $event->{type} eq 'mode'; + $_ = "*** $event->{nick} changes topic to \"$event->{args}->[0]\"" if $event->{type} eq 'topic'; + my $nostamp = $_; + $_ = strftime($cfg->{timefmt}, @time) . $_ . "\n"; + my $line = $_; + my @backlog = (); + if (defined($self->{backlog}->{$chan})) { + @backlog = @{$self->{backlog}->{$chan}}; + if (scalar @backlog >= 30) { + shift @backlog; + } + } + push @backlog, $line; + $self->{backlog}->{$chan} = \@backlog; + if (open(FH, $path)) { # or die "Can't open $path: $!"; + print FH $line; + ASM::Util->dprint($line, 'logger'); + close(FH); + } else { + print "COULDN'T PRINT TO $path - $line"; + } + my $spy; + if (defined($::spy{$chan})) { + $spy = $::spy{$chan}; + } elsif (defined($::spy{lc $event->{nick}})) { + $spy = $::spy{lc $event->{nick}}; + } + if (defined($spy)) { + say $spy "$chan: $nostamp"; + } +# $_ >> io($path); + } +} + +1; diff --git a/lib/ASM/Services.pm b/lib/ASM/Services.pm new file mode 100644 index 0000000..528901d --- /dev/null +++ b/lib/ASM/Services.pm @@ -0,0 +1,69 @@ +package ASM::Services; +use warnings; +use strict; + +use Data::Dumper; +$Data::Dumper::Useqq=1; + +sub new +{ + my $self = {}; + bless($self); + return $self; +} + +sub doServices { + my ($self, $conn, $event) = @_; + my $i = 1; + if ($event->{from} eq 'NickServ!NickServ@services.') + { + ASM::Util->dprint("NickServ: $event->{args}->[0]", 'snotice'); + if ( $event->{args}->[0] =~ /^This nickname is registered/ ) + { + $conn->privmsg( 'NickServ@services.', "identify $::settings->{nick} $::settings->{pass}" ); + } + elsif ( $event->{args}->[0] =~ /^You are now identified/ ) + { + my @autojoins = @{$::settings->{autojoins}}; + if (defined($autojoins[30])) { + $conn->join(join(',', @autojoins[0..30])); + if (defined($autojoins[60])) { + $conn->join(join(',', @autojoins[30..60])); + $conn->join(join(',', @autojoins[60..$#autojoins])); + } else { + $conn->join(join(',', @autojoins[30..$#autojoins])); + } + } else { + $conn->join(join(',', @autojoins)); + } + $conn->sl("PING :" . time); + $conn->schedule(2, sub { $conn->privmsg($::settings->{masterchan}, 'Now joined to all channels in '. (time - $::starttime) . " seconds."); }); + } + elsif ($event->{args}->[0] =~ /has been (killed|released)/ ) + { +# ASM::Util->dprint('Got kill/release successful from NickServ!', 'snotice'); + $conn->nick( $::settings->{nick} ); + } + elsif ($event->{args}->[0] =~ /has been regained/ ) + { +# ASM::Util->dprint('Got regain successful from nickserv!', 'snotice'); + } + elsif ($event->{args}->[0] =~ /Password Incorrect/ ) + { + die("NickServ password invalid.") + } + } + elsif ($event->{from} eq 'ChanServ!ChanServ@services.') + { + if ( $event->{args}->[0] =~ /^\[#/ ) { + return; + } + ASM::Util->dprint("ChanServ: $event->{args}->[0]", 'snotice'); + if ( $event->{args}->[0] =~ /^All.*bans matching.*have been cleared on(.*)/) + { + $conn->join($1); + } + } +} + +return 1; diff --git a/lib/ASM/Util.pm b/lib/ASM/Util.pm new file mode 100644 index 0000000..f9895a0 --- /dev/null +++ b/lib/ASM/Util.pm @@ -0,0 +1,297 @@ +package ASM::Util; +use Array::Utils qw(:all); +use POSIX qw(strftime); +use warnings; +use strict; +use Term::ANSIColor qw (:constants); +use Socket qw( inet_aton inet_ntoa ); +use Data::Dumper; +use Carp qw(cluck); + +%::RISKS = +( + 'disable'=> -1, #this isn't really an alert + 'debug' => 10, + 'info' => 20, + 'low' => 30, + 'medium' => 40, + 'high' => 50, + 'opalert'=> 9001 #OVER NINE THOUSAND!!! +); + +#leaves room for more levels if for some reason we end up needing more +#theoretically, you should be able to change those numbers without any damage + +%::COLORS = +( + 'white' => '00', + 'black' => '01', + 'blue' => '02', + 'green' => '03', + 'red' => '04', + 'brown' => '05', + 'purple' => '06', + 'orange' => '07', + 'yellow' => '08', + 'ltgreen' => '09', + 'teal' => '10', + 'ltcyan' => '11', + 'ltblue' => '12', + 'pink' => '13', + 'grey' => '14', + 'ltgrey' => '15', +); + +%::RCOLOR = +( + $::RISKS{debug} => $::COLORS{purple}, + $::RISKS{info} => $::COLORS{blue}, + $::RISKS{low} => $::COLORS{green}, + $::RISKS{medium} => $::COLORS{orange}, + $::RISKS{high} => $::COLORS{red}, +); + +sub new +{ + my $module = shift; + my $self = {}; + bless ($self); + return $self; +} + +sub maxlen { + my ($a, $b) = @_; + my ($la, $lb) = (length($a), length($b)); + return $la if ($la > $lb); + return $lb; +} + +#cs: returns the xml settings for the specified chan, or default if there aren't any settings for that chan +sub cs { + my ($module, $chan) = @_; + $chan = lc $chan; + $chan =~ s/^[@+]//; + return $::channels->{channel}->{default} unless defined($::channels->{channel}->{$chan}); + if ( defined($::channels->{channel}->{$chan}->{link}) ) { + return $::channels->{channel}->{ $::channels->{channel}->{$chan}->{link} }; + } + return $::channels->{channel}->{$chan}; +} + +sub getLink +{ + my ($module, $chan) = @_; + $chan = lc $chan; + $chan =~ s/^[@+]//; + my $link = $::channels->{channel}->{$chan}->{link}; + if ( defined($link) ) { + return $link; + } + return $chan; +} + +sub speak +{ + my ($module, $chan) = @_; + $chan = lc $chan; + $chan =~ s/^[@+]//; + if ( defined($::channels->{channel}->{$chan}->{silence}) ) { + if ($::channels->{channel}->{$chan}->{silence} eq "no") { + return 1; + } + elsif ($::channels->{channel}->{$chan}->{silence} eq "yes") { + return 0; + } + } + if ( defined($::channels->{channel}->{default}->{silence}) ) { + if ( $::channels->{channel}->{default}->{silence} eq "no" ) { + return 1; + } + elsif ( $::channels->{channel}->{default}->{silence} eq "yes" ) { + return 0; + } + } + return 1; +} + +#this item is a stub, dur +sub hostip { + #cluck "Calling gethostbyname in hostip"; + return gethostbyname($_[0]); +} + +# If $tgts="#antispammeta" that's fine, and if $tgts = ["#antispammeta", "##linux-ops"] that's cool too +sub sendLongMsg { + my ($module, $conn, $tgts, $txtz) = @_; + if (length($txtz) <= 380) { + $conn->privmsg($tgts, $txtz); + } else { + my $splitpart = rindex($txtz, " ", 380); + $conn->privmsg($tgts, substr($txtz, 0, $splitpart)); + $conn->privmsg($tgts, substr($txtz, $splitpart)); + } +} + +sub getAlert { + my ($module, $c, $risk, $t) = @_; + my @disable = (); + my @x = (); + $c = lc $c; + $c =~ s/^[@+]//; + foreach my $prisk ( keys %::RISKS) { + if ( $::RISKS{$risk} >= $::RISKS{$prisk} ) { + push( @x, @{$::channels->{channel}->{master}->{$t}->{$prisk}} ) if defined $::channels->{channel}->{master}->{$t}->{$prisk}; + push( @x, @{cs($module, $c)->{$t}->{$prisk}} ) if defined cs($module, $c)->{$t}->{$prisk}; + } + } + push( @disable, @{$::channels->{channel}->{master}->{$t}->{disable}} ) if defined $::channels->{channel}->{master}->{$t}->{disable}; + push( @disable, @{cs($module, $c)->{$t}->{disable}} ) if defined cs($module, $c)->{$t}->{disable}; + @x = unique(@x); + @x = array_diff(@x, @disable); + return @x; +} + +sub commaAndify { + my $module = shift; + my @seq = @_; + my $len = ($#seq); + my $last = $seq[$len]; + return '' if $len eq -1; + return $seq[0] if $len eq 0; + return join( ' and ', $seq[0], $seq[1] ) if $len eq 1; + return join( ', ', splice(@seq,0,$len) ) . ', and ' . $last; +} + +sub leq { + my ($s1, $s2) = @_; + return (lc $s1 eq lc $s2); +} + +sub seq { + my ($n1, $n2) = @_; + return 0 unless defined($n1); + return 0 unless defined($n2); + return ($n1 eq $n2); +} + +#I last worked on this function while having way too many pain meds, if it's fucked up, that's why. +sub dprint { + my ($module, $text, $type) = @_; + if (!defined($type)) { + die "old method for dprint called!\n"; + } + if (!defined($::debugx{$type})) { + die "dprint called with invalid type!\n"; + } + if ($::debugx{$type} eq 0) { + return; + } + say STDERR strftime("%F %T ", gmtime), + GREEN, 'DEBUG', RESET, '(', $::debugx{$type}, $type, RESET, ') ', $text; +} + + +sub intToDottedQuad { + my ($module, $num) = @_; + return inet_ntoa(pack('N', $num)); +} + +sub dottedQuadToInt +{ + my ($module, $dottedquad) = @_; +# my $ip_number = 0; +# my @octets = split(/\./, $dottedquad); +# foreach my $octet (@octets) { +# $ip_number <<= 8; +# $ip_number |= $octet; +# } +# return $ip_number; + return unpack('N', inet_aton($dottedquad)); +} + +sub getHostIP +{ + my ($module, $host) = @_; + if ( ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) or + ($host =~ /^gateway\/web\/.*\/ip\.(\d+)\.(\d+)\.(\d+)\.(\d+)$/) ) { + #yay, easy IP! + return dottedQuadToInt(undef, "$1.$2.$3.$4"); + } elsif (index($host, '/') != -1) { + return; + } elsif ($host =~ /^2001:0:/) { + my @splitip = split(/:/, $host); + return unless defined($splitip[6]) && defined($splitip[7]); + #I think I can just do (hex($splitip[6] . $splitip[7]) ^ hex('ffffffff')) here but meh + my $host = join('.', unpack('C4', pack('N', (hex($splitip[6] . $splitip[7])^hex('ffffffff'))))); + return dottedQuadToInt(undef, $host); + } + #cluck "Calling gethostbyname in getHostIP"; + my @resolve = gethostbyname($host); + return unless @resolve; + return dottedQuadToInt(undef, join('.', unpack('C4', $resolve[4]))); +} + +sub getNickIP +{ + my ($module, $nick, $host) = @_; + $nick = lc $nick; + return unless defined($::sn{$nick}); + if (defined($::sn{$nick}{ip})) { + return $::sn{$nick}{ip}; + } + $host //= $::sn{$nick}{host}; + my $ip = getHostIP(undef, $host); + if (defined($ip)) { + $::sn{$nick}{ip} = $ip; + return $ip; + } + return; +# if ( ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) or +# ($host =~ /^gateway\/web\/freenode\/ip\.(\d+)\.(\d+)\.(\d+)\.(\d+)$/) ) { +# #yay, easy IP! +# $::sn{$nick}{ip} = dottedQuadToInt(undef, "$1.$2.$3.$4"); +# return $::sn{$nick}{ip}; +# } elsif (index($host, '/') != -1) { +# return; +# } elsif ($host =~ /^2001:0:/) { +# my @splitip = split(/:/, $host); +# #I think I can just do (hex($splitip[6] . $splitip[7]) ^ hex('ffffffff')) here but meh +# my $host = join('.', unpack('C4', pack('N', (hex($splitip[6] . $splitip[7])^hex('ffffffff'))))); +# $::sn{$nick}{ip} = dottedQuadToInt(undef, $host); +# return $::sn{$nick}{ip}; +# } +# my @resolve = gethostbyname($::sn{$nick}{host}); +# return unless @resolve; +# $::sn{$nick}{ip} = dottedQuadToInt(undef, join('.', unpack('C4', $resolve[4]))); +# return $::sn{$nick}{ip}; +} + +sub notRestricted { + my ($module, $nick, $restriction) = @_; + $nick = lc $nick; + my $host = lc $::sn{$nick}{host}; + my $account = lc $::sn{$nick}{account}; + foreach my $regex (keys %{$::restrictions->{nicks}->{nick}}) { + if ($nick =~ /^$regex$/i && defined($::restrictions->{nicks}->{nick}->{$regex}->{$restriction})) { + dprint("blah", "Restriction $restriction found for $nick (nick $regex)", "restrictions"); + return 0; + } + } + if ((defined($host)) && (defined($account))) { + foreach my $regex (keys %{$::restrictions->{accounts}->{account}}) { + if ($account =~ /^$regex$/i && defined($::restrictions->{accounts}->{account}->{$regex}->{$restriction})) { + dprint("blah", "Restriction $restriction found for $nick (account $regex)", "restrictions"); + return 0; + } + } + foreach my $regex (keys %{$::restrictions->{hosts}->{host}}) { + if ($host =~ /^$regex$/i && defined($::restrictions->{hosts}->{host}->{$regex}->{$restriction})) { + dprint("blah", "Restriction $restriction found for $nick (host $regex)", "restrictions"); + return 0; + } + } + } + return 1; +} + +return 1; diff --git a/lib/ASM/XML.pm b/lib/ASM/XML.pm new file mode 100644 index 0000000..1128dda --- /dev/null +++ b/lib/ASM/XML.pm @@ -0,0 +1,69 @@ +package ASM::XML; +use warnings; +use strict; + +use XML::Simple qw(:strict); +use IO::All; + +$::xs1 = XML::Simple->new( KeyAttr => ['id'], Cache => [ qw/memcopy/ ]); + +sub readXML { + my ( $p ) = $::cset; + my @fchan = ( 'event', keys %::RISKS ); + $::settings = $::xs1->XMLin( "$p/settings.xml", ForceArray => ['host'], + 'GroupTags' => { altnicks => 'altnick', server => 'host', + autojoins => 'autojoin' }); + $::channels = $::xs1->XMLin( "$p/channels.xml", ForceArray => \@fchan ); + $::users = $::xs1->XMLin( "$p/users.xml", ForceArray => 'person'); + $::commands = $::xs1->XMLin( "$p/commands.xml", ForceArray => [qw/command/]); + $::mysql = $::xs1->XMLin( "$p/mysql.xml", ForceArray => ['ident', 'geco'], + 'GroupTags' => { ignoredidents => 'ident', ignoredgecos => 'geco' }); + $::dnsbl = $::xs1->XMLin( "$p/dnsbl.xml", ForceArray => []); + $::rules = $::xs1->XMLin( "$p/rules.xml", ForceArray => []); + $::restrictions = $::xs1->XMLin( "$p/restrictions.xml", ForceArray => ['host', 'nick', 'account']); + $::blacklist = $::xs1->XMLin( "$p/blacklist.xml", ForceArray => 'string'); +} + +sub writeXML { + writeSettings(); + writeChannels(); + writeUsers(); + writeRestrictions(); + writeBlacklist(); + writeMysql(); +# $::xs1->XMLout($::commands, RootName => 'commands', KeyAttr => ['id']) > io("$::cset/commands.xml"); +} + +sub writeMysql { + $::settingschanged=1; + $::xs1->XMLout($::mysql, RootName => 'mysql', KeyAttr => ['id']) > io("$::cset/mysql.xml"); +} + +sub writeChannels { + $::settingschanged=1; + $::xs1->XMLout($::channels, RootName => 'channels', KeyAttr => ['id'], NumericEscape => 2) > io("$::cset/channels.xml"); +} + +sub writeUsers { + $::settingschanged=1; + $::xs1->XMLout($::users, RootName => 'people', KeyAttr => ['id']) > io("$::cset/users.xml"); +} + +sub writeSettings { + $::settingschanged=1; + $::xs1->XMLout($::settings, RootName => 'settings', + GroupTags => { altnicks => 'altnick', server => 'host', autojoins => 'autojoin' }, NoAttr => 1) > io("$::cset/settings.xml"); +} + +sub writeRestrictions { + $::settingschanged=1; + $::xs1->XMLout($::restrictions, RootName => 'restrictions', KeyAttr => ['id'], + GroupTags => { hosts => "host", nicks => "nick", accounts => "account"}) > io("$::cset/restrictions.xml"); +} + +sub writeBlacklist { + $::settingschanged=1; + $::xs1->XMLout($::blacklist, RootName => 'blacklist', KeyAttr => ['id'], NumericEscape => 2) > io("$::cset/blacklist.xml"); +} + +return 1; diff --git a/lib/Net/IRC.pm b/lib/Net/IRC.pm new file mode 100644 index 0000000..9e39458 --- /dev/null +++ b/lib/Net/IRC.pm @@ -0,0 +1,759 @@ +##################################################################### +# # +# Net::IRC -- Object-oriented Perl interface to an IRC server # +# # +# IRC.pm: A nifty little wrapper that makes your life easier. # +# # +# Copyright (c) 1997 Greg Bacon & Dennis Taylor. # +# All rights reserved. # +# # +# This module is free software; you can redistribute or # +# modify it under the terms of Perl's Artistic License. # +# # +##################################################################### +# $Id: IRC.pm,v 1.10 2004/04/30 18:02:51 jmuhlich Exp $ + + +package Net::IRC; + +BEGIN { require 5.004; } # needs IO::* and $coderef->(@args) syntax + +use Net::IRC::Connection; +use Net::IRC::EventQueue; +use IO::Select; +use Carp; + + +# grab the drop-in replacement for time() from Time::HiRes, if it's available +BEGIN { + Time::HiRes->import('time') if eval "require Time::HiRes"; +} + + +use strict; +use vars qw($VERSION); + +$VERSION = "0.80"; + +sub new { + my $proto = shift; + + my $self = { + '_conn' => [], + '_connhash' => {}, + '_error' => IO::Select->new(), + '_debug' => 0, + '_schedulequeue' => new Net::IRC::EventQueue(), + '_outputqueue' => new Net::IRC::EventQueue(), + '_read' => IO::Select->new(), + '_timeout' => 1, + '_write' => IO::Select->new(), + }; + + bless $self, $proto; + + return $self; +} + +sub outputqueue { + my $self = shift; + return $self->{_outputqueue}; +} + +sub schedulequeue { + my $self = shift; + return $self->{_schedulequeue}; +} + +# Front end to addfh(), below. Sets it to read by default. +# Takes at least 1 arg: an object to add to the select loop. +# (optional) a flag string to pass to addfh() (see below) +sub addconn { + my ($self, $conn) = @_; + + $self->addfh( $conn->socket, $conn->can('parse'), ($_[2] || 'r'), $conn); +} + +# Adds a filehandle to the select loop. Tasty and flavorful. +# Takes 3 args: a filehandle or socket to add +# a coderef (can be undef) to pass the ready filehandle to for +# user-specified reading/writing/error handling. +# (optional) a string with r/w/e flags, similar to C's fopen() syntax, +# except that you can combine flags (i.e., "rw"). +# (optional) an object that the coderef is a method of +sub addfh { + my ($self, $fh, $code, $flag, $obj) = @_; + my ($letter); + + die "Not enough arguments to IRC->addfh()" unless defined $code; + + if ($flag) { + foreach $letter (split(//, lc $flag)) { + if ($letter eq 'r') { + $self->{_read}->add( $fh ); + } elsif ($letter eq 'w') { + $self->{_write}->add( $fh ); + } elsif ($letter eq 'e') { + $self->{_error}->add( $fh ); + } + } + } else { + $self->{_read}->add( $fh ); + } + + $self->{_connhash}->{$fh} = [ $code, $obj ]; +} + +# Sets or returns the debugging flag for this object. +# Takes 1 optional arg: a new boolean value for the flag. +sub debug { + my $self = shift; + + if (@_) { + $self->{_debug} = $_[0]; + } + return $self->{_debug}; +} + +# Goes through one iteration of the main event loop. Useful for integrating +# other event-based systems (Tk, etc.) with Net::IRC. +# Takes no args. +sub do_one_loop { + my $self = shift; + my ($ev, $sock, $time, $nexttimer, $timeout); + my (undef, undef, undef, $caller) = caller(1); + + $time = time(); # no use calling time() all the time. + + if(!$self->outputqueue->is_empty) { + my $outputevent = undef; + while(defined($outputevent = $self->outputqueue->head) + && $outputevent->time <= $time) { + $outputevent = $self->outputqueue->dequeue(); + $outputevent->content->{coderef}->(@{$outputevent->content->{args}}); + } + $nexttimer = $self->outputqueue->head->time if !$self->outputqueue->is_empty(); + } + + # we don't want to bother waiting on input or running + # scheduled events if we're just flushing the output queue + # so we bail out here + return if $caller eq 'Net::IRC::flush_output_queue'; + + # Check the queue for scheduled events to run. + if(!$self->schedulequeue->is_empty) { + my $scheduledevent = undef; + while(defined($scheduledevent = $self->schedulequeue->head) && $scheduledevent->time <= $time) { + $scheduledevent = $self->schedulequeue->dequeue(); + $scheduledevent->content->{coderef}->(@{$scheduledevent->content->{args}}); + } + if(!$self->schedulequeue->is_empty() + && $nexttimer + && $self->schedulequeue->head->time < $nexttimer) { + $nexttimer = $self->schedulequeue->head->time; + } + } + + # Block until input arrives, then hand the filehandle over to the + # user-supplied coderef. Look! It's a freezer full of government cheese! + + if ($nexttimer) { + $timeout = $nexttimer - $time < $self->{_timeout} + ? $nexttimer - $time : $self->{_timeout}; + } else { + $timeout = $self->{_timeout}; + } + foreach $ev (IO::Select->select($self->{_read}, + $self->{_write}, + $self->{_error}, + $timeout)) { + foreach $sock (@{$ev}) { + my $conn = $self->{_connhash}->{$sock}; + $conn or next; + + # $conn->[0] is a code reference to a handler sub. + # $conn->[1] is optionally an object which the + # handler sub may be a method of. + + $conn->[0]->($conn->[1] ? ($conn->[1], $sock) : $sock); + } + } +} + +sub flush_output_queue { + my $self = shift; + + while(!$self->outputqueue->is_empty()) { + $self->do_one_loop(); + } +} + +# Creates and returns a new Connection object. +# Any args here get passed to Connection->connect(). +sub newconn { + my $self = shift; + my $conn = Net::IRC::Connection->new($self, @_); + + return if $conn->error; + return $conn; +} + +# Takes the args passed to it by Connection->schedule()... see it for details. +sub enqueue_scheduled_event { + my $self = shift; + my $time = shift; + my $coderef = shift; + my @args = @_; + + return $self->schedulequeue->enqueue($time, { coderef => $coderef, args => \@args }); +} + +# Takes a scheduled event ID to remove from the queue. +# Returns the deleted coderef, if you actually care. +sub dequeue_scheduled_event { + my ($self, $id) = @_; + $self->schedulequeue->dequeue($id); +} + +# Takes the args passed to it by Connection->schedule()... see it for details. +sub enqueue_output_event { + my $self = shift; + my $time = shift; + my $coderef = shift; + my @args = @_; + + return $self->outputqueue->enqueue($time, { coderef => $coderef, args => \@args }); +} + +# Takes a scheduled event ID to remove from the queue. +# Returns the deleted coderef, if you actually care. +sub dequeue_output_event { + my ($self, $id) = @_; + $self->outputqueue->dequeue($id); +} + +# Front-end for removefh(), below. +# Takes 1 arg: a Connection (or DCC or whatever) to remove. +sub removeconn { + my ($self, $conn) = @_; + + $self->removefh( $conn->socket ); +} + +# Given a filehandle, removes it from all select lists. You get the picture. +sub removefh { + my ($self, $fh) = @_; + + $self->{_read}->remove( $fh ); + $self->{_write}->remove( $fh ); + $self->{_error}->remove( $fh ); + delete $self->{_connhash}->{$fh}; +} + +# Begin the main loop. Wheee. Hope you remembered to set up your handlers +# first... (takes no args, of course) +sub start { + my $self = shift; + + while (1) { + $self->do_one_loop(); + } +} + +# Sets or returns the current timeout, in seconds, for the select loop. +# Takes 1 optional arg: the new value for the timeout, in seconds. +# Fractional timeout values are just fine, as per the core select(). +sub timeout { + my $self = shift; + + if (@_) { $self->{_timeout} = $_[0] } + return $self->{_timeout}; +} + +1; + + +__END__ + + +=head1 NAME + +Net::IRC - DEAD SINCE 2004 Perl interface to the Internet Relay Chat protocol + +=head1 USE THESE INSTEAD + +This module has been abandoned and is no longer developed. This release serves +only to warn current and future users about this and to direct them to supported +and actively-developed libraries for connecting Perl to IRC. Most new users will +want to use L, whereas more advanced users will appreciate the +flexibility offered by L. We understand that porting code +to a new framework can be difficult. Please stop by #perl on irc.freenode.net +and we'll be happy to help you out with bringing your bots into the modern era. + +=head1 SYNOPSIS + + use Net::IRC; + + $irc = new Net::IRC; + $conn = $irc->newconn(Nick => 'some_nick', + Server => 'some.irc.server.com', + Port => 6667, + Ircname => 'Some witty comment.'); + $irc->start; + +=head1 DESCRIPTION + +This module has been abandoned and deprecated since 2004. The original authors +have moved onto L and more modern techniques. This +distribution is not maintained and only uploaded to present successively louder +"don't use this" warnings to those unaware. + +Welcome to Net::IRC, a work in progress. First intended to be a quick tool +for writing an IRC script in Perl, Net::IRC has grown into a comprehensive +Perl implementation of the IRC protocol (RFC 1459), developed by several +members of the EFnet IRC channel #perl, and maintained in channel #net-irc. + +There are 4 component modules which make up Net::IRC: + +=over + +=item * + +Net::IRC + +The wrapper for everything else, containing methods to generate +Connection objects (see below) and a connection manager which does an event +loop on all available filehandles. Sockets or files which are readable (or +writable, or whatever you want it to select() for) get passed to user-supplied +handler subroutines in other packages or in user code. + +=item * + +Net::IRC::Connection + +The big time sink on this project. Each Connection instance is a +single connection to an IRC server. The module itself contains methods for +every single IRC command available to users (Net::IRC isn't designed for +writing servers, for obvious reasons), methods to set, retrieve, and call +handler functions which the user can set (more on this later), and too many +cute comments. Hey, what can I say, we were bored. + +=item * + +Net::IRC::Event + +Kind of a struct-like object for storing info about things that the +IRC server tells you (server responses, channel talk, joins and parts, et +cetera). It records who initiated the event, who it affects, the event +type, and any other arguments provided for that event. Incidentally, the +only argument passed to a handler function. + +=item * + +Net::IRC::DCC + +The analogous object to Connection.pm for connecting, sending and +retrieving with the DCC protocol. Instances of DCC.pm are invoked from +Cnew_{send,get,chat}> in the same way that +Cnewconn> invokes Cnew>. This will make more +sense later, we promise. + +=back + +The central concept that Net::IRC is built around is that of handlers +(or hooks, or callbacks, or whatever the heck you feel like calling them). +We tried to make it a completely event-driven model, a la Tk -- for every +conceivable type of event that your client might see on IRC, you can give +your program a custom subroutine to call. But wait, there's more! There are +3 levels of handler precedence: + +=over + +=item * + +Default handlers + +Considering that they're hardwired into Net::IRC, these won't do +much more than the bare minimum needed to keep the client listening on the +server, with an option to print (nicely formatted, of course) what it hears +to whatever filehandles you specify (STDOUT by default). These get called +only when the user hasn't defined any of his own handlers for this event. + +=item * + +User-definable global handlers + +The user can set up his own subroutines to replace the default +actions for I IRC connection managed by your program. These only get +invoked if the user hasn't set up a per-connection handler for the same +event. + +=item * + +User-definable per-connection handlers + +Simple: this tells a single connection what to do if it gets an event of +this type. Supersedes global handlers if any are defined for this event. + +=back + +And even better, you can choose to call your custom handlers before +or after the default handlers instead of replacing them, if you wish. In +short, it's not perfect, but it's about as good as you can get and still be +documentable, given the sometimes horrendous complexity of the IRC protocol. + + +=head1 GETTING STARTED + +=head2 Initialization + +To start a Net::IRC script, you need two things: a Net::IRC object, and a +Net::IRC::Connection object. The Connection object does the dirty work of +connecting to the server; the IRC object handles the input and output for it. +To that end, say something like this: + + use Net::IRC; + + $irc = new Net::IRC; + + $conn = $irc->newconn(Nick => 'some_nick', + Server => 'some.irc.server.com'); + +...or something similar. Acceptable parameters to newconn() are: + +=over + +=item * + +Nick + +The nickname you'll be known by on IRC, often limited to a maximum of 9 +letters. Acceptable characters for a nickname are C<[\w{}[]\`^|-]>. If +you don't specify a nick, it defaults to your username. + +=item * + +Server + +The IRC server to connect to. There are dozens of them across several +widely-used IRC networks, but the oldest and most popular is EFNet (Eris +Free Net), home to #perl. See http://www.irchelp.org/ for lists of +popular servers, or ask a friend. + +=item * + +Port + +The port to connect to this server on. By custom, the default is 6667. + +=item * + +Username + +On systems not running identd, you can set the username for your user@host +to anything you wish. Note that some IRC servers won't allow connections from +clients which don't run identd. + +=item * + +Ircname + +A short (maybe 60 or so chars) piece of text, originally intended to display +your real name, which people often use for pithy quotes and URLs. Defaults to +the contents of your GECOS field. + +=item * + +Password + +If the IRC server you're trying to write a bot for is +password-protected, no problem. Just say "C 'foo'>" and +you're set. + +=item * + +SSL + +If you wish to connect to an irc server which is using SSL, set this to a +true value. Ie: "C 1>". + +=back + +=head2 Handlers + +Once that's over and done with, you need to set up some handlers if you want +your bot to do anything more than sit on a connection and waste resources. +Handlers are references to subroutines which get called when a specific event +occurs. Here's a sample handler sub: + + # What to do when the bot successfully connects. + sub on_connect { + my $self = shift; + + print "Joining #IRC.pm..."; + $self->join("#IRC.pm"); + $self->privmsg("#IRC.pm", "Hi there."); + } + +The arguments to a handler function are always the same: + +=over + +=item $_[0]: + +The Connection object that's calling it. + +=item $_[1]: + +An Event object (see below) that describes what the handler is responding to. + +=back + +Got it? If not, see the examples in the irctest script that came with this +distribution. Anyhow, once you've defined your handler subroutines, you need +to add them to the list of handlers as either a global handler (affects all +Connection objects) or a local handler (affects only a single Connection). To +do so, say something along these lines: + + $self->add_global_handler('376', \&on_connect); # global + $self->add_handler('msg', \&on_msg); # local + +376, incidentally, is the server number for "end of MOTD", which is an event +that the server sends to you after you're connected. See Event.pm for a list +of all possible numeric codes. The 'msg' event gets called whenever someone +else on IRC sends your client a private message. For a big list of possible +events, see the B section in the documentation for +Net::IRC::Event. + +=head2 Getting Connected + +When you've set up all your handlers, the following command will put your +program in an infinite loop, grabbing input from all open connections and +passing it off to the proper handlers: + + $irc->start; + +Note that new connections can be added and old ones dropped from within your +handlers even after you call this. Just don't expect any code below the call +to C to ever get executed. + +If you're tying Net::IRC into another event-based module, such as perl/Tk, +there's a nifty C method provided for your convenience. Calling +C<$irc-Edo_one_loop()> runs through the IRC.pm event loop once, hands +all ready filehandles over to the appropriate handler subs, then returns +control to your program. + +=head1 METHOD DESCRIPTIONS + +This section contains only the methods in IRC.pm itself. Lists of the +methods in Net::IRC::Connection, Net::IRC::Event, or Net::IRC::DCC are in +their respective modules' documentation; just C +(or Event or DCC or whatever) to read them. Functions take no arguments +unless otherwise specified in their description. + +By the way, expect Net::IRC to use AutoLoader sometime in the future, once +it becomes a little more stable. + +=over + +=item * + +addconn() + +Adds the specified object's socket to the select loop in C. +This is mostly for the use of Connection and DCC objects (and for pre-0.5 +compatibility)... for most (read: all) purposes, you can just use C, +described below. + +Takes at least 1 arg: + +=over + +=item 0. + +An object whose socket needs to be added to the select loop + +=item 1. + +B A string consisting of one or more of the letters r, w, and e. +Passed directly to C... see the description below for more info. + +=back + +=item * + +addfh() + +This sub takes a user's socket or filehandle and a sub to handle it with and +merges it into C's list of select()able filehandles. This makes +integration with other event-based systems (Tk, for instance) a good deal +easier than in previous releases. + +Takes at least 2 args: + +=over + +=item 0. + +A socket or filehandle to monitor + +=item 1. + +A reference to a subroutine. When C determines that the filehandle +is ready, it passes the filehandle to this (presumably user-supplied) sub, +where you can read from it, write to it, etc. as your script sees fit. + +=item 2. + +B A string containing any combination of the letters r, w or e +(standing for read, write, and error, respectively) which determines what +conditions you're expecting on that filehandle. For example, this line +select()s $fh (a filehandle, of course) for both reading and writing: + + $irc->addfh( $fh, \&callback, "rw" ); + +=back + +=item * + +do_one_loop() + +Cs on all open filehandles and passes any ready ones to the +appropriate handler subroutines. Also responsible for executing scheduled +events from Cschedule()> on time. + +=item * + +new() + +A fairly vanilla constructor which creates and returns a new Net::IRC object. + +=item * + +newconn() + +Creates and returns a new Connection object. All arguments are passed straight +to Cnew()>; examples of common arguments can be +found in the B or B sections. + +=item * + +removeconn() + +Removes the specified object's socket from C's list of +select()able filehandles. This is mostly for the use of Connection and DCC +objects (and for pre-0.5 compatibility)... for most (read: all) purposes, +you can just use C, described below. + +Takes 1 arg: + +=over + +=item 0. + +An object whose socket or filehandle needs to be removed from the select loop + +=back + +=item * + +removefh() + +This method removes a given filehandle from C's list of +selectable filehandles. + +Takes 1 arg: + +=over + +=item 0. + +A socket or filehandle to remove + +=back + +=item * + +start() + +Starts an infinite event loop which repeatedly calls C to +read new events from all open connections and pass them off to any +applicable handlers. + +=item * + +timeout() + +Sets or returns the current C timeout for the main event loop, in +seconds (fractional amounts allowed). See the documentation for the +C function for more info. + +Takes 1 optional arg: + +=over + +=item 0. + +B A new value for the C timeout for this IRC object. + +=back + +=item * + +flush_output_queue() + +Flushes any waiting messages in the output queue if pacing is enabled. This +method will not return until the output queue is empty. + +=over + +=back + +=head1 AUTHORS + +=over + +=item * + +Conceived and initially developed by Greg Bacon Egbacon@adtran.comE +and Dennis Taylor Edennis@funkplanet.comE. + +=item * + +Ideas and large amounts of code donated by Nat "King" Torkington +Egnat@frii.comE. + +=item * + +Currently being hacked on, hacked up, and worked over by the members of the +Net::IRC developers mailing list. For details, see +http://www.execpc.com/~corbeau/irc/list.html . + +=back + +=head1 URL + +Up-to-date source and information about the Net::IRC project can be found at +http://www.sourceforge.net/projects/net-irc/ . + +=head1 SEE ALSO + +=over + +=item * + +perl(1). + +=item * + +RFC 1459: The Internet Relay Chat Protocol + +=item * + +http://www.irchelp.org/, home of fine IRC resources. + +=back + +=cut + + diff --git a/lib/Net/IRC/Connection.pm b/lib/Net/IRC/Connection.pm new file mode 100644 index 0000000..6918bda --- /dev/null +++ b/lib/Net/IRC/Connection.pm @@ -0,0 +1,1691 @@ +##################################################################### +# # +# Net::IRC -- Object-oriented Perl interface to an IRC server # +# # +# Connection.pm: The basic functions for a simple IRC connection # +# # +# # +# Copyright (c) 2001 Pete Sergeant, Greg Bacon & Dennis Taylor. # +# All rights reserved. # +# # +# This module is free software; you can redistribute or # +# modify it under the terms of Perl's Artistic License. # +# # +##################################################################### + +package Net::IRC::Connection; + +use Net::IRC::Event; +use Net::IRC::DCC; +use IO::Socket; +use IO::Socket::INET; +use Symbol; +use Carp; +use Data::Dumper; + +# all this junk below just to conditionally load a module +# sometimes even perl is braindead... + +eval 'use Time::HiRes qw(time)'; +if(!$@) { + sub time (); + use subs 'time'; + require Time::HiRes; + Time::HiRes->import('time'); +} + +use strict; + +use vars ( + '$AUTOLOAD', +); + + +# The names of the methods to be handled by &AUTOLOAD. +my %autoloaded = ( 'ircname' => undef, + 'port' => undef, + 'username' => undef, + 'socket' => undef, + 'verbose' => undef, + 'parent' => undef, + 'hostname' => undef, + 'pacing' => undef, + 'ssl' => undef, + ); + +# This hash will contain any global default handlers that the user specifies. + +my %_udef = (); + +# Creates a new IRC object and assigns some default attributes. +sub new { + my $proto = shift; + + my $self = { # obvious defaults go here, rest are user-set + _debug => $_[0]->{_debug}, + _port => 6667, + # Evals are for non-UNIX machines, just to make sure. + _username => eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "japh", + _ircname => $ENV{IRCNAME} || eval { (getpwuid($>))[6] } || "Just Another Perl Hacker", + _nick => $ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "WankerBot", + _ignore => {}, + _handler => {}, + _verbose => 0, # Is this an OK default? + _parent => shift, + _frag => '', + _connected => 0, + _maxlinelen => 510, # The RFC says we shouldn't exceed this. + _lastsl => 0, + _pacing => 0, # no pacing by default + _ssl => 0, # no ssl by default + _format => { 'default' => "[%f:%t] %m <%d>", }, + _rx => 0, + _tx => 0, + }; + + bless $self, $proto; + # do any necessary initialization here + $self->connect(@_) if @_; + + return $self; +} + +# Takes care of the methods in %autoloaded +# Sets specified attribute, or returns its value if called without args. +sub AUTOLOAD { + my $self = @_; ## can't modify @_ for goto &name + my $class = ref $self; ## die here if !ref($self) ? + my $meth; + + # -- #perl was here! -- + # absolute power corrupts absolutely, but it's a helluva lot + # of fun. + # =) + + ($meth = $AUTOLOAD) =~ s/^.*:://; ## strip fully qualified portion + + unless (exists $autoloaded{$meth}) { + croak "No method called \"$meth\" for $class object."; + } + + eval <{"_$meth"}; + + \$self->{"_$meth"} = shift; + + return \$old; + } + else { + return \$self->{"_$meth"}; + } +} +EOSub + + # no reason to play this game every time + goto &$meth; +} + +# This sub is the common backend to add_handler and add_global_handler +# +sub _add_generic_handler { + my ($self, $event, $ref, $rp, $hash_ref, $real_name) = @_; + my $ev; + my %define = ( "replace" => 0, "before" => 1, "after" => 2 ); + + unless (@_ >= 3) { + croak "Not enough arguments to $real_name()"; + } + unless (ref($ref) eq 'CODE') { + croak "Second argument of $real_name isn't a coderef"; + } + + # Translate REPLACE, BEFORE and AFTER. + if (not defined $rp) { + $rp = 0; + } elsif ($rp =~ /^\D/) { + $rp = $define{lc $rp} || 0; + } + + foreach $ev (ref $event eq "ARRAY" ? @{$event} : $event) { + # Translate numerics to names + if ($ev =~ /^\d/) { + $ev = Net::IRC::Event->trans($ev); + unless ($ev) { + carp "Unknown event type in $real_name: $ev"; + return; + } + } + + $hash_ref->{lc $ev} = [ $ref, $rp ]; + } + return 1; +} + +# This sub will assign a user's custom function to a particular event which +# might be received by any Connection object. +# Takes 3 args: the event to modify, as either a string or numeric code +# If passed an arrayref, the array is assumed to contain +# all event names which you want to set this handler for. +# a reference to the code to be executed for the event +# (optional) A value indicating whether the user's code should replace +# the built-in handler, or be called with it. Possible values: +# 0 - Replace the built-in handlers entirely. (the default) +# 1 - Call this handler right before the default handler. +# 2 - Call this handler right after the default handler. +# These can also be referred to by the #define-like strings in %define. +sub add_global_handler { + my ($self, $event, $ref, $rp) = @_; + return $self->_add_generic_handler($event, $ref, $rp, \%_udef, 'add_global_handler'); +} + +# This sub will assign a user's custom function to a particular event which +# this connection might receive. Same args as above. +sub add_handler { + my ($self, $event, $ref, $rp) = @_; + return $self->_add_generic_handler($event, $ref, $rp, $self->{_handler}, 'add_handler'); +} + +# Hooks every event we know about... +sub add_default_handler { + my ($self, $ref, $rp) = @_; + foreach my $eventtype (keys(%Net::IRC::Event::_names)) { + $self->_add_generic_handler($eventtype, $ref, $rp, $self->{_handler}, 'add_default_handler'); + } + return 1; +} + +# Why do I even bother writing subs this simple? Sends an ADMIN command. +# Takes 1 optional arg: the name of the server you want to query. +sub admin { + my $self = shift; # Thank goodness for AutoLoader, huh? + # Perhaps we'll finally use it soon. + + $self->sl("ADMIN" . ($_[0] ? " $_[0]" : "")); +} + +# Toggles away-ness with the server. Optionally takes an away message. +sub away { + my $self = shift; + $self->sl("AWAY" . ($_[0] ? " :$_[0]" : "")); +} + +# Attempts to connect to the specified IRC (server, port) with the specified +# (nick, username, ircname). Will close current connection if already open. +sub connect { + my $self = shift; + my ($password, $sock); + + if (@_) { + my (%arg) = @_; + + $self->hostname($arg{'LocalAddr'}) if exists $arg{'LocalAddr'}; + $password = $arg{'Password'} if exists $arg{'Password'}; + $self->nick($arg{'Nick'}) if exists $arg{'Nick'}; + $self->port($arg{'Port'}) if exists $arg{'Port'}; + $self->server($arg{'Server'}) if exists $arg{'Server'}; + $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'}; + $self->username($arg{'Username'}) if exists $arg{'Username'}; + $self->pacing($arg{'Pacing'}) if exists $arg{'Pacing'}; + $self->ssl($arg{'SSL'}) if exists $arg{'SSL'}; + } + + # Lots of error-checking claptrap first... + unless ($self->server) { + unless ($ENV{IRCSERVER}) { + croak "No server address specified in connect()"; + } + $self->server( $ENV{IRCSERVER} ); + } + unless ($self->nick) { + $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) } + || $ENV{USER} || $ENV{LOGNAME} || "WankerBot"); + } + unless ($self->port) { + $self->port($ENV{IRCPORT} || 6667); + } + unless ($self->ircname) { + $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] } + || "Just Another Perl Hacker"); + } + unless ($self->username) { + $self->username(eval { scalar getpwuid($>) } || $ENV{USER} + || $ENV{LOGNAME} || "japh"); + } + + # Now for the socket stuff... + if ($self->connected) { + $self->quit("Changing servers"); + } + + if($self->ssl) { + require IO::Socket::SSL; + + $self->socket(IO::Socket::SSL->new(PeerAddr => $self->server, + PeerPort => $self->port, + Proto => "tcp", + LocalAddr => $self->hostname, + )); + } else { + + $self->socket(IO::Socket::INET->new(PeerAddr => $self->server, + PeerPort => $self->port, + Proto => "tcp", + LocalAddr => $self->hostname, + )); + } + + if(!$self->socket) { + carp (sprintf "Can't connect to %s:%s!", + $self->server, $self->port); + $self->error(1); + return; + } + + # Send a PASS command if they specified a password. According to + # the RFC, we should do this as soon as we connect. + if (defined $password) { + $self->sl("PASS $password"); + } + + # Now, log in to the server... + unless ($self->sl('NICK ' . $self->nick()) and + $self->sl(sprintf("USER %s %s %s :%s", + $self->username(), + "foo.bar.com", + $self->server(), + $self->ircname()))) { + carp "Couldn't send introduction to server: $!"; + $self->error(1); + $! = "Couldn't send NICK/USER introduction to " . $self->server; + return; + } + + $self->{_connected} = 1; + $self->parent->addconn($self); +} + +# Returns a boolean value based on the state of the object's socket. +sub connected { + my $self = shift; + + return ( $self->{_connected} and $self->socket() ); +} + +# Sends a CTCP request to some hapless victim(s). +# Takes at least two args: the type of CTCP request (case insensitive) +# the nick or channel of the intended recipient(s) +# Any further args are arguments to CLIENTINFO, ERRMSG, or ACTION. +sub ctcp { + my ($self, $type, $target) = splice @_, 0, 3; + $type = uc $type; + + unless ($target) { + croak "Not enough arguments to ctcp()"; + } + + if ($type eq "PING") { + unless ($self->sl("PRIVMSG $target :\001PING " . int(time) . "\001")) { + carp "Socket error sending $type request in ctcp()"; + return; + } + } elsif (($type eq "CLIENTINFO" or $type eq "ACTION") and @_) { + unless ($self->sl("PRIVMSG $target :\001$type " . + CORE::join(" ", @_) . "\001")) { + carp "Socket error sending $type request in ctcp()"; + return; + } + } elsif ($type eq "ERRMSG") { + unless (@_) { + carp "Not enough arguments to $type in ctcp()"; + return; + } + unless ($self->sl("PRIVMSG $target :\001ERRMSG " . + CORE::join(" ", @_) . "\001")) { + carp "Socket error sending $type request in ctcp()"; + return; + } + } else { + unless ($self->sl("PRIVMSG $target :\001$type " . + CORE::join(" ",@_) . "\001")) { + carp "Socket error sending $type request in ctcp()"; + return; + } + } +} + +# Sends replies to CTCP queries. Simple enough, right? +# Takes 2 args: the target person or channel to send a reply to +# the text of the reply +sub ctcp_reply { + my $self = shift; + + $self->notice($_[0], "\001" . $_[1] . "\001"); +} + + +# Sets or returns the debugging flag for this object. +# Takes 1 optional arg: a new boolean value for the flag. +sub debug { + my $self = shift; + if (@_) { + $self->{_debug} = $_[0]; + } + return $self->{_debug}; +} + + +# Dequotes CTCP messages according to ctcp.spec. Nothing special. +# Then it breaks them into their component parts in a flexible, ircII- +# compatible manner. This is not quite as trivial. Oh, well. +# Takes 1 arg: the line to be dequoted. +sub dequote { + my $line = shift; + my ($order, @chunks) = (0, ()); # CHUNG! CHUNG! CHUNG! + + # Filter misplaced \001s before processing... (Thanks, Tom!) + substr($line, rindex($line, "\001"), 1) = '\\a' + unless ($line =~ tr/\001//) % 2 == 0; + + # Thanks to Abigail (abigail@fnx.com) for this clever bit. + if (index($line, "\cP") >= 0) { # dequote low-level \n, \r, ^P, and \0. + my (%h) = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP"); + $line =~ s/\cP([nr0\cP])/$h{$1}/g; + } + $line =~ s/\\([^\\a])/$1/g; # dequote unnecessarily quoted characters. + + # If true, it's in odd order... ctcp commands start with first chunk. + $order = 1 if index($line, "\001") == 0; + @chunks = map { s/\\\\/\\/g; $_ } (split /\cA/, $line); + + return ($order, @chunks); +} + +# Standard destructor method for the GC routines. (HAHAHAH! DIE! DIE! DIE!) +sub DESTROY { + my $self = shift; + $self->handler("destroy", "nobody will ever use this"); + $self->quit(); + # anything else? +} + + +# Disconnects this Connection object cleanly from the server. +# Takes at least 1 arg: the format and args parameters to Event->new(). +sub disconnect { + my $self = shift; + + $self->{_connected} = 0; + $self->parent->removeconn($self); + $self->socket( undef ); + $self->handler(Net::IRC::Event->new( "disconnect", + $self->server, + '', + @_ )); +} + + +# Tells IRC.pm if there was an error opening this connection. It's just +# for sane error passing. +# Takes 1 optional arg: the new value for $self->{'iserror'} +sub error { + my $self = shift; + + $self->{'iserror'} = $_[0] if @_; + return $self->{'iserror'}; +} + +# Lets the user set or retrieve a format for a message of any sort. +# Takes at least 1 arg: the event whose format you're inquiring about +# (optional) the new format to use for this event +sub format { + my ($self, $ev) = splice @_, 0, 2; + + unless ($ev) { + croak "Not enough arguments to format()"; + } + + if (@_) { + $self->{'_format'}->{$ev} = $_[0]; + } else { + return ($self->{'_format'}->{$ev} || + $self->{'_format'}->{'default'}); + } +} + +# Calls the appropriate handler function for a specified event. +# Takes 2 args: the name of the event to handle +# the arguments to the handler function +sub handler { + my ($self, $event) = splice @_, 0, 2; + + unless (defined $event) { + croak 'Too few arguments to Connection->handler()'; + } + + # Get name of event. + my $ev; + if (ref $event) { + $ev = $event->type; + } elsif (defined $event) { + $ev = $event; + $event = Net::IRC::Event->new($event, '', '', ''); + } else { + croak "Not enough arguments to handler()"; + } + + print STDERR "Trying to handle event '$ev'.\n" if $self->{_debug}; + + my $handler = undef; + if (exists $self->{_handler}->{$ev}) { + $handler = $self->{_handler}->{$ev}; + } elsif (exists $_udef{$ev}) { + $handler = $_udef{$ev}; + } else { + return $self->_default($event, @_); + } + + my ($code, $rp) = @{$handler}; + + # If we have args left, try to call the handler. + if ($rp == 0) { # REPLACE + &$code($self, $event, @_); + } elsif ($rp == 1) { # BEFORE + &$code($self, $event, @_); + $self->_default($event, @_); + } elsif ($rp == 2) { # AFTER + $self->_default($event, @_); + &$code($self, $event, @_); + } else { + confess "Bad parameter passed to handler(): rp=$rp"; + } + + warn "Handler for '$ev' called.\n" if $self->{_debug}; + + return 1; +} + +# Lets a user set hostmasks to discard certain messages from, or (if called +# with only 1 arg), show a list of currently ignored hostmasks of that type. +# Takes 2 args: type of ignore (public, msg, ctcp, etc) +# (optional) [mask(s) to be added to list of specified type] +sub ignore { + my $self = shift; + + unless (@_) { + croak "Not enough arguments to ignore()"; + } + + if (@_ == 1) { + if (exists $self->{_ignore}->{$_[0]}) { + return @{ $self->{_ignore}->{$_[0]} }; + } else { + return (); + } + } elsif (@_ > 1) { # code defensively, remember... + my $type = shift; + + # I moved this part further down as an Obsessive Efficiency + # Initiative. It shouldn't be a problem if I do _parse right... + # ... but those are famous last words, eh? + unless (grep {$_ eq $type} + qw(public msg ctcp notice channel nick other all)) { + carp "$type isn't a valid type to ignore()"; + return; + } + + if ( exists $self->{_ignore}->{$type} ) { + push @{$self->{_ignore}->{$type}}, @_; + } else { + $self->{_ignore}->{$type} = [ @_ ]; + } + } +} + + +# Yet Another Ridiculously Simple Sub. Sends an INFO command. +# Takes 1 optional arg: the name of the server to query. +sub info { + my $self = shift; + + $self->sl("INFO" . ($_[0] ? " $_[0]" : "")); +} + + +# Invites someone to an invite-only channel. Whoop. +# Takes 2 args: the nick of the person to invite +# the channel to invite them to. +# I hate the syntax of this command... always seemed like a protocol flaw. +sub invite { + my $self = shift; + + unless (@_ > 1) { + croak "Not enough arguments to invite()"; + } + + $self->sl("INVITE $_[0] $_[1]"); +} + +# Checks if a particular nickname is in use. +# Takes at least 1 arg: nickname(s) to look up. +sub ison { + my $self = shift; + + unless (@_) { + croak 'Not enough args to ison().'; + } + + $self->sl("ISON " . CORE::join(" ", @_)); +} + +# Joins a channel on the current server if connected, eh?. +# Corresponds to /JOIN command. +# Takes 2 args: name of channel to join +# optional channel password, for +k channels +sub join { + my $self = shift; + + unless ( $self->connected ) { + carp "Can't join() -- not connected to a server"; + return; + } + + unless (@_) { + croak "Not enough arguments to join()"; + } + + return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : "")); + +} + +# Takes at least 2 args: the channel to kick the bastard from +# the nick of the bastard in question +# (optional) a parting comment to the departing bastard +sub kick { + my $self = shift; + + unless (@_ > 1) { + croak "Not enough arguments to kick()"; + } + return $self->sl("KICK $_[0] $_[1]" . ($_[2] ? " :$_[2]" : "")); +} + +# Gets a list of all the servers that are linked to another visible server. +# Takes 2 optional args: it's a bitch to describe, and I'm too tired right +# now, so read the RFC. +sub links { + my ($self) = (shift, undef); + + $self->sl("LINKS" . (scalar(@_) ? " " . CORE::join(" ", @_[0,1]) : "")); +} + + +# Requests a list of channels on the server, or a quick snapshot of the current +# channel (the server returns channel name, # of users, and topic for each). +sub list { + my $self = shift; + + $self->sl("LIST " . CORE::join(",", @_)); +} + +# Sends a request for some server/user stats. +# Takes 1 optional arg: the name of a server to request the info from. +sub lusers { + my $self = shift; + + $self->sl("LUSERS" . ($_[0] ? " $_[0]" : "")); +} + +# Gets and/or sets the max line length. The value previous to the sub +# call will be returned. +# Takes 1 (optional) arg: the maximum line length (in bytes) +sub maxlinelen { + my $self = shift; + + my $ret = $self->{_maxlinelen}; + + $self->{_maxlinelen} = shift if @_; + + return $ret; +} + +# Sends an action to the channel/nick you specify. It's truly amazing how +# many IRCers have no idea that /me's are actually sent via CTCP. +# Takes 2 args: the channel or nick to bother with your witticism +# the action to send (e.g., "weed-whacks billn's hand off.") +sub me { + my $self = shift; + + $self->ctcp("ACTION", $_[0], $_[1]); +} + +# Change channel and user modes (this one is easy... the handler is a bitch.) +# Takes at least 1 arg: the target of the command (channel or nick) +# (optional) the mode string (i.e., "-boo+i") +# (optional) operands of the mode string (nicks, hostmasks, etc.) +sub mode { + my $self = shift; + + unless (@_ >= 1) { + croak "Not enough arguments to mode()"; + } + $self->sl("MODE $_[0] " . CORE::join(" ", @_[1..$#_])); +} + +# Sends a MOTD command to a server. +# Takes 1 optional arg: the server to query (defaults to current server) +sub motd { + my $self = shift; + + $self->sl("MOTD" . ($_[0] ? " $_[0]" : "")); +} + +# Requests the list of users for a particular channel (or the entire net, if +# you're a masochist). +# Takes 1 or more optional args: name(s) of channel(s) to list the users from. +sub names { + my $self = shift; + + $self->sl("NAMES " . CORE::join(",", @_)); + +} # Was this the easiest sub in the world, or what? + +# Creates and returns a DCC CHAT object, analogous to IRC.pm's newconn(). +# Takes at least 1 arg: An Event object for the DCC CHAT request. +# OR A list or listref of args to be passed to new(), +# consisting of: +# - A boolean value indicating whether or not +# you're initiating the CHAT connection. +# - The nick of the chattee +# - The address to connect to +# - The port to connect on +sub new_chat { + my $self = shift; + my ($init, $nick, $address, $port); + + if (ref($_[0]) =~ /Event/) { + # If it's from an Event object, we can't be initiating, right? + ($init, undef, undef, undef, $address, $port) = (0, $_[0]->args); + $nick = $_[0]->nick; + + } elsif (ref($_[0]) eq "ARRAY") { + ($init, $nick, $address, $port) = @{$_[0]}; + } else { + ($init, $nick, $address, $port) = @_; + } + + Net::IRC::DCC::CHAT->new($self, $init, $nick, $address, $port); +} + +# Creates and returns a DCC GET object, analogous to IRC.pm's newconn(). +# Takes at least 1 arg: An Event object for the DCC SEND request. +# OR A list or listref of args to be passed to new(), +# consisting of: +# - The nick of the file's sender +# - The name of the file to receive +# - The address to connect to +# - The port to connect on +# - The size of the incoming file +# For all of the above, an extra argument should be added at the end: +# An open filehandle to save the incoming file into, +# in globref, FileHandle, or IO::* form. +# If you wish to do a DCC RESUME, specify the offset in bytes that you +# want to start downloading from as the last argument. +sub new_get { + my $self = shift; + my ($nick, $name, $address, $port, $size, $offset, $handle); + + if (ref($_[0]) =~ /Event/) { + (undef, undef, $name, $address, $port, $size) = $_[0]->args; + $nick = $_[0]->nick; + $handle = $_[1] if defined $_[1]; + } elsif (ref($_[0]) eq "ARRAY") { + ($nick, $name, $address, $port, $size) = @{$_[0]}; + $handle = $_[1] if defined $_[1]; + } else { + ($nick, $name, $address, $port, $size, $handle) = @_; + } + + unless (defined $handle and ref $handle and + (ref $handle eq "GLOB" or $handle->can('print'))) + { + carp ("Filehandle argument to Connection->new_get() must be ". + "a glob reference or object"); + return; # is this behavior OK? + } + + my $dcc = Net::IRC::DCC::GET->new( $self, $nick, $address, $port, $size, + $name, $handle, $offset ); + + $self->parent->addconn($dcc) if $dcc; + return $dcc; +} + +# Creates and returns a DCC SEND object, analogous to IRC.pm's newconn(). +# Takes at least 2 args: The nickname of the person to send to +# The name of the file to send +# (optional) The blocksize for the connection (default 1k) +sub new_send { + my $self = shift; + my ($nick, $filename, $blocksize); + + if (ref($_[0]) eq "ARRAY") { + ($nick, $filename, $blocksize) = @{$_[0]}; + } else { + ($nick, $filename, $blocksize) = @_; + } + + Net::IRC::DCC::SEND->new($self, $nick, $filename, $blocksize); +} + +# Selects nick for this object or returns currently set nick. +# No default; must be set by user. +# If changed while the object is already connected to a server, it will +# automatically try to change nicks. +# Takes 1 arg: the nick. (I bet you could have figured that out...) +sub nick { + my $self = shift; + + if (@_) { + $self->{'_nick'} = shift; + if ($self->connected) { + return $self->sl("NICK " . $self->{'_nick'}); + } + } else { + return $self->{'_nick'}; + } +} + +# Sends a notice to a channel or person. +# Takes 2 args: the target of the message (channel or nick) +# the text of the message to send +# The message will be chunked if it is longer than the _maxlinelen +# attribute, but it doesn't try to protect against flooding. If you +# give it too much info, the IRC server will kick you off! +sub notice { + my ($self, $to) = splice @_, 0, 2; + + unless (@_) { + croak "Not enough arguments to notice()"; + } + + my ($buf, $length, $line) = (CORE::join("", @_), $self->{_maxlinelen}); + + while(length($buf) > 0) { + ($line, $buf) = unpack("a$length a*", $buf); + $self->sl("NOTICE $to :$line"); + } +} + +# Makes you an IRCop, if you supply the right username and password. +# Takes 2 args: Operator's username +# Operator's password +sub oper { + my $self = shift; + + unless (@_ > 1) { + croak "Not enough arguments to oper()"; + } + + $self->sl("OPER $_[0] $_[1]"); +} + +# This function splits apart a raw server line into its component parts +# (message, target, message type, CTCP data, etc...) and passes it to the +# appropriate handler. Takes no args, really. +sub parse { + my ($self) = shift; + my ($from, $type, $message, @stuff, $itype, $ev, @lines, $line); + + if (defined ($self->ssl ? + $self->socket->read($line, 10240) : + $self->socket->recv($line, 10240, 0)) + and + (length($self->{_frag}) + length($line)) > 0) { + # grab any remnant from the last go and split into lines + $self->{_rx} += length($line); + my $chunk = $self->{_frag} . $line; + @lines = split /\012/, $chunk; + + # if the last line was incomplete, pop it off the chunk and + # stick it back into the frag holder. + $self->{_frag} = (substr($chunk, -1) ne "\012" ? pop @lines : ''); + + } else { + # um, if we can read, i say we should read more than 0 + # besides, recv isn't returning undef on closed + # sockets. getting rid of this connection... + $self->disconnect('error', 'Connection reset by peer'); + return; + } + + PARSELOOP: foreach $line (@lines) { + + # Clean the lint filter every 2 weeks... + $line =~ s/[\012\015]+$//; + next unless $line; + + print STDERR "<<< $line\n" if $self->{_debug}; + + $::lastline = $line; #this is so __WARN__ can print the last line received on IRC. + # Like the RFC says: "respond as quickly as possible..." + if ($line =~ /^PING/) { + $ev = (Net::IRC::Event->new( "ping", + $self->server, + $self->nick, + "serverping", # FIXME? + substr($line, 5) + )); + + # Had to move this up front to avoid a particularly pernicious bug. + } elsif ($line =~ /^NOTICE/) { + $ev = Net::IRC::Event->new( "snotice", + $self->server, + '', + 'server', + (split /:/, $line, 2)[1] ); + + + # Spurious backslashes are for the benefit of cperl-mode. + # Assumption: all non-numeric message types begin with a letter + } elsif ($line =~ /^:? + (?:[][}{\w\\\`^|\-]+? # The nick (valid nickname chars) + ! # The nick-username separator + .+? # The username + \@)? # Umm, duh... + \S+ # The hostname + \s+ # Space between mask and message type + [A-Za-z] # First char of message type + [^\s:]+? # The rest of the message type + /x) # That ought to do it for now... + { + $line = substr $line, 1 if $line =~ /^:/; + + # Patch submitted for v.0.72 + # Fixes problems with IPv6 hostnames. + # ($from, $line) = split ":", $line, 2; + ($from, $line) = $line =~ /^(?:|)(\S+\s+[^:]+):?(.*)/; + + ($from, $type, @stuff) = split /\s+/, $from; + $type = lc $type; + # This should be fairly intuitive... (cperl-mode sucks, though) + + # The order of this was changed by AfterDeath because a \x01 in a geco fucked shit up + if ($type eq "join" or $type eq "part" or + $type eq "mode" or $type eq "topic" or + $type eq "kick") { + $itype = "channel"; + } elsif (defined $line and index($line, "\001") == 0) { #originally >=0. Hopefully this will fuck less shit up. +# print Dumper($from, $type, \@stuff, $line); + $itype = "ctcp"; + unless ($type eq "notice") { + $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg"); + } + } elsif ($type eq "privmsg") { + $itype = $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg"); + } elsif ($type eq "notice") { + $itype = "notice"; + } elsif ($type eq "nick") { + $itype = "nick"; + } else { + $itype = "other"; + } + + # This goes through the list of ignored addresses for this message + # type and drops out of the sub if it's from an ignored hostmask. + + study $from; + foreach ( $self->ignore($itype), $self->ignore("all") ) { + $_ = quotemeta; s/\\\*/.*/g; + next PARSELOOP if $from =~ /$_/i; + } + + # It used to look a lot worse. Here was the original version... + # the optimization above was proposed by Silmaril, for which I am + # eternally grateful. (Mine still looks cooler, though. :) + + # return if grep { $_ = join('.*', split(/\\\*/, + # quotemeta($_))); /$from/ } + # ($self->ignore($type), $self->ignore("all")); + + # Add $line to @stuff for the handlers + push @stuff, $line if defined $line; + + # Now ship it off to the appropriate handler and forget about it. + if ( $itype eq "ctcp" ) { # it's got CTCP in it! + $self->parse_ctcp($type, $from, $stuff[0], $line); + next; + + } elsif ($type eq "public" or $type eq "msg" or + $type eq "notice" or $type eq "mode" or + $type eq "join" or $type eq "part" or + $type eq "topic" or $type eq "invite" ) { + + $ev = Net::IRC::Event->new( $type, + $from, + shift(@stuff), + $type, + @stuff, + ); + } elsif ($type eq "quit" or $type eq "nick") { + + $ev = Net::IRC::Event->new( $type, + $from, + $from, + $type, + @stuff, + ); + } elsif ($type eq "kick") { + + $ev = Net::IRC::Event->new( $type, + $from, + $stuff[1], + $type, + @stuff[0,2..$#stuff], + ); + + } elsif ($type eq "kill") { + $ev = Net::IRC::Event->new($type, + $from, + '', + $type, + $line); # Ahh, what the hell. + } elsif ($type eq "wallops") { + $ev = Net::IRC::Event->new($type, + $from, + '', + $type, + $line); + } elsif ($type eq "account") { #these next 3 event hooks added by AfterDeath + $ev = Net::IRC::Event->new($type, + $from, + '', + $type, + @stuff); + } elsif ($type eq "cap") { + $ev = Net::IRC::Event->new($type, + $from, + '', + $type, + @stuff); + } elsif ($type eq "pong") { + $ev = Net::IRC::Event->new($type, + $from, + $self->{nick}, + 'server', + $stuff[1]); + } else { + carp "Unknown event type: $type"; + } + } + elsif ($line =~ /^:? # Here's Ye Olde Numeric Handler! + \S+? # the servername (can't assume RFC hostname) + \s+? # Some spaces here... + \d+? # The actual number + \b/x # Some other crap, whatever... + ) { + $ev = $self->parse_num($line); + + } elsif ($line =~ /^:(\w+) MODE \1 /) { + $ev = Net::IRC::Event->new( 'umode', + $self->server, + $self->nick, + 'server', + substr($line, index($line, ':', 1) + 1)); + + } elsif ($line =~ /^:? # Here's Ye Olde Server Notice handler! + .+? # the servername (can't assume RFC hostname) + \s+? # Some spaces here... + NOTICE # The server notice + \b/x # Some other crap, whatever... + ) { + $ev = Net::IRC::Event->new( 'snotice', + $self->server, + '', + 'server', + (split /\s+/, $line, 3)[2] ); + + + } elsif ($line =~ /^ERROR/) { + if ($line =~ /^ERROR :Closing [Ll]ink/) { # is this compatible? + + $ev = 'done'; + $self->disconnect( 'error', ($line =~ /(.*)/) ); + + } else { + $ev = Net::IRC::Event->new( "error", + $self->server, + '', + 'error', + (split /:/, $line, 2)[1]); + } + } elsif ($line =~ /^Closing [Ll]ink/) { + $ev = 'done'; + $self->disconnect( 'error', ($line =~ /(.*)/) ); + + } + + if ($ev) { + + # We need to be able to fall through if the handler has + # already been called (i.e., from within disconnect()). + + $self->handler($ev) unless $ev eq 'done'; + + } else { + # If it gets down to here, it's some exception I forgot about. + carp "Funky parse case: $line\n"; + } + } +} + +# The backend that parse() sends CTCP requests off to. Pay no attention +# to the camel behind the curtain. +# Takes 4 arguments: the type of message +# who it's from +# the first bit of stuff +# the line from the server. +sub parse_ctcp { + my ($self, $type, $from, $stuff, $line) = @_; + + my ($one, $two); + my ($odd, @foo) = (&dequote($line)); + + while (($one, $two) = (splice @foo, 0, 2)) { + + ($one, $two) = ($two, $one) if $odd; + + my ($ctype) = $one =~ /^(\w+)\b/; + my $prefix = undef; + if ($type eq 'notice') { + $prefix = 'cr'; + } elsif ($type eq 'public' or + $type eq 'msg' ) { + $prefix = 'c'; + } else { + carp "Unknown CTCP type: $type"; + return; + } + + if ($prefix) { + my $handler = $prefix . lc $ctype; # unit. value prob with $ctype + + $one =~ s/^$ctype //i; # strip the CTCP type off the args + $self->handler(Net::IRC::Event->new( $handler, $from, $stuff, + $handler, $one )); + } + + $self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two)) + if $two; + } + return 1; +} + +# Does special-case parsing for numeric events. Separate from the rest of +# parse() for clarity reasons (I can hear Tkil gasping in shock now. :-). +# Takes 1 arg: the raw server line +sub parse_num { + my ($self, $line) = @_; + + # Figlet protection? This seems to be a bit closer to the RFC than + # the original version, which doesn't seem to handle :trailers quite + # correctly. + + my ($from, $type, $stuff) = split(/\s+/, $line, 3); + my ($blip, $space, $other, @stuff); + while ($stuff) { + ($blip, $space, $other) = split(/(\s+)/, $stuff, 2); + $space = "" unless $space; + $other = "" unless $other; # Thanks to jack velte... + if ($blip =~ /^:/) { + push @stuff, $blip . $space . $other; + last; + } else { + push @stuff, $blip; + $stuff = $other; + } + } + + $from = substr $from, 1 if $from =~ /^:/; + + return Net::IRC::Event->new( $type, + $from, + '', + 'server', + @stuff ); +} + +# Helps you flee those hard-to-stand channels. +# Takes at least one arg: name(s) of channel(s) to leave. +sub part { + my $self = shift; + + unless (@_) { + croak "No arguments provided to part()"; + } + $self->sl("PART " . CORE::join(",", @_)); # "A must!" +} + + +# Tells what's on the other end of a connection. Returns a 2-element list +# consisting of the name on the other end and the type of connection. +# Takes no args. +sub peer { + my $self = shift; + + return ($self->server(), "IRC connection"); +} + + +# Prints a message to the defined error filehandle(s). +# No further description should be necessary. +sub printerr { + shift; + print STDERR @_, "\n"; +} + +# Prints a message to the defined output filehandle(s). +sub print { + shift; + print STDOUT @_, "\n"; +} + +# Sends a message to a channel or person. +# Takes 2 args: the target of the message (channel or nick) +# the text of the message to send +# Don't use this for sending CTCPs... that's what the ctcp() function is for. +# The message will be chunked if it is longer than the _maxlinelen +# attribute, but it doesn't try to protect against flooding. If you +# give it too much info, the IRC server will kick you off! +sub privmsg { + my ($self, $to) = splice @_, 0, 2; + + unless (@_) { + croak 'Not enough arguments to privmsg()'; + } + + my $buf = CORE::join '', @_; + my $length = $self->{_maxlinelen} - 80 - length($to); + my $line; + + if (ref($to) =~ /^(GLOB|IO::Socket)/) { + while(length($buf) > 0) { + ($line, $buf) = unpack("a$length a*", $buf); + send($to, $line . "\012", 0); + } + } else { + while(length($buf) > 0) { + ($line, $buf) = unpack("a$length a*", $buf); + if (ref $to eq 'ARRAY') { + $self->sl("PRIVMSG ", CORE::join(',', @$to), " :$line"); + } else { + $self->sl("PRIVMSG $to :$line"); + } + } + } +} + + +# Closes connection to IRC server. (Corresponding function for /QUIT) +# Takes 1 optional arg: parting message, defaults to "Leaving" by custom. +sub quit { + my $self = shift; + + # Do any user-defined stuff before leaving + $self->handler("leaving"); + + unless ( $self->connected ) { return (1) } + + # Why bother checking for sl() errors now, after all? :) + # We just send the QUIT command and leave. The server will respond with + # a "Closing link" message, and parse() will catch it, close the + # connection, and throw a "disconnect" event. Neat, huh? :-) + + $self->sl("QUIT :" . (defined $_[0] ? $_[0] : "Leaving")); + + # since the quit sends a line to the server, we need to flush the + # output queue to make sure it gets there so the disconnect + $self->parent->flush_output_queue(); + + return 1; +} + +# As per the RFC, ask the server to "re-read and process its configuration +# file." Your server may or may not take additional arguments. Generally +# requires IRCop status. +sub rehash { + my $self = shift; + $self->sl("REHASH" . CORE::join(" ", @_)); +} + + +# As per the RFC, "force a server restart itself." (Love that RFC.) +# Takes no arguments. If it succeeds, you will likely be disconnected, +# but I assume you already knew that. This sub is too simple... +sub restart { + my $self = shift; + $self->sl("RESTART"); +} + +# Schedules an event to be executed after some length of time. +# Takes at least 2 args: the number of seconds to wait until it's executed +# a coderef to execute when time's up +# Any extra args are passed as arguments to the user's coderef. +sub schedule { + my $self = shift; + my $time = shift; + my $coderef = shift; + + unless($coderef) { + croak 'Not enough arguments to Connection->schedule()'; + } + unless(ref($coderef) eq 'CODE') { + croak 'Second argument to schedule() isn\'t a coderef'; + } + + $time += time; + $self->parent->enqueue_scheduled_event($time, $coderef, $self, @_); +} + +sub schedule_output_event { + my $self = shift; + my $time = shift; + my $coderef = shift; + + unless($coderef) { + croak 'Not enough arguments to Connection->schedule()'; + } + unless(ref($coderef) eq 'CODE') { + croak 'Second argument to schedule() isn\'t a coderef'; + } + + $time += time; + $self->parent->enqueue_output_event($time, $coderef, $self, @_); +} + +# Lets J. Random IRCop connect one IRC server to another. How uninteresting. +# Takes at least 1 arg: the name of the server to connect your server with +# (optional) the port to connect them on (default 6667) +# (optional) the server to connect to arg #1. Used mainly by +# servers to communicate with each other. +sub sconnect { + my $self = shift; + + unless (@_) { + croak "Not enough arguments to sconnect()"; + } + $self->sl("CONNECT " . CORE::join(" ", @_)); +} + +# Sets/changes the IRC server which this instance should connect to. +# Takes 1 arg: the name of the server (see below for possible syntaxes) +# ((syntaxen? syntaxi? syntaces?)) +sub server { + my ($self) = shift; + + if (@_) { + # cases like "irc.server.com:6668" + if (index($_[0], ':') > 0) { + my ($serv, $port) = split /:/, $_[0]; + if ($port =~ /\D/) { + carp "$port is not a valid port number in server()"; + return; + } + $self->{_server} = $serv; + $self->port($port); + + # cases like ":6668" (buried treasure!) + } elsif (index($_[0], ':') == 0 and $_[0] =~ /^:(\d+)/) { + $self->port($1); + + # cases like "irc.server.com" + } else { + $self->{_server} = shift; + } + return (1); + + } else { + return $self->{_server}; + } +} + + +# sends a raw IRC line to the server, possibly with pacing +sub sl { + my $self = shift; + my $line = CORE::join '', @_; + + unless (@_) { + croak "Not enough arguments to sl()"; + } + + if (! $self->pacing) { + return $self->sl_real($line); + } + + # calculate how long to wait before sending this line + my $time = time; + if ($time - $self->{_lastsl} > $self->pacing) { + $self->{_lastsl} = $time; + } else { + $self->{_lastsl} += $self->pacing; + } + my $seconds = $self->{_lastsl} - $time; + + ### DEBUG DEBUG DEBUG + if ($self->{_debug}) { + print "S-> $seconds $line\n"; + } + + $self->schedule_output_event($seconds, \&sl_real, $line); +} + + +# Sends a raw IRC line to the server. +# Corresponds to the internal sirc function of the same name. +# Takes 1 arg: string to send to server. (duh. :) +sub sl_real { + my $self = shift; + my $line = shift; + + unless ($line) { + croak "Not enough arguments to sl_real()"; + } + + ### DEBUG DEBUG DEBUG + if ($self->{_debug}) { + print ">>> $line\n"; + } + + # RFC compliance can be kinda nice... + my $rv = $self->ssl ? + $self->socket->print("$line\015\012") : + $self->socket->send("$line\015\012", 0); + unless ($rv) { + $self->handler("sockerror"); + return; + } + $self->{_tx} += (length($line) + 2); + return $rv; +} + +# Tells any server that you're an oper on to disconnect from the IRC network. +# Takes at least 1 arg: the name of the server to disconnect +# (optional) a comment about why it was disconnected +sub squit { + my $self = shift; + + unless (@_) { + croak "Not enough arguments to squit()"; + } + + $self->sl("SQUIT $_[0]" . ($_[1] ? " :$_[1]" : "")); +} + +# Gets various server statistics for the specified host. +# Takes at least 2 arg: the type of stats to request [chiklmouy] +# (optional) the server to request from (default is current server) +sub stats { + my $self = shift; + + unless (@_) { + croak "Not enough arguments passed to stats()"; + } + + $self->sl("STATS $_[0]" . ($_[1] ? " $_[1]" : "")); +} + +# If anyone still has SUMMON enabled, this will implement it for you. +# If not, well...heh. Sorry. First arg mandatory: user to summon. +# Second arg optional: a server name. +sub summon { + my $self = shift; + + unless (@_) { + croak "Not enough arguments passed to summon()"; + } + + $self->sl("SUMMON $_[0]" . ($_[1] ? " $_[1]" : "")); +} + +# Requests timestamp from specified server. Easy enough, right? +# Takes 1 optional arg: a server name/mask to query +# renamed to not collide with things... -- aburke +sub timestamp { + my ($self, $serv) = (shift, undef); + + $self->sl("TIME" . ($_[0] ? " $_[0]" : "")); +} + +# Sends request for current topic, or changes it to something else lame. +# Takes at least 1 arg: the channel whose topic you want to screw around with +# (optional) the new topic you want to impress everyone with +sub topic { + my $self = shift; + + unless (@_) { + croak "Not enough arguments to topic()"; + } + + # Can you tell I've been reading the Nethack source too much? :) + $self->sl("TOPIC $_[0]" . ($_[1] ? " :$_[1]" : "")); +} + +# Sends a trace request to the server. Whoop. +# Take 1 optional arg: the server or nickname to trace. +sub trace { + my $self = shift; + + $self->sl("TRACE" . ($_[0] ? " $_[0]" : "")); +} + +# This method submitted by Dave Schmitt . Thanks, Dave! +sub unignore { + my $self = shift; + + croak "Not enough arguments to unignore()" unless @_; + + if (@_ == 1) { + if (exists $self->{_ignore}->{$_[0]}) { + return @{ $self->{_ignore}->{$_[0]} }; + } else { + return (); + } + } elsif (@_ > 1) { # code defensively, remember... + my $type = shift; + + # I moved this part further down as an Obsessive Efficiency + # Initiative. It shouldn't be a problem if I do _parse right... + # ... but those are famous last words, eh? + unless (grep {$_ eq $type} + qw(public msg ctcp notice channel nick other all)) { + carp "$type isn't a valid type to unignore()"; + return; + } + + if ( exists $self->{_ignore}->{$type} ) { + # removes all specifed entries ala _Perl_Cookbook_ recipe 4.7 + my @temp = @{$self->{_ignore}->{$type}}; + @{$self->{_ignore}->{$type}}= (); + my %seen = (); + foreach my $item (@_) { $seen{$item}=1 } + foreach my $item (@temp) { + push(@{$self->{_ignore}->{$type}}, $item) + unless ($seen{$item}); + } + } else { + carp "no ignore entry for $type to remove"; + } + } +} + + +# Requests userhost info from the server. +# Takes at least 1 arg: nickname(s) to look up. +sub userhost { + my $self = shift; + + unless (@_) { + croak 'Not enough args to userhost().'; + } + + $self->sl("USERHOST " . CORE::join (" ", @_)); +} + +# Sends a users request to the server, which may or may not listen to you. +# Take 1 optional arg: the server to query. +sub users { + my $self = shift; + + $self->sl("USERS" . ($_[0] ? " $_[0]" : "")); +} + +# Asks the IRC server what version and revision of ircd it's running. Whoop. +# Takes 1 optional arg: the server name/glob. (default is current server) +sub version { + my $self = shift; + + $self->sl("VERSION" . ($_[0] ? " $_[0]" : "")); +} + +# Sends a message to all opers on the network. Hypothetically. +# Takes 1 arg: the text to send. +sub wallops { + my $self = shift; + + unless ($_[0]) { + croak 'No arguments passed to wallops()'; + } + + $self->sl("WALLOPS :" . CORE::join("", @_)); +} + +# Asks the server about stuff, you know. Whatever. Pass the Fritos, dude. +# Takes 2 optional args: the bit of stuff to ask about +# an "o" (nobody ever uses this...) +sub who { + my $self = shift; + + # Obfuscation! + $self->sl("WHO" . (@_ ? " @_" : "")); +} + +# If you've gotten this far, you probably already know what this does. +# Takes at least 1 arg: nickmasks or channels to /whois +sub whois { + my $self = shift; + + unless (@_) { + croak "Not enough arguments to whois()"; + } + return $self->sl("WHOIS " . CORE::join(",", @_)); +} + +# Same as above, in the past tense. +# Takes at least 1 arg: nick to do the /whowas on +# (optional) max number of hits to display +# (optional) server or servermask to query +sub whowas { + my $self = shift; + + unless (@_) { + croak "Not enough arguments to whowas()"; + } + return $self->sl("WHOWAS $_[0]" . ($_[1] ? " $_[1]" : "") . + (($_[1] && $_[2]) ? " $_[2]" : "")); +} + +# This sub executes the default action for an event with no user-defined +# handlers. It's all in one sub so that we don't have to make a bunch of +# separate anonymous subs stuffed in a hash. +sub _default { + my ($self, $event) = @_; + my $verbose = $self->verbose; + + # Users should only see this if the programmer (me) fucked up. + unless ($event) { + croak "You EEEEEDIOT!!! Not enough args to _default()!"; + } + + # Reply to PING from server as quickly as possible. + if ($event->type eq "ping") { + $self->sl("PONG " . (CORE::join ' ', $event->args)); + + } elsif ($event->type eq "disconnect") { + + # I violate OO tenets. (It's consensual, of course.) + unless (keys %{$self->parent->{_connhash}} > 0) { + die "No active connections left, exiting...\n"; + } + } + + return 1; +} + +1; + + +__END__ + +=head1 NAME + +Net::IRC::Connection - Object-oriented interface to a single IRC connection + +=head1 SYNOPSIS + +Hard hat area: This section under construction. + +=head1 DESCRIPTION + +This documentation is a subset of the main Net::IRC documentation. If +you haven't already, please "perldoc Net::IRC" before continuing. + +Net::IRC::Connection defines a class whose instances are individual +connections to a single IRC server. Several Net::IRC::Connection objects may +be handled simultaneously by one Net::IRC object. + +=head1 METHOD DESCRIPTIONS + +This section is under construction, but hopefully will be finally written up +by the next release. Please see the C script and the source for +details about this module. + +=head1 AUTHORS + +Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and +Dennis Taylor Edennis@funkplanet.comE. + +Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. + +Currently being hacked on, hacked up, and worked over by the members of the +Net::IRC developers mailing list. For details, see +http://www.execpc.com/~corbeau/irc/list.html . + +=head1 URL + +Up-to-date source and information about the Net::IRC project can be found at +http://netirc.betterbox.net/ . + +=head1 SEE ALSO + +=over + +=item * + +perl(1). + +=item * + +RFC 1459: The Internet Relay Chat Protocol + +=item * + +http://www.irchelp.org/, home of fine IRC resources. + +=back + +=cut + diff --git a/lib/Net/IRC/DCC.pm b/lib/Net/IRC/DCC.pm new file mode 100644 index 0000000..eccbba3 --- /dev/null +++ b/lib/Net/IRC/DCC.pm @@ -0,0 +1,808 @@ +##################################################################### +# # +# Net::IRC -- Object-oriented Perl interface to an IRC server # +# # +# DCC.pm: An object for Direct Client-to-Client connections. # +# # +# Copyright (c) 1997 Greg Bacon & Dennis Taylor. # +# All rights reserved. # +# # +# This module is free software; you can redistribute or # +# modify it under the terms of Perl's Artistic License. # +# # +##################################################################### +# $Id: DCC.pm,v 1.1.1.1 2002/11/14 17:32:15 jmuhlich Exp $ + +package Net::IRC::DCC; + +use strict; + + + +# --- #perl was here! --- +# +# The comments scattered throughout this module are excerpts from a +# log saved from one particularly surreal night on #perl. Ahh, the +# trials of being young, single, and drunk... +# +# --------------------- +# \merlyn has offered the shower to a randon guy he met in a bar. +# fimmtiu: Shower? +# \petey raises an eyebrow at \merlyn +# \merlyn: but he seems like a nice trucker guy... +# archon: you offered to shower with a random guy? + + +# Methods that can be shared between the various DCC classes. +package Net::IRC::DCC::Connection; + +use Carp; +use Socket; # need inet_ntoa... +use strict; + +sub fixaddr { + my ($address) = @_; + + chomp $address; # just in case, sigh. + if ($address =~ /^\d+$/) { + return inet_ntoa(pack "N", $address); + } elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) { + return $address; + } elsif ($address =~ tr/a-zA-Z//) { # Whee! Obfuscation! + return inet_ntoa(((gethostbyname($address))[4])[0]); + } else { + return; + } +} + +sub bytes_in { + return shift->{_bin}; +} + +sub bytes_out { + return shift->{_bout}; +} + +sub nick { + return shift->{_nick}; +} + +sub socket { + return shift->{_socket}; +} + +sub time { + return time - shift->{_time}; +} + +sub debug { + return shift->{_debug}; +} + +# Changes here 1998-04-01 by MJD +# Optional third argument `$block'. +# If true, don't break the input into lines... just process it in blocks. +sub _getline { + my ($self, $sock, $block) = @_; + my ($input, $line); + my $frag = $self->{_frag}; + + if (defined $sock->recv($input, 10240)) { + $frag .= $input; + if (length($frag) > 0) { + + warn "Got ". length($frag) ." bytes from $sock\n" + if $self->{_debug}; + + if ($block) { # Block mode (GET) + return $input; + + } else { # Line mode (CHAT) + # We're returning \n's 'cause DCC's need 'em + my @lines = split /\012/, $frag, -1; + $lines[-1] .= "\012"; + $self->{_frag} = ($frag !~ /\012$/) ? pop @lines : ''; + return (@lines); + } + } + else { + # um, if we can read, i say we should read more than 0 + # besides, recv isn't returning undef on closed + # sockets. getting rid of this connection... + + warn "recv() received 0 bytes in _getline, closing connection.\n" + if $self->{_debug}; + + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_parent}->parent->removefh($sock); + $self->{_socket}->close; + $self->{_fh}->close if $self->{_fh}; + return; + } + } else { + # Error, lets scrap this connection + + warn "recv() returned undef, socket error in _getline()\n" + if $self->{_debug}; + + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_parent}->parent->removefh($sock); + $self->{_socket}->close; + $self->{_fh}->close if $self->{_fh}; + return; + } +} + +sub DESTROY { + my $self = shift; + + # Only do the Disconnection Dance of Death if the socket is still + # live. Duplicate dcc_close events would be a Bad Thing. + + if ($self->{_socket}->opened) { + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + close $self->{_fh} if $self->{_fh}; + $self->{_parent}->{_parent}->parent->removeconn($self); + } + +} + +sub peer { + return ( $_[0]->{_nick}, "DCC " . $_[0]->{_type} ); +} + +# -- #perl was here! -- +# orev: hehe... +# Silmaril: to, not with. +# archon: heheh +# tmtowtdi: \merlyn will be hacked to death by a psycho +# archon: yeah, but with is much more amusing + + +# Connection handling GETs +package Net::IRC::DCC::GET; + +use IO::Socket; +use Carp; +use strict; + +@Net::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection); + +sub new { + + my ($class, $container, $nick, $address, + $port, $size, $filename, $handle, $offset) = @_; + my ($sock, $fh); + + # get the address into a dotted quad + $address = &Net::IRC::DCC::Connection::fixaddr($address); + return if $port < 1024 or not defined $address or $size < 1; + + $fh = defined $handle ? $handle : IO::File->new(">$filename"); + + unless(defined $fh) { + carp "Can't open $filename for writing: $!"; + $sock = new IO::Socket::INET( Proto => "tcp", + PeerAddr => "$address:$port" ) and + $sock->close(); + return; + } + + binmode $fh; # I love this next line. :-) + ref $fh eq 'GLOB' ? select((select($fh), $|++)[0]) : $fh->autoflush(1); + + $sock = new IO::Socket::INET( Proto => "tcp", + PeerAddr => "$address:$port" ); + + if (defined $sock) { + $container->handler(Net::IRC::Event->new('dcc_open', + $nick, + $sock, + 'get', + 'get', $sock)); + + } else { + carp "Can't connect to $address: $!"; + close $fh; + return; + } + + $sock->autoflush(1); + + my $self = { + _bin => defined $offset ? $offset : 0, # bytes recieved so far + _bout => 0, # Bytes we've sent + _connected => 1, + _debug => $container->debug, + _fh => $fh, # FileHandle we will be writing to. + _filename => $filename, + _frag => '', + _nick => $nick, # Nick of person on other end + _parent => $container, + _size => $size, # Expected size of file + _socket => $sock, # Socket we're reading from + _time => time, + _type => 'GET', + }; + + bless $self, $class; + + return $self; +} + +# -- #perl was here! -- +# \merlyn: we were both ogling a bartender named arley +# \merlyn: I mean carle +# \merlyn: carly +# Silmaril: man merlyn +# Silmaril: you should have offered HER the shower. +# \petey: all three of them? + +sub parse { + my ($self) = shift; + + my $line = $self->_getline($_[0], 'BLOCKS'); + + next unless defined $line; + unless(print {$self->{_fh}} $line) { + carp ("Error writing to " . $self->{_filename} . ": $!"); + close $self->{_fh}; + $self->{_parent}->parent->removeconn($self); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; + } + + $self->{_bin} += length($line); + + + # confirm the packet we've just recieved + unless ( $self->{_socket}->send( pack("N", $self->{_bin}) ) ) { + carp "Error writing to DCC GET socket: $!"; + close $self->{_fh}; + $self->{_parent}->parent->removeconn($self); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; + } + + $self->{_bout} += 4; + + # The file is done. + # If we close the socket, the select loop gets screwy because + # it won't remove its reference to the socket. + if ( $self->{_size} and $self->{_size} <= $self->{_bin} ) { + close $self->{_fh}; + $self->{_parent}->parent->removeconn($self); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; + } + + $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', + $self->{_nick}, + $self, + $self->{_type}, + $self )); +} + +sub filename { + return shift->{_filename}; +} + +sub size { + return shift->{_size}; +} + +sub close { + my ($self, $sock) = @_; + $self->{_fh}->close; + $self->{_parent}->parent->removeconn($self); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; +} + +# -- #perl was here! -- +# \merlyn: I can't type... she created a numbner of very good drinks +# \merlyn: She's still at work +# \petey resists mentioning that there's "No manual entry +# for merlyn." +# Silmaril: Haven't you ever seen swingers? +# \merlyn: she's off tomorrow... will meet me at the bar at 9:30 +# Silmaril: AWWWWwwww yeeeaAAHH. +# archon: waka chica waka chica + + +# Connection handling SENDs +package Net::IRC::DCC::SEND; +@Net::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection); + +use IO::File; +use IO::Socket; +use Carp; +use strict; + +sub new { + + my ($class, $container, $nick, $filename, $blocksize) = @_; + my ($size, $port, $fh, $sock, $select); + + $blocksize ||= 1024; + + # Shell-safe DCC filename stuff. Trying to prank-proof this + # module is rather difficult. + $filename =~ tr/a-zA-Z.+0-9=&()[]%\-\\\/:,/_/c; + $fh = new IO::File $filename; + + unless (defined $fh) { + carp "Couldn't open $filename for reading: $!"; + return; + } + + binmode $fh; + $fh->seek(0, SEEK_END); + $size = $fh->tell; + $fh->seek(0, SEEK_SET); + + $sock = new IO::Socket::INET( Proto => "tcp", + Listen => 1); + + unless (defined $sock) { + carp "Couldn't open DCC SEND socket: $!"; + $fh->close; + return; + } + + $container->ctcp('DCC SEND', $nick, $filename, + unpack("N",inet_aton($container->hostname())), + $sock->sockport(), $size); + + $sock->autoflush(1); + + my $self = { + _bin => 0, # Bytes we've recieved thus far + _blocksize => $blocksize, + _bout => 0, # Bytes we've sent + _debug => $container->debug, + _fh => $fh, # FileHandle we will be reading from. + _filename => $filename, + _frag => '', + _nick => $nick, + _parent => $container, + _size => $size, # Size of file + _socket => $sock, # Socket we're writing to + _time => 0, # This gets set by Accept->parse() + _type => 'SEND', + }; + + bless $self, $class; + + $sock = Net::IRC::DCC::Accept->new($sock, $self); + + unless (defined $sock) { + carp "Error in accept: $!"; + $fh->close; + return; + } + + return $self; +} + +# -- #perl was here! -- +# fimmtiu: So a total stranger is using your shower? +# \merlyn: yes... a total stranger is using my hotel shower +# Stupid coulda sworn \merlyn was married... +# \petey: and you have a date. +# fimmtiu: merlyn isn't married. +# \petey: not a bad combo...... +# \merlyn: perhaps a adate +# \merlyn: not maerried +# \merlyn: not even sober. --) + +sub parse { + my ($self, $sock) = @_; + my $size = ($self->_getline($sock, 1))[0]; + my $buf; + + # i don't know how useful this is, but let's stay consistent + $self->{_bin} += 4; + + unless (defined $size) { + # Dang! The other end unexpectedly canceled. + carp (($self->peer)[1] . " connection to " . + ($self->peer)[0] . " lost"); + $self->{_fh}->close; + $self->{_parent}->parent->removefh($sock); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; + } + + $size = unpack("N", $size); + + if ($size >= $self->{_size}) { + + if ($self->{_debug}) { + warn "Other end acknowledged entire file ($size >= ", + $self->{_size}, ")"; + } + # they've acknowledged the whole file, we outtie + $self->{_fh}->close; + $self->{_parent}->parent->removeconn($self); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; + } + + # we're still waiting for acknowledgement, + # better not send any more + return if $size < $self->{_bout}; + + unless (defined $self->{_fh}->read($buf,$self->{_blocksize})) { + + if ($self->{_debug}) { + warn "Failed to read from source file in DCC SEND!"; + } + $self->{_fh}->close; + $self->{_parent}->parent->removeconn($self); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; + } + + unless($self->{_socket}->send($buf)) { + + if ($self->{_debug}) { + warn "send() failed horribly in DCC SEND" + } + $self->{_fh}->close; + $self->{_parent}->parent->removeconn($self); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; + } + + $self->{_bout} += length($buf); + + $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', + $self->{_nick}, + $self, + $self->{_type}, + $self )); + + return 1; +} + +# -- #perl was here! -- +# fimmtiu: Man, merlyn, you must be drunk to type like that. :) +# \merlyn: too many longislands. +# \merlyn: she made them strong +# archon: it's a plot +# \merlyn: not even a good amoun tof coke +# archon: she's in league with the guy in your shower +# archon: she gets you drunk and he takes your wallet! + + +# handles CHAT connections +package Net::IRC::DCC::CHAT; +@Net::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection); + +use IO::Socket; +use Carp; +use strict; + +sub new { + + my ($class, $container, $type, $nick, $address, $port) = @_; + my ($sock, $self); + + if ($type) { + # we're initiating + + $sock = new IO::Socket::INET( Proto => "tcp", + Listen => 1); + + unless (defined $sock) { + carp "Couldn't open DCC CHAT socket: $!"; + return; + } + + $sock->autoflush(1); + $container->ctcp('DCC CHAT', $nick, 'chat', + unpack("N",inet_aton($container->hostname)), + $sock->sockport()); + + $self = { + _bin => 0, # Bytes we've recieved thus far + _bout => 0, # Bytes we've sent + _connected => 1, + _debug => $container->debug, + _frag => '', + _nick => $nick, # Nick of the client on the other end + _parent => $container, + _socket => $sock, # Socket we're reading from + _time => 0, # This gets set by Accept->parse() + _type => 'CHAT', + }; + + bless $self, $class; + + $sock = Net::IRC::DCC::Accept->new($sock, $self); + + unless (defined $sock) { + carp "Error in DCC CHAT connect: $!"; + return; + } + + } else { # we're connecting + + $address = &Net::IRC::DCC::Connection::fixaddr($address); + return if $port < 1024 or not defined $address; + + $sock = new IO::Socket::INET( Proto => "tcp", + PeerAddr => "$address:$port"); + + if (defined $sock) { + $container->handler(Net::IRC::Event->new('dcc_open', + $nick, + $sock, + 'chat', + 'chat', $sock)); + } else { + carp "Error in DCC CHAT connect: $!"; + return; + } + + $sock->autoflush(1); + + $self = { + _bin => 0, # Bytes we've recieved thus far + _bout => 0, # Bytes we've sent + _connected => 1, + _nick => $nick, # Nick of the client on the other end + _parent => $container, + _socket => $sock, # Socket we're reading from + _time => time, + _type => 'CHAT', + }; + + bless $self, $class; + + $self->{_parent}->parent->addfh($self->socket, + $self->can('parse'), 'r', $self); + } + + return $self; +} + +# -- #perl was here! -- +# \merlyn: tahtd be coole +# KTurner bought the camel today, so somebody can afford one +# more drink... ;) +# tmtowtdi: I've heard of things like this... +# \merlyn: as an experience. that is. +# archon: i can think of cooler things (; +# \merlyn: I don't realiy have that mch in my wallet. + +sub parse { + my ($self, $sock) = @_; + + foreach my $line ($self->_getline($sock)) { + return unless defined $line; + + $self->{_bin} += length($line); + + return undef if $line eq "\012"; + $self->{_bout} += length($line); + + $self->{_parent}->handler(Net::IRC::Event->new('chat', + $self->{_nick}, + $self->{_socket}, + 'chat', + $line)); + + $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', + $self->{_nick}, + $self, + $self->{_type}, + $self )); + } +} + +# Sends a message to a channel or person. +# Takes 2 args: the target of the message (channel or nick) +# the text of the message to send +sub privmsg { + my ($self) = shift; + + unless (@_) { + croak 'Not enough arguments to privmsg()'; + } + + # Don't send a CR over DCC CHAT -- it's not wanted. + $self->socket->send(join('', @_) . "\012"); +} + + +# -- #perl was here! -- +# \merlyn: this girl carly at the bar is aBABE +# archon: are you sure? you don't sound like you're in a condition to +# judge such things (; +# *** Stupid has set the topic on channel #perl to \merlyn is shit-faced +# with a trucker in the shower. +# tmtowtdi: uh, yeah... +# \merlyn: good topic + + +# Sockets waiting for accept() use this to shoehorn into the select loop. +package Net::IRC::DCC::Accept; + +@Net::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection); +use Carp; +use Socket; # we use a lot of Socket functions in parse() +use strict; + + +sub new { + my ($class, $sock, $parent) = @_; + my ($self); + + $self = { _debug => $parent->debug, + _nonblock => 1, + _socket => $sock, + _parent => $parent, + _type => 'accept', + }; + + bless $self, $class; + + # Tkil's gonna love this one. :-) But what the hell... it's safe to + # assume that the only thing initiating DCCs will be Connections, right? + # Boy, we're not built for extensibility, I guess. Someday, I'll clean + # all of the things like this up. + $self->{_parent}->{_parent}->parent->addconn($self); + return $self; +} + +sub parse { + my ($self) = shift; + my ($sock); + + $sock = $self->{_socket}->accept; + $self->{_parent}->{_socket} = $sock; + $self->{_parent}->{_time} = time; + + if ($self->{_parent}->{_type} eq 'SEND') { + # ok, to get the ball rolling, we send them the first packet. + my $buf; + unless (defined $self->{_parent}->{_fh}-> + read($buf, $self->{_parent}->{_blocksize})) { + return; + } + unless (defined $sock->send($buf)) { + $sock->close; + $self->{_parent}->{_fh}->close; + $self->{_parent}->{_parent}->parent->removefh($sock); + $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', + $self->{_nick}, + $self->{_socket}, + $self->{_type})); + $self->{_socket}->close; + return; + } + } + + $self->{_parent}->{_parent}->parent->addconn($self->{_parent}); + $self->{_parent}->{_parent}->parent->removeconn($self); + + $self->{_parent}->{_parent}->handler(Net::IRC::Event-> + new('dcc_open', + $self->{_parent}->{_nick}, + $self->{_parent}->{_socket}, + $self->{_parent}->{_type}, + $self->{_parent}->{_type}, + $self->{_parent}->{_socket}) + ); +} + + + +1; + + +__END__ + +=head1 NAME + +Net::IRC::DCC - Object-oriented interface to a single DCC connection + +=head1 SYNOPSIS + +Hard hat area: This section under construction. + +=head1 DESCRIPTION + +This documentation is a subset of the main Net::IRC documentation. If +you haven't already, please "perldoc Net::IRC" before continuing. + +Net::IRC::DCC defines a few subclasses that handle DCC CHAT, GET, and SEND +requests for inter-client communication. DCC objects are created by +Cnew_{chat,get,send}()> in much the same way that +Cnewconn()> creates a new connection object. + +=head1 METHOD DESCRIPTIONS + +This section is under construction, but hopefully will be finally written up +by the next release. Please see the C script and the source for +details about this module. + +=head1 AUTHORS + +Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and +Dennis Taylor Edennis@funkplanet.comE. + +Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. + +Currently being hacked on, hacked up, and worked over by the members of the +Net::IRC developers mailing list. For details, see +http://www.execpc.com/~corbeau/irc/list.html . + +=head1 URL + +Up-to-date source and information about the Net::IRC project can be found at +http://netirc.betterbox.net/ . + +=head1 SEE ALSO + +=over + +=item * + +perl(1). + +=item * + +RFC 1459: The Internet Relay Chat Protocol + +=item * + +http://www.irchelp.org/, home of fine IRC resources. + +=back + +=cut diff --git a/lib/Net/IRC/Event.pm b/lib/Net/IRC/Event.pm new file mode 100644 index 0000000..3359a2f --- /dev/null +++ b/lib/Net/IRC/Event.pm @@ -0,0 +1,873 @@ +##################################################################### +# # +# Net::IRC -- Object-oriented Perl interface to an IRC server # +# # +# Event.pm: The basic data type for any IRC occurrence. # +# # +# Copyright (c) 2001 Pete Sergeant, Greg Bacon & Dennis Taylor. # +# All rights reserved. # +# # +# This module is free software; you can redistribute or # +# modify it under the terms of Perl's Artistic License. # +# # +##################################################################### + +# there used to be lots of cute little log quotes from #perl in here +# +# they're gone now because they made working on this already crappy +# code even more annoying... 'HI!!! I'm from #perl and so I don't +# write understandable, maintainable code!!! You see, i'm a perl +# badass, so I try to be as obscure as possible in everything I do!' +# +# Well, welcome to the real world, guys, where code needs to be +# maintainable and sane. + +package Net::IRC::Event; + +use strict; +our %_names; + +# Constructor method for Net::IRC::Event objects. +# Takes at least 4 args: the type of event +# the person or server that initiated the event +# the recipient(s) of the event, as arrayref or scalar +# the name of the format string for the event +# (optional) any number of arguments provided by the event +sub new { + my $class = shift; + my $type = shift; + my $from = shift; + my $to = shift; + my $format = shift; + my $args = \@_; + + my $self = { + 'type' => $type, + 'from' => undef, + 'to' => ref($to) eq 'ARRAY' ? $to : [ $to ], + 'format' => $format, + 'args' => [], + }; + + bless $self, $class; + + if ($self->type !~ /\D/) { + $self->type($self->trans($self->type)); + } else { + $self->type(lc($self->type)); + } + + $self->from($from); # sets nick, user, and host + $self->args($args); # strips colons from args + + return $self; +} + +# Sets or returns an argument list for this event. +# Takes any number of args: the arguments for the event. +sub args { + my $self = shift; + my $args = shift; + + if($args) { + my (@q, $i, $ct) = @{$args}; # This line is solemnly dedicated to \mjd. + + $self->{'args'} = [ ]; + while (@q) { + $i = shift @q; + next unless defined $i; + + if ($i =~ /^:/ and $ct) { # Concatenate :-args. + $i = join ' ', (substr($i, 1), @q); + push @{$self->{'args'}}, $i; + last; + } + push @{$self->{'args'}}, $i; + $ct++; + } + } + + return @{$self->{'args'}}; +} + +# Dumps the contents of an event to STDERR so you can see what's inside. +# Takes no args. +sub dump { + my ($self, $arg, $counter) = (shift, undef, 0); # heh heh! + + printf STDERR "TYPE: %-30s FORMAT: %-30s\n", $self->type, $self->format; + print STDERR "FROM: ", $self->from, "\n"; + print STDERR "TO: ", join(", ", @{$self->to}), "\n"; + foreach $arg ($self->args) { + print "Arg ", $counter++, ": ", $arg, "\n"; + } +} + +# Sets or returns the format string for this event. +# Takes 1 optional arg: the new value for this event's "format" field. +sub format { + my $self = shift; + + $self->{'format'} = $_[0] if @_; + return $self->{'format'}; +} + +# Sets or returns the originator of this event +# Takes 1 optional arg: the new value for this event's "from" field. +sub from { + my $self = shift; + my @part; + + if (@_) { + # avoid certain irritating and spurious warnings from this line... + { local $^W; + @part = split /[\@!]/, $_[0], 3; + } + + $self->nick(defined $part[0] ? $part[0] : ''); + $self->user(defined $part[1] ? $part[1] : ''); + $self->host(defined $part[2] ? $part[2] : ''); + defined $self->user ? + $self->userhost($self->user . '@' . $self->host) : + $self->userhost($self->host); + $self->{'from'} = $_[0]; + } + + return $self->{'from'}; +} + +# Sets or returns the hostname of this event's initiator +# Takes 1 optional arg: the new value for this event's "host" field. +sub host { + my $self = shift; + + $self->{'host'} = $_[0] if @_; + return $self->{'host'}; +} + +# Sets or returns the nick of this event's initiator +# Takes 1 optional arg: the new value for this event's "nick" field. +sub nick { + my $self = shift; + + $self->{'nick'} = $_[0] if @_; + return $self->{'nick'}; +} + +# Sets or returns the recipient list for this event +# Takes any number of args: this event's list of recipients. +sub to { + my $self = shift; + + $self->{'to'} = [ @_ ] if @_; + return wantarray ? @{$self->{'to'}} : $self->{'to'}; +} + +# Sets or returns the type of this event +# Takes 1 optional arg: the new value for this event's "type" field. +sub type { + my $self = shift; + + $self->{'type'} = $_[0] if @_; + return $self->{'type'}; +} + +# Sets or returns the username of this event's initiator +# Takes 1 optional arg: the new value for this event's "user" field. +sub user { + my $self = shift; + + $self->{'user'} = $_[0] if @_; + return $self->{'user'}; +} + +# Just $self->user plus '@' plus $self->host, for convenience. +sub userhost { + my $self = shift; + + $self->{'userhost'} = $_[0] if @_; + return $self->{'userhost'}; +} + +#added by AfterDeath. Use this to reply to channel messages in channel, but private messages to the nick that sent it. +sub replyto { + my $self = shift; + if ($self->{to}->[0] =~ /^[+@#&%]/) { + return $self->{to}->[0]; + } else { + return $self->{nick}; + } +} + +# Simple sub for translating server numerics to their appropriate names. +# Takes one arg: the number to be translated. +sub trans { + shift if (ref($_[0]) || $_[0]) =~ /^Net::IRC/; + my $ev = shift; + + return (exists $_names{$ev} ? $_names{$ev} : undef); +} + +%_names = ( + # suck! these aren't treated as strings -- + # 001 ne 1 for the purpose of hash keying, apparently. + '001' => "welcome", + '002' => "yourhost", + '003' => "created", + '004' => "myinfo", + '005' => "map", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 + '006' => "mapmore", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 + '007' => "mapend", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 + '008' => "snomask", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 + '009' => "statmemtot", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 + '010' => "statmem", # Undernet Extension, Kajetan@Hinner.com, 17/11/98 + + 200 => "tracelink", + 201 => "traceconnecting", + 202 => "tracehandshake", + 203 => "traceunknown", + 204 => "traceoperator", + 205 => "traceuser", + 206 => "traceserver", + 208 => "tracenewtype", + 209 => "traceclass", + 211 => "statslinkinfo", + 212 => "statscommands", + 213 => "statscline", + 214 => "statsnline", + 215 => "statsiline", + 216 => "statskline", + 217 => "statsqline", + 218 => "statsyline", + 219 => "endofstats", + 220 => "statsbline", # UnrealIrcd, Hendrik Frenzel + 221 => "umodeis", + 222 => "sqline_nick", # UnrealIrcd, Hendrik Frenzel + 223 => "statsgline", # UnrealIrcd, Hendrik Frenzel + 224 => "statstline", # UnrealIrcd, Hendrik Frenzel + 225 => "statseline", # UnrealIrcd, Hendrik Frenzel + 226 => "statsnline", # UnrealIrcd, Hendrik Frenzel + 227 => "statsvline", # UnrealIrcd, Hendrik Frenzel + 231 => "serviceinfo", + 232 => "endofservices", + 233 => "service", + 234 => "servlist", + 235 => "servlistend", + 241 => "statslline", + 242 => "statsuptime", + 243 => "statsoline", + 244 => "statshline", + 245 => "statssline", # Reserved, Kajetan@Hinner.com, 17/10/98 + 246 => "statstline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 247 => "statsgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 +### TODO: need numerics to be able to map to multiple strings +### 247 => "statsxline", # UnrealIrcd, Hendrik Frenzel + 248 => "statsuline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 249 => "statsdebug", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98 + 250 => "luserconns", # 1998-03-15 -- tkil + 251 => "luserclient", + 252 => "luserop", + 253 => "luserunknown", + 254 => "luserchannels", + 255 => "luserme", + 256 => "adminme", + 257 => "adminloc1", + 258 => "adminloc2", + 259 => "adminemail", + 261 => "tracelog", + 262 => "endoftrace", # 1997-11-24 -- archon + 263 => "rpl_tryagain", + 265 => "n_local", # 1997-10-16 -- tkil + 266 => "n_global", # 1997-10-16 -- tkil + 271 => "silelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 272 => "endofsilelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 275 => "statsdline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 280 => "glist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 281 => "endofglist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 290 => "helphdr", # UnrealIrcd, Hendrik Frenzel + 291 => "helpop", # UnrealIrcd, Hendrik Frenzel + 292 => "helptlr", # UnrealIrcd, Hendrik Frenzel + 293 => "helphlp", # UnrealIrcd, Hendrik Frenzel + 294 => "helpfwd", # UnrealIrcd, Hendrik Frenzel + 295 => "helpign", # UnrealIrcd, Hendrik Frenzel + + 300 => "none", + 301 => "away", + 302 => "userhost", + 303 => "ison", + 304 => "rpl_text", # Bahamut IRCD + 305 => "unaway", + 306 => "nowaway", + 307 => "userip", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 308 => "rulesstart", # UnrealIrcd, Hendrik Frenzel + 309 => "endofrules", # UnrealIrcd, Hendrik Frenzel + 310 => "whoishelp", # (July01-01)Austnet Extension, found by Andypoo + 311 => "whoisuser", + 312 => "whoisserver", + 313 => "whoisoperator", + 314 => "whowasuser", + 315 => "endofwho", + 316 => "whoischanop", + 317 => "whoisidle", + 318 => "endofwhois", + 319 => "whoischannels", + 320 => "whoisvworld", # (July01-01)Austnet Extension, found by Andypoo + 321 => "liststart", + 322 => "list", + 323 => "listend", + 324 => "channelmodeis", + 328 => "channelurlis", + 329 => "channelcreate", # 1997-11-24 -- archon + 331 => "notopic", + 332 => "topic", + 333 => "topicinfo", # 1997-11-24 -- archon + 334 => "listusage", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 335 => "whoisbot", # UnrealIrcd, Hendrik Frenzel + 341 => "inviting", + 342 => "summoning", + 346 => "invitelist", # UnrealIrcd, Hendrik Frenzel + 347 => "endofinvitelist", # UnrealIrcd, Hendrik Frenzel + 348 => "exlist", # UnrealIrcd, Hendrik Frenzel + 349 => "endofexlist", # UnrealIrcd, Hendrik Frenzel + 351 => "version", + 352 => "whoreply", + 353 => "namreply", + 354 => "whospcrpl", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 361 => "killdone", + 362 => "closing", + 363 => "closeend", + 364 => "links", + 365 => "endoflinks", + 366 => "endofnames", + 367 => "banlist", + 368 => "endofbanlist", + 369 => "endofwhowas", + 371 => "info", + 372 => "motd", + 373 => "infostart", + 374 => "endofinfo", + 375 => "motdstart", + 376 => "endofmotd", + 377 => "motd2", # 1997-10-16 -- tkil + 378 => "austmotd", # (July01-01)Austnet Extension, found by Andypoo + 379 => "whoismodes", # UnrealIrcd, Hendrik Frenzel + 381 => "youreoper", + 382 => "rehashing", + 383 => "youreservice", # UnrealIrcd, Hendrik Frenzel + 384 => "myportis", + 385 => "notoperanymore", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98 + 386 => "qlist", # UnrealIrcd, Hendrik Frenzel + 387 => "endofqlist", # UnrealIrcd, Hendrik Frenzel + 388 => "alist", # UnrealIrcd, Hendrik Frenzel + 389 => "endofalist", # UnrealIrcd, Hendrik Frenzel + 391 => "time", + 392 => "usersstart", + 393 => "users", + 394 => "endofusers", + 395 => "nousers", + 396 => "hosthidden", + + 401 => "nosuchnick", + 402 => "nosuchserver", + 403 => "nosuchchannel", + 404 => "cannotsendtochan", + 405 => "toomanychannels", + 406 => "wasnosuchnick", + 407 => "toomanytargets", + 408 => "nosuchservice", # UnrealIrcd, Hendrik Frenzel + 409 => "noorigin", + 411 => "norecipient", + 412 => "notexttosend", + 413 => "notoplevel", + 414 => "wildtoplevel", + 416 => "querytoolong", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 421 => "unknowncommand", + 422 => "nomotd", + 423 => "noadmininfo", + 424 => "fileerror", + 425 => "noopermotd", # UnrealIrcd, Hendrik Frenzel + 431 => "nonicknamegiven", + 432 => "erroneusnickname", # This iz how its speld in thee RFC. + 433 => "nicknameinuse", + 434 => "norules", # UnrealIrcd, Hendrik Frenzel + 435 => "serviceconfused", # UnrealIrcd, Hendrik Frenzel + 436 => "nickcollision", + 437 => "bannickchange", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 438 => "nicktoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 439 => "targettoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 440 => "servicesdown", # Bahamut IRCD + 441 => "usernotinchannel", + 442 => "notonchannel", + 443 => "useronchannel", + 444 => "nologin", + 445 => "summondisabled", + 446 => "usersdisabled", + 447 => "nonickchange", # UnrealIrcd, Hendrik Frenzel + 451 => "notregistered", + 455 => "hostilename", # UnrealIrcd, Hendrik Frenzel + 459 => "nohiding", # UnrealIrcd, Hendrik Frenzel + 460 => "notforhalfops", # UnrealIrcd, Hendrik Frenzel + 461 => "needmoreparams", + 462 => "alreadyregistered", + 463 => "nopermforhost", + 464 => "passwdmismatch", + 465 => "yourebannedcreep", # I love this one... + 466 => "youwillbebanned", + 467 => "keyset", + 468 => "invalidusername", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 469 => "linkset", # UnrealIrcd, Hendrik Frenzel + 470 => "linkchannel", # UnrealIrcd, Hendrik Frenzel + 471 => "channelisfull", + 472 => "unknownmode", + 473 => "inviteonlychan", + 474 => "bannedfromchan", + 475 => "badchannelkey", + 476 => "badchanmask", + 477 => "needreggednick", # Bahamut IRCD + 478 => "banlistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 479 => "secureonlychannel", # pircd +### TODO: see above todo +### 479 => "linkfail", # UnrealIrcd, Hendrik Frenzel + 480 => "cannotknock", # UnrealIrcd, Hendrik Frenzel + 481 => "noprivileges", + 482 => "chanoprivsneeded", + 483 => "cantkillserver", + 484 => "ischanservice", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 485 => "killdeny", # UnrealIrcd, Hendrik Frenzel + 486 => "htmdisabled", # UnrealIrcd, Hendrik Frenzel + 489 => "secureonlychan", # UnrealIrcd, Hendrik Frenzel + 491 => "nooperhost", + 492 => "noservicehost", + + 501 => "umodeunknownflag", + 502 => "usersdontmatch", + + 511 => "silelistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 513 => "nosuchgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 513 => "badping", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 + 518 => "noinvite", # UnrealIrcd, Hendrik Frenzel + 519 => "admonly", # UnrealIrcd, Hendrik Frenzel + 520 => "operonly", # UnrealIrcd, Hendrik Frenzel + 521 => "listsyntax", # UnrealIrcd, Hendrik Frenzel + 524 => "operspverify", # UnrealIrcd, Hendrik Frenzel + + 600 => "rpl_logon", # Bahamut IRCD + 601 => "rpl_logoff", # Bahamut IRCD + 602 => "rpl_watchoff", # UnrealIrcd, Hendrik Frenzel + 603 => "rpl_watchstat", # UnrealIrcd, Hendrik Frenzel + 604 => "rpl_nowon", # Bahamut IRCD + 605 => "rpl_nowoff", # Bahamut IRCD + 606 => "rpl_watchlist", # UnrealIrcd, Hendrik Frenzel + 607 => "rpl_endofwatchlist", # UnrealIrcd, Hendrik Frenzel + 610 => "mapmore", # UnrealIrcd, Hendrik Frenzel + 640 => "rpl_dumping", # UnrealIrcd, Hendrik Frenzel + 641 => "rpl_dumprpl", # UnrealIrcd, Hendrik Frenzel + 642 => "rpl_eodump", # UnrealIrcd, Hendrik Frenzel + + 716 => "rpl_ignored", + + 728 => "quietlist", + 729 => "quietlistend", + 999 => "numericerror", # Bahamut IRCD + 'pong' => "pong", + ); + + +1; + + +__END__ + +=head1 NAME + +Net::IRC::Event - A class for passing event data between subroutines + +=head1 SYNOPSIS + +None yet. These docs are under construction. + +=head1 DESCRIPTION + +This documentation is a subset of the main Net::IRC documentation. If +you haven't already, please "perldoc Net::IRC" before continuing. + +Net::IRC::Event defines a standard interface to the salient information for +just about any event your client may witness on IRC. It's about as close as +we can get in Perl to a struct, with a few extra nifty features thrown in. + +=head1 METHOD DESCRIPTIONS + +This section is under construction, but hopefully will be finally written up +by the next release. Please see the C script and the source for +details about this module. + +=head1 LIST OF EVENTS + +Net::IRC is an entirely event-based system, which takes some getting used to +at first. To interact with the IRC server, you tell Net::IRC's server +connection to listen for certain events and activate your own subroutines when +they occur. Problem is, this doesn't help you much if you don't know what to +tell it to look for. Below is a list of the possible events you can pass to +Net::IRC, along with brief descriptions of each... hope this helps. + +=head2 Common events + +=over + +=item * + +nick + +The "nick" event is triggered when the client receives a NICK message, meaning +that someone on a channel with the client has changed eir nickname. + +=item * + +quit + +The "quit" event is triggered upon receipt of a QUIT message, which means that +someone on a channel with the client has disconnected. + +=item * + +join + +The "join" event is triggered upon receipt of a JOIN message, which means that +someone has entered a channel that the client is on. + +=item * + +part + +The "part" event is triggered upon receipt of a PART message, which means that +someone has left a channel that the client is on. + +=item * + +mode + +The "mode" event is triggered upon receipt of a MODE message, which means that +someone on a channel with the client has changed the channel's parameters. + +=item * + +topic + +The "topic" event is triggered upon receipt of a TOPIC message, which means +that someone on a channel with the client has changed the channel's topic. + +=item * + +kick + +The "kick" event is triggered upon receipt of a KICK message, which means that +someone on a channel with the client (or possibly the client itself!) has been +forcibly ejected. + +=item * + +public + +The "public" event is triggered upon receipt of a PRIVMSG message to an entire +channel, which means that someone on a channel with the client has said +something aloud. + +=item * + +msg + +The "msg" event is triggered upon receipt of a PRIVMSG message which is +addressed to one or more clients, which means that someone is sending the +client a private message. (Duh. :-) + +=item * + +notice + +The "notice" event is triggered upon receipt of a NOTICE message, which means +that someone has sent the client a public or private notice. (Is that +sufficiently vague?) + +=item * + +ping + +The "ping" event is triggered upon receipt of a PING message, which means that +the IRC server is querying the client to see if it's alive. Don't confuse this +with CTCP PINGs, explained later. + +=item * + +other + +The "other" event is triggered upon receipt of any number of unclassifiable +miscellaneous messages, but you're not likely to see it often. + +=item * + +invite + +The "invite" event is triggered upon receipt of an INVITE message, which means +that someone is permitting the client's entry into a +i channel. + +=item * + +kill + +The "kill" event is triggered upon receipt of a KILL message, which means that +an IRC operator has just booted your sorry arse offline. Seeya! + +=item * + +disconnect + +The "disconnect" event is triggered when the client loses its +connection to the IRC server it's talking to. Don't confuse it with +the "leaving" event. (See below.) + +=item * + +leaving + +The "leaving" event is triggered just before the client deliberately +closes a connection to an IRC server, in case you want to do anything +special before you sign off. + +=item * + +umode + +The "umode" event is triggered when the client changes its personal mode flags. + +=item * + +error + +The "error" event is triggered when the IRC server complains to you about +anything. Sort of the evil twin to the "other" event, actually. + +=back + +=head2 CTCP Requests + +=over + +=item * + +cping + +The "cping" event is triggered when the client receives a CTCP PING request +from another user. See the irctest script for an example of how to properly +respond to this common request. + +=item * + +cversion + +The "cversion" event is triggered when the client receives a CTCP VERSION +request from another client, asking for version info about its IRC client +program. + +=item * + +csource + +The "csource" event is triggered when the client receives a CTCP SOURCE +request from another client, asking where it can find the source to its +IRC client program. + +=item * + +ctime + +The "ctime" event is triggered when the client receives a CTCP TIME +request from another client, asking for the local time at its end. + +=item * + +cdcc + +The "cdcc" event is triggered when the client receives a DCC request of any +sort from another client, attempting to establish a DCC connection. + +=item * + +cuserinfo + +The "cuserinfo" event is triggered when the client receives a CTCP USERINFO +request from another client, asking for personal information from the client's +user. + +=item * + +cclientinfo + +The "cclientinfo" event is triggered when the client receives a CTCP CLIENTINFO +request from another client, asking for whatever the hell "clientinfo" means. + +=item * + +cerrmsg + +The "cerrmsg" event is triggered when the client receives a CTCP ERRMSG +request from another client, notifying it of a protocol error in a preceding +CTCP communication. + +=item * + +cfinger + +The "cfinger" event is triggered when the client receives a CTCP FINGER +request from another client. How to respond to this should best be left up +to your own moral stance. + +=item * + +caction + +The "caction" event is triggered when the client receives a CTCP ACTION +message from another client. I should hope you're getting the hang of how +Net::IRC handles CTCP requests by now... + +=back + +=head2 CTCP Responses + +=over + +=item * + +crping + +The "crping" event is triggered when the client receives a CTCP PING response +from another user. See the irctest script for an example of how to properly +respond to this common event. + +=item * + +crversion + +The "crversion" event is triggered when the client receives a CTCP VERSION +response from another client. + +=item * + +crsource + +The "crsource" event is triggered when the client receives a CTCP SOURCE +response from another client. + +=item * + +crtime + +The "crtime" event is triggered when the client receives a CTCP TIME +response from another client. + +=item * + +cruserinfo + +The "cruserinfo" event is triggered when the client receives a CTCP USERINFO +response from another client. + +=item * + +crclientinfo + +The "crclientinfo" event is triggered when the client receives a CTCP +CLIENTINFO response from another client. + +=item * + +crfinger + +The "crfinger" event is triggered when the client receives a CTCP FINGER +response from another client. I'm not even going to consider making a joke +about this one. + +=back + +=head2 DCC Events + +=over + +=item * + +dcc_open + +The "dcc_open" event is triggered when a DCC connection is established between +the client and another client. + +=item * + +dcc_update + +The "dcc_update" event is triggered when any data flows over a DCC connection. +Useful for doing things like monitoring file transfer progress, for instance. + +=item * + +dcc_close + +The "dcc_close" event is triggered when a DCC connection closes, whether from +an error or from natural causes. + +=item * + +chat + +The "chat" event is triggered when the person on the other end of a DCC CHAT +connection sends you a message. Think of it as the private equivalent of "msg", +if you will. + +=back + +=head2 Numeric Events + +=over + +=item * + +There's a whole lot of them, and they're well-described elsewhere. Please see +the IRC RFC (1495, at http://cs-ftp.bu.edu/pub/irc/support/IRC_RFC ) for a +detailed description, or the Net::IRC::Event.pm source code for a quick list. + +=back + +=head1 AUTHORS + +Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and +Dennis Taylor Edennis@funkplanet.comE. + +Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. + +Currently being hacked on, hacked up, and worked over by the members of the +Net::IRC developers mailing list. For details, see +http://www.execpc.com/~corbeau/irc/list.html . + +=head1 URL + +Up-to-date source and information about the Net::IRC project can be found at +http://netirc.betterbox.net/ . + +=head1 SEE ALSO + +=over + +=item * + +perl(1). + +=item * + +RFC 1459: The Internet Relay Chat Protocol + +=item * + +http://www.irchelp.org/, home of fine IRC resources. + +=back + +=cut + diff --git a/lib/Net/IRC/EventQueue.pm b/lib/Net/IRC/EventQueue.pm new file mode 100644 index 0000000..fdb7b44 --- /dev/null +++ b/lib/Net/IRC/EventQueue.pm @@ -0,0 +1,73 @@ +package Net::IRC::EventQueue; + +use Net::IRC::EventQueue::Entry; + +use strict; + +sub new { + my $class = shift; + + my $self = { + 'queue' => {}, + }; + + bless $self, $class; +} + +sub queue { + my $self = shift; + return $self->{'queue'}; +} + +sub enqueue { + my $self = shift; + my $time = shift; + my $content = shift; + + my $entry = new Net::IRC::EventQueue::Entry($time, $content); + $self->queue->{$entry->id} = $entry; + return $entry->id; +} + +sub dequeue { + my $self = shift; + my $event = shift; + my $result; + + if(!$event) { # we got passed nothing, so return the first event + $event = $self->head(); + delete $self->queue->{$event->id}; + $result = $event; + } elsif(!ref($event)) { # we got passed an id + $result = $self->queue->{$event}; + delete $self->queue->{$event}; + } else { # we got passed an actual event object + ref($event) eq 'Net::IRC::EventQueue::Entry' + or die "Cannot delete event type of " . ref($event) . "!"; + + $result = $self->queue->{$event->id}; + delete $self->queue->{$event->id}; + } + + return $result; +} + +sub head { + my $self = shift; + + return undef if $self->is_empty; + + no warnings; # because we want to numerically sort strings... + my $headkey = (sort {$a <=> $b} (keys(%{$self->queue})))[0]; + use warnings; + + return $self->queue->{$headkey}; +} + +sub is_empty { + my $self = shift; + + return keys(%{$self->queue}) ? 0 : 1; +} + +1; diff --git a/lib/Net/IRC/EventQueue/Entry.pm b/lib/Net/IRC/EventQueue/Entry.pm new file mode 100644 index 0000000..94a3802 --- /dev/null +++ b/lib/Net/IRC/EventQueue/Entry.pm @@ -0,0 +1,40 @@ +package Net::IRC::EventQueue::Entry; + +use strict; + +my $id = 0; + +sub new { + my $class = shift; + my $time = shift; + my $content = shift; + + my $self = { + 'time' => $time, + 'content' => $content, + 'id' => "$time:" . $id++, + }; + + bless $self, $class; + return $self; +} + +sub id { + my $self = shift; + return $self->{'id'}; +} + +sub time { + my $self = shift; + $self->{'time'} = $_[0] if @_; + return $self->{'time'}; +} + +sub content { + my $self = shift; + $self->{'content'} = $_[0] if @_; + return $self->{'content'}; +} + +1; + diff --git a/meta.pl b/meta.pl index 00045a6..2e651d6 100755 --- a/meta.pl +++ b/meta.pl @@ -1,12 +1,11 @@ -#!/usr/bin/perl -w +#!/usr/bin/env perl -use lib '/home/icxcnika/AntiSpamMeta'; - -#use Devel::Profiler package_filter => sub { return 0 if $_[0] =~ /^XML::Simple/; return 1; }; +use strict; +use warnings; +use FindBin; +use lib "$FindBin::Bin/lib";; -use warnings; -use strict; use Net::IRC; use Data::Dumper; use IO::All; @@ -18,6 +17,16 @@ use feature qw(say); use HTTP::Async; use Carp; +use ASM::Util; +use ASM::XML; +use ASM::Inspect; +use ASM::Event; +use ASM::Services; +use ASM::Log; +use ASM::Commander; +use ASM::Classes; +use ASM::DB; + $Data::Dumper::Useqq=1; $::pass = ''; @@ -72,11 +81,6 @@ sub alarmdeath $SIG{ALRM} = \&alarmdeath; alarm 300; -BEGIN { -my @modules = qw/Util Xml Inspect Event Services Log Command Classes Mysql/; -require 'modules/' . lc $_ . '.pl' foreach @modules; -} - sub init { my ( $conn, $host ); my $irc = new Net::IRC; diff --git a/modules/classes.pl b/modules/classes.pl deleted file mode 100644 index 1054f63..0000000 --- a/modules/classes.pl +++ /dev/null @@ -1,514 +0,0 @@ -package ASM::Classes; - -use strict; -use warnings; -use Text::LevenshteinXS qw(distance); -use Data::Dumper; -use Regexp::Wildcards; -use Carp qw(cluck); - -my %sf = (); - -sub new -{ - my $module = shift; - my $self = {}; - my $tbl = { - "strbl" => \&strbl, - "strblnew" => \&strblnew, - "dnsbl" => \&dnsbl, - "floodqueue" => \&floodqueue, - "floodqueue2" => \&floodqueue2, - "nickspam" => \&nickspam, - "splitflood" => \&splitflood, - "advsplitflood" => \&advsplitflood, - "re" => \&re, - "nick" => \&nick, - "ident" => \&ident, - "host" => \&host, - "gecos" => \&gecos, - "nuhg" => \&nuhg, - "levenflood" => \&levenflood, - "proxy" => \&proxy, - "nickbl" => \&nickbl, - "nickfuzzy" => \&nickfuzzy, - "asciiflood" => \&asciiflood, - "joinmsgquit" => \&joinmsgquit, - "garbagemeter" => \&garbagemeter, - "cyclebotnet" => \&cyclebotnet, - "banevade" => \&banevade, - "urlcrunch" => \&urlcrunch - }; - $self->{ftbl} = $tbl; - bless($self); - return $self; -} - -sub garbagemeter { - my ($chk, $id, $event, $chan, $rev) = @_; - my @cut = split(/:/, $chk->{content}); - my $limit = int($cut[0]); - my $timeout = int($cut[1]); - my $threshold = int($cut[2]); - my $threshold2 = int($cut[3]); - my $wordcount = 0; - my $line = $event->{args}->[0]; - return 0 unless ($line =~ /^[A-Za-z: ]+$/); - my @words = split(/ /, $line); - return 0 unless ((scalar @words) >= $threshold2); - foreach my $word (@words) { - if (defined($::wordlist{lc $word})) { - $wordcount += 1; - } - return 0 if ($wordcount >= $threshold); - } - return 1 if ( flood_add( $chan, $id, 0, $timeout ) == $limit ); - return 0; -} - -sub joinmsgquit -{ - my ($chk, $id, $event, $chan, $rev) = @_; - my $time = $chk->{content}; -##STATE - $chan = lc $chan; #don't know if this is necessary but I'm trying to track down some mysterious state tracking corruption - return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{jointime}); - return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{msgtime}); - return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{jointime}) > $time); - return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{msgtime}) > $time); - return 1; -} - -sub urlcrunch -{ - my ($chk, $id, $event, $chan, $response) = @_; - return 0 unless defined($response); - return 0 unless ref($response); - return 0 unless defined($response->{_previous}); - return 0 unless defined($response->{_previous}->{_headers}); - return 0 unless defined($response->{_previous}->{_headers}->{location}); - if ($response->{_previous}->{_headers}->{location} =~ /$chk->{content}/i) { - return 1; - } - return 0; -} - -sub check -{ - my $self = shift; - my $item = shift; - return $self->{ftbl}->{$item}->(@_); -} - -sub nickbl -{ - my ($chk, $id, $event, $chan, $rev) = @_; - my $match = lc $event->{nick}; - foreach my $line (@::nick_blacklist) { - if ($line eq $match) { - return 1; - } - } - return 0; -} - -sub banevade -{ - my ($chk, $id, $event, $chan, $rev) = @_; - my $ip = ASM::Util->getNickIP($event->{nick}); - return 0 unless defined($ip); - if (defined($::sc{lc $chan}{ipbans}{$ip})) { - return 1; - } - return 0; -} - -sub proxy -{ - my ($chk, $id, $event, $chan, $rev) = @_; - if (defined($rev) and ($rev =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)\./)) { - if (defined($::proxies{"$4.$3.$2.$1"})) { - return 1; - } - } - return 0; -} - -my %ls = (); -sub levenflood -{ - my ($chk, $id, $event, $chan) = @_; - my $text; - if ($event->{type} =~ /^(public|notice|part|caction)$/) { - $text = $event->{args}->[0]; - } - return 0 unless ( defined($text) && (length($text) >= 30) ); - if ( ! defined($ls{$chan}) ) { - $ls{$chan} = [ $text ]; - return 0; - } - my @leven = @{$ls{$chan}}; - my $ret = 0; - if ( $#leven >= 5 ) { - my $mx = 0; - foreach my $item ( @leven ) { - next unless length($text) eq length($item); - my $tld = distance($text, $item); - if ($tld <= 4) { - $mx = $mx + 1; - } - } - if ($mx >= 5) { - $ret = 1; - } - } - push(@leven, $text); - shift @leven if $#leven > 10; - $ls{$chan} = \@leven; - return $ret; -} - -sub nickfuzzy -{ - my ($chk, $id, $event, $chan) = @_; - my $nick = $event->{nick}; - $nick = $event->{args}->[0] if ($event->{type} eq 'nick'); - my ($fuzzy, $match) = split(/:/, $chk->{content}); - my @nicks = split(/,/, $match); - foreach my $item (@nicks) { - if (distance(lc $nick, lc $item) <= $fuzzy) { - return 1; - } - } - return 0; -} - -sub dnsbl -{ - my ($chk, $id, $event, $chan, $rev) = @_; -# return unless index($event->{host}, '/') == -1; -# hopefully getting rid of this won't cause shit to assplode -# but I'm getting rid of it so it can detect cgi:irc shit -# return 0; - if (defined $rev) { - ASM::Util->dprint("Querying $rev$chk->{content}", "dnsbl"); - #cluck "Calling gethostbyname in dnsbl"; - my $iaddr = gethostbyname( "$rev$chk->{content}" ); - my @dnsbl = unpack( 'C4', $iaddr ) if defined $iaddr; - my $strip; - if (@dnsbl) { - $strip = sprintf("%s.%s.%s.%s", @dnsbl); - ASM::Util->dprint("found host (rev $rev) in $chk->{content} - $strip", 'dnsbl'); - } - if ((@dnsbl) && (defined($::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}))) { - $::lastlookup=$::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content}; - ASM::Util->dprint("chk->content: $chk->{content}", 'dnsbl'); - ASM::Util->dprint("strip: $strip", 'dnsbl'); - ASM::Util->dprint("result: " . $::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content}, 'dnsbl'); - $::sn{lc $event->{nick}}->{dnsbl} = 1; - # lol really icky hax - return $::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content}; - } - } - return 0; -} - -sub floodqueue2 { - my ($chk, $id, $event, $chan, $rev) = @_; - my @cut = split(/:/, $chk->{content}); - - my $cvt = Regexp::Wildcards->new(type => 'jokers'); - my $hit = 0; - foreach my $mask ( keys %{$::sc{lc $chan}{quiets}}) { - if ($mask !~ /^\$/) { - my @div = split(/\$/, $mask); - my $regex = $cvt->convert($div[0]); - if (lc $event->{from} =~ lc $regex) { - $hit = 1; - } - } elsif ( (defined($::sn{lc $event->{nick}}{account})) && ($mask =~ /^\$a:(.*)/)) { - my @div = split(/\$/, $mask); - my $regex = $cvt->convert($div[0]); - if (lc ($::sn{lc $event->{nick}}{account}) =~ lc $regex) { - $hit = 1; - } - } - } - return 0 unless $hit; - - return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[1]) ) == int($cut[0]) ); - return 0; -} - -sub floodqueue { - my ($chk, $id, $event, $chan, $rev) = @_; - my @cut = split(/:/, $chk->{content}); - return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[1]) ) == int($cut[0]) ); - return 0; -} - -sub asciiflood { - my ($chk, $id, $event, $chan, $rev) = @_; - my @cut = split(/:/, $chk->{content}); - return 0 if (length($event->{args}->[0]) < $cut[0]); - return 0 if ($event->{args}->[0] =~ /[A-Za-z0-9]/); - return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[2]) ) == int($cut[1]) ); - return 0; -} - -sub cyclebotnet -{ - my ($chk, $id, $event, $chan, $rev) = @_; - my ($cycletime, $queueamt, $queuetime) = split(/:/, $chk->{content}); - $chan = lc $chan; #don't know if this is necessary but I'm trying to track down some mysterious state tracking corruption - return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{jointime}); - return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{jointime}) > int($cycletime)); - return 1 if ( flood_add( $chan, $id, "cycle", int($queuetime)) == int($queueamt) ); - return 0; -} - -sub nickspam { - my ($chk, $id, $event, $chan) = @_; - my @cut = split(/:/, $chk->{content}); - if ( length $event->{args}->[0] >= int($cut[0]) ) { - my %users = %{$::sc{lc $chan}->{users}}; - my %x = map { $_=>$_ } keys %users; - my @uniq = grep( $x{$_}, split( /[^a-zA-Z0-9_\\|`[\]{}^-]+/ , lc $event->{args}->[0]) ); - return 1 if ( @uniq >= int($cut[1]) ); - } - return 0; -} - -my %cf=(); -my %bs=(); -my $cfc = 0; -sub process_cf -{ - foreach my $nid ( keys %cf ) { - foreach my $xchan ( keys %{$cf{$nid}} ) { - next if $xchan eq 'timeout'; - foreach my $host ( keys %{$cf{$nid}{$xchan}} ) { - next unless defined $cf{$nid}{$xchan}{$host}[0]; - while ( time >= $cf{$nid}{$xchan}{$host}[0] + $cf{$nid}{'timeout'} ) { - shift ( @{$cf{$nid}{$xchan}{$host}} ); - if ( (scalar @{$cf{$nid}{$xchan}{$host}}) == 0 ) { - delete $cf{$nid}{$xchan}{$host}; - last; - } -# last if ( $#{ $cf{$nid}{$xchan}{$host} } == 0 ); -# shift ( @{$cf{$nid}{$xchan}{$host}} ); - } - } - } - } -} - -sub splitflood { - my ($chk, $id, $event, $chan) = @_; - my $text; - my @cut = split(/:/, $chk->{content}); - $cf{$id}{timeout}=int($cut[1]); - if ($event->{type} =~ /^(public|notice|part|caction)$/) { - $text=$event->{args}->[0]; - } - return unless defined($text); - # a bit ugly but this should avoid alerting on spammy bot commands - # give them the benefit of the doubt if they talked before ... but not too recently - # if we didn't see them join, assume they did talk at some point - my $msgtime = $::sc{$chan}{users}{lc $event->{nick}}{msgtime} // 0; - $msgtime ||= 1 if !$::sc{$chan}{users}{lc $event->{nick}}{jointime}; - return if $text =~ /^[^\w\s]+\w+\s*$/ && $msgtime && ($msgtime + 2 * $cf{$id}{timeout}) < time; -# return unless length($text) >= 10; - if (defined($bs{$id}{$text}) && (time <= $bs{$id}{$text} + 600)) { - return 1; - } - push( @{$cf{$id}{$chan}{$text}}, time ); - while ( time >= $cf{$id}{$chan}{$text}[0] + $cf{$id}{'timeout'} ) { - last if ( $#{$cf{$id}{$chan}{$text}} == 0 ); - shift ( @{$cf{$id}{$chan}{$text}} ); - } - $cfc = $cfc + 1; - if ( $cfc >= 100 ) { - $cfc = 0; - process_cf(); - } - if ( scalar @{$cf{$id}{$chan}{$text}} == int($cut[0]) ) { - $bs{$id}{$text} = time unless length($text) < 10; - return 1; - } - return 0; -} - -sub advsplitflood { - my ($chk, $id, $event, $chan) = @_; - my $text; - my @cut = split(/:/, $chk->{content}); - $cf{$id}{timeout}=int($cut[1]); - if ($event->{type} =~ /^(public|notice|part|caction)$/) { - $text=$event->{args}->[0]; - } - return unless defined($text); - $text=~s/^\d*(.*)\d*$/$1/; - return unless length($text) >= 10; - if (defined($bs{$id}{$text}) && (time <= $bs{$id}{$text} + 600)) { - return 1; - } - push( @{$cf{$id}{$chan}{$text}}, time ); - while ( time >= $cf{$id}{$chan}{$text}[0] + $cf{$id}{'timeout'} ) { - last if ( $#{$cf{$id}{$chan}{$text}} == 0 ); - shift ( @{$cf{$id}{$chan}{$text}} ); - } - $cfc = $cfc + 1; - if ( $cfc >= 100 ) { - $cfc = 0; - process_cf(); - } - if ( scalar @{$cf{$id}{$chan}{$text}} == int($cut[0]) ) { - $bs{$id}{$text} = time; - return 1; - } - return 0; -} - -sub re { - my ($chk, $id, $event, $chan) = @_; - my $match = $event->{args}->[0]; - $match = $event->{nick} if ($event->{type} eq 'join'); - return 1 if ($match =~ /$chk->{content}/); - return 0; -} - -sub strbl { - my ($chk, $id, $event, $chan) = @_; - my $match = lc $event->{args}->[0]; - foreach my $line (@::string_blacklist) { - my $xline = lc $line; - my $idx = index $match, $xline; - if ( $idx != -1 ) { - return 1; - } - } - return 0; -} - -sub strblnew { - my ($chk, $xid, $event, $chan) = @_; - my $match = lc $event->{args}->[0]; - foreach my $id (keys %{$::blacklist->{string}}) { - my $line = lc $::blacklist->{string}->{$id}->{content}; - my $idx = index $match, $line; - if ( $idx != -1 ) { - my $setby = $::blacklist->{string}->{$id}->{setby}; - $setby = substr($setby, 0, 1) . "\x02\x02" . substr($setby, 1); - return defined($::blacklist->{string}->{$id}->{reason}) ? - "id $id added by $setby because $::blacklist->{string}->{$id}->{reason}" : - "id $id added by $setby for no reason"; - } - } - return 0; -} - -sub nick { - my ($chk, $id, $event, $chan) = @_; - if ( lc $event->{nick} eq lc $chk->{content} ) { - return 1; - } - return 0; -} - -sub ident { - my ( $chk, $id, $event, $chan) = @_; - if ( lc $event->{user} eq lc $chk->{content} ) { - return 1; - } - return 0; -} - -sub host { - my ( $chk, $id, $event, $chan) = @_; - if ( lc $event->{host} eq lc $chk->{content} ) { - return 1; - } - return 0; -} - -sub gecos { - my ( $chk, $id, $event, $chan) = @_; - if ( lc $::sn{lc $event->{nick}}->{gecos} eq lc $chk->{content} ) { - return 1; - } - return 0; -} - -sub nuhg { - my ( $chk, $id, $event, $chan) = @_; - return 0 unless defined($::sn{lc $event->{nick}}->{gecos}); - my $match = $event->{from} . '!' . $::sn{lc $event->{nick}}->{gecos}; - return 1 if ($match =~ /$chk->{content}/); - return 0; -} - -sub invite { - my ( $chk, $id, $event, $chan) = @_; - return 1; -} - -my $sfc = 0; - -sub flood_add -{ - my ( $chan, $id, $host, $to ) = @_; - push( @{$sf{$id}{$chan}{$host}}, time ); - while ( time >= $sf{$id}{$chan}{$host}[0] + $to ) { - last if ( $#{ $sf{$id}{$chan}{$host} } == 0 ); - shift( @{$sf{$id}{$chan}{$host}} ); - } - $sf{$id}{'timeout'} = $to; - $sfc = $sfc + 1; - if ($sfc > 100) { - $sfc = 0; - flood_process(); - } -# return $#{ @{$sf{$id}{$chan}{$host}}}+1; - return scalar @{$sf{$id}{$chan}{$host}}; -} - -sub flood_process -{ - for my $id ( keys %sf ) { - for my $chan ( keys %{$sf{$id}} ) { - next if $chan eq 'timeout'; - for my $host ( keys %{$sf{$id}{$chan}} ) { - next unless defined $sf{$id}{$chan}{$host}[0]; - while ( time >= $sf{$id}{$chan}{$host}[0] + $sf{$id}{'timeout'} ) { - shift ( @{$sf{$id}{$chan}{$host}} ); - if ( (scalar @{$sf{$id}{$chan}{$host}}) == 0 ) { - delete $sf{$id}{$chan}{$host}; - last; - } -# last if ( $#{ $sf{$id}{$chan}{$host} } == 0 ); -# shift ( @{$sf{$id}{$chan}{$host}} ); - } - } - } - } -} - -sub dump -{ - #%sf, %ls, %cf, %bs - open(FH, ">", "sf.txt"); - print FH Dumper(\%sf); - close(FH); - open(FH, ">", "ls.txt"); - print FH Dumper(\%ls); - close(FH); - open(FH, ">", "cf.txt"); - print FH Dumper(\%cf); - close(FH); - open(FH, ">", "bs.txt"); - print FH Dumper(\%bs); - close(FH); -} - -1; diff --git a/modules/command.pl b/modules/command.pl deleted file mode 100644 index aa79f4d..0000000 --- a/modules/command.pl +++ /dev/null @@ -1,61 +0,0 @@ -package ASM::Commander; - -use warnings; -use strict; -use IO::All; -use POSIX qw(strftime); -use Data::Dumper; -use URI::Escape; - -sub new -{ - my $module = shift; - my $self = {}; - bless($self); - return $self; -} - -sub command -{ - my ($self, $conn, $event) = @_; - my $args = $event->{args}->[0]; - my $from = $event->{from}; - my $cmd = $args; - my $d1; - my $nick = lc $event->{nick}; - my $acct = lc $::sn{$nick}->{account}; -# return 0 unless (ASM::Util->speak($event->{to}->[0])); - foreach my $command ( @{$::commands->{command}} ) - { - my $fail = 0; - unless ( (ASM::Util->speak($event->{to}->[0])) ) { - next unless (defined($command->{nohush}) && ($command->{nohush} eq "nohush")); - } - if (defined($command->{flag})) { #If the command is restricted, - if (!defined($::users->{person}->{$acct})) { #make sure the requester has an account - $fail = 1; - } - elsif (!defined($::users->{person}->{$acct}->{flags})) { #make sure the requester has flags defined - $fail = 1; - } - elsif (!(grep {$_ eq $command->{flag}} split('', $::users->{person}->{$acct}->{flags}))) { #make sure the requester has the needed flags - $fail = 1; - } - } - if ($cmd=~/$command->{cmd}/) { - ASM::Util->dprint("$event->{from} told me: $cmd", "commander"); - if (!ASM::Util->notRestricted($nick, "nocommands")) { - $fail = 1; - } - if ($fail == 1) { - $conn->privmsg($nick, "You don't have permission to use that command, or you're not signed into nickserv."); - } else { - eval $command->{content}; - warn $@ if $@; - } - last; - } - } -} - -1; diff --git a/modules/event.pl b/modules/event.pl deleted file mode 100644 index e6f4c23..0000000 --- a/modules/event.pl +++ /dev/null @@ -1,887 +0,0 @@ -package ASM::Event; -use warnings; -use strict; - -use Data::Dumper; -use Text::LevenshteinXS qw(distance); -use IO::All; -use POSIX qw(strftime); -use Regexp::Wildcards; -use HTTP::Request; - -sub cs { - my ($chan) = @_; - $chan = lc $chan; - $chan =~ s/^[@+]//; - return $::channels->{channel}->{$chan} if ( defined($::channels->{channel}->{$chan}) ); - return $::channels->{channel}->{default}; -} - -sub maxlen { - my ($a, $b) = @_; - my ($la, $lb) = (length($a), length($b)); - return $la if ($la > $lb); - return $lb; -} - -sub new -{ - my $module = shift; - my ($conn, $inspector) = @_; - my $self = {}; - $self->{CONN} = $conn; - $self->{INSPECTOR} = $inspector; - ASM::Util->dprint('Installing handler routines...', 'startup'); - $conn->add_default_handler(\&blah); - $conn->add_handler('bannedfromchan', \&on_bannedfromchan); - $conn->add_handler('mode', \&on_mode); - $conn->add_handler('join', \&on_join); - $conn->add_handler('part', \&on_part); - $conn->add_handler('quit', \&on_quit); - $conn->add_handler('nick', \&on_nick); - $conn->add_handler('notice', \&on_notice); - $conn->add_handler('caction', \&on_public); - $conn->add_handler('msg', \&on_msg); - $conn->add_handler('namreply', \&on_names); - $conn->add_handler('endofnames', \&on_names); - $conn->add_handler('public', \&on_public); - $conn->add_handler('376', \&on_connect); - $conn->add_handler('topic', \&irc_topic); - $conn->add_handler('topicinfo', \&irc_topic); - $conn->add_handler('nicknameinuse', \&on_errnickinuse); - $conn->add_handler('bannickchange', \&on_bannickchange); - $conn->add_handler('kick', \&on_kick); - $conn->add_handler('cping', \&on_ctcp); - $conn->add_handler('cversion', \&on_ctcp); - $conn->add_handler('csource', \&on_ctcp_source); - $conn->add_handler('ctime', \&on_ctcp); - $conn->add_handler('cdcc', \&on_ctcp); - $conn->add_handler('cuserinfo', \&on_ctcp); - $conn->add_handler('cclientinfo', \&on_ctcp); - $conn->add_handler('cfinger', \&on_ctcp); - $conn->add_handler('354', \&on_whoxreply); - $conn->add_handler('315', \&on_whoxover); - $conn->add_handler('263', \&on_whofuckedup); - $conn->add_handler('account', \&on_account); - $conn->add_handler('ping', \&on_ping); - $conn->add_handler('banlist', \&on_banlist); - $conn->add_handler('dcc_open', \&dcc_open); - $conn->add_handler('chat', \&on_dchat); - $conn->add_handler('channelmodeis', \&on_channelmodeis); - $conn->add_handler('quietlist', \&on_quietlist); - $conn->add_handler('pong', \&on_pong); - $conn->add_handler('statsdebug', \&on_statsdebug); - $conn->add_handler('endofstats', \&on_endofstats); - $conn->add_handler('channelurlis', \&on_channelurlis); - $conn->add_handler('480', \&on_jointhrottled); - $conn->add_handler('invite', \&blah); # This doesn't need to be fancy; I just need it to go through inspect - bless($self); - return $self; -} - -my $clearstatsp = 1; -my %statsp = (); -my %oldstatsp = (); - -sub on_jointhrottled -{ - my ($conn, $event) = @_; - my $chan = $event->{args}->[1]; - ASM::Util->dprint("$event->{nick}: $chan: $event->{args}->[2]", 'snotice'); - if ($event->{args}->[2] =~ /throttle exceeded, try again later/) { - $conn->schedule(5, sub { $conn->join($chan); }); - } -} - -sub on_statsdebug -{ - my ($conn, $event) = @_; - my ($char, $line) = ($event->{args}->[1], $event->{args}->[2]); - if ($char eq 'p') { - if ($clearstatsp) { - $clearstatsp = 0; - %oldstatsp = %statsp; - %statsp = (); - } - if ($line =~ /^(\d+) staff members$/) { - #this is the end of the report - } else { - my ($nick, $userhost) = split(" ", $line); - $userhost =~ s/\((.*)\)/$1/; - my ($user, $host) = split("@", $userhost); - $statsp{$nick}= [$user, $host]; - } - } -} - -sub on_endofstats -{ - my ($conn, $event) = @_; - if ($event->{args}->[1] eq 'p') { - $clearstatsp=1; - my $tmp = Dumper(\%statsp); chomp $tmp; - if ( join(',', sort(keys %oldstatsp)) ne join(',', sort(keys %statsp)) ) { - open(FH, '>>', 'statsplog.txt'); - say FH strftime('%F %T ', gmtime) . join(',', sort(keys %statsp)); - close(FH); - ASM::Util->dprint(join(",", keys %statsp), 'statsp'); - } - # $event->{args}->[2] == "End of /STATS report" - #end of /stats p - } -} - -my $lagcycles = 0; -my $pongcount = 0; - -sub on_pong -{ - my ($conn, $event) = @_; - alarm 120; - $conn->schedule( 30, sub { $conn->sl("PING :" . time); } ); - ASM::Util->dprint('Pong? ... Ping!', 'pingpong'); - my $lag = time - $event->{args}->[0]; - my @changes = $::fm->scan(); - if (@changes) { - if ($::settingschanged) { - $::settingschanged = 0; - } else { - $conn->privmsg($::settings->{masterchan}, "Config files changed, auto rehash triggered. Check console for possible errors."); - ASM::XML->readXML(); - my @strbl = io('string_blacklist.txt')->getlines; - chomp @strbl; - @::string_blacklist = @strbl; - } - } - if ($lag > 1) { - ASM::Util->dprint("Latency: $lag", 'latency'); - } - if (($pongcount % 3) == 0) { #easiest way to do something roughly every 90 seconds - $conn->sl('STATS p'); - } - if ((time - $::starttime) < 240 ) { - return; #we don't worry about lag if we've just started up and are still syncing etc. - } - if (($lag > 2) && ($lag < 5)) { - $conn->privmsg( $::settings->{masterchan}, "Warning: I'm currently lagging by $lag seconds."); - } - if ($lag >= 5) { - $lagcycles++; - if ($lagcycles >= 3) { - $conn->quit("Automatic restart triggered due to persistent lag. Freenode staff: If this is happening too frequently, please " . - "set a nickserv freeze on my account, and once my connection is stable, unfreeze the account and /kill me to tri" . - "gger a reconnect."); - } else { - $conn->privmsg( $::settings->{masterchan}, "Warning: I'm currently lagging by $lag seconds. This marks heavy lag cycle " . - "$lagcycles - automatic restart will be triggered after 3 lag cycles." ); - } - } - if (($lag <= 5) && ($lagcycles > 0)) { - $lagcycles--; -# $conn->privmsg( $::settings->{masterchan}, "Warning: Heavy lag cycle count has been reduced to $lagcycles" ); - ASM::Util->dprint('$lag = ' . $lag . '; $lagcycles = ' . $lagcycles, 'latency'); - } -} - -sub on_dchat -{ - my ($conn, $event) = @_; - ASM::Util->dprint(Dumper($event), 'dcc'); - if ( #(lc $event->{nick} eq 'afterdeath') && - ($event->{args}->[0] ne '')) { - my $msg = $event->{args}->[0]; - if ($msg =~ /^SPY (.*)/) { - my $chan = $1; - $::spy{lc $chan} = $event->{to}[0]; - } elsif ($msg =~ /^STOPSPY (.*)/) { - delete $::spy{lc $1}; - } elsif ($msg =~ /^RETRIEVE (\S+)/) { - my $chan = lc $1; - my $out = $event->{to}[0]; - my @time = ($::settings->{log}->{zone} eq 'local') ? localtime : gmtime; - say $out 'Retrieving ' . "$::settings->{log}->{dir}${chan}/${chan}" . strftime($::settings->{log}->{filefmt}, @time); - open(FHX, "$::settings->{log}->{dir}${chan}/${chan}" . strftime($::settings->{log}->{filefmt}, @time)); - while () { - print $out $_; - } - close FHX; - } - #lols we gots a chat message! :D - } -} - -sub on_ping -{ - my ($conn, $event) = @_; - $conn->sl("PONG " . $event->{args}->[0]); -# alarm 200; - ASM::Util->dprint('Ping? Pong!', 'pingpong'); -# ASM::Util->dprint(Dumper($event), 'pingpong'); -} - -sub on_account -{ - my ($conn, $event) = @_; - $::sn{lc $event->{nick}}{account} = lc $event->{args}->[0]; -} - -sub on_connect { - my ($conn, $event) = @_; # need to check for no services - $conn->sl("MODE $event->{args}->[0] +Q"); - if (lc $event->{args}->[0] ne lc $::settings->{nick}) { - ASM::Util->dprint('Attempting to regain my main nick', 'startup'); - $conn->privmsg( 'NickServ@services.', "regain $::settings->{nick} $::settings->{pass}" ); - } - $conn->sl('CAP REQ :extended-join multi-prefix account-notify'); #god help you if you try to use this bot off freenode -} - -sub on_join { - my ($conn, $event) = @_; - my $nick = lc $event->{nick}; - my $chan = lc $event->{to}->[0]; - my $rate; -# alarm 200; - if ( lc $conn->{_nick} eq lc $nick) { - $::sc{$chan} = {}; - mkdir($::settings->{log}->{dir} . $chan); - $::synced{$chan} = 0; - unless ( @::syncqueue ) { - $conn->sl('who ' . $chan . ' %tcnuhra,314'); - $conn->sl('mode ' . $chan); - $conn->sl('mode ' . $chan . ' bq'); - } - push @::syncqueue, $chan; - } - $::sc{$chan}{users}{$nick} = {}; - $::sc{$chan}{users}{$nick}{hostmask} = $event->{userhost}; - $::sc{$chan}{users}{$nick}{op} = 0; - $::sc{$chan}{users}{$nick}{voice} = 0; - $::sc{$chan}{users}{$nick}{jointime} = time; - $::sc{$chan}{users}{$nick}{msgtime} = 0; - if (defined($::sn{$nick})) { - my @mship = (); - if (defined($::sn{$nick}->{mship})) { - @mship = @{$::sn{$nick}->{mship}}; - } - @mship = (@mship, $chan); - $::sn{$nick}->{mship} = \@mship; - } else { - $::sn{$nick} = {}; - $::sn{$nick}->{mship} = [ $chan ]; - } - $::sn{$nick}->{dnsbl} = 0; - $::sn{$nick}->{netsplit} = 0; - $::sn{$nick}->{gecos} = $event->{args}->[1]; - $::sn{$nick}->{user} = $event->{user}; - $::sn{$nick}->{host} = $event->{host}; - $::sn{$nick}->{account} = lc $event->{args}->[0]; - $::db->logg($event) if defined $::db; - $::log->logg( $event ); - $::inspector->inspect( $conn, $event ) unless $::netsplit; -} - -sub on_part -{ - my ($conn, $event) = @_; - my $nick = lc $event->{nick}; - my $chan = lc $event->{to}->[0]; - $::log->logg( $event ); - $::db->logg( $event ) if defined $::db; - if (defined $::db and $event->{args}->[0] =~ /^requested by/) { - my $idx = $::db->actionlog( $event); - $::log->sqlIncident($chan, $idx) if $idx; - } -# "to" => [ "#antispammeta" ], -# "args" => [ "requested by ow (test)" ], -# "nick" => "aoregcdu", - $::inspector->inspect( $conn, $event ); - if (defined($::sn{$nick}) && defined($::sn{$nick}->{mship})) { - my @mship = @{$::sn{$nick}->{mship}}; - @mship = grep { lc $_ ne $chan } @mship; - if ( @mship ) { - $::sn{$nick}->{mship} = \@mship; - } else { - delete($::sn{$nick}); - } - } - if ( lc $conn->{_nick} eq $nick ) - { - delete( $::sc{$chan} ); - on_byechan($chan); - } - else - { - delete( $::sc{$chan}{users}{$nick} ); - } -} - -sub on_msg -{ - my ($conn, $event) = @_; - $::commander->command($conn, $event); - ASM::Util->dprint($event->{from} . " - " . $event->{args}->[0], 'msg'); - if ((ASM::Util->notRestricted($event->{nick}, "nomsgs")) && ($event->{args}->[0] !~ /^;;/)) { -# disabled by DL 130513 due to spammer abuse -# $conn->privmsg($::settings->{masterchan}, $event->{from} . ' told me: ' . $event->{args}->[0]); - } -} - -sub on_public -{ - my ($conn, $event) = @_; -# alarm 200; - my $chan = lc $event->{to}[0]; - $chan =~ s/^[+@]//; - $::log->logg( $event ); - $::db->logg( $event ) if defined $::db; - if ($event->{args}->[0] =~ /(https?:\/\/bitly.com\/\w+|https?:\/\/bit.ly\/\w+|https?:\/\/j.mp\/\w+|https?:\/\/tinyurl.com\/\w+)/i) { - my $reqid = $::async->add( HTTP::Request->new( GET => $1 ) ); - $::httpRequests{$reqid} = $event; - my ($response, $id) = $::async->wait_for_next_response( 1 ); - if (defined($response)) { - on_httpResponse($conn, $id, $response); - } - else { $conn->schedule( 1, sub { checkHTTP($conn); } ); } - } - $::inspector->inspect( $conn, $event ); - $::commander->command( $conn, $event ); - $::sc{$chan}{users}{lc $event->{nick}}{msgtime} = time; -} - -sub checkHTTP -{ - my ($conn) = @_; - my ($response, $id) = $::async->next_response(); - if (defined ($response)) { - on_httpResponse($conn, $id, $response); - } - $conn->schedule( 1, sub { checkHTTP($conn); } ); -} - -sub on_httpResponse -{ - my ($conn, $id, $response) = @_; - my $event = $::httpRequests{$id}; - delete $::httpRequests{$id}; - $::inspector->inspect( $conn, $event, $response ); -} -# if ($response->{_previous}->{_headers}->{location} =~ /^https?:\/\/bitly.com\/a\/warning/) - -sub on_notice -{ - my ($conn, $event) = @_; - return if ( $event->{to}->[0] eq '$*' ); # if this is a global notice FUCK THAT SHIT - $::log->logg( $event ); - $::db->logg( $event ) if defined $::db; - $::inspector->inspect( $conn, $event ); - $::services->doServices($conn, $event); -} - -sub on_errnickinuse -{ - my ($conn, $event) = @_; - $_ = ${$::settings->{altnicks}}[rand @{$::settings->{altnicks}}]; - ASM::Util->dprint("Nick is in use, trying $_", 'startup'); - $conn->nick($_); -} - -sub on_bannickchange -{ - my ($conn, $event) = @_; - $_ = ${$::settings->{altnicks}}[rand @{$::settings->{altnicks}}]; - ASM::Util->dprint("Nick is in use, trying $_", 'startup'); - $conn->nick($_); -} - -sub on_quit -{ - my ($conn, $event) = @_; - my @channels=(); - for ( keys %::sc ) { - push ( @channels, lc $_ ) if delete $::sc{lc $_}{users}{lc $event->{nick}}; - } - $event->{to} = \@channels; - if (defined $::db) { - my $idx = $::db->actionlog($event); - $::log->sqlIncident( join(',', @channels), $idx ) if $idx; - $::db->logg( $event ); - } - $::log->logg( $event ); - - if (($::netsplit == 0) && ($event->{args}->[0] eq "*.net *.split") && (lc $event->{nick} ne 'chanserv')) { #special, netsplit situation - $conn->privmsg($::settings->{masterchan}, "Entering netsplit mode - JOIN and QUIT inspection will be disabled for 60 minutes"); - $::netsplit = 1; - $conn->schedule(60*60, sub { $::netsplit = 0; $conn->privmsg($::settings->{masterchan}, 'Returning to regular operation'); }); - } - $::inspector->inspect( $conn, $event ) unless $::netsplit; - #ugh. Repurge some shit, hopefully this will fix some stuff where things are going wrong - foreach my $chan ( keys %::sc ) { - delete $::sc{$chan}{users}{lc $event->{nick}}; - } - delete($::sn{lc $event->{nick}}); -} - -sub blah -{ - my ($self, $event) = @_; - ASM::Util->dprint(Dumper($event), 'misc'); - $::inspector->inspect($self, $event); -} - -sub irc_users -{ - my ( $channel, @users ) = @_; - for (@users) - { - my ( $op, $voice ); - $op = 0; $voice = 0; - $op = 1 if s/^\@//; - $voice = 1 if s/^\+//; - $::sc{lc $channel}{users}{lc $_} = {}; - $::sc{lc $channel}{users}{lc $_}{op} = $op; - $::sc{lc $channel}{users}{lc $_}{voice} = $voice; - $::sc{lc $channel}{users}{lc $_}{jointime} = 0; - } -} - -sub on_names { - my ($conn, $event) = @_; - irc_users( $event->{args}->[2], split(/ /, $event->{args}->[3]) ) if ($event->{type} eq 'namreply'); -} - -sub irc_topic { - my ($conn, $event) = @_; - if ($event->{format} eq 'server') - { - my $chan = lc $event->{args}->[1]; - if ($event->{type} eq 'topic') - { - $::sc{$chan}{topic}{text} = $event->{args}->[2]; - } - elsif ($event->{type} eq 'topicinfo') - { - $::sc{$chan}{topic}{time} = $event->{args}->[3]; - $::sc{$chan}{topic}{by} = $event->{args}->[2]; - } - } - else - { - if ($event->{type} eq 'topic') - { - my $chan = lc $event->{to}->[0]; - $::sc{$chan}{topic}{text} = $event->{args}->[0]; - $::sc{$chan}{topic}{time} = time; - $::sc{$chan}{topic}{by} = $event->{from}; - } - $::log->logg($event); - $::db->logg( $event ) if defined $::db; - $::inspector->inspect($conn, $event); - } -} - -sub on_nick { - my ($conn, $event) = @_; - my @channels=(); - my $oldnick = lc $event->{nick}; - my $newnick = lc $event->{args}->[0]; - foreach my $chan ( keys %::sc ) - { - $chan = lc $chan; - if ( defined $::sc{$chan}{users}{$oldnick} ) - { - if ($oldnick ne $newnick) { #otherwise a nick change where they're only - #changing the case of their nick means that - #ASM forgets about them. - $::sc{$chan}{users}{$newnick} = $::sc{$chan}{users}{$oldnick}; - delete( $::sc{$chan}{users}{$oldnick} ); - } - push ( @channels, $chan ); - } - } - - # unfortunately Net::IRC sucks at IRC so we have to implement this ourselves - if ($oldnick eq lc $conn->{_nick}) { - $conn->{_nick} = $event->{args}[0]; - } - - $::sn{$newnick} = $::sn{$oldnick} if ($oldnick ne $newnick); - $::db->logg( $event ) if defined $::db; - delete( $::sn{$oldnick}) if ($oldnick ne $newnick); - $event->{to} = \@channels; - $::log->logg($event); - # Well, the nick change actually was done from the old nick ... but - # by the time we process it, they already changed nicks. Therefore - # we'll pretend it's the *new* nick that generated the event. - $event->{nick} = $event->{args}[0]; - $::inspector->inspect($conn, $event); -} - -sub on_kick { - my ($conn, $event) = @_; - if (lc $event->{to}->[0] eq lc $::settings->{nick}) { - $conn->privmsg($::settings->{masterchan}, "I've been kicked from " . $event->{args}->[0] . ": " . $event->{args}->[1]); -# $conn->join($event->{args}->[0]); - } - my $nick = lc $event->{to}->[0]; - my $chan = lc $event->{args}->[0]; - $::log->logg( $event ); - if (defined $::db) { - $::db->logg( $event ); - my $idx = $::db->actionlog($event); - $::log->sqlIncident($chan, $idx) if $idx; - } - if (defined($::sn{$nick}) && defined($::sn{$nick}->{mship})) { - my @mship = @{$::sn{$nick}->{mship}}; - @mship = grep { lc $_ ne $chan } @mship; - if ( @mship ) { - $::sn{$nick}->{mship} = \@mship; - } else { - delete($::sn{$nick}); - } - } - if ( lc $conn->{_nick} eq $nick ) - { - delete( $::sc{lc $event->{args}->[0]} ); - on_byechan(lc $event->{to}->[0]); - } - else - { - delete( $::sc{lc $event->{args}->[0]}{users}{$nick} ); - } -} - -sub parse_modes -{ - my ( $n ) = @_; - my @args = @{$n}; - my @modes = split '', shift @args; - my @new_modes=(); - my $t; - foreach my $c ( @modes ) { - if (($c eq '-') || ($c eq '+')) { - $t=$c; - } - else { #eIbq,k,flj,CFLMPQcgimnprstz - if ($t eq '+') { - if ( grep( /[eIbqkfljov]/,($c) ) ) { #modes that take args WHEN BEING ADDED - push (@new_modes, [$t.$c, shift @args]); - } - elsif ( grep( /[CFLMPQcgimnprstz]/, ($c) ) ) { - push (@new_modes, [$t.$c]); - } - else { - die "Unknown mode $c !\n"; - } - } else { - if ( grep( /[eIbqov]/,($c) ) ) { #modes that take args WHEN BEING REMOVED - push (@new_modes, [$t.$c, shift @args]); - } - elsif ( grep( /[CFLMPQcgimnprstzkflj]/, ($c) ) ) { - push (@new_modes, [$t.$c]); - } - else { - die "Unknown mode $c !\n"; - } - } - } - } - return \@new_modes; -} - -sub on_channelmodeis -{ - my ($conn, $event) = @_; - my $chan = lc $event->{args}->[1]; - my @temp = @{$event->{args}}; - shift @temp; shift @temp; - my @modes = @{parse_modes(\@temp)}; - foreach my $line ( @modes ) { - my @ex = @{$line}; - my ($what, $mode) = split (//, $ex[0]); - if ($what eq '+') { - if (defined($ex[1])) { - push @{$::sc{$chan}{modes}}, $mode . ' ' . $ex[1]; - } else { - push @{$::sc{$chan}{modes}}, $mode; - } - } else { - my @modes = grep {!/^$mode/} @{$::sc{$chan}{modes}}; - $::sc{$chan}{modes} = \@modes; - } - } -} - -sub whoGotHit -{ - my ($chan, $mask) = @_; - my $cvt = Regexp::Wildcards->new(type => 'jokers'); - my @affected = (); - if ($mask !~ /^\$/) { - my @div = split(/\$/, $mask); - my $regex = $cvt->convert($div[0]); - foreach my $nick (keys %::sn) { - next unless defined($::sn{$nick}{user}); - if (lc ($nick.'!'.$::sn{$nick}{user}.'@'.$::sn{$nick}{host}) =~ /^$regex$/i) { - push @affected, $nick if defined($::sc{$chan}{users}{$nick}); - } - } - } elsif ($mask =~ /^\$a:(.*)/) { - my @div = split(/\$/, $1); - my $regex = $cvt->convert($div[0]); - foreach my $nick (keys %::sn) { - next unless defined($::sn{$nick}{account}); - if (lc ($::sn{$nick}{account}) =~ /^$regex$/i) { - push @affected, $nick if defined($::sc{$chan}{users}{$nick}); - } - } - } - return @affected; -} - -sub on_mode -{ - my ($conn, $event) = @_; - my $chan = lc $event->{to}->[0]; -# holy shit, I feel so bad doing this -# I have no idea how or why Net::IRC fucks up modes if they've got a ':' in one of the args -# but you do what you must... - my @splitted = split(/ /, $::lastline); shift @splitted; shift @splitted; shift @splitted; - $event->{args}=\@splitted; - if ($chan =~ /^#/) { - my @modes = @{parse_modes($event->{args})}; - ASM::Util->dprint(Dumper(\@modes), 'misc'); - foreach my $line ( @modes ) { - my @ex = @{$line}; - - if ( $ex[0] eq '+o' ) { $::sc{$chan}{users}{lc $ex[1]}{op} = 1; } - elsif ( $ex[0] eq '-o' ) { $::sc{$chan}{users}{lc $ex[1]}{op} = 0; } - elsif ( $ex[0] eq '+v' ) { $::sc{$chan}{users}{lc $ex[1]}{voice} = 1; } - elsif ( $ex[0] eq '-v' ) { $::sc{$chan}{users}{lc $ex[1]}{voice} = 0; } - - elsif ( $ex[0] eq '+b' ) { - $::sc{$chan}{bans}{$ex[1]} = { bannedBy => $event->{from}, bannedOn => time }; - if (lc $event->{nick} !~ /^(floodbot)/) { #ignore the ubuntu floodbots 'cause they quiet people a lot - my @affected = whoGotHit($chan, $ex[1]); - if ( defined($::db) && (@affected) && (scalar @affected <= 4) ) { - foreach my $victim (@affected) { - my $idx = $::db->actionlog($event, 'ban', $victim); - $::log->sqlIncident( $chan, $idx ) if $idx; - } - } - if ($ex[1] =~ /^\*\!\*\@(.*)$/) { - my $ip = ASM::Util->getHostIP($1); - $::sc{$chan}{ipbans}{$ip} = { bannedBy => $event->{from}, bannedOn => time } if defined($ip); - } - } - } - elsif ( $ex[0] eq '-b' ) { - delete $::sc{$chan}{bans}{$ex[1]}; - if ($ex[1] =~ /^\*\!\*\@(.*)$/) { - my $ip = ASM::Util->getHostIP($1); - delete $::sc{$chan}{ipbans}{$ip} if defined($ip); - } - } - - elsif ( $ex[0] eq '+q' ) { - $::sc{$chan}{quiets}{$ex[1]} = { bannedBy => $event->{from}, bannedOn => time }; - if (lc $event->{nick} !~ /^(floodbot)/) { - my @affected = whoGotHit($chan, $ex[1]); - if ( defined($::db) && (@affected) && (scalar @affected <= 4) ) { - foreach my $victim (@affected) { - my $idx = $::db->actionlog($event, 'quiet', $victim); - $::log->sqlIncident( $chan, $idx ) if $idx; - } - } - if ($ex[1] =~ /^\*\!\*\@(.*)$/) { - my $ip = ASM::Util->getHostIP($1); - $::sc{$chan}{ipquiets}{$ip} = { bannedBy => $event->{from}, bannedOn => time } if defined($ip); - } - } - } - elsif ( $ex[0] eq '-q' ) { - delete $::sc{$chan}{quiets}{$ex[1]}; - if ($ex[1] =~ /^\*\!\*\@(.*)$/) { - my $ip = ASM::Util->getHostIP($1); - delete $::sc{$chan}{ipquiets}{$ip} if defined($ip); - } - } - - else { - my ($what, $mode) = split (//, $ex[0]); - if ($what eq '+') { - if (defined($ex[1])) { push @{$::sc{$chan}{modes}}, $mode . ' ' . $ex[1]; } - else { push @{$::sc{$chan}{modes}}, $mode; } - } else { - my @modes = grep {!/^$mode/} @{$::sc{$chan}{modes}}; - $::sc{$chan}{modes} = \@modes; - } - if ( ($ex[0] eq '+r') && (! defined($::watchRegged{$chan})) ) { - $::watchRegged{$chan} = 1; - $conn->schedule(60*45, sub { checkRegged($conn, $chan); }); - } - } - } - $::log->logg($event); - } -} - -sub checkRegged -{ - my ($conn, $chan) = @_; - if (grep {/^r/} @{$::sc{$chan}{modes}} - and not ((defined($::channels->{channel}{$chan}{monitor})) and ($::channels->{channel}{$chan}{monitor} eq "no")) ) - { - my $tgt = $chan; - my $risk = "debug"; - my $hilite=ASM::Util->commaAndify(ASM::Util->getAlert($tgt, $risk, 'hilights')); - my $txtz ="\x03" . $::RCOLOR{$::RISKS{$risk}} . "\u$risk\x03 risk threat [\x02$chan\x02] - channel appears to still be +r after 45 minutes; ping $hilite !att-$chan-$risk"; - my @tgts = ASM::Util->getAlert($tgt, $risk, 'msgs'); - ASM::Util->sendLongMsg($conn, \@tgts, $txtz) - } - delete $::watchRegged{$chan}; -} - -sub on_banlist -{ - my ($conn, $event) = @_; - my ($me, $chan, $ban, $banner, $bantime) = @{$event->{args}}; - $::sc{lc $chan}{bans}{$ban} = { bannedBy => $banner, bannedOn => $bantime }; - if ($ban =~ /^\*\!\*\@((([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9]))$/) { - # ASM::Util->dprint("banlist hostname $ban $1", 'sync'); - my $ip = ASM::Util->getHostIP($1); - $::sc{lc $chan}{ipbans}{$ip} = { bannedBy => $banner, bannedOn => $bantime } if defined($ip); - } -} - -sub on_quietlist -{ - my ($conn, $event) = @_; - my ($me, $chan, $mode, $ban, $banner, $bantime) = @{$event->{args}}; - $::sc{lc $chan}{quiets}{$ban} = { bannedBy => $banner, bannedOn => $bantime }; - if ($ban =~ /^\*\!\*\@((([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9]))$/) { - # ASM::Util->dprint("quietlist hostname $ban $1", 'sync'); - my $ip = ASM::Util->getHostIP($1); - $::sc{lc $chan}{ipquiets}{$ip} = { bannedBy => $banner, bannedOn => $bantime } if defined($ip); - } -} - -sub on_channelurlis -{ - my ($conn, $event) = @_; - $::sc{lc $event->{args}->[1]}{url} = $event->{args}->[2]; -} - -sub on_ctcp -{ - my ($conn, $event) = @_; - my $acct = lc $::sn{lc $event->{nick}}->{account}; - ASM::Util->dprint(Dumper($event), 'ctcp'); - if (($event->{type} eq 'cdcc') && - (defined($::users->{person}->{$acct})) && - (defined($::users->{person}->{$acct}->{flags})) && - (grep {$_ eq 'c'} split('', $::users->{person}->{$acct}->{flags}))) { - ASM::Util->dprint(Dumper($event), 'dcc'); - my @spit = split(/ /, $event->{args}->[0]); - if (($spit[0] eq 'CHAT') && ($spit[1] eq 'CHAT')) { - $::chat = Net::IRC::DCC::CHAT->new($conn, 0, lc $event->{nick}, $spit[2], $spit[3]); - } - } else { - $::inspector->inspect($conn, $event); - } -} - -sub dcc_open -{ - my ($conn, $event) = @_; - $::dsock{lc $event->{nick}} = $event->{args}->[1]; -} - -sub on_ctcp_source -{ - my ($conn, $event) = @_; - $conn->ctcp_reply($event->{nick}, 'SOURCE https://gitlab.devlabs.linuxassist.net/asm/antispammeta/'); -} - -sub on_whoxreply -{ - my ($conn, $event) = @_; - return unless $event->{args}->[1] eq '314'; - my ($tgt, $magic, $chan, $user, $host, $nick, $account, $gecos) = @{$event->{args}}; - $nick = lc $nick; $chan = lc $chan; - if (!defined $::sn{lc $nick}) { - $::sn{$nick} = {}; - $::sn{$nick}->{mship} = [$chan]; - } else { - $::sn{$nick}->{mship} = [grep { lc $_ ne $chan } @{$::sn{$nick}->{mship}}]; - push @{$::sn{$nick}->{mship}}, $chan; - } - $::sn{$nick}->{gecos} = $gecos; - $::sn{$nick}->{user} = $user; - $::sn{$nick}->{host} = $host; - $::sn{$nick}->{account} = lc $account; -} - -sub on_whoxover -{ - my ($conn, $event) = @_; - my $chan = pop @::syncqueue; - $::synced{lc $event->{args}->[1]} = 1; - if (defined($chan) ){ - $conn->sl('who ' . $chan . ' %tcnuhra,314'); - $conn->sl('mode ' . $chan); - $conn->sl('mode ' . $chan . ' bq'); - } else { - my $size = `ps -p $$ h -o size`; - my $cputime = `ps -p $$ h -o time`; - chomp $size; chomp $cputime; - my ($tx, $rx); - if ($conn->{_tx}/1024 > 1024) { - $tx = sprintf("%.2fMB", $conn->{_tx}/(1024*1024)); - } else { - $tx = sprintf("%.2fKB", $conn->{_tx}/1024); - } - if ($conn->{_rx}/1024 > 1024) { - $rx = sprintf("%.2fMB", $conn->{_rx}/(1024*1024)); - } else { - $rx = sprintf("%.2fKB", $conn->{_rx}/1024); - } - $conn->privmsg($::settings->{masterchan}, "Finished syncing after " . (time - $::starttime) . " seconds. " . - "I'm tracking " . (scalar (keys %::sn)) . " nicks" . - " across " . (scalar (keys %::sc)) . " tracked channels." . - " I'm using " . $size . "KB of RAM" . - ", have used " . $cputime . " of CPU time" . - ", have sent $tx of data, and received $rx of data."); - my %x = (); - foreach my $c (@{$::settings->{autojoins}}) { $x{$c} = 1; } - foreach my $cx (keys %::sc) { delete $x{$cx}; } - if (scalar (keys %x)) { - $conn->privmsg($::settings->{masterchan}, "Syncing appears to have failed for " . ASM::Util->commaAndify(keys %x)); - } - } -} - -sub on_whofuckedup -{ - my ($conn, $event) = @_; - ASM::Util->dprint('on_whofuckedup called!', 'sync'); - if ($event->{args}->[1] eq "STATS") { -#most likely this is getting called because we did stats p too often. -#unfortunately the server doesn't let us know what exactly we called stats for. -#anyways, we don't need to do anything for this - } else { #dunno why it got called, print the data and I'll add a handler for it. - ASM::Util->dprint(Dumper($event), 'sync'); - } -} - -sub on_bannedfromchan { - my ($conn, $event) = @_; - ASM::Util->dprint("I'm banned from " . $event->{args}->[1] . "... attempting to unban myself", 'startup'); - $conn->privmsg('ChanServ', "unban $event->{args}->[1]"); -} - -sub on_byechan { - my ($chan) = @_; - #TODO do del event stuff -} - -return 1; diff --git a/modules/inspect.pl b/modules/inspect.pl deleted file mode 100644 index df515dc..0000000 --- a/modules/inspect.pl +++ /dev/null @@ -1,101 +0,0 @@ -package ASM::Inspect; -use warnings; -use strict; -use feature qw(say); - -use Data::Dumper; -#use List::Util qw(first); -use String::Interpolate qw(interpolate); -use Carp qw(cluck); - -%::ignored = (); -sub new -{ - my $module = shift; - my $self = {}; - bless($self); - return $self; -} - -sub inspect { - our ($self, $conn, $event, $response) = @_; - my (%aonx, %dct, $rev, $chan, $id); - %aonx=(); %dct=(); $chan=""; $id=""; - my (@dnsbl, @uniq); - my ($match, $txtz, $iaddr); - my @override = []; - my $nick = lc $event->{nick}; - my $xresult; - return if (index($nick, ".") != -1); - if ( $event->{host} =~ /gateway\/web\// ) { - if ( $event->{user} =~ /([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})/ ) { - $rev = sprintf("%d.%d.%d.%d.", hex($4), hex($3), hex($2), hex($1)); - } - } - if ( (!defined($rev)) && ($event->{type} eq 'join') ) { -# Only doing DNS lookups for join events will mean that DNSBL will break if we try to do it on something other than joins, -# But it also means we cut back on the DNS lookups by a metric shitton - $iaddr = gethostbyname($event->{host}) if ($event->{host} !~ /\//); - $rev = join('.', reverse(unpack('C4', $iaddr))).'.' if (defined $iaddr); - } - ## NB: isn't there a better way to do this with grep, somehow? - %aonx = %{$::rules->{event}}; - foreach $chan ( @{$event->{to}} ) { - # don't do anything for channels we haven't synced yet - # because we can't yet respect stuff like notrigger for these - next unless $::synced{lc $chan}; - next unless $chan =~ /^#/; - next if ((defined($::channels->{channel}->{$chan}->{monitor})) and ($::channels->{channel}->{$chan}->{monitor} eq "no")); - foreach $id (keys %aonx) { - next unless ( grep { $event->{type} eq $_ } split(/[,:; ]+/, $aonx{$id}{type}) ); - if (defined($response)) { - if ($aonx{$id}{class} ne 'urlcrunch') { next; } #don't run our regular checks if this is being called from a URL checking function - else { $xresult = $::classes->check($aonx{$id}{class}, $aonx{$id}, $id, $event, $chan, $response); } - } - else { - $xresult = $::classes->check($aonx{$id}{class}, $aonx{$id}, $id, $event, $chan, $rev); # this is another bad hack done for dnsbl-related stuff - } - next unless (defined($xresult)) && ($xresult ne 0); - ASM::Util->dprint(Dumper($xresult), 'inspector'); - $dct{$id} = $aonx{$id}; - $dct{$id}{xresult} = $xresult; - } - } - foreach ( keys %dct ) { - if ( defined $dct{$_}{override} ) { - push( @override, split( /[ ,;]+/, $dct{$_}{override} ) ); - } - } - delete $dct{$_} foreach @override; - my $evcontent = $event->{args}->[0]; - my $evhost = $event->{host}; - foreach $chan (@{$event->{to}}) { - foreach $id ( keys %dct ) { - return unless (ASM::Util->notRestricted($nick, "notrigger") && ASM::Util->notRestricted($nick, "no$id")); - $xresult = $dct{$id}{xresult}; - my $nicereason = interpolate($dct{$id}{reason}); - if (defined $::db) { - $::db->record($chan, $event->{nick}, $event->{user}, $event->{host}, $::sn{lc $event->{nick}}->{gecos}, $dct{$id}{risk}, $id, $nicereason); - } - $txtz = "\x03" . $::RCOLOR{$::RISKS{$dct{$id}{risk}}} . "\u$dct{$id}{risk}\x03 risk threat [\x02$chan\x02] - ". - "\x02$event->{nick}\x02 - ${nicereason}; ping "; - $txtz = $txtz . ASM::Util->commaAndify(ASM::Util->getAlert(lc $chan, $dct{$id}{risk}, 'hilights')) if (ASM::Util->getAlert(lc $chan, $dct{$id}{risk}, 'hilights')); - $txtz = $txtz . ' !att-' . $chan . '-' . $dct{$id}{risk}; - if ($id eq 'last_measure_regex') { #TODO: Note that this is another example of things that shouldn't be hardcoded, but are. - - } - if ( - (!(defined($::ignored{$chan}) && ($::ignored{$chan} >= $::RISKS{$dct{$id}{risk}}))) || - (($::pacealerts == 0) && ($dct{$id}{risk} eq 'info')) - ) { - my @tgts = ASM::Util->getAlert($chan, $dct{$id}{risk}, 'msgs'); - ASM::Util->sendLongMsg($conn, \@tgts, $txtz); - $conn->schedule(45, sub { delete($::ignored{$chan}) if $::ignored{$chan} == $::RISKS{$dct{$id}{risk}} }); - $::ignored{$chan} = $::RISKS{$dct{$id}{risk}}; - } - $::log->incident($chan, "$chan: $dct{$id}{risk} risk: $event->{nick} - $nicereason\n"); - } - } -} - -1; diff --git a/modules/log.pl b/modules/log.pl deleted file mode 100644 index c2a2b72..0000000 --- a/modules/log.pl +++ /dev/null @@ -1,112 +0,0 @@ -package ASM::Log; - -use warnings; -use strict; - -#use IO::All; -use POSIX qw(strftime); - -sub new -{ - my $module = shift; - my $config = shift; - my $self = {}; - $self->{CONFIG} = $config; - $self->{backlog} = {}; - bless($self); - return $self; -} - -sub incident -{ - my $self = shift; - my ($chan, $header) = @_; - $chan = lc $chan; - open(FH, '>>', 'dctlog.txt'); - print FH $header; - if (defined($self->{backlog}->{$chan})) { - print FH join('', @{$self->{backlog}->{$chan}}); - } - print FH "\n\n"; - close(FH); -} - -#writes out the backlog to a file which correlates to ASM's SQL actionlog table -sub sqlIncident -{ - my $self = shift; - my ($channel, $index) = @_; - $channel = lc $channel; - my @chans = split(/,/, $channel); - open(FH, '>', $self->{CONFIG}->{actiondir} . $index . '.txt'); - foreach my $chan (@chans) { - if (defined($self->{backlog}->{$chan})) { - say FH "$chan"; - say FH join('', @{$self->{backlog}->{$chan}}); - } - } - close(FH); -} - -sub logg -{ - my $self = shift; - my ($event) = @_; - my $cfg = $self->{CONFIG}; - my @chans = @{$event->{to}}; - @chans = ( $event->{args}->[0] ) if ($event->{type} eq 'kick'); - my @time = ($cfg->{zone} eq 'local') ? localtime : gmtime; - foreach my $chan ( @chans ) - { - $chan = lc $chan; - next if ($chan eq '$$*'); - $chan =~ s/^[@+]//; - if ($chan eq '*') { - ASM::Util->dprint("$event->{nick}: $event->{args}->[0]", 'snotice'); - next; - } - my $path = ">>$cfg->{dir}${chan}/${chan}" . strftime($cfg->{filefmt}, @time); - $_ = ''; - $_ = "<$event->{nick}> $event->{args}->[0]" if $event->{type} eq 'public'; - $_ = "*** $event->{nick} has joined $chan" if $event->{type} eq 'join'; - $_ = "*** $event->{nick} has left $chan ($event->{args}->[0])" if $event->{type} eq 'part'; - $_ = "* $event->{nick} $event->{args}->[0]" if $event->{type} eq 'caction'; - $_ = "*** $event->{nick} is now known as $event->{args}->[0]" if $event->{type} eq 'nick'; - $_ = "*** $event->{nick} has quit ($event->{args}->[0])" if $event->{type} eq 'quit'; - $_ = "*** $event->{to}->[0] was kicked by $event->{nick}" if $event->{type} eq 'kick'; - $_ = "-$event->{nick}- $event->{args}->[0]" if $event->{type} eq 'notice'; - $_ = "*** $event->{nick} sets mode: " . join(" ",@{$event->{args}}) if $event->{type} eq 'mode'; - $_ = "*** $event->{nick} changes topic to \"$event->{args}->[0]\"" if $event->{type} eq 'topic'; - my $nostamp = $_; - $_ = strftime($cfg->{timefmt}, @time) . $_ . "\n"; - my $line = $_; - my @backlog = (); - if (defined($self->{backlog}->{$chan})) { - @backlog = @{$self->{backlog}->{$chan}}; - if (scalar @backlog >= 30) { - shift @backlog; - } - } - push @backlog, $line; - $self->{backlog}->{$chan} = \@backlog; - if (open(FH, $path)) { # or die "Can't open $path: $!"; - print FH $line; - ASM::Util->dprint($line, 'logger'); - close(FH); - } else { - print "COULDN'T PRINT TO $path - $line"; - } - my $spy; - if (defined($::spy{$chan})) { - $spy = $::spy{$chan}; - } elsif (defined($::spy{lc $event->{nick}})) { - $spy = $::spy{lc $event->{nick}}; - } - if (defined($spy)) { - say $spy "$chan: $nostamp"; - } -# $_ >> io($path); - } -} - -1; diff --git a/modules/mysql.pl b/modules/mysql.pl deleted file mode 100644 index 86a1c78..0000000 --- a/modules/mysql.pl +++ /dev/null @@ -1,323 +0,0 @@ -package ASM::DB; - -use warnings; -use strict; -use DBI; -use Data::Dumper; - -sub new { - my $module = shift; - my ($db, $host, $port, $user, $pass, $table, $actiontable, $dblog) = @_; - my $self = {}; - $self->{DBH} = DBI->connect("DBI:mysql:database=$db;host=$host;port=$port", $user, $pass); - $self->{DBH_LOG} = DBI->connect("DBI:mysql:database=$dblog;host=$host;port=$port", $user, $pass); - $self->{DBH}->{mysql_auto_reconnect} = 1; - $self->{DBH_LOG}->{mysql_auto_reconnect} = 1; - $self->{TABLE} = $table; - $self->{ACTIONTABLE} = $actiontable; - bless($self); - return $self; -} - -#sub sql_connect -#{ -# $::dbh = DBI->connect("DBI:mysql:database=$::mysql->{db};host=$::mysql->{host};port=$::mysql->{port}", -# $::mysql->{user}, $::mysql->{pass}); -# $::dbh->{mysql_auto_reconnect} = 1; -#} - -sub raw -{ - my $self = shift; - my ($conn, $tgt, $dbh, $qry) = @_; - my $sth = $dbh->prepare($qry); - $sth->execute; - my $names = $sth->{'NAME'}; - my $numFields = $sth->{'NUM_OF_FIELDS'}; - my $string = ""; - for (my $i = 0; $i < $numFields; $i++) { - $string = $string . sprintf("%s%s", $i ? "," : "", $$names[$i]); - } - $conn->privmsg($tgt, $string); - while (my $ref = $sth->fetchrow_arrayref) { - $string = ""; - for (my $i = 0; $i < $numFields; $i++) { - $string = $string . sprintf("%s%s", $i ? "," : "", $$ref[$i]); - } - $conn->privmsg($tgt, $string); - } -} - -sub record -{ - my $self = shift; - my ($channel, $nick, $user, $host, $gecos, $level, $id, $reason) = @_; - $gecos //= "NOT_DEFINED"; - - my $dbh = $self->{DBH}; - $dbh->do("INSERT INTO $self->{TABLE} (channel, nick, user, host, gecos, level, id, reason) VALUES (" . - $dbh->quote($channel) . ", " . $dbh->quote($nick) . ", " . $dbh->quote($user) . - ", " . $dbh->quote($host) . ", " . $dbh->quote($gecos) . ", " . $dbh->quote($level) . ", " . - $dbh->quote($id) . ", " . $dbh->quote($reason) . ");"); -} - -sub actionlog -{ - my ($self, $event, $modedata1, $modedata2) = @_; - my $dbh = $self->{DBH}; - my ($action, $reason, $channel, - $nick, $user, $host, $gecos, $account, $ip, - $bynick, $byuser, $byhost, $bygecos, $byaccount); - - if ($event->{type} eq 'mode') { - $action = $modedata1; - $nick = $modedata2; - $channel = lc $event->{to}->[0]; - $bynick = $event->{nick}; - $byuser = $event->{user}; - $byhost = $event->{host}; - } elsif ($event->{type} eq 'quit') { - my $quitmsg = $event->{args}->[0]; - if ($quitmsg =~ /^Killed \((\S+) \((.*)\)\)$/) { - $bynick = $1; - $reason = $2 unless ($2 eq ''); - return if ($reason =~ /Nickname regained by services/); - $action = 'kill'; - } elsif ($quitmsg =~ /^K-Lined$/) { - $action = 'k-line'; - } else { - return; #quit not forced/tracked - } - $nick = $event->{nick}; - $user = $event->{user}; - $host = $event->{host}; - } elsif (($event->{type} eq 'part') && ($event->{args}->[0] =~ /^requested by (\S+) \((.*)\)/)) { - $bynick = $1; - $reason = $2 unless (lc $reason eq lc $event->{nick}); - $action = 'remove'; - $nick = $event->{nick}; - $user = $event->{user}; - $host = $event->{host}; - $channel = $event->{to}->[0]; - } elsif ($event->{type} eq 'kick') { - $action = 'kick'; - $bynick = $event->{nick}; - $byuser = $event->{user}; - $byhost = $event->{host}; - $reason = $event->{args}->[1] unless ($event->{args}->[1] eq $event->{to}->[0]); - $nick = $event->{to}->[0]; - $channel = $event->{args}->[0]; - } - return unless defined($action); -# $bynick = lc $bynick if defined $bynick; #we will lowercase the NUHGA info later. - if ( (defined($bynick)) && (defined($::sn{lc $bynick})) ) { #we have the nick taking the action available, fill in missing NUHGA info - $byuser //= $::sn{lc $bynick}{user}; - $byhost //= $::sn{lc $bynick}{host}; - $bygecos //= $::sn{lc $bynick}{gecos}; - $byaccount //= $::sn{lc $bynick}{account}; - if (($byaccount eq '0') or ($byaccount eq '*')) { - $byaccount = undef; - } - } -# $nick = lc $nick if defined $nick; - if ( (defined($nick)) && (defined($::sn{lc $nick})) ) { #this should always be true, else something has gone FUBAR - $user //= $::sn{lc $nick}{user}; - $host //= $::sn{lc $nick}{host}; - $gecos //= $::sn{lc $nick}{gecos}; - $account //= $::sn{lc $nick}{account}; - if (($account eq '0') or ($account eq '*')) { - $account = undef; - } - $ip = ASM::Util->getNickIP(lc $nick); - } -# my ($action, $reason, $channel, -# $nick, $user, $host, $gecos, $account, $ip -# $bynick, $byuser, $byhost, $bygecos, $byaccount); -#Now, time to escape/NULLify everything - $action = $dbh->quote($action); - if (defined($reason)) { $reason = $dbh->quote($reason); } else { $reason = 'NULL'; } -## removed lc's from everything except IP - if (defined($channel)) { $channel = $dbh->quote($channel); } else { $channel = 'NULL'; } - - if (defined($nick)) { $nick = $dbh->quote($nick); } else { $nick = 'NULL'; } - if (defined($user)) { $user = $dbh->quote($user); } else { $user = 'NULL'; } - if (defined($host)) { $host = $dbh->quote($host); } else { $host = 'NULL'; } - if (defined($gecos)) { $gecos = $dbh->quote($gecos); } else { $gecos = 'NULL'; } - if (defined($account)) { $account = $dbh->quote($account); } else { $account = 'NULL'; } - if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; } - - if (defined($bynick)) { $bynick = $dbh->quote($bynick); } else { $bynick = 'NULL'; } - if (defined($byuser)) { $byuser = $dbh->quote($byuser); } else { $byuser = 'NULL'; } - if (defined($byhost)) { $byhost = $dbh->quote($byhost); } else { $byhost = 'NULL'; } - if (defined($bygecos)) { $bygecos = $dbh->quote($bygecos); } else { $bygecos = 'NULL'; } - if (defined($byaccount)) { $byaccount = $dbh->quote($byaccount); } else { $byaccount = 'NULL'; } - my $sqlstr = "INSERT INTO $self->{ACTIONTABLE} " . - "(action, reason, channel, " . - "nick, user, host, gecos, account, ip, " . - "bynick, byuser, byhost, bygecos, byaccount)" . - " VALUES " . - "($action, $reason, $channel, " . - "$nick, $user, $host, $gecos, $account, $ip, " . - "$bynick, $byuser, $byhost, $bygecos, $byaccount);"; - ASM::Util->dprint( $sqlstr, 'mysql' ); - $dbh->do( $sqlstr ); - return $dbh->last_insert_id(undef, undef, $self->{ACTIONTABLE}, undef); -# $::sn{ow} looks like: -#$VAR1 = { -# "account" => "afterdeath", -# "gecos" => "William Athanasius Heimbigner", -# "user" => "icxcnika", -# "mship" => [ -# "#baadf00d", -# "#antispammeta-debug", -# "#antispammeta" -# ], -# "host" => "freenode/weird-exception/network-troll/afterdeath" -# }; - -} - -#FIXME: This function is shit. Also, it doesn't work like I want it to with mode. -sub logg -{ - my $self = shift; - my ($event) = @_; - my $dbh = $self->{DBH_LOG}; - my $table = $event->{type}; - $table = 'action' if ($table eq 'caction'); - $table = 'privmsg' if ($table eq 'public'); - return if (($table eq 'action') or ($table eq 'privmsg')); #Disabling logging of privmsg stuffs to mysql. no point. - my $realtable = $table; - $realtable = 'joins' if $realtable eq 'join'; #mysql doesn't like a table named join - my $string = 'INSERT INTO `' . $realtable . '` ('; -## begin saner code for this function - if ($table eq 'quit') { - $string = 'INSERT INTO `quit` (nick, user, host, geco, ip, account, content1) VALUES (' . - $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' . - $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ','; - my $ip = ASM::Util->getNickIP(lc $event->{nick}, $event->{host}); - if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; } - my $account = $::sn{lc $event->{nick}}->{account}; - if (!defined($account) or ($account eq '0') or ($account eq '*')) { - $account = 'NULL'; - } else { - $account = $dbh->quote($account); - } - $string = $string . $ip . ',' . $account . ',' . $dbh->quote($event->{args}->[0]) . ');'; - $dbh->do($string); - ASM::Util->dprint($string, 'mysql'); - return; - } elsif ($table eq 'part') { - $string = 'INSERT INTO `part` (channel, nick, user, host, geco, ip, account, content1) VALUES (' . - $dbh->quote($event->{to}->[0]) . ',' . - $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' . - $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ','; - my $ip = ASM::Util->getNickIP(lc $event->{nick}, $event->{host}); - if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; } - my $account = $::sn{lc $event->{nick}}->{account}; - if (!defined($account) or ($account eq '0') or ($account eq '*')) { - $account = 'NULL'; - } else { - $account = $dbh->quote($account); - } - $string = $string . $ip . ',' . $account . ',' . $dbh->quote($event->{args}->[0]) . ');'; - $dbh->do($string); - ASM::Util->dprint($string, 'mysql'); - return; - } elsif ($table eq 'kick') { - $string = 'INSERT INTO `kick` (channel, nick, user, host, geco, ip, account, ' . - 'victim_nick, victim_user, victim_host, victim_geco, victim_ip, victim_account, content1) VALUES (' . - $dbh->quote($event->{args}->[0]) . ',' . - $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' . - $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ','; - my $ip = ASM::Util->getNickIP(lc $event->{nick}); - if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; } - my $account = $::sn{lc $event->{nick}}->{account}; - if (($account eq '0') or ($account eq '*')) { $account = 'NULL'; } else { $account = $dbh->quote($account); } - $string = $string . $ip . ',' . $account; - $string = $string . ', ' . $dbh->quote($event->{to}->[0]); - $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{user}); - $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{host}); - $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{gecos}); - my $vic_ip = ASM::Util->getNickIP(lc $event->{to}->[0]); - if (defined($vic_ip)) { $vic_ip = $dbh->quote($vic_ip); } else { $vic_ip = 'NULL'; } - my $vic_account = $::sn{lc $event->{to}->[0]}->{account}; - if (($vic_account eq '0') or ($vic_account eq '*')) { $vic_account = 'NULL'; } else { $vic_account = $dbh->quote($vic_account); } - $string = $string . ', ' . $vic_ip . ',' . $vic_account . ',' . $dbh->quote($event->{args}->[1]) . ');'; - $dbh->do($string); - ASM::Util->dprint($string, 'mysql'); - return; - } -## end saner code for this function - if (($table ne 'nick') && ($table ne 'quit')) { - $string = $string . 'channel, '; - } - $string = $string . 'nick, user, host, geco'; - if (($table ne 'join') && ($table ne 'kick')) { - $string = $string . ', content1'; - } - if ($table eq 'mode') { - $string = $string . ', content2'; - } - if ($table eq 'kick') { - $string = $string . ', victim_nick, victim_user, victim_host, victim_geco, content1'; - } - $string = $string . ') VALUES ('; - if (($table ne 'nick') && ($table ne 'quit') && ($table ne 'kick')) { - $string = $string . $dbh->quote($event->{to}->[0]) . ", "; - } - if ($table eq 'kick') { - $string = $string . $dbh->quote($event->{args}->[0]) . ", "; - } - my $geco = $::sn{lc $event->{nick}}->{gecos}; - $string = $string . $dbh->quote($event->{nick}) . ", " . $dbh->quote($event->{user}) . ", " . - $dbh->quote($event->{host}) . ", " . $dbh->quote($geco); - if (($table ne 'join') && ($table ne 'kick')) { - $string = $string. ', ' . $dbh->quote($event->{args}->[0]); - } - if ($table eq 'kick') { - $string = $string . ', ' . $dbh->quote($event->{to}->[0]); - $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{user}); - $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{host}); - $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{gecos}); - $string = $string . ', ' . $dbh->quote($event->{args}->[1]); - } - if ($table eq 'mode') { - $string = $string . ', ' . $dbh->quote($event->{args}->[1]); - } - $string = $string . ');'; -# ASM::Util->dprint($string, "mysql"); - $dbh->do($string); -} - -sub query -{ - my $self = shift; - my ($channel, $nick, $user, $host) = @_; - my $dbh = $self->{DBH}; - $channel = $dbh->quote($channel); - $nick = $dbh->quote($nick); - $user = $dbh->quote($user); - $host = $dbh->quote($host); - - $nick =~ s/\*/%/g; - $nick =~ s/_/\\_/g; - $nick =~ s/\?/_/g; - - $user =~ s/\*/%/g; - $user =~ s/_/\\_/g; - $user =~ s/\?/_/g; - - $host =~ s/\*/%/g; - $host =~ s/_/\\_/g; - $host =~ s/\?/_/g; - my $sth = $dbh->prepare("SELECT * from $self->{TABLE} WHERE channel like $channel and nick like $nick and user like $user and host like $host;"); - $sth->execute; - my $i = 0; - while (my $ref = $sth->fetchrow_arrayref) { - $i++; - } - return $i; -} - -1; diff --git a/modules/services.pl b/modules/services.pl deleted file mode 100644 index 528901d..0000000 --- a/modules/services.pl +++ /dev/null @@ -1,69 +0,0 @@ -package ASM::Services; -use warnings; -use strict; - -use Data::Dumper; -$Data::Dumper::Useqq=1; - -sub new -{ - my $self = {}; - bless($self); - return $self; -} - -sub doServices { - my ($self, $conn, $event) = @_; - my $i = 1; - if ($event->{from} eq 'NickServ!NickServ@services.') - { - ASM::Util->dprint("NickServ: $event->{args}->[0]", 'snotice'); - if ( $event->{args}->[0] =~ /^This nickname is registered/ ) - { - $conn->privmsg( 'NickServ@services.', "identify $::settings->{nick} $::settings->{pass}" ); - } - elsif ( $event->{args}->[0] =~ /^You are now identified/ ) - { - my @autojoins = @{$::settings->{autojoins}}; - if (defined($autojoins[30])) { - $conn->join(join(',', @autojoins[0..30])); - if (defined($autojoins[60])) { - $conn->join(join(',', @autojoins[30..60])); - $conn->join(join(',', @autojoins[60..$#autojoins])); - } else { - $conn->join(join(',', @autojoins[30..$#autojoins])); - } - } else { - $conn->join(join(',', @autojoins)); - } - $conn->sl("PING :" . time); - $conn->schedule(2, sub { $conn->privmsg($::settings->{masterchan}, 'Now joined to all channels in '. (time - $::starttime) . " seconds."); }); - } - elsif ($event->{args}->[0] =~ /has been (killed|released)/ ) - { -# ASM::Util->dprint('Got kill/release successful from NickServ!', 'snotice'); - $conn->nick( $::settings->{nick} ); - } - elsif ($event->{args}->[0] =~ /has been regained/ ) - { -# ASM::Util->dprint('Got regain successful from nickserv!', 'snotice'); - } - elsif ($event->{args}->[0] =~ /Password Incorrect/ ) - { - die("NickServ password invalid.") - } - } - elsif ($event->{from} eq 'ChanServ!ChanServ@services.') - { - if ( $event->{args}->[0] =~ /^\[#/ ) { - return; - } - ASM::Util->dprint("ChanServ: $event->{args}->[0]", 'snotice'); - if ( $event->{args}->[0] =~ /^All.*bans matching.*have been cleared on(.*)/) - { - $conn->join($1); - } - } -} - -return 1; diff --git a/modules/util.pl b/modules/util.pl deleted file mode 100644 index f9895a0..0000000 --- a/modules/util.pl +++ /dev/null @@ -1,297 +0,0 @@ -package ASM::Util; -use Array::Utils qw(:all); -use POSIX qw(strftime); -use warnings; -use strict; -use Term::ANSIColor qw (:constants); -use Socket qw( inet_aton inet_ntoa ); -use Data::Dumper; -use Carp qw(cluck); - -%::RISKS = -( - 'disable'=> -1, #this isn't really an alert - 'debug' => 10, - 'info' => 20, - 'low' => 30, - 'medium' => 40, - 'high' => 50, - 'opalert'=> 9001 #OVER NINE THOUSAND!!! -); - -#leaves room for more levels if for some reason we end up needing more -#theoretically, you should be able to change those numbers without any damage - -%::COLORS = -( - 'white' => '00', - 'black' => '01', - 'blue' => '02', - 'green' => '03', - 'red' => '04', - 'brown' => '05', - 'purple' => '06', - 'orange' => '07', - 'yellow' => '08', - 'ltgreen' => '09', - 'teal' => '10', - 'ltcyan' => '11', - 'ltblue' => '12', - 'pink' => '13', - 'grey' => '14', - 'ltgrey' => '15', -); - -%::RCOLOR = -( - $::RISKS{debug} => $::COLORS{purple}, - $::RISKS{info} => $::COLORS{blue}, - $::RISKS{low} => $::COLORS{green}, - $::RISKS{medium} => $::COLORS{orange}, - $::RISKS{high} => $::COLORS{red}, -); - -sub new -{ - my $module = shift; - my $self = {}; - bless ($self); - return $self; -} - -sub maxlen { - my ($a, $b) = @_; - my ($la, $lb) = (length($a), length($b)); - return $la if ($la > $lb); - return $lb; -} - -#cs: returns the xml settings for the specified chan, or default if there aren't any settings for that chan -sub cs { - my ($module, $chan) = @_; - $chan = lc $chan; - $chan =~ s/^[@+]//; - return $::channels->{channel}->{default} unless defined($::channels->{channel}->{$chan}); - if ( defined($::channels->{channel}->{$chan}->{link}) ) { - return $::channels->{channel}->{ $::channels->{channel}->{$chan}->{link} }; - } - return $::channels->{channel}->{$chan}; -} - -sub getLink -{ - my ($module, $chan) = @_; - $chan = lc $chan; - $chan =~ s/^[@+]//; - my $link = $::channels->{channel}->{$chan}->{link}; - if ( defined($link) ) { - return $link; - } - return $chan; -} - -sub speak -{ - my ($module, $chan) = @_; - $chan = lc $chan; - $chan =~ s/^[@+]//; - if ( defined($::channels->{channel}->{$chan}->{silence}) ) { - if ($::channels->{channel}->{$chan}->{silence} eq "no") { - return 1; - } - elsif ($::channels->{channel}->{$chan}->{silence} eq "yes") { - return 0; - } - } - if ( defined($::channels->{channel}->{default}->{silence}) ) { - if ( $::channels->{channel}->{default}->{silence} eq "no" ) { - return 1; - } - elsif ( $::channels->{channel}->{default}->{silence} eq "yes" ) { - return 0; - } - } - return 1; -} - -#this item is a stub, dur -sub hostip { - #cluck "Calling gethostbyname in hostip"; - return gethostbyname($_[0]); -} - -# If $tgts="#antispammeta" that's fine, and if $tgts = ["#antispammeta", "##linux-ops"] that's cool too -sub sendLongMsg { - my ($module, $conn, $tgts, $txtz) = @_; - if (length($txtz) <= 380) { - $conn->privmsg($tgts, $txtz); - } else { - my $splitpart = rindex($txtz, " ", 380); - $conn->privmsg($tgts, substr($txtz, 0, $splitpart)); - $conn->privmsg($tgts, substr($txtz, $splitpart)); - } -} - -sub getAlert { - my ($module, $c, $risk, $t) = @_; - my @disable = (); - my @x = (); - $c = lc $c; - $c =~ s/^[@+]//; - foreach my $prisk ( keys %::RISKS) { - if ( $::RISKS{$risk} >= $::RISKS{$prisk} ) { - push( @x, @{$::channels->{channel}->{master}->{$t}->{$prisk}} ) if defined $::channels->{channel}->{master}->{$t}->{$prisk}; - push( @x, @{cs($module, $c)->{$t}->{$prisk}} ) if defined cs($module, $c)->{$t}->{$prisk}; - } - } - push( @disable, @{$::channels->{channel}->{master}->{$t}->{disable}} ) if defined $::channels->{channel}->{master}->{$t}->{disable}; - push( @disable, @{cs($module, $c)->{$t}->{disable}} ) if defined cs($module, $c)->{$t}->{disable}; - @x = unique(@x); - @x = array_diff(@x, @disable); - return @x; -} - -sub commaAndify { - my $module = shift; - my @seq = @_; - my $len = ($#seq); - my $last = $seq[$len]; - return '' if $len eq -1; - return $seq[0] if $len eq 0; - return join( ' and ', $seq[0], $seq[1] ) if $len eq 1; - return join( ', ', splice(@seq,0,$len) ) . ', and ' . $last; -} - -sub leq { - my ($s1, $s2) = @_; - return (lc $s1 eq lc $s2); -} - -sub seq { - my ($n1, $n2) = @_; - return 0 unless defined($n1); - return 0 unless defined($n2); - return ($n1 eq $n2); -} - -#I last worked on this function while having way too many pain meds, if it's fucked up, that's why. -sub dprint { - my ($module, $text, $type) = @_; - if (!defined($type)) { - die "old method for dprint called!\n"; - } - if (!defined($::debugx{$type})) { - die "dprint called with invalid type!\n"; - } - if ($::debugx{$type} eq 0) { - return; - } - say STDERR strftime("%F %T ", gmtime), - GREEN, 'DEBUG', RESET, '(', $::debugx{$type}, $type, RESET, ') ', $text; -} - - -sub intToDottedQuad { - my ($module, $num) = @_; - return inet_ntoa(pack('N', $num)); -} - -sub dottedQuadToInt -{ - my ($module, $dottedquad) = @_; -# my $ip_number = 0; -# my @octets = split(/\./, $dottedquad); -# foreach my $octet (@octets) { -# $ip_number <<= 8; -# $ip_number |= $octet; -# } -# return $ip_number; - return unpack('N', inet_aton($dottedquad)); -} - -sub getHostIP -{ - my ($module, $host) = @_; - if ( ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) or - ($host =~ /^gateway\/web\/.*\/ip\.(\d+)\.(\d+)\.(\d+)\.(\d+)$/) ) { - #yay, easy IP! - return dottedQuadToInt(undef, "$1.$2.$3.$4"); - } elsif (index($host, '/') != -1) { - return; - } elsif ($host =~ /^2001:0:/) { - my @splitip = split(/:/, $host); - return unless defined($splitip[6]) && defined($splitip[7]); - #I think I can just do (hex($splitip[6] . $splitip[7]) ^ hex('ffffffff')) here but meh - my $host = join('.', unpack('C4', pack('N', (hex($splitip[6] . $splitip[7])^hex('ffffffff'))))); - return dottedQuadToInt(undef, $host); - } - #cluck "Calling gethostbyname in getHostIP"; - my @resolve = gethostbyname($host); - return unless @resolve; - return dottedQuadToInt(undef, join('.', unpack('C4', $resolve[4]))); -} - -sub getNickIP -{ - my ($module, $nick, $host) = @_; - $nick = lc $nick; - return unless defined($::sn{$nick}); - if (defined($::sn{$nick}{ip})) { - return $::sn{$nick}{ip}; - } - $host //= $::sn{$nick}{host}; - my $ip = getHostIP(undef, $host); - if (defined($ip)) { - $::sn{$nick}{ip} = $ip; - return $ip; - } - return; -# if ( ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) or -# ($host =~ /^gateway\/web\/freenode\/ip\.(\d+)\.(\d+)\.(\d+)\.(\d+)$/) ) { -# #yay, easy IP! -# $::sn{$nick}{ip} = dottedQuadToInt(undef, "$1.$2.$3.$4"); -# return $::sn{$nick}{ip}; -# } elsif (index($host, '/') != -1) { -# return; -# } elsif ($host =~ /^2001:0:/) { -# my @splitip = split(/:/, $host); -# #I think I can just do (hex($splitip[6] . $splitip[7]) ^ hex('ffffffff')) here but meh -# my $host = join('.', unpack('C4', pack('N', (hex($splitip[6] . $splitip[7])^hex('ffffffff'))))); -# $::sn{$nick}{ip} = dottedQuadToInt(undef, $host); -# return $::sn{$nick}{ip}; -# } -# my @resolve = gethostbyname($::sn{$nick}{host}); -# return unless @resolve; -# $::sn{$nick}{ip} = dottedQuadToInt(undef, join('.', unpack('C4', $resolve[4]))); -# return $::sn{$nick}{ip}; -} - -sub notRestricted { - my ($module, $nick, $restriction) = @_; - $nick = lc $nick; - my $host = lc $::sn{$nick}{host}; - my $account = lc $::sn{$nick}{account}; - foreach my $regex (keys %{$::restrictions->{nicks}->{nick}}) { - if ($nick =~ /^$regex$/i && defined($::restrictions->{nicks}->{nick}->{$regex}->{$restriction})) { - dprint("blah", "Restriction $restriction found for $nick (nick $regex)", "restrictions"); - return 0; - } - } - if ((defined($host)) && (defined($account))) { - foreach my $regex (keys %{$::restrictions->{accounts}->{account}}) { - if ($account =~ /^$regex$/i && defined($::restrictions->{accounts}->{account}->{$regex}->{$restriction})) { - dprint("blah", "Restriction $restriction found for $nick (account $regex)", "restrictions"); - return 0; - } - } - foreach my $regex (keys %{$::restrictions->{hosts}->{host}}) { - if ($host =~ /^$regex$/i && defined($::restrictions->{hosts}->{host}->{$regex}->{$restriction})) { - dprint("blah", "Restriction $restriction found for $nick (host $regex)", "restrictions"); - return 0; - } - } - } - return 1; -} - -return 1; diff --git a/modules/xml.pl b/modules/xml.pl deleted file mode 100644 index 1128dda..0000000 --- a/modules/xml.pl +++ /dev/null @@ -1,69 +0,0 @@ -package ASM::XML; -use warnings; -use strict; - -use XML::Simple qw(:strict); -use IO::All; - -$::xs1 = XML::Simple->new( KeyAttr => ['id'], Cache => [ qw/memcopy/ ]); - -sub readXML { - my ( $p ) = $::cset; - my @fchan = ( 'event', keys %::RISKS ); - $::settings = $::xs1->XMLin( "$p/settings.xml", ForceArray => ['host'], - 'GroupTags' => { altnicks => 'altnick', server => 'host', - autojoins => 'autojoin' }); - $::channels = $::xs1->XMLin( "$p/channels.xml", ForceArray => \@fchan ); - $::users = $::xs1->XMLin( "$p/users.xml", ForceArray => 'person'); - $::commands = $::xs1->XMLin( "$p/commands.xml", ForceArray => [qw/command/]); - $::mysql = $::xs1->XMLin( "$p/mysql.xml", ForceArray => ['ident', 'geco'], - 'GroupTags' => { ignoredidents => 'ident', ignoredgecos => 'geco' }); - $::dnsbl = $::xs1->XMLin( "$p/dnsbl.xml", ForceArray => []); - $::rules = $::xs1->XMLin( "$p/rules.xml", ForceArray => []); - $::restrictions = $::xs1->XMLin( "$p/restrictions.xml", ForceArray => ['host', 'nick', 'account']); - $::blacklist = $::xs1->XMLin( "$p/blacklist.xml", ForceArray => 'string'); -} - -sub writeXML { - writeSettings(); - writeChannels(); - writeUsers(); - writeRestrictions(); - writeBlacklist(); - writeMysql(); -# $::xs1->XMLout($::commands, RootName => 'commands', KeyAttr => ['id']) > io("$::cset/commands.xml"); -} - -sub writeMysql { - $::settingschanged=1; - $::xs1->XMLout($::mysql, RootName => 'mysql', KeyAttr => ['id']) > io("$::cset/mysql.xml"); -} - -sub writeChannels { - $::settingschanged=1; - $::xs1->XMLout($::channels, RootName => 'channels', KeyAttr => ['id'], NumericEscape => 2) > io("$::cset/channels.xml"); -} - -sub writeUsers { - $::settingschanged=1; - $::xs1->XMLout($::users, RootName => 'people', KeyAttr => ['id']) > io("$::cset/users.xml"); -} - -sub writeSettings { - $::settingschanged=1; - $::xs1->XMLout($::settings, RootName => 'settings', - GroupTags => { altnicks => 'altnick', server => 'host', autojoins => 'autojoin' }, NoAttr => 1) > io("$::cset/settings.xml"); -} - -sub writeRestrictions { - $::settingschanged=1; - $::xs1->XMLout($::restrictions, RootName => 'restrictions', KeyAttr => ['id'], - GroupTags => { hosts => "host", nicks => "nick", accounts => "account"}) > io("$::cset/restrictions.xml"); -} - -sub writeBlacklist { - $::settingschanged=1; - $::xs1->XMLout($::blacklist, RootName => 'blacklist', KeyAttr => ['id'], NumericEscape => 2) > io("$::cset/blacklist.xml"); -} - -return 1; -- cgit v1.2.3