1 #####################################################################
3 # Net::IRC -- Object-oriented Perl interface to an IRC server #
5 # Connection.pm: The basic functions for a simple IRC connection #
8 # Copyright (c) 1997 Greg Bacon & Dennis Taylor. #
9 # All rights reserved. #
11 # This module is free software; you can redistribute or #
12 # modify it under the terms of Perl's Artistic License. #
14 #####################################################################
18 package Net::IRC::Connection;
25 use strict; # A little anal-retention never hurt...
26 use vars ( # with a few exceptions...
27 '$AUTOLOAD', # - the name of the sub in &AUTOLOAD
28 '%_udef', # - the hash containing the user's global handlers
29 '%autoloaded', # - the hash containing names of &AUTOLOAD methods
33 # The names of the methods to be handled by &AUTOLOAD.
34 # It seems the values ought to be useful *somehow*...
44 # This hash will contain any global default handlers that the user specifies.
50 #####################################################################
51 # Methods start here, arranged in alphabetical order. #
52 #####################################################################
55 # This sub is the common backend to add_handler and add_global_handler
57 sub _add_generic_handler
59 my ($self, $event, $ref, $rp, $hash_ref, $real_name) = @_;
61 my %define = ( "replace" => 0, "before" => 1, "after" => 2 );
64 croak "Not enough arguments to $real_name()";
66 unless (ref($ref) eq 'CODE') {
67 croak "Second argument of $real_name isn't a coderef";
70 # Translate REPLACE, BEFORE and AFTER.
71 if (not defined $rp) {
73 } elsif ($rp =~ /^\D/) {
74 $rp = $define{lc $rp} || 0;
77 foreach $ev (ref $event eq "ARRAY" ? @{$event} : $event) {
78 # Translate numerics to names
80 $ev = Net::IRC::Event->trans($ev);
82 carp "Unknown event type in $real_name: $ev";
87 $hash_ref->{lc $ev} = [ $ref, $rp ];
92 # This sub will assign a user's custom function to a particular event which
93 # might be received by any Connection object.
94 # Takes 3 args: the event to modify, as either a string or numeric code
95 # If passed an arrayref, the array is assumed to contain
96 # all event names which you want to set this handler for.
97 # a reference to the code to be executed for the event
98 # (optional) A value indicating whether the user's code should replace
99 # the built-in handler, or be called with it. Possible values:
100 # 0 - Replace the built-in handlers entirely. (the default)
101 # 1 - Call this handler right before the default handler.
102 # 2 - Call this handler right after the default handler.
103 # These can also be referred to by the #define-like strings in %define.
104 sub add_global_handler {
105 my ($self, $event, $ref, $rp) = @_;
106 return $self->_add_generic_handler($event, $ref, $rp,
107 \%_udef, 'add_global_handler');
110 # This sub will assign a user's custom function to a particular event which
111 # this connection might receive. Same args as above.
113 my ($self, $event, $ref, $rp) = @_;
114 return $self->_add_generic_handler($event, $ref, $rp,
115 $self->{_handler}, 'add_handler');
118 # -- #perl was here! --
119 # fimmtiu: Oh, dear. There actually _is_ an alt.fan.jwz.
120 # Freiheit: "Join us. *whapdewhapwhap* Join us now. *whapdewhapwhap* Join
121 # us now and share the software."
122 # Freiheit: is that actually RMS singing or is it a voice-synthesizer?
125 # Why do I even bother writing subs this simple? Sends an ADMIN command.
126 # Takes 1 optional arg: the name of the server you want to query.
128 my $self = shift; # Thank goodness for AutoLoader, huh?
129 # Perhaps we'll finally use it soon.
131 $self->sl("ADMIN" . ($_[0] ? " $_[0]" : ""));
134 # Takes care of the methods in %autoloaded
135 # Sets specified attribute, or returns its value if called without args.
137 my $self = @_; ## can't modify @_ for goto &name
138 my $class = ref $self; ## die here if !ref($self) ?
141 # -- #perl was here! --
142 # <Teratogen> absolute power corrupts absolutely, but it's a helluva lot
146 ($meth = $AUTOLOAD) =~ s/^.*:://; ## strip fully qualified portion
148 unless (exists $autoloaded{$meth}) {
149 croak "No method called \"$meth\" for $class object.";
157 my \$old = \$self->{"_$meth"};
159 \$self->{"_$meth"} = shift;
164 return \$self->{"_$meth"};
169 ## no reason to play this game every time
174 # Toggles away-ness with the server. Optionally takes an away message.
177 $self->sl("AWAY" . ($_[0] ? " :$_[0]" : ""));
181 # -- #perl was here! --
182 # <crab> to irc as root demonstrates about the same brains as a man in a
183 # thunderstorm waving a lightning rod and standing in a copper tub
184 # of salt water yelling "ALL GODS ARE BASTARDS!"
185 # DrForr saves that one.
187 # Attempts to connect to the specified IRC (server, port) with the specified
188 # (nick, username, ircname). Will close current connection if already open.
191 my ($hostname, $password, $sock);
196 $hostname = $arg{'LocalAddr'} if exists $arg{'LocalAddr'};
197 $password = $arg{'Password'} if exists $arg{'Password'};
198 $self->nick($arg{'Nick'}) if exists $arg{'Nick'};
199 $self->port($arg{'Port'}) if exists $arg{'Port'};
200 $self->server($arg{'Server'}) if exists $arg{'Server'};
201 $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'};
202 $self->username($arg{'Username'}) if exists $arg{'Username'};
205 # Lots of error-checking claptrap first...
206 unless ($self->server) {
207 unless ($ENV{IRCSERVER}) {
208 croak "No server address specified in connect()";
210 $self->server( $ENV{IRCSERVER} );
212 unless ($self->nick) {
213 $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) }
214 || $ENV{USER} || $ENV{LOGNAME} || "WankerBot");
216 unless ($self->port) {
217 $self->port($ENV{IRCPORT} || 6667);
219 unless ($self->ircname) {
220 $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] }
221 || "Just Another Perl Hacker");
223 unless ($self->username) {
224 $self->username(eval { scalar getpwuid($>) } || $ENV{USER}
225 || $ENV{LOGNAME} || "japh");
228 # Now for the socket stuff...
229 if ($self->connected) {
230 $self->quit("Changing servers");
233 # my $sock = IO::Socket::INET->new(PeerAddr => $self->server,
234 # PeerPort => $self->port,
238 $sock = Symbol::gensym();
239 unless (socket( $sock, PF_INET, SOCK_STREAM, getprotobyname('tcp') )) {
240 carp ("Can't create a new socket: $!");
245 # This bind() stuff is so that people with virtual hosts can select
246 # the hostname they want to connect with. For this, I dumped the
247 # astonishingly gimpy IO::Socket. Talk about letting the interface
248 # get in the way of the functionality...
251 unless (bind( $sock, sockaddr_in( 0, inet_aton($hostname) ) )) {
252 carp "Can't bind to $hostname: $!";
258 if (connect( $sock, sockaddr_in($self->port, inet_aton($self->server)) )) {
259 $self->socket($sock);
262 carp (sprintf "Can't connect to %s:%s!",
263 $self->server, $self->port);
268 # Send a PASS command if they specified a password. According to
269 # the RFC, we should do this as soon as we connect.
270 if (defined $password) {
271 $self->sl("PASS $password");
274 # Now, log in to the server...
275 unless ($self->sl('NICK ' . $self->nick()) and
276 $self->sl(sprintf("USER %s %s %s :%s",
280 $self->ircname()))) {
281 carp "Couldn't send introduction to server: $!";
283 $! = "Couldn't send NICK/USER introduction to " . $self->server;
287 $self->{_connected} = 1;
288 $self->parent->addconn($self);
291 # Returns a boolean value based on the state of the object's socket.
295 return ( $self->{_connected} and $self->socket() );
298 # Sends a CTCP request to some hapless victim(s).
299 # Takes at least two args: the type of CTCP request (case insensitive)
300 # the nick or channel of the intended recipient(s)
301 # Any further args are arguments to CLIENTINFO, ERRMSG, or ACTION.
303 my ($self, $type, $target) = splice @_, 0, 3;
307 croak "Not enough arguments to ctcp()";
310 if ($type eq "PING") {
311 unless ($self->sl("PRIVMSG $target :\001PING " . time . "\001")) {
312 carp "Socket error sending $type request in ctcp()";
315 } elsif (($type eq "CLIENTINFO" or $type eq "ACTION") and @_) {
316 unless ($self->sl("PRIVMSG $target :\001$type " .
317 CORE::join(" ", @_) . "\001")) {
318 carp "Socket error sending $type request in ctcp()";
321 } elsif ($type eq "ERRMSG") {
323 carp "Not enough arguments to $type in ctcp()";
326 unless ($self->sl("PRIVMSG $target :\001ERRMSG " .
327 CORE::join(" ", @_) . "\001")) {
328 carp "Socket error sending $type request in ctcp()";
332 unless ($self->sl("PRIVMSG $target :\001$type " .
333 CORE::join(" ",@_) . "\001")) {
334 carp "Socket error sending $type request in ctcp()";
340 # Sends replies to CTCP queries. Simple enough, right?
341 # Takes 2 args: the target person or channel to send a reply to
342 # the text of the reply
346 $self->notice($_[0], "\001" . $_[1] . "\001");
350 # Sets or returns the debugging flag for this object.
351 # Takes 1 optional arg: a new boolean value for the flag.
355 $self->{_debug} = $_[0];
357 return $self->{_debug};
361 # Dequotes CTCP messages according to ctcp.spec. Nothing special.
362 # Then it breaks them into their component parts in a flexible, ircII-
363 # compatible manner. This is not quite as trivial. Oh, well.
364 # Takes 1 arg: the line to be dequoted.
367 my ($order, @chunks) = (0, ()); # CHUNG! CHUNG! CHUNG!
369 # Filter misplaced \001s before processing... (Thanks, Tom!)
370 substr($line, rindex($line, "\001"), 1) = '\\a'
371 unless ($line =~ tr/\001//) % 2 == 0;
373 # Thanks to Abigail (abigail@fnx.com) for this clever bit.
374 if (index($line, "\cP") >= 0) { # dequote low-level \n, \r, ^P, and \0.
375 my (%h) = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP");
376 $line =~ s/\cP([nr0\cP])/$h{$1}/g;
378 $line =~ s/\\([^\\a])/$1/g; # dequote unnecessarily quoted characters.
380 # -- #perl was here! --
381 # roy7: Chip Chip he's our man!
382 # fimmtiu: If he can't do it, Larry can!
383 # ChipDude: I thank you! No applause, just throw RAM chips!
385 # If true, it's in odd order... ctcp commands start with first chunk.
386 $order = 1 if index($line, "\001") == 0;
387 @chunks = map { s/\\\\/\\/g; $_ } (split /\cA/, $line);
389 return ($order, @chunks);
392 # Standard destructor method for the GC routines. (HAHAHAH! DIE! DIE! DIE!)
396 $self->handler("destroy", "nobody will ever use this");
400 # Disconnects this Connection object cleanly from the server.
401 # Takes at least 1 arg: the format and args parameters to Event->new().
405 $self->{_connected} = 0;
406 $self->parent->removeconn($self);
407 $self->socket( undef );
408 $self->handler(Net::IRC::Event->new( "disconnect",
415 # Tells IRC.pm if there was an error opening this connection. It's just
416 # for sane error passing.
417 # Takes 1 optional arg: the new value for $self->{'iserror'}
421 $self->{'iserror'} = $_[0] if @_;
422 return $self->{'iserror'};
425 # -- #perl was here! --
426 # <nocarrier> No, I commute Mon-Wed-Fri from Allentown.
427 # <rudefix> the billy joel and skinhead place
428 # <nocarrier> that's what they say.
429 # <\lembit> it's hard to keep a good man down.
430 # <qw[jeff]> but only the good die young!
431 # \lembit won't be getting up today.
432 # <rudefix> because they're under too much pressure, jeff
433 # <qw[jeff]> and it surely will catch up to them, somewhere along the line.
436 # Lets the user set or retrieve a format for a message of any sort.
437 # Takes at least 1 arg: the event whose format you're inquiring about
438 # (optional) the new format to use for this event
440 my ($self, $ev) = splice @_, 0, 2;
443 croak "Not enough arguments to format()";
447 $self->{'_format'}->{$ev} = $_[0];
449 return ($self->{'_format'}->{$ev} ||
450 $self->{'_format'}->{'default'});
454 # -- #perl was here! --
455 # <q[merlyn]> \lem... know any good austin Perl hackers for hire?
456 # <q[merlyn]> I'm on a hunt for one for a friend.
457 # <archon> for a job?
458 # <Stupid_> No, in his spare time merlyn bow-hunts for perl programmers
462 # Calls the appropriate handler function for a specified event.
463 # Takes 2 args: the name of the event to handle
464 # the arguments to the handler function
466 my ($self, $event) = splice @_, 0, 2;
468 unless (defined $event) {
469 croak 'Too few arguments to Connection->handler()';
476 } elsif (defined $event) {
478 $event = Net::IRC::Event->new($event, '', '', '');
480 croak "Not enough arguments to handler()";
483 print STDERR "Trying to handle event '$ev'.\n" if $self->{_debug};
485 # -- #perl was here! --
486 # <\lembit> tainted code...oh-oh..tainted code...sometimes I know I've
487 # got to (boink boink) run away...
488 # <Excession> \lembit I'd ease up on the caffiene if I were you
491 if (exists $self->{_handler}->{$ev}) {
492 $handler = $self->{_handler}->{$ev};
493 } elsif (exists $_udef{$ev}) {
494 $handler = $_udef{$ev};
496 return $self->_default($event, @_);
499 my ($code, $rp) = @{$handler};
501 # If we have args left, try to call the handler.
502 if ($rp == 0) { # REPLACE
503 &$code($self, $event, @_);
504 } elsif ($rp == 1) { # BEFORE
505 &$code($self, $event, @_);
506 $self->_default($event, @_);
507 } elsif ($rp == 2) { # AFTER
508 $self->_default($event, @_);
509 &$code($self, $event, @_);
511 confess "Bad parameter passed to handler(): rp=$rp";
514 warn "Handler for '$ev' called.\n" if $self->{_debug};
519 # -- #perl was here! --
520 # <JavaJive> last night I dreamt I was flying over mountainous terrains
521 # which changed into curves and and valleys shooting everywhere
522 # and then finally into physical abominations which could never
523 # really exist in the material universe.
524 # <JavaJive> then I realized it was just one of my perl data structures.
527 # Lets a user set hostmasks to discard certain messages from, or (if called
528 # with only 1 arg), show a list of currently ignored hostmasks of that type.
529 # Takes 2 args: type of ignore (public, msg, ctcp, etc)
530 # (optional) [mask(s) to be added to list of specified type]
535 croak "Not enough arguments to ignore()";
539 if (exists $self->{_ignore}->{$_[0]}) {
540 return @{ $self->{_ignore}->{$_[0]} };
544 } elsif (@_ > 1) { # code defensively, remember...
547 # I moved this part further down as an Obsessive Efficiency
548 # Initiative. It shouldn't be a problem if I do _parse right...
549 # ... but those are famous last words, eh?
550 unless (grep {$_ eq $type}
551 qw(public msg ctcp notice channel nick other all)) {
552 carp "$type isn't a valid type to ignore()";
556 if ( exists $self->{_ignore}->{$type} ) {
557 push @{$self->{_ignore}->{$type}}, @_;
559 $self->{_ignore}->{$type} = [ @_ ];
565 # -- #perl was here! --
566 # <Moonlord> someone can tell me some web side for "hack" programs
567 # <fimmtiu> Moonlord: http://pinky.wtower.com/nethack/
568 # <Moonlord> thank`s fimmtiu
569 # fimmtiu giggles maniacally.
572 # Yet Another Ridiculously Simple Sub. Sends an INFO command.
573 # Takes 1 optional arg: the name of the server to query.
577 $self->sl("INFO" . ($_[0] ? " $_[0]" : ""));
581 # -- #perl was here! --
582 # <Teratogen> terminals in the night
583 # <Teratogen> exchanging ascii
584 # <Teratogen> oops, we dropped a byte
585 # <Teratogen> please hit the break key
586 # <Teratogen> doo be doo be doo
589 # Invites someone to an invite-only channel. Whoop.
590 # Takes 2 args: the nick of the person to invite
591 # the channel to invite them to.
592 # I hate the syntax of this command... always seemed like a protocol flaw.
597 croak "Not enough arguments to invite()";
600 $self->sl("INVITE $_[0] $_[1]");
603 # Checks if a particular nickname is in use.
604 # Takes at least 1 arg: nickname(s) to look up.
609 croak 'Not enough args to ison().';
612 $self->sl("ISON " . CORE::join(" ", @_));
615 # Joins a channel on the current server if connected, eh?.
616 # Corresponds to /JOIN command.
617 # Takes 2 args: name of channel to join
618 # optional channel password, for +k channels
622 unless ( $self->connected ) {
623 carp "Can't join() -- not connected to a server";
627 # -- #perl was here! --
628 # *** careful is Starch@ncb.mb.ca (The WebMaster)
629 # *** careful is on IRC via server irc.total.net (Montreal Hub &
631 # careful: well, it's hard to buy more books now too cause where the
632 # heck do you put them all? i have to move and my puter room is
633 # almost 400 square feet, it's the largest allowed in my basement
634 # without calling it a room and pay taxes, hehe
637 croak "Not enough arguments to join()";
640 # \petey: paying taxes by the room?
642 # careful: that's what they do for finished basements and stuff
643 # careful: need an emergency exit and stuff
644 # jjohn: GOOD GOD! ARE THEY HEATHENS IN CANADA? DO THEY EAT THEIR
647 return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : ""));
649 # \petey: "On the 'net nobody knows you're Canadian, eh?"
650 # jjohn: shut up, eh?
653 # Opens a righteous can of whoop-ass on any luser foolish enough to ask a
654 # CGI question in #perl. Eat flaming death, web wankers!
655 # Takes at least 2 args: the channel to kick the bastard from
656 # the nick of the bastard in question
657 # (optional) a parting comment to the departing bastard
662 croak "Not enough arguments to kick()";
664 return $self->sl("KICK $_[0] $_[1]" . ($_[2] ? " :$_[2]" : ""));
667 # -- #perl was here! --
668 # sputnik1 listens in glee to the high-pitched whine of the Pratt
669 # and Whitney generator heating up on the launcher of his
670 # AGM-88B HARM missile
671 # <lej> sputnik1: calm down, little commie satellite
674 # Gets a list of all the servers that are linked to another visible server.
675 # Takes 2 optional args: it's a bitch to describe, and I'm too tired right
676 # now, so read the RFC.
678 my ($self) = (shift, undef);
680 $self->sl("LINKS" . (scalar(@_) ? " " . CORE::join(" ", @_[0,1]) : ""));
684 # Requests a list of channels on the server, or a quick snapshot of the current
685 # channel (the server returns channel name, # of users, and topic for each).
689 $self->sl("LIST " . CORE::join(",", @_));
692 # -- #perl was here! --
693 # <china`blu> see, neo?
694 # <china`blu> they're crowded
695 # <china`blu> i bet some programmers/coders might be here
696 # <fimmtiu> Nope. No programmers here. We're just Larry Wall groupies.
697 # <china`blu> come on
698 # <Kilbaniar> Larry Wall isn't as good in bed as you'd think.
699 # <Kilbaniar> For the record...
702 # -- #perl was here! --
703 # <Skrewtape> Larry Wall is a lot sexier than Richard Stallman
704 # <Skrewtape> But I've heard Stallman is better in bed.
705 # <Schwern> Does he leave the halo on?
706 # * aether cocks her head at skrew...uh...whatever?
707 # <fimmtiu> Stallman's beard is a sex magnet.
708 # <Skrewtape> Larry's moustache is moreso, Fimm.
709 # <aether> oh yeah...women all over the world are hot for stallman....
710 # <Skrewtape> Moustaches make my heart melt.
711 # <Schwern> I dunno, there's something about a man in hawaiian shirts...
714 # Sends a request for some server/user stats.
715 # Takes 1 optional arg: the name of a server to request the info from.
719 $self->sl("LUSERS" . ($_[0] ? " $_[0]" : ""));
722 # Gets and/or sets the max line length. The value previous to the sub
723 # call will be returned.
724 # Takes 1 (optional) arg: the maximum line length (in bytes)
728 my $ret = $self->{_maxlinelen};
730 $self->{_maxlinelen} = shift if @_;
735 # -- #perl was here! --
736 # <KeithW> Hey, actually, I just got a good idea for an April Fools-day
738 # <KeithW> tchrist-mode
740 # <KeithW> When you finish typing a word, emacs automatically replaces it
741 # with the longest synonym from the online Merriam-Webster
745 # Sends an action to the channel/nick you specify. It's truly amazing how
746 # many IRCers have no idea that /me's are actually sent via CTCP.
747 # Takes 2 args: the channel or nick to bother with your witticism
748 # the action to send (e.g., "weed-whacks billn's hand off.")
752 $self->ctcp("ACTION", $_[0], $_[1]);
755 # -- #perl was here! --
756 # *** china`blu (azizam@pm5-30.flinet.com) has joined channel #perl
757 # <china`blu> hi guys
758 # <china`blu> and girls
759 # <purl> I am NOT a lesbian!
762 # Change channel and user modes (this one is easy... the handler is a bitch.)
763 # Takes at least 1 arg: the target of the command (channel or nick)
764 # (optional) the mode string (i.e., "-boo+i")
765 # (optional) operands of the mode string (nicks, hostmasks, etc.)
770 croak "Not enough arguments to mode()";
772 $self->sl("MODE $_[0] " . CORE::join(" ", @_[1..$#_]));
775 # -- #perl was here! --
776 # *** billnolio (billn@initiate.monk.org) has joined channel #perl
777 # *** Mode change "+v billnolio" on channel #perl by select
778 # billnolio humps fimmtiu's leg
779 # *** billnolio has left channel #perl
782 # Sends a MOTD command to a server.
783 # Takes 1 optional arg: the server to query (defaults to current server)
787 $self->sl("MOTD" . ($_[0] ? " $_[0]" : ""));
790 # -- #perl was here! --
791 # <Roderick> "Women were put on this earth to weaken us. Drain our energy.
792 # Laugh at us when they see us naked."
793 # <qw[jeff]> rod - maybe YOUR women...
794 # <fimmtiu> jeff: Oh, just wait....
795 # <Roderick> "Love is a snowmobile racing across the tundra, which
796 # suddenly flips over, pinning you underneath. At night,
797 # the ice weasels come."
798 # <qw[jeff]> rod - where do you GET these things?!
799 # <Roderick> They do tend to accumulate. Clutter in the brain.
802 # Requests the list of users for a particular channel (or the entire net, if
803 # you're a masochist).
804 # Takes 1 or more optional args: name(s) of channel(s) to list the users from.
808 $self->sl("NAMES " . CORE::join(",", @_));
810 } # Was this the easiest sub in the world, or what?
812 # Creates a new IRC object and assigns some default attributes.
816 # -- #perl was here! --
817 # <\merlyn> just don't use ref($this) || $this;
818 # <\merlyn> tchrist's abomination.
819 # <\merlyn> lame lame lame. frowned upon by any OO programmer I've seen.
820 # <tchrist> randal disagrees, but i don't care.
821 # <tchrist> Randal isn't being flexible/imaginative.
822 # <ChipDude> fimm: WRT "ref ($proto) || $proto", I'm against. Class
823 # methods and object methods are distinct.
825 # my $class = ref($proto) || $proto; # Man, am I confused...
827 my $self = { # obvious defaults go here, rest are user-set
828 _debug => $_[0]->{_debug},
830 # Evals are for non-UNIX machines, just to make sure.
831 _username => eval { scalar getpwuid($>) } || $ENV{USER}
832 || $ENV{LOGNAME} || "japh",
833 _ircname => $ENV{IRCNAME} || eval { (getpwuid($>))[6] }
834 || "Just Another Perl Hacker",
835 _nick => $ENV{IRCNICK} || eval { scalar getpwuid($>) }
836 || $ENV{USER} || $ENV{LOGNAME} || "WankerBot", # heheh...
839 _verbose => 0, # Is this an OK default?
843 _maxlinelen => 510, # The RFC says we shouldn't exceed this.
845 'default' => "[%f:%t] %m <%d>",
850 # do any necessary initialization here
851 $self->connect(@_) if @_;
856 # Creates and returns a DCC CHAT object, analogous to IRC.pm's newconn().
857 # Takes at least 1 arg: An Event object for the DCC CHAT request.
858 # OR A list or listref of args to be passed to new(),
860 # - A boolean value indicating whether or not
861 # you're initiating the CHAT connection.
862 # - The nick of the chattee
863 # - The address to connect to
864 # - The port to connect on
867 my ($init, $nick, $address, $port);
869 if (ref($_[0]) =~ /Event/) {
870 # If it's from an Event object, we can't be initiating, right?
871 ($init, undef, undef, undef, $address, $port) = (0, $_[0]->args);
874 } elsif (ref($_[0]) eq "ARRAY") {
875 ($init, $nick, $address, $port) = @{$_[0]};
877 ($init, $nick, $address, $port) = @_;
880 # -- #perl was here! --
882 # gnat: no fucking microsoft products, thanks :)
883 # ^Pudge: what about non-fucking MS products? i hear MS Bob is a virgin.
885 Net::IRC::DCC::CHAT->new($self, $init, $nick, $address, $port);
888 # Creates and returns a DCC GET object, analogous to IRC.pm's newconn().
889 # Takes at least 1 arg: An Event object for the DCC SEND request.
890 # OR A list or listref of args to be passed to new(),
892 # - The nick of the file's sender
893 # - The name of the file to receive
894 # - The address to connect to
895 # - The port to connect on
896 # - The size of the incoming file
897 # For all of the above, an extra argument can be added at the end:
898 # An open filehandle to save the incoming file into,
899 # in globref, FileHandle, or IO::* form.
902 my ($nick, $name, $address, $port, $size, $handle);
904 if (ref($_[0]) =~ /Event/) {
905 (undef, undef, $name, $address, $port, $size) = $_[0]->args;
907 $handle = $_[1] if defined $_[1];
908 } elsif (ref($_[0]) eq "ARRAY") {
909 ($nick, $name, $address, $port, $size) = @{$_[0]};
910 $handle = $_[1] if defined $_[1];
912 ($nick, $name, $address, $port, $size, $handle) = @_;
915 unless (defined $handle and ref $handle and
916 (ref $handle eq "GLOB" or $handle->can('print')))
918 carp ("Filehandle argument to Connection->new_get() must be ".
919 "a glob reference or object");
920 return; # is this behavior OK?
923 my $dcc = Net::IRC::DCC::GET->new($self, $nick, $address,
924 $port, $size, $name, $handle);
926 $self->parent->addconn($dcc) if $dcc;
930 # Creates and returns a DCC SEND object, analogous to IRC.pm's newconn().
931 # Takes at least 2 args: The nickname of the person to send to
932 # The name of the file to send
933 # (optional) The blocksize for the connection (default 1k)
936 my ($nick, $filename, $blocksize);
938 if (ref($_[0]) eq "ARRAY") {
939 ($nick, $filename, $blocksize) = @{$_[0]};
941 ($nick, $filename, $blocksize) = @_;
944 Net::IRC::DCC::SEND->new($self, $nick, $filename, $blocksize);
947 # -- #perl was here! --
948 # [petey suspects I-Que of not being 1337!
949 # <fimmtiu> Eat flaming death, petey.
950 # <I-Que> I'm only 22!
954 # Selects nick for this object or returns currently set nick.
955 # No default; must be set by user.
956 # If changed while the object is already connected to a server, it will
957 # automatically try to change nicks.
958 # Takes 1 arg: the nick. (I bet you could have figured that out...)
963 $self->{'_nick'} = shift;
964 if ($self->connected) {
965 return $self->sl("NICK " . $self->{'_nick'});
968 return $self->{'_nick'};
972 # Sends a notice to a channel or person.
973 # Takes 2 args: the target of the message (channel or nick)
974 # the text of the message to send
975 # The message will be chunked if it is longer than the _maxlinelen
976 # attribute, but it doesn't try to protect against flooding. If you
977 # give it too much info, the IRC server will kick you off!
979 my ($self, $to) = splice @_, 0, 2;
982 croak "Not enough arguments to notice()";
985 my ($buf, $length, $line) = (CORE::join("", @_), $self->{_maxlinelen});
988 ($line, $buf) = unpack("a$length a*", $buf);
989 $self->sl("NOTICE $to :$line");
993 # -- #perl was here! --
994 # <TorgoX> this was back when I watched Talk Soup, before I had to stop
995 # because I saw friends of mine on it.
996 # [petey chuckles at TorgoX
997 # <Technik> TorgoX: on the Jerry Springer clips?
998 # <TorgoX> I mean, when people you know appear on, like, some Springer
999 # knockoff, in a cheap disguise, and the Talk Soup host makes fun
1000 # of them, you just have to stop.
1001 # <Technik> TorgoX: you need to get better friends
1002 # <TorgoX> I was shamed. I left town.
1003 # <TorgoX> grad school was just the pretext for the move. this was the
1008 # Makes you an IRCop, if you supply the right username and password.
1009 # Takes 2 args: Operator's username
1010 # Operator's password
1015 croak "Not enough arguments to oper()";
1018 $self->sl("OPER $_[0] $_[1]");
1021 # This function splits apart a raw server line into its component parts
1022 # (message, target, message type, CTCP data, etc...) and passes it to the
1023 # appropriate handler. Takes no args, really.
1026 my ($from, $type, $message, @stuff, $itype, $ev, @lines, $line);
1028 # Read newly arriving data from $self->socket
1029 # -- #perl was here! --
1030 # <Tkil2> hm.... any joy if you add a 'defined' to the test? like
1031 # if (defined $sock...
1032 # <fimmtiu> Much joy now.
1035 if (defined recv($self->socket, $line, 10240, 0) and
1036 (length($self->{_frag}) + length($line)) > 0) {
1037 # grab any remnant from the last go and split into lines
1038 my $chunk = $self->{_frag} . $line;
1039 @lines = split /\012/, $chunk;
1041 # if the last line was incomplete, pop it off the chunk and
1042 # stick it back into the frag holder.
1043 $self->{_frag} = (substr($chunk, -1) ne "\012" ? pop @lines : '');
1046 # um, if we can read, i say we should read more than 0
1047 # besides, recv isn't returning undef on closed
1048 # sockets. getting rid of this connection...
1049 $self->disconnect('error', 'Connection reset by peer');
1053 foreach $line (@lines) {
1055 # Clean the lint filter every 2 weeks...
1056 $line =~ s/[\012\015]+$//;
1059 print STDERR "<<< $line\n" if $self->{_debug};
1061 # Like the RFC says: "respond as quickly as possible..."
1062 if ($line =~ /^PING/) {
1063 $ev = (Net::IRC::Event->new( "ping",
1066 "serverping", # FIXME?
1070 # Had to move this up front to avoid a particularly pernicious bug.
1071 } elsif ($line =~ /^NOTICE/) {
1072 $ev = Net::IRC::Event->new( "snotice",
1076 (split /:/, $line, 2)[1] );
1079 # Spurious backslashes are for the benefit of cperl-mode.
1080 # Assumption: all non-numeric message types begin with a letter
1081 } elsif ($line =~ /^:?
1082 ([][}{\w\\\`^|\-]+? # The nick (valid nickname chars)
1083 ! # The nick-username separator
1087 \s+ # Space between mask and message type
1088 [A-Za-z] # First char of message type
1089 [^\s:]+? # The rest of the message type
1090 /x) # That ought to do it for now...
1092 $line = substr $line, 1 if $line =~ /^:/;
1093 ($from, $line) = split ":", $line, 2;
1094 ($from, $type, @stuff) = split /\s+/, $from;
1097 # This should be fairly intuitive... (cperl-mode sucks, though)
1098 if (defined $line and index($line, "\001") >= 0) {
1100 unless ($type eq "notice") {
1101 $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg");
1103 } elsif ($type eq "privmsg") {
1104 $itype = $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg");
1105 } elsif ($type eq "notice") {
1107 } elsif ($type eq "join" or $type eq "part" or
1108 $type eq "mode" or $type eq "topic" or
1111 } elsif ($type eq "nick") {
1117 # This goes through the list of ignored addresses for this message
1118 # type and drops out of the sub if it's from an ignored hostmask.
1121 foreach ( $self->ignore($itype), $self->ignore("all") ) {
1122 $_ = quotemeta; s/\\\*/.*/g;
1123 return 1 if $from =~ /$_/;
1126 # It used to look a lot worse. Here was the original version...
1127 # the optimization above was proposed by Silmaril, for which I am
1128 # eternally grateful. (Mine still looks cooler, though. :)
1130 # return if grep { $_ = join('.*', split(/\\\*/,
1131 # quotemeta($_))); /$from/ }
1132 # ($self->ignore($type), $self->ignore("all"));
1134 # Add $line to @stuff for the handlers
1135 push @stuff, $line if defined $line;
1137 # Now ship it off to the appropriate handler and forget about it.
1138 if ( $itype eq "ctcp" ) { # it's got CTCP in it!
1139 $self->parse_ctcp($type, $from, $stuff[0], $line);
1142 } elsif ($type eq "public" or $type eq "msg" or
1143 $type eq "notice" or $type eq "mode" or
1144 $type eq "join" or $type eq "part" or
1145 $type eq "topic" or $type eq "invite" ) {
1147 $ev = Net::IRC::Event->new( $type,
1153 } elsif ($type eq "quit" or $type eq "nick") {
1155 $ev = Net::IRC::Event->new( $type,
1161 } elsif ($type eq "kick") {
1163 $ev = Net::IRC::Event->new( $type,
1167 @stuff[0,2..$#stuff],
1170 } elsif ($type eq "kill") {
1171 $ev = Net::IRC::Event->new($type,
1175 $line); # Ahh, what the hell.
1176 } elsif ($type eq "wallops") {
1177 $ev = Net::IRC::Event->new($type,
1183 carp "Unknown event type: $type";
1187 # -- #perl was here! --
1188 # *** orwant (orwant@media.mit.edu) has joined channel #perl
1189 # orwant: Howdy howdy.
1190 # orwant: Just came back from my cartooning class.
1191 # orwant: I'm working on a strip for TPJ.
1192 # njt: it's happy bouncy clown jon from clownland! say 'hi' to
1194 # orwant splits open njt like a wet bag of groceries and
1195 # dances on his sticky bones.
1196 # njt: excuse me, ladies, but I've got to go eviscerate myself with
1197 # a leaky biro. don't wait up.
1199 elsif ($line =~ /^:? # Here's Ye Olde Numeric Handler!
1200 \S+? # the servername (can't assume RFC hostname)
1201 \s+? # Some spaces here...
1202 \d+? # The actual number
1203 \b/x # Some other crap, whatever...
1205 $ev = $self->parse_num($line);
1207 } elsif ($line =~ /^:(\w+) MODE \1 /) {
1208 $ev = Net::IRC::Event->new( 'umode',
1212 substr($line, index($line, ':', 1) + 1));
1214 } elsif ($line =~ /^:? # Here's Ye Olde Server Notice handler!
1215 .+? # the servername (can't assume RFC hostname)
1216 \s+? # Some spaces here...
1217 NOTICE # The server notice
1218 \b/x # Some other crap, whatever...
1220 $ev = Net::IRC::Event->new( 'snotice',
1224 (split /\s+/, $line, 3)[2] );
1227 } elsif ($line =~ /^ERROR/) {
1228 if ($line =~ /^ERROR :Closing [Ll]ink/) { # is this compatible?
1231 $self->disconnect( 'error', ($line =~ /(.*)/) );
1234 $ev = Net::IRC::Event->new( "error",
1238 (split /:/, $line, 2)[1]);
1240 } elsif ($line =~ /^Closing [Ll]ink/) {
1242 $self->disconnect( 'error', ($line =~ /(.*)/) );
1248 # We need to be able to fall through if the handler has
1249 # already been called (i.e., from within disconnect()).
1251 $self->handler($ev) unless $ev eq 'done';
1254 # If it gets down to here, it's some exception I forgot about.
1255 carp "Funky parse case: $line\n";
1260 # The backend that parse() sends CTCP requests off to. Pay no attention
1261 # to the camel behind the curtain.
1262 # Takes 4 arguments: the type of message
1264 # the first bit of stuff
1265 # the line from the server.
1267 my ($self, $type, $from, $stuff, $line) = @_;
1270 my ($odd, @foo) = (&dequote($line));
1272 while (($one, $two) = (splice @foo, 0, 2)) {
1274 ($one, $two) = ($two, $one) if $odd;
1276 my ($ctype) = $one =~ /^(\w+)\b/;
1278 if ($type eq 'notice') {
1280 } elsif ($type eq 'public' or
1284 carp "Unknown CTCP type: $type";
1289 my $handler = $prefix . lc $ctype; # unit. value prob with $ctype
1291 # -- #perl was here! --
1292 # fimmtiu: Words cannot describe my joy. Sil, you kick ass.
1293 # fimmtiu: I was passing the wrong arg to Event::new()
1295 $self->handler(Net::IRC::Event->new($handler, $from, $stuff,
1296 $handler, (split /\s/, $one)));
1299 # This next line is very likely broken somehow. Sigh.
1300 $self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two))
1306 # Does special-case parsing for numeric events. Separate from the rest of
1307 # parse() for clarity reasons (I can hear Tkil gasping in shock now. :-).
1308 # Takes 1 arg: the raw server line
1310 my ($self, $line) = @_;
1312 ## Figlet protection? This seems to be a bit closer to the RFC than
1313 ## the original version, which doesn't seem to handle :trailers quite
1316 my ($from, $type, $stuff) = split(/\s+/, $line, 3);
1317 my ($blip, $space, $other, @stuff);
1319 ($blip, $space, $other) = split(/(\s+)/, $stuff, 2);
1320 $space = "" unless $space;
1321 $other = "" unless $other; # I hate warnings. Thanks to jack velte...
1322 if ($blip =~ /^:/) {
1323 push @stuff, $blip . $space . $other;
1331 $from = substr $from, 1 if $from =~ /^:/;
1333 return Net::IRC::Event->new( $type,
1340 # -- #perl was here! --
1341 # <megas> heh, why are #windowsNT people so quiet? are they all blue screened?
1342 # <Hiro> they're busy flapping their arms and making swooshing jet noises
1345 # Helps you flee those hard-to-stand channels.
1346 # Takes at least one arg: name(s) of channel(s) to leave.
1351 croak "No arguments provided to part()";
1353 $self->sl("PART " . CORE::join(",", @_)); # "A must!"
1357 # Tells what's on the other end of a connection. Returns a 2-element list
1358 # consisting of the name on the other end and the type of connection.
1363 return ($self->server(), "IRC connection");
1367 # -- #perl was here! --
1368 # <thoth> We will have peace, when you and all your works have perished--
1369 # and the works of your Dark Master, Mammon, to whom you would
1370 # deliver us. You are a strumpet, Fmh, and a corrupter of men's
1372 # <Fmh> thoth, smile when you say that
1373 # <Fmh> i'd much rather be thought of as a corrupter of women's hearts.
1376 # Prints a message to the defined error filehandle(s).
1377 # No further description should be necessary.
1380 print STDERR @_, "\n";
1384 # -- #perl was here! --
1385 # <_thoth> The hummer was like six feet up.
1387 # <_thoth> The cat did this Flash trick.
1388 # <_thoth> And when the cat landed, there was a hummer in his mouth.
1389 # <_thoth> Once you see a cat pluck a hummer from the sky, you know why
1390 # the dogs are scared.
1393 # Prints a message to the defined output filehandle(s).
1396 print STDOUT @_, "\n";
1399 # Sends a message to a channel or person.
1400 # Takes 2 args: the target of the message (channel or nick)
1401 # the text of the message to send
1402 # Don't use this for sending CTCPs... that's what the ctcp() function is for.
1403 # The message will be chunked if it is longer than the _maxlinelen
1404 # attribute, but it doesn't try to protect against flooding. If you
1405 # give it too much info, the IRC server will kick you off!
1407 my ($self, $to) = splice @_, 0, 2;
1410 croak 'Not enough arguments to privmsg()';
1413 my $buf = CORE::join '', @_;
1414 my $length = $self->{_maxlinelen} - 11 - length($to);
1417 # -- #perl was here! --
1418 # <v0id_> i really haven't dug into Net::IRC yet.
1419 # <v0id_> hell, i still need to figure out how to make it just say
1420 # something on its current channel...
1421 # <fimmtiu> $connection->privmsg('#channel', "Umm, hi.");
1422 # <v0id_> but you have to know the channel already eh?
1423 # <fimmtiu> Yes. This is how IRC works. :-)
1424 # <v0id_> damnit, why can't everything be a default. :)
1425 # <happybob> v0id_: it can. you end up with things like a 1 button
1426 # mouse then, though. :)
1428 if (ref($to) =~ /^(GLOB|IO::Socket)/) {
1430 ($line, $buf) = unpack("a$length a*", $buf);
1431 send($to, $line . "\012", 0);
1435 ($line, $buf) = unpack("a$length a*", $buf);
1436 if (ref $to eq 'ARRAY') {
1437 $self->sl("PRIVMSG ", CORE::join(',', @$to), " :$line");
1439 $self->sl("PRIVMSG $to :$line");
1446 # Closes connection to IRC server. (Corresponding function for /QUIT)
1447 # Takes 1 optional arg: parting message, defaults to "Leaving" by custom.
1451 # Do any user-defined stuff before leaving
1452 $self->handler("leaving");
1454 unless ( $self->connected ) { return (1) }
1456 # Why bother checking for sl() errors now, after all? :)
1457 # We just send the QUIT command and leave. The server will respond with
1458 # a "Closing link" message, and parse() will catch it, close the
1459 # connection, and throw a "disconnect" event. Neat, huh? :-)
1461 $self->sl("QUIT :" . (defined $_[0] ? $_[0] : "Leaving"));
1465 # As per the RFC, ask the server to "re-read and process its configuration
1466 # file." Your server may or may not take additional arguments. Generally
1467 # requires IRCop status.
1470 $self->sl("REHASH" . CORE::join(" ", @_));
1474 # As per the RFC, "force a server restart itself." (Love that RFC.)
1475 # Takes no arguments. If it succeeds, you will likely be disconnected,
1476 # but I assume you already knew that. This sub is too simple...
1479 $self->sl("RESTART");
1482 # Schedules an event to be executed after some length of time.
1483 # Takes at least 2 args: the number of seconds to wait until it's executed
1484 # a coderef to execute when time's up
1485 # Any extra args are passed as arguments to the user's coderef.
1487 my ($self, $time, $code) = splice @_, 0, 3;
1490 croak 'Not enough arguments to Connection->schedule()';
1492 unless (ref $code eq 'CODE') {
1493 croak 'Second argument to schedule() isn\'t a coderef';
1496 $time = time + int $time;
1497 $self->parent->queue($time, $code, $self, @_);
1501 # -- #perl was here! --
1502 # <freeside> YOU V3GAN FIEND, J00 W1LL P4Y D3ARLY F0R TH1S TRESPASS!!!!!!!!!!!
1503 # <Netslave> be quiet freeside
1504 # <freeside> WE W1LL F0RCE PR0K DOWN YOUR V1RG1N THR0AT
1505 # <freeside> MAKE ME
1506 # <freeside> :-PPPPPPPPP
1507 # <freeside> FORCE IS THE LAST REFUGE OF THE WEAK
1508 # <freeside> I DIE, OH, HORATIO, I DIE!
1509 # Che_Fox hugs freeside
1510 # <initium> freeside (=
1511 # <Che_Fox> I lurve you all :)
1512 # freeside lashes himself to the M4ST.
1513 # <Netslave> freeside, why do you eat meat?
1514 # <freeside> 4NARCHY R00000LZ!!!!! F1GHT TH3 P0W3R!!!!!!
1515 # <freeside> I 3AT M3AT S0 TH4T J00 D0N'T H4V3 TO!!!!!!!!!!!!
1516 # <freeside> I 3AT M3AT F0R J00000R SINS, NETSLAVE!!!!!!!!!!
1517 # <freeside> W0RSH1P M3333333!!!!!!!
1518 # *** t0fu (wasian@pm3l-12.pacificnet.net) joined #perl.
1520 # *** t0fu (wasian@pm3l-12.pacificnet.net) left #perl.
1521 # <freeside> T0FU, MY SAV10UIRRRRRRRRRRRRR
1522 # <freeside> NOOOOOOOOOOOOOO
1523 # <freeside> COME BAAAAAAAAAACK
1524 # <Che_Fox> no t0fu for you.
1527 # Lets J. Random IRCop connect one IRC server to another. How uninteresting.
1528 # Takes at least 1 arg: the name of the server to connect your server with
1529 # (optional) the port to connect them on (default 6667)
1530 # (optional) the server to connect to arg #1. Used mainly by
1531 # servers to communicate with each other.
1536 croak "Not enough arguments to sconnect()";
1538 $self->sl("CONNECT " . CORE::join(" ", @_));
1541 # Sets/changes the IRC server which this instance should connect to.
1542 # Takes 1 arg: the name of the server (see below for possible syntaxes)
1543 # ((syntaxen? syntaxi? syntaces?))
1548 # cases like "irc.server.com:6668"
1549 if (index($_[0], ':') > 0) {
1550 my ($serv, $port) = split /:/, $_[0];
1551 if ($port =~ /\D/) {
1552 carp "$port is not a valid port number in server()";
1555 $self->{_server} = $serv;
1558 # cases like ":6668" (buried treasure!)
1559 } elsif (index($_[0], ':') == 0 and $_[0] =~ /^:(\d+)/) {
1562 # cases like "irc.server.com"
1564 $self->{_server} = shift;
1569 return $self->{_server};
1574 # Sends a raw IRC line to the server.
1575 # Corresponds to the internal sirc function of the same name.
1576 # Takes 1 arg: string to send to server. (duh. :)
1579 my $line = CORE::join '', @_;
1582 croak "Not enough arguments to sl()";
1585 ### DEBUG DEBUG DEBUG
1586 if ($self->{_debug}) {
1587 print ">>> $line\n";
1590 # RFC compliance can be kinda nice...
1591 my $rv = send( $self->{_socket}, "$line\015\012", 0 );
1593 $self->handler("sockerror");
1599 # -- #perl was here! --
1600 # <mandrake> the person at wendy's in front of me had a heart attack while
1602 # <Stupid> mandrake: Before or -after- they ate the food?
1603 # <DrForr> mandrake: What did he have?
1604 # <mandrake> DrForr: a big bacon classic
1606 # Tells any server that you're an oper on to disconnect from the IRC network.
1607 # Takes at least 1 arg: the name of the server to disconnect
1608 # (optional) a comment about why it was disconnected
1613 croak "Not enough arguments to squit()";
1616 $self->sl("SQUIT $_[0]" . ($_[1] ? " :$_[1]" : ""));
1619 # -- #perl was here! --
1620 # * QDeath is trying to compile a list of email addresses given a HUGE
1621 # file of people's names... :)
1622 # <fimmtiu> Is this spam-related?
1623 # <QDeath> no, actually, it's official school related.
1624 # <fimmtiu> Good. Was afraid I had been doing the devil's work for a second.
1625 # * Tkil sprinkles fimmtiu's terminal with holy water, just in case.
1626 # *** Signoff: billn (Fimmtiu is the devil's tool. /msg him and ask him
1628 # *Fmh* are you the devil's "tool" ?
1629 # -> *fmh* Yep. All 6 feet of me.
1632 # Gets various server statistics for the specified host.
1633 # Takes at least 1 arg: the type of stats to request [chiklmouy]
1634 # (optional) the server to request from (default is current server)
1639 croak "Not enough arguments passed to stats()";
1642 $self->sl("STATS $_[0]" . ($_[1] ? " $_[1]" : ""));
1645 # -- #perl was here! --
1646 # <Schwern> Wheat grass juice is properly served in a NyQuil sized cup, in
1647 # a NyQuil sized color with a NyQuil sized flavor.
1648 # <mendel> how big is nyquil's color
1649 # <foobah> often wheat grass is served mixed in with other fruit juices
1651 # <Schwern> mendel: As BIG AS THE FUCKIN' Q!
1652 # <yuckf00> this big <---------------------------------->
1653 # <foobah> since by itself it can burn holes in your esophagus
1658 # If anyone still has SUMMON enabled, this will implement it for you.
1659 # If not, well...heh. Sorry. First arg mandatory: user to summon.
1660 # Second arg optional: a server name.
1665 croak "Not enough arguments passed to summon()";
1668 $self->sl("SUMMON $_[0]" . ($_[1] ? " $_[1]" : ""));
1672 # -- #perl was here! --
1673 # <Sauvin> Bigotry will never die.
1674 # <billn> yes it will
1675 # <billn> as soon as I'm allowed to buy weapons.
1677 # <rmah> billn, baisc human nature has to change for bigotry to go away
1678 # <billn> rmah: no, I just need bigger guns.
1681 # Requests timestamp from specified server. Easy enough, right?
1682 # Takes 1 optional arg: a server name/mask to query
1684 my ($self, $serv) = (shift, undef);
1686 $self->sl("TIME" . ($_[0] ? " $_[0]" : ""));
1689 # -- #perl was here! --
1690 # <Murr> DrForr, presumably the tank crew *knew* how to swim, but not how
1691 # to escape from a tank with open hatch that had turned on its roof
1693 # <DrForr> The tank flipped over -then- sank? Now that's rich.
1694 # <arkuat> what is this about? cisco is building tanks now?
1695 # <Winkola> arkuat: If they do, you can count on a lot of drowned newbie
1697 # <Winkola> "To report a drowning emergency, press 1, and hold for 27 minutes."
1700 # Sends request for current topic, or changes it to something else lame.
1701 # Takes at least 1 arg: the channel whose topic you want to screw around with
1702 # (optional) the new topic you want to impress everyone with
1707 croak "Not enough arguments to topic()";
1710 # Can you tell I've been reading the Nethack source too much? :)
1711 $self->sl("TOPIC $_[0]" . ($_[1] ? " :$_[1]" : ""));
1714 # -- #perl was here! --
1715 # crimethnk: problem found.
1716 # crimethnk: log file was 2GB and i could not write to it anymore.
1717 # crimethnk: shit. lost almost a week of stats.
1718 # vorsprung: crimethnk> i guess you'll have to rotate the logs more frequently
1719 # crimethnk: i usually rotate once a month. i missed last month.
1720 # crimethnk: i thought i was pregnant.
1723 # Sends a trace request to the server. Whoop.
1724 # Take 1 optional arg: the server or nickname to trace.
1728 $self->sl("TRACE" . ($_[0] ? " $_[0]" : ""));
1732 # -- #perl was here! --
1733 # <DragonFaX> Net::IRC is having my babies
1734 # <fimmtiu> DragonFax: Damn, man! She told me the child was MINE!
1735 # <Alpha232> Dragon: IRC has enough bastard children
1736 # <DragonFaX> IRC has enough bastards?
1737 # <fimmtiu> New Frosted Lucky Bastards, they're magically delicious!
1738 # <archon> they're after me lucky bastards!
1741 # Requests userhost info from the server.
1742 # Takes at least 1 arg: nickname(s) to look up.
1747 croak 'Not enough args to userhost().';
1750 $self->sl("USERHOST " . CORE::join (" ", @_));
1753 # Sends a users request to the server, which may or may not listen to you.
1754 # Take 1 optional arg: the server to query.
1758 $self->sl("USERS" . ($_[0] ? " $_[0]" : ""));
1761 # Asks the IRC server what version and revision of ircd it's running. Whoop.
1762 # Takes 1 optional arg: the server name/glob. (default is current server)
1766 $self->sl("VERSION" . ($_[0] ? " $_[0]" : ""));
1770 # -- #perl was here! --
1771 # <vald> Does anyone know how to modify a perl server that accepts
1772 # telnet to make it accept emails ?
1773 # <TorgoX> vald -- do you know how to modify a car so that it has six
1774 # legs, spins webs, and eats flies?
1775 # <Schwern> Does a "perl server" serve perl?
1776 # <clintp> We all serve Perl. Some days, it serves us.
1779 # Sends a message to all opers on the network. Hypothetically.
1780 # Takes 1 arg: the text to send.
1785 croak 'No arguments passed to wallops()';
1788 $self->sl("WALLOPS :" . CORE::join("", @_));
1791 # Asks the server about stuff, you know. Whatever. Pass the Fritos, dude.
1792 # Takes 2 optional args: the bit of stuff to ask about
1793 # an "o" (nobody ever uses this...)
1798 $self->sl("WHO" . (@_ ? " @_" : ""));
1801 # -- #perl was here! --
1802 # <\lembit> linda mccartney died yesterday, didn't she?
1803 # <q[merlyn]> yes... she's dead.
1804 # <q[merlyn]> WHY COULDN'T IT HAVE BEEN YOKO?
1807 # If you've gotten this far, you probably already know what this does.
1808 # Takes at least 1 arg: nickmasks or channels to /whois
1813 croak "Not enough arguments to whois()";
1815 return $self->sl("WHOIS " . CORE::join(",", @_));
1818 # -- #perl was here! --
1819 # <dnm> Fmh - do you want to telnet to one box and then ssh to another?
1820 # <Fmh> i realize an ssh proxy allows a man-in-the-middle attack.
1821 # <gargoyle> that sounds kinda pleasant right now
1822 # gargoyle goes off to find a set of twins
1823 # <amagosa> billn (=
1826 # Same as above, in the past tense.
1827 # Takes at least 1 arg: nick to do the /whowas on
1828 # (optional) max number of hits to display
1829 # (optional) server or servermask to query
1834 croak "Not enough arguments to whowas()";
1836 return $self->sl("WHOWAS $_[0]" . ($_[1] ? " $_[1]" : "") .
1837 (($_[1] && $_[2]) ? " $_[2]" : ""));
1841 # -- #perl was here! --
1842 # <veblen> On the first day, God created Shrimp.
1843 # * thoth parries the shrimp penis.
1845 # <veblen> On the second day, God created cocktail sauce.
1846 # <URanalog> "This is Chewbacca"
1847 # <Fmh> do not covet thy neighbor's shrimp.
1848 # * thoth pitches the shrimp penes on the barbie.
1849 # <thoth> UR: that's shrimp with penes, not shrimp with penne.
1852 # This sub executes the default action for an event with no user-defined
1853 # handlers. It's all in one sub so that we don't have to make a bunch of
1854 # separate anonymous subs stuffed in a hash.
1856 my ($self, $event) = @_;
1857 my $verbose = $self->verbose;
1859 # Users should only see this if the programmer (me) fucked up.
1861 croak "You EEEEEDIOT!!! Not enough args to _default()!";
1864 # Reply to PING from server as quickly as possible.
1865 if ($event->type eq "ping") {
1866 $self->sl("PONG " . (CORE::join ' ', $event->args));
1868 } elsif ($event->type eq "disconnect") {
1870 # I violate OO tenets. (It's consensual, of course.)
1871 unless (keys %{$self->parent->{_connhash}} > 0) {
1872 die "No active connections left, exiting...\n";
1881 # -- #perl was here! --
1882 # <fimmtiu> OK, once you've passed the point where caffeine no longer has
1883 # any discernible effect on any part of your body but your
1884 # bladder, it's time to sleep.
1885 # <fimmtiu> 'Night, all.
1886 # <regex> Night, fimm
1895 Net::IRC::Connection - Object-oriented interface to a single IRC connection
1899 Hard hat area: This section under construction.
1903 This documentation is a subset of the main Net::IRC documentation. If
1904 you haven't already, please "perldoc Net::IRC" before continuing.
1906 Net::IRC::Connection defines a class whose instances are individual
1907 connections to a single IRC server. Several Net::IRC::Connection objects may
1908 be handled simultaneously by one Net::IRC object.
1910 =head1 METHOD DESCRIPTIONS
1912 This section is under construction, but hopefully will be finally written up
1913 by the next release. Please see the C<irctest> script and the source for
1914 details about this module.
1918 Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt> and
1919 Dennis Taylor E<lt>dennis@funkplanet.comE<gt>.
1921 Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>.
1923 Currently being hacked on, hacked up, and worked over by the members of the
1924 Net::IRC developers mailing list. For details, see
1925 http://www.execpc.com/~corbeau/irc/list.html .
1929 Up-to-date source and information about the Net::IRC project can be found at
1930 http://netirc.betterbox.net/ .
1942 RFC 1459: The Internet Relay Chat Protocol
1946 http://www.irchelp.org/, home of fine IRC resources.