diff options
| author |   Janik Kleinhoff <janik@kleinhoff.de> | 2015-09-24 01:32:11 +0000 |
|---|---|---|
| committer | Janik Kleinhoff <janik@kleinhoff.de> | 2015-09-24 01:32:11 +0000 |
| commit | 9b472795d26cd93d1bb58488ef60a062f5237295 (patch) | |
| tree | 8572778595d145176e720a1b7168c73adbd64ed4 /lib/Net | |
| parent | b93c3a24f14e0f64bc46b4945a65ae1bba62dc12 (diff) | |
Rework module paths
Diffstat (limited to 'lib/Net')
| -rw-r--r-- | lib/Net/IRC.pm | 759 | ||||
| -rw-r--r-- | lib/Net/IRC/Connection.pm | 1691 | ||||
| -rw-r--r-- | lib/Net/IRC/DCC.pm | 808 | ||||
| -rw-r--r-- | lib/Net/IRC/Event.pm | 873 | ||||
| -rw-r--r-- | lib/Net/IRC/EventQueue.pm | 73 | ||||
| -rw-r--r-- | lib/Net/IRC/EventQueue/Entry.pm | 40 |
6 files changed, 4244 insertions, 0 deletions
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<Bot::BasicBot>, whereas more advanced users will appreciate the +flexibility offered by L<POE::Component::IRC>. 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<POE::Component::IRC> 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 +C<Connection-E<gt>new_{send,get,chat}> in the same way that +C<IRC-E<gt>newconn> invokes C<Connection-E<gt>new>. 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<every> 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<Password => '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<SSL => 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<Event List> 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<start()> to ever get executed. + +If you're tying Net::IRC into another event-based module, such as perl/Tk, +there's a nifty C<do_one_loop()> method provided for your convenience. Calling +C<$irc-E<gt>do_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<perldoc Net::IRC::Connection> +(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<do_one_loop()>. +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<addfh()>, +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<Optional:> A string consisting of one or more of the letters r, w, and e. +Passed directly to C<addfh()>... 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<do_one_loop()>'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<select()> 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<Optional:> 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() + +C<select()>s on all open filehandles and passes any ready ones to the +appropriate handler subroutines. Also responsible for executing scheduled +events from C<Net::IRC::Connection-E<gt>schedule()> 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 C<Net::IRC::Connection-E<gt>new()>; examples of common arguments can be +found in the B<Synopsis> or B<Getting Started> sections. + +=item * + +removeconn() + +Removes the specified object's socket from C<do_one_loop()>'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<removefh()>, 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<do_one_loop()>'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<do_one_loop()> to +read new events from all open connections and pass them off to any +applicable handlers. + +=item * + +timeout() + +Sets or returns the current C<select()> timeout for the main event loop, in +seconds (fractional amounts allowed). See the documentation for the +C<select()> function for more info. + +Takes 1 optional arg: + +=over + +=item 0. + +B<Optional:> A new value for the C<select()> 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 E<lt>gbacon@adtran.comE<gt> +and Dennis Taylor E<lt>dennis@funkplanet.comE<gt>. + +=item * + +Ideas and large amounts of code donated by Nat "King" Torkington +E<lt>gnat@frii.comE<gt>. + +=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! -- + # <Teratogen> absolute power corrupts absolutely, but it's a helluva lot + # of fun. + # <Teratogen> =) + + ($meth = $AUTOLOAD) =~ s/^.*:://; ## strip fully qualified portion + + unless (exists $autoloaded{$meth}) { + croak "No method called \"$meth\" for $class object."; + } + + eval <<EOSub; +sub $meth { + my \$self = shift; + + if (\@_) { + my \$old = \$self->{"_$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 <dschmi1@umbc.edu>. 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<irctest> script and the source for +details about this module. + +=head1 AUTHORS + +Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt> and +Dennis Taylor E<lt>dennis@funkplanet.comE<gt>. + +Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>. + +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 +C<Connection-E<gt>new_{chat,get,send}()> in much the same way that +C<IRC-E<gt>newconn()> 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<irctest> script and the source for +details about this module. + +=head1 AUTHORS + +Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt> and +Dennis Taylor E<lt>dennis@funkplanet.comE<gt>. + +Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>. + +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 <andypoo@secret.com.au> + 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 <andypoo@secret.com.au> + 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 <andypoo@secret.com.au> + 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<irctest> 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 E<lt>gbacon@adtran.comE<gt> and +Dennis Taylor E<lt>dennis@funkplanet.comE<gt>. + +Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>. + +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; + |