Net-IRC-0.75/0040775000076600007660000000000010044512665013023 5ustar jmuhlichjmuhlichNet-IRC-0.75/Entry.pm0100664000076600007660000000331007647673746014503 0ustar jmuhlichjmuhlichpackage 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; Net-IRC-0.75/Changes0100664000076600007660000005207310044512274014316 0ustar jmuhlichjmuhlichRevision history for Perl extension Net::IRC. 0.1 Fri Oct 17 00:25:41 CDT 1997 - original version; created by h2xs 1.18 0.2 Sat Oct 18 16:00:38 CDT 1997 - it works now, thanks entirely to Tkil (tkil@scrye.com) - substantial cleanup of Connection.pm - Removed "Written and designed by:" line in header comments... it didn't seem fair to the many other people who are putting such studly efforts into this. 0.25 Sun Oct 19 06:26:36 CDT 1997 - Removed extraneous return values from handler code (don't ask) - It's now possible to have more than one Net::IRC object in a single script, but I can't see why you'd ever want to. - We now disconnect properly. Woohoo! - Fixed YA CTCP bug. - Fixed up parse() handling for cases like MODE and NICK. - Fixed many stupid bugs that should have been caught long ago. - Lots more, but I can't remember them all. Again, huge gigantic thanks are due to Tkil for his tireless dedication to hunting down and patching bugs. You go, man! 0.26 Mon Oct 20 01:37:39 CDT 1997 - Fixed Makefile.PL to install IRC.pm and the other module in different places (it's nice to have make install actually work.) 0.27 Mon Oct 20 23:28:48 CDT 1997 - Made trivial changes to the formatted output code (format(), Event->new(), _pr(), Connection->new()). This should give other developers a bit clearer idea of where I'm going with it. Time for extended hacking is scarce right now, alas. 0.28 Fri Oct 24 06:12:42 CDT 1997 - Added $conn->me("#perl", "hacks billn to pieces") as an alias to $conn->ctcp("action", "#perl", "hacks billn to pieces"). - Fixed a couple small errors (typos, mostly). 0.29 Sat Oct 25 16:48:19 CDT 1997 - Added a placeholder DCC.pm to the source tree so I won't have to go back and change stuff once it's written. - Changed the order of default nick/ircname variables. - Fixed the source tree and makedist script on execpc.com to allow for easier diffing and patching. 0.3 Tue Nov 25 02:49:37 CST 1997 - Makefile.PL now barfs on older versions of Perl. - IRC.pm caches $self->ioselect in select() to clean up the code a little. OO and procedural style bigots reach a compromise. - IRC.pm's start() and select() methods have been merged. - All eval "code;" statements changed to eval { code; }. - Made small adjustment to Connection->parse() numeric routine. - Working draft of DCC.pm written by borys, who kicks much ass. - Bunch of subsequent revisions to DCC.pm, mostly by archon. - irctest script nearly doubles in size. - IRC.pm, especially start(), gets modified for DCC.pm. - A bunch of other smaller changes associated with DCC.pm that I'm too tired to write down. You get the idea. - Spent HOURS hacking miscellaneous CTCP and parse() bugs. Millions of thanks to Silmaril for devoting his brainpower to the bughunt. 0.31 Wed Nov 26 00:19:30 CST 1997 - Fixed the irritating "Sender: owner-test@betterbox.net" bug in the mailing list config. OK, so it doesn't belong in this file, but I guess it's worth mentioning somewhere. - ctcp_reply() method added to Connection.pm and used in irctest. 0.32 Wed Dec 3 07:59:28 CST 1997 - Added new_send(), new_get(), and new_chat() to Connection.pm - Removed ^A-removing stuff in DCC.pm (it's been fixed in Connection). - Completely rewrote the irctest script, with more additions planned. - The numeric event stuff has been farmed off from parse() to a separate routine, parse_num(). - Default block size for DCC SEND now 1k instead of 8k. - DCC SEND and GET now always do binary transfers. If a problem comes up with this, blame it on tchrist and BeeF. :-) 0.33 Fri Dec 5 14:27:41 CST 1997 - Version numbers now more realistic. - Net::IRC now specifically resides under the Artistic License, which is now distributed with the module. Anyone have a problem with this? - Connection.pm now strips CRs as well as LFs. Thanks, Aryeh! - \r and \n hardcoded as \015 and \012 in some places to avoid possible cross-platform confusion. - Problems with certain literal handler calls fixed in handler(). - irctest is now a full-featured Zippybot! Yow!! - Made a first pathetic stab at documentation, still working on it. 0.4 Wed Dec 10 16:08:21 CST 1997 - Made small changes to arg list for DCC::CHAT->new(). - Fixed precedence problem in Connection->new_* methods. - Added DCC CHAT and GET capabilities to irctest. - Added 'Proto => "tcp",' to all IO::Socket calls in DCC.pm, after being led astray by incorrect documentation. :-) - User notification for dropped connections is more polite. - Change to fragment handling in IRC->start(). - DCC CHAT->new() now requires nick as argument. - privmsg() can be used to send DCC CHAT messages... just pass it an IO::Socket instead of a nick. - Removed some debugging prints that accidentally got left in a few parts of the code. Doh! 0.41 Wed Dec 10 22:36:10 CST 1997 - Fixed the order of args to Connection->ctcp(). - Fixed lots of bugs that this change caused to manifest. Argh. - First Net::IRC release posted to CPAN, 11 Dec 1997. 0.42 Mon Dec 29 22:44:18 CST 1997 - Added dcc_open and dcc_close handlers for DCC connections. - DCC::GET now requires a nick as an argument to new(). - Added motd, users, whowas, ison, lusers, userhost and wallops subs to Connection.pm. - Added event scheduler to IRC.pm and Connection.pm. Good idea, Che! - &AUTOLOAD in Connection.pm completely rewritten by gbacon. - Applied a nifty patch that breaks big messages to privmsg() and notice() into smaller chunks and sends them piecemeal. - irctest now does DCC SEND via public message, as a demonstration. - Real POD documentation for IRC.pm written; work begun on PODs for the rest, but it's a nontrivial task. - Added do_one_loop() patch to IRC.pm and rewrote start() for easier Tk integration with Net::IRC scripts. - Fixed user mode case in Connection->parse(). - Added a timeout() method to IRC.pm for finer user control over the select loop. Woo woo! 0.43 Tue Dec 30 18:20:26 CST 1997 - Fixed some problems with the previous distribution... a few outdated files weren't properly removed before tarring by a particularly mischevious script. 0.44 Wed Dec 31 18:13:32 CST 1997 - Fixed some newly created bugs with Connection->connected. Argh! - Scrapped and redid distribution-rolling scripts. You know, ExtUtils::MakeMaker is really nice. 0.45 Sat Jan 3 15:48:57 CST 1998 - All connections now give their names and causes of death upon expiring. This should make DCC problems much less confusing. :-) - DCC SEND and CHAT no longer block on accept(). Woohoo! - IRC->remove_conn() changed to removeconn() for consistency with IRC->addconn() and IRC->newconn(). 0.5b Sun Mar 15 14:29:09 CST 1998 - Sizable chunks of IRC, DCC, and Connection.pm rewritten according to wise suggestions from the venerable elders \merlyn and Roderick. - addfh() and removefh() methods added to IRC.pm; changed() and closed(), having been rendered utterly useless, were removed. - Reading data from ready non-{DCC,Connection} sockets is now the responsibility of the user. This provides more flexibility (if you only want to read N bytes, if it's a buffered FH and not a socket, etc.), but will break any existing such code. Better now than later. - Various documentation updates for IRC.pm; more progress made on the as-yet-unreleased Connection.pm docs. Any volunteers to help out with the PODs? - The select loop now monitors writable and errored filehandles as well as readable ones. See the updated documentation for IRC.pm. - Chat request feature added to irctest... if you say anything matching /^Chat/i on a channel with your bot, it will try to initiate a DCC CHAT with you. Mostly for debugging purposes, but it might actually be useful to someone out there anyhow... - A bug report from Che_Fox led to the squashing of a bug in privmsg that kept it from properly trimming long lines before sending. - Johnathan Vasilis pointed out a quickly-fixed bug in Connection-> userhost(). Thanks! - Events now trim preceding colons properly. Happy now, longhair? :-) - Fixed a big fat bug with _add_generic_handler. Setting up multiple handlers with arrayrefs works again now. - Connection.pm and DCC.pm's input routines now actually throw a "disconnect" or "dcc_close" event for connection-losing errors. - Alex Ibrado's bug report resulted in the fixing of some stupid bugs in the kick, topic, squit, and wallops methods. Doh... - Added Tkil's monster patch to fix Connection->parse errors, among other things. You go, Tkil! 0.5 Wed Apr 1 23:28:13 CST 1998 - Added a few Undernet compatibility changes suggested by Che_Fox. - Fixed a really dumb bug in Connection->default. Umm, doh. - DCC.pm got a number of miscellaneous changes, including making $dcc->{_time} actually useful for SEND and CHAT, and adding events for dcc_open and dcc_close all over. Thanks, mjd! - Fixed some evil bugs in DCC.pm... CHAT could call autoflush() on the result of a failed IO::Socket->new(), and DCC GET had an odd hanging problem on the last block of a file. *Many* thanks to the indefatigable \mjd for spotting and patching the latter. - Added sanity checks to DCC.pm to prevent abuse by malicious remote clients. Net::IRC -- making the world safe for bots, one Boolahman at a time! - Stupid low-level CTCP dequoting bug fixed on a report from \mjd. - Even stupider Connection->server bug tracked down and stomped. 0.51 Tue May 19 01:03:57 CDT 1998 - Aryeh patched a few minor bugs in the formatting functions. - Problem with the select timeout in do_one_loop() squashed. - Minor changes to dain-bramaged parts of DCC::CHAT::parse(). - Connection::parse() is now much friendlier to "localhost" servers. - Added another error check to IRC::schedule() (thanks, Cuberoot!) - Connection::sl() won't send \r\n over DCC CHAT anymore. - All "return undef"s changed to "return;" as per gbacon's suggestion. - irctest now uses strict -- it was mostly strict-safe before, but I had forgotten the actual 'use'... doh. Thanks, arkuat! - tile is the DCC God. A two-line patch of his fixed an ugly DCC CHAT blocking bug I'd been hacking on for a few days. You GO, tile! - The Net::IRC source now uses Carp for all error reporting. - The setout() and seterr() methods are dead as a result of the previous change. You'll have to do your own tee'ing... sorry. 0.52 Tue Jun 9 21:16:53 CDT 1998 - Fixed a stupid bug introduced in 0.51 which causes Net::IRC to attack the CPU like a rabid wolverine. Mea culpa. You just don't notice these things as much when you're testing each new version on a quad-CPU UltraSparc. :-) - Fixed an oddity with irctest's cping handler which caused it to no longer work with the current version of Net::IRC. - Formats will actually work with CTCP events now. Doh. - Added Event->dump method to spew the contents of an Event object to STDERR for debugging. This is a good thing. 0.53 Fri Jun 12 20:25:02 CDT 1998 - Fixed compatibility problems with Net::IRC on MacPerl. Many thanks to Chris Nandor for bringing this to our attention... - Jonathan Vasilis spotted an incompatibility between ircd 2.9 and Net::IRC, which has since been squashed. Thanks, Jon! - One can now pass Connection->new_get() an open filehandle as the last argument to specify a particular filename for incoming DCC SENDs. Naturally, when you don't provide the extra argument, the behavior is the same as before. 0.54 Sun Jun 28 18:49:03 CDT 1998 - IRC::addfh() now requires only two arguments. In the absence of any indication of what you're using the filehandle for, it will assume you're reading from it. Previous behavior is, of course, unchanged. - Connection::pr() finally got diked out. Took long enough... - Minor doc fixes all over and cosmetic changes to irctest. - List of events added to Event.pm documentation (finally!). - The add_*handler functions will accept upper, lower, or mixed-case event names indiscriminately now. 0.56b Tue Dec 29 13:37:01 CST 1998 - The Makefile.PL was edited slightly for compatibility with nmake. Thanks to Duncan Harris for the bug report on this one. - DCC CHAT objects can now send messages by calling the new privmsg() method... $chat->privmsg('string to send...'); . Useful, no? - The indefatigable oznoid spent a good deal of his hard-earned time chasing down a pernicious connection bug. Way to go! - Fixed, at long last, the "Read error" bugs in Connection->quit(). - Repaired some manifest idiocy in irctest. (Whoops. Thanks, Stupid_!) - Fixed the new CORE::join warnings that crop up under 5.005. Grrrrr. - Some debugging code added. Set DEBUG to 1 at the top of IRC.pm to enable verbose spewage of the module's actions. Still needs fleshing out, and needs some more debugging code in DCC.pm too. - Net::IRC now dies by default when there are no open connections left. (Install a 'disconnect' handler to avoid this.) This keeps it from ending up in a tight select loop over no sockets, which chews up CPU like mad. - Fixed a parse problem where the handler for numeric events would grab non-numeric server messages, like "ERROR :Closing Link". Heh. - Added disconnect() method to Connection.pm, to ensure that connections die properly BEFORE we call disconnect handlers. This approach is much cleaner... and less buggy. - The handler which gets executed just before the quit() method issues a QUIT command (for saying things before you leave, etc.) is now known as "leaving", not "disconnect". This is a USER-VISIBLE CHANGE which may break some of existing code. BE WARNED. - addconn() is now only called from Connection->connect(), and removeconn only from Connection->disconnect(). This is a good thing. - DCC GET almost works. I accidentally reversed a test in some previous version and totally borked it so that it would die after one packet. Don't I feel like a total doofus... now, for those regression tests... - Added a topic handler to irctest on a lark. I get more questions about topic reading/setting than about anything else... - Added a "LocalAddr" atribute for Connection->connect(). Setting it to a valid hostname for your machine will cause you to connect with that hostname, instead of whatever default one your DNS will return. (Note: Some paranoid IRC servers don't like this.) 0.57 Mon Mar 1 19:50:03 CST 1999 - Thanks to Gantoris for pointing out a bug in Event->to(). Now, when called in scalar context, it will return an array reference instead of the number of recipients. - fubar@ameritech.net pointed out another motd numeric code which isn't in the (woefully outdated) RFC. If you've ever found yourself never receiving the MOTDs, this version's for you. - Many thanks to Moses Moore, who offered some much-needed changes to Connection->privmsg(). Now the first argument can be an arrayref of recipient names, to specify a single message to be sent to multiple nicks/channels. - Doru Petrescu is not just the man. Nor, in fact, is he The Man. THIS is a person who can only be described as THE MAN HIMSELF, and I bow before his studly debugging skills. He sent me a two-character fix today that seems to solve all the DCC problems I was having. Boy, do I feel dumb. Thanks, Doru! - Everything's been checked into CVS, so I can have more detailed change logging. Hopefully, this will help avoid future rebreakings of DCC. - Harald Kreuzer tipped me off to a bug in irctest's on_topic handler subroutine which really should have been caught in testing. Sorry about that... and thanks, Harald! - Kajetan Hinner sent me a monster patch against 0.54. I'm still picking the relevant parts out of it, but I've included a couple notable parts from it already... especially all the new event numerics he added. 0.58 Thu Apr 8 11:00:58 CDT 1999 - Oh, dear. Many thanks to kleptog and Epesh for bringing to my attention a really simple, stupid bug which broke scripts using multiple connections. 0.57 was borked. Mea culpa. - Added a "Password" parameter to the connect() method, for bots on restricted servers. Updated the docs to reflect this. 0.59 Fri Jun 18 10:52:44 CDT 1999 - The default timeout for the select loop was changed from 1 to undef. If you're calling Net::IRC via do_one_loop instead of with start(), then you'll probably experience weird freezes with this. Tough. Do a $irc->timeout(0); to make your program run better than ever before, if you weren't already. - Cleaned up some bogus ugly code here and there. Don't mind me, I'm just tidying up... - Added Tom "tnalpggE" Monroe's nifty patch, which gives us away, rehash, summon, and restart methods, and improves parsing of numeric events. - Andrew Mackenzie kicks ass. After unsuccessfully nagging me to get off my lazy ass and fix a DCC bug, he did it himself. DCC receive now works again. h3o++ ! - Fixed a bogosity in Connection->mode(). Don't ask. 0.60 Thu Aug 12 16:19:58 EDT 1999 - Fixed a stupid oversight in the Net::IRC::DCC::SEND::new() method which prevented one from sending files in directories outside of the current directory. Thanks to Frank Tobin for spotting this; sorry it took me so long to fix, but your email got lost in the noise for a couple weeks... - Jan L. Peterson sent me a nifty patch which fixes the infamous colon- stripping bug in Event->args(). Sorry it took me so long to fix this one, everybody. Unlike the previous bug, this one has no excuse. - Thanks to Jack Velte for pointing out the cause of some spurious "uninitialized value" warnings in Connection.pm. 0.61 Thu Aug 26 22:29:39 EDT 1999 - Shizukesa pointed out the root cause of a bug that was sending duplicate dcc_close events when DCC connections shut down. Now fixed. He kicks ass. :-) Added a $dcc->nick accessor method, too, as per his excellent suggestion. 0.62 Wed Sep 22 18:13:28 EDT 1999 - Vadim Belman spotted two bugs in DCC.pm: one, a mistyping of 'socket' as 'sock'; the other, a thoroughly inappropriate use of IO::Socket's LocalPort attribute. Both fixed, as per his patch. - Jeremy Muhlich reminded me of a stupid change I made to the select loop several revisions ago which broke the proper behavior of schedule()ed events. Sigh. 0.63 Sun Jan 30 18:50:28 PST 2000 - Harald Paulsen spent a good deal of time and effort hunting down a couple of really dumb bugs in Connection::parse(). Replaced a couple of "return"s with "next"s and it's all good. Wee! - Richard-William Loerakker sent me a patch for DCC on multihomed machines... the DCC code wasn't paying attention to which interface the Connection object was attached to. Thanks, Richard! 0.70 Mon May 29 11:52:26 PDT 2000 - Igor Shevchenko sent me a patch for DCC.pm which adds support for resuming DCC GETs. I haven't tested this feature, but the code looks right. :-) - Finally fixed the pernicious "stripping the first colon" bug. Let's hope it stays dead this time! This may cause you to have to make a minor change to your CTCP handlers... but that's a small price to pay. (Shifting the first arg off should no longer be necessary.) - Fixed an ugly DCC bug reported by Matthew Boehm. I can't believe I didn't notice this before! The fix uses Sys::Hostname to determine the machine's IP address; I'm not sure if this works on Windows, but it probably should. Let me know if not. - Added Dave Schmitt's unignore patch, which fixes a big omission in Connection.pm -- you can now turn off ignores that you set with ignore(). Nifty! 0.71 Mon Jul 02 00:00:00 GMT 2001 - Removed debugging information that was printing out weird messages as far as ACTIONs were concerned. Thanks to Joshua Swink, Glen and Mike. - Made the LocalAddr option actually work, thanks to Abigail and Greg. - Added some more Handlers, from Austnet, thanks to Andrew Macks - Updated the documentation 0.72 Fri Dec 14 13:00:00 GMT 2001 - Added a patch from Anti Veeranna in Connection.pm to fix the problems with IPv6 hostnames. Has not been tested with DCC. 0.73 Wed Jan 02 13:00:00 GMT 2002 - Anti's Patch broke MODE handling. Implemented a quick fix. 0.74 Wed Apr 16 Sometime GMT 2003 - Added Pacing - Added SSL support - Added Time::HiRes conditional support for fractional times - Net::IRC::Connection::time -> Net::IRC::Connection::timestamp - Hopefully this doesn't break anyone, this was an undocumented access to the IRC 'TIME' command. - Updated docs slightly, pointing to new webpage, etc. 0.75 Fri Apr 30 who cares what time? 2004 - Hopefully fixed mysterious LocalAddr-related connection problems - Rewrote event output system - created EventQueue - Added add_default_handler for hooking all events at once - UnrealIrcd events added (thanks to Hendrik Frenzel) - Conditional require of Time::HiRes now works right in its absence (thanks to Adam Monsen ) - Massive readability/maintainability changes - Subs ordered in logical order, not alphabetical - Indentation - Updated current maintainers (should have been changed for 0.74) Net-IRC-0.75/DCC.pm0100664000076600007660000005353207564757037014000 0ustar jmuhlichjmuhlich##################################################################### # # # Net::IRC -- Object-oriented Perl interface to an IRC server # # # # DCC.pm: An object for Direct Client-to-Client connections. # # # # Copyright (c) 1997 Greg Bacon & Dennis Taylor. # # All rights reserved. # # # # This module is free software; you can redistribute or # # modify it under the terms of Perl's Artistic License. # # # ##################################################################### # $Id: DCC.pm,v 1.1.1.1 2002/11/14 17:32:15 jmuhlich Exp $ package Net::IRC::DCC; use strict; # --- #perl was here! --- # # The comments scattered throughout this module are excerpts from a # log saved from one particularly surreal night on #perl. Ahh, the # trials of being young, single, and drunk... # # --------------------- # \merlyn has offered the shower to a randon guy he met in a bar. # fimmtiu: Shower? # \petey raises an eyebrow at \merlyn # \merlyn: but he seems like a nice trucker guy... # archon: you offered to shower with a random guy? # Methods that can be shared between the various DCC classes. package Net::IRC::DCC::Connection; use Carp; use Socket; # need inet_ntoa... use strict; sub fixaddr { my ($address) = @_; chomp $address; # just in case, sigh. if ($address =~ /^\d+$/) { return inet_ntoa(pack "N", $address); } elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) { return $address; } elsif ($address =~ tr/a-zA-Z//) { # Whee! Obfuscation! return inet_ntoa(((gethostbyname($address))[4])[0]); } else { return; } } sub bytes_in { return shift->{_bin}; } sub bytes_out { return shift->{_bout}; } sub nick { return shift->{_nick}; } sub socket { return shift->{_socket}; } sub time { return time - shift->{_time}; } sub debug { return shift->{_debug}; } # Changes here 1998-04-01 by MJD # Optional third argument `$block'. # If true, don't break the input into lines... just process it in blocks. sub _getline { my ($self, $sock, $block) = @_; my ($input, $line); my $frag = $self->{_frag}; if (defined $sock->recv($input, 10240)) { $frag .= $input; if (length($frag) > 0) { warn "Got ". length($frag) ." bytes from $sock\n" if $self->{_debug}; if ($block) { # Block mode (GET) return $input; } else { # Line mode (CHAT) # We're returning \n's 'cause DCC's need 'em my @lines = split /\012/, $frag, -1; $lines[-1] .= "\012"; $self->{_frag} = ($frag !~ /\012$/) ? pop @lines : ''; return (@lines); } } else { # um, if we can read, i say we should read more than 0 # besides, recv isn't returning undef on closed # sockets. getting rid of this connection... warn "recv() received 0 bytes in _getline, closing connection.\n" if $self->{_debug}; $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_parent}->parent->removefh($sock); $self->{_socket}->close; $self->{_fh}->close if $self->{_fh}; return; } } else { # Error, lets scrap this connection warn "recv() returned undef, socket error in _getline()\n" if $self->{_debug}; $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_parent}->parent->removefh($sock); $self->{_socket}->close; $self->{_fh}->close if $self->{_fh}; return; } } sub DESTROY { my $self = shift; # Only do the Disconnection Dance of Death if the socket is still # live. Duplicate dcc_close events would be a Bad Thing. if ($self->{_socket}->opened) { $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; close $self->{_fh} if $self->{_fh}; $self->{_parent}->{_parent}->parent->removeconn($self); } } sub peer { return ( $_[0]->{_nick}, "DCC " . $_[0]->{_type} ); } # -- #perl was here! -- # orev: hehe... # Silmaril: to, not with. # archon: heheh # tmtowtdi: \merlyn will be hacked to death by a psycho # archon: yeah, but with is much more amusing # Connection handling GETs package Net::IRC::DCC::GET; use IO::Socket; use Carp; use strict; @Net::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection); sub new { my ($class, $container, $nick, $address, $port, $size, $filename, $handle, $offset) = @_; my ($sock, $fh); # get the address into a dotted quad $address = &Net::IRC::DCC::Connection::fixaddr($address); return if $port < 1024 or not defined $address or $size < 1; $fh = defined $handle ? $handle : IO::File->new(">$filename"); unless(defined $fh) { carp "Can't open $filename for writing: $!"; $sock = new IO::Socket::INET( Proto => "tcp", PeerAddr => "$address:$port" ) and $sock->close(); return; } binmode $fh; # I love this next line. :-) ref $fh eq 'GLOB' ? select((select($fh), $|++)[0]) : $fh->autoflush(1); $sock = new IO::Socket::INET( Proto => "tcp", PeerAddr => "$address:$port" ); if (defined $sock) { $container->handler(Net::IRC::Event->new('dcc_open', $nick, $sock, 'get', 'get', $sock)); } else { carp "Can't connect to $address: $!"; close $fh; return; } $sock->autoflush(1); my $self = { _bin => defined $offset ? $offset : 0, # bytes recieved so far _bout => 0, # Bytes we've sent _connected => 1, _debug => $container->debug, _fh => $fh, # FileHandle we will be writing to. _filename => $filename, _frag => '', _nick => $nick, # Nick of person on other end _parent => $container, _size => $size, # Expected size of file _socket => $sock, # Socket we're reading from _time => time, _type => 'GET', }; bless $self, $class; return $self; } # -- #perl was here! -- # \merlyn: we were both ogling a bartender named arley # \merlyn: I mean carle # \merlyn: carly # Silmaril: man merlyn # Silmaril: you should have offered HER the shower. # \petey: all three of them? sub parse { my ($self) = shift; my $line = $self->_getline($_[0], 'BLOCKS'); next unless defined $line; unless(print {$self->{_fh}} $line) { carp ("Error writing to " . $self->{_filename} . ": $!"); close $self->{_fh}; $self->{_parent}->parent->removeconn($self); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } $self->{_bin} += length($line); # confirm the packet we've just recieved unless ( $self->{_socket}->send( pack("N", $self->{_bin}) ) ) { carp "Error writing to DCC GET socket: $!"; close $self->{_fh}; $self->{_parent}->parent->removeconn($self); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } $self->{_bout} += 4; # The file is done. # If we close the socket, the select loop gets screwy because # it won't remove its reference to the socket. if ( $self->{_size} and $self->{_size} <= $self->{_bin} ) { close $self->{_fh}; $self->{_parent}->parent->removeconn($self); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', $self->{_nick}, $self, $self->{_type}, $self )); } sub filename { return shift->{_filename}; } sub size { return shift->{_size}; } sub close { my ($self, $sock) = @_; $self->{_fh}->close; $self->{_parent}->parent->removeconn($self); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } # -- #perl was here! -- # \merlyn: I can't type... she created a numbner of very good drinks # \merlyn: She's still at work # \petey resists mentioning that there's "No manual entry # for merlyn." # Silmaril: Haven't you ever seen swingers? # \merlyn: she's off tomorrow... will meet me at the bar at 9:30 # Silmaril: AWWWWwwww yeeeaAAHH. # archon: waka chica waka chica # Connection handling SENDs package Net::IRC::DCC::SEND; @Net::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection); use IO::File; use IO::Socket; use Carp; use strict; sub new { my ($class, $container, $nick, $filename, $blocksize) = @_; my ($size, $port, $fh, $sock, $select); $blocksize ||= 1024; # Shell-safe DCC filename stuff. Trying to prank-proof this # module is rather difficult. $filename =~ tr/a-zA-Z.+0-9=&()[]%\-\\\/:,/_/c; $fh = new IO::File $filename; unless (defined $fh) { carp "Couldn't open $filename for reading: $!"; return; } binmode $fh; $fh->seek(0, SEEK_END); $size = $fh->tell; $fh->seek(0, SEEK_SET); $sock = new IO::Socket::INET( Proto => "tcp", Listen => 1); unless (defined $sock) { carp "Couldn't open DCC SEND socket: $!"; $fh->close; return; } $container->ctcp('DCC SEND', $nick, $filename, unpack("N",inet_aton($container->hostname())), $sock->sockport(), $size); $sock->autoflush(1); my $self = { _bin => 0, # Bytes we've recieved thus far _blocksize => $blocksize, _bout => 0, # Bytes we've sent _debug => $container->debug, _fh => $fh, # FileHandle we will be reading from. _filename => $filename, _frag => '', _nick => $nick, _parent => $container, _size => $size, # Size of file _socket => $sock, # Socket we're writing to _time => 0, # This gets set by Accept->parse() _type => 'SEND', }; bless $self, $class; $sock = Net::IRC::DCC::Accept->new($sock, $self); unless (defined $sock) { carp "Error in accept: $!"; $fh->close; return; } return $self; } # -- #perl was here! -- # fimmtiu: So a total stranger is using your shower? # \merlyn: yes... a total stranger is using my hotel shower # Stupid coulda sworn \merlyn was married... # \petey: and you have a date. # fimmtiu: merlyn isn't married. # \petey: not a bad combo...... # \merlyn: perhaps a adate # \merlyn: not maerried # \merlyn: not even sober. --) sub parse { my ($self, $sock) = @_; my $size = ($self->_getline($sock, 1))[0]; my $buf; # i don't know how useful this is, but let's stay consistent $self->{_bin} += 4; unless (defined $size) { # Dang! The other end unexpectedly canceled. carp (($self->peer)[1] . " connection to " . ($self->peer)[0] . " lost"); $self->{_fh}->close; $self->{_parent}->parent->removefh($sock); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } $size = unpack("N", $size); if ($size >= $self->{_size}) { if ($self->{_debug}) { warn "Other end acknowledged entire file ($size >= ", $self->{_size}, ")"; } # they've acknowledged the whole file, we outtie $self->{_fh}->close; $self->{_parent}->parent->removeconn($self); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } # we're still waiting for acknowledgement, # better not send any more return if $size < $self->{_bout}; unless (defined $self->{_fh}->read($buf,$self->{_blocksize})) { if ($self->{_debug}) { warn "Failed to read from source file in DCC SEND!"; } $self->{_fh}->close; $self->{_parent}->parent->removeconn($self); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } unless($self->{_socket}->send($buf)) { if ($self->{_debug}) { warn "send() failed horribly in DCC SEND" } $self->{_fh}->close; $self->{_parent}->parent->removeconn($self); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } $self->{_bout} += length($buf); $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', $self->{_nick}, $self, $self->{_type}, $self )); return 1; } # -- #perl was here! -- # fimmtiu: Man, merlyn, you must be drunk to type like that. :) # \merlyn: too many longislands. # \merlyn: she made them strong # archon: it's a plot # \merlyn: not even a good amoun tof coke # archon: she's in league with the guy in your shower # archon: she gets you drunk and he takes your wallet! # handles CHAT connections package Net::IRC::DCC::CHAT; @Net::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection); use IO::Socket; use Carp; use strict; sub new { my ($class, $container, $type, $nick, $address, $port) = @_; my ($sock, $self); if ($type) { # we're initiating $sock = new IO::Socket::INET( Proto => "tcp", Listen => 1); unless (defined $sock) { carp "Couldn't open DCC CHAT socket: $!"; return; } $sock->autoflush(1); $container->ctcp('DCC CHAT', $nick, 'chat', unpack("N",inet_aton($container->hostname)), $sock->sockport()); $self = { _bin => 0, # Bytes we've recieved thus far _bout => 0, # Bytes we've sent _connected => 1, _debug => $container->debug, _frag => '', _nick => $nick, # Nick of the client on the other end _parent => $container, _socket => $sock, # Socket we're reading from _time => 0, # This gets set by Accept->parse() _type => 'CHAT', }; bless $self, $class; $sock = Net::IRC::DCC::Accept->new($sock, $self); unless (defined $sock) { carp "Error in DCC CHAT connect: $!"; return; } } else { # we're connecting $address = &Net::IRC::DCC::Connection::fixaddr($address); return if $port < 1024 or not defined $address; $sock = new IO::Socket::INET( Proto => "tcp", PeerAddr => "$address:$port"); if (defined $sock) { $container->handler(Net::IRC::Event->new('dcc_open', $nick, $sock, 'chat', 'chat', $sock)); } else { carp "Error in DCC CHAT connect: $!"; return; } $sock->autoflush(1); $self = { _bin => 0, # Bytes we've recieved thus far _bout => 0, # Bytes we've sent _connected => 1, _nick => $nick, # Nick of the client on the other end _parent => $container, _socket => $sock, # Socket we're reading from _time => time, _type => 'CHAT', }; bless $self, $class; $self->{_parent}->parent->addfh($self->socket, $self->can('parse'), 'r', $self); } return $self; } # -- #perl was here! -- # \merlyn: tahtd be coole # KTurner bought the camel today, so somebody can afford one # more drink... ;) # tmtowtdi: I've heard of things like this... # \merlyn: as an experience. that is. # archon: i can think of cooler things (; # \merlyn: I don't realiy have that mch in my wallet. sub parse { my ($self, $sock) = @_; foreach my $line ($self->_getline($sock)) { return unless defined $line; $self->{_bin} += length($line); return undef if $line eq "\012"; $self->{_bout} += length($line); $self->{_parent}->handler(Net::IRC::Event->new('chat', $self->{_nick}, $self->{_socket}, 'chat', $line)); $self->{_parent}->handler(Net::IRC::Event->new('dcc_update', $self->{_nick}, $self, $self->{_type}, $self )); } } # Sends a message to a channel or person. # Takes 2 args: the target of the message (channel or nick) # the text of the message to send sub privmsg { my ($self) = shift; unless (@_) { croak 'Not enough arguments to privmsg()'; } # Don't send a CR over DCC CHAT -- it's not wanted. $self->socket->send(join('', @_) . "\012"); } # -- #perl was here! -- # \merlyn: this girl carly at the bar is aBABE # archon: are you sure? you don't sound like you're in a condition to # judge such things (; # *** Stupid has set the topic on channel #perl to \merlyn is shit-faced # with a trucker in the shower. # tmtowtdi: uh, yeah... # \merlyn: good topic # Sockets waiting for accept() use this to shoehorn into the select loop. package Net::IRC::DCC::Accept; @Net::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection); use Carp; use Socket; # we use a lot of Socket functions in parse() use strict; sub new { my ($class, $sock, $parent) = @_; my ($self); $self = { _debug => $parent->debug, _nonblock => 1, _socket => $sock, _parent => $parent, _type => 'accept', }; bless $self, $class; # Tkil's gonna love this one. :-) But what the hell... it's safe to # assume that the only thing initiating DCCs will be Connections, right? # Boy, we're not built for extensibility, I guess. Someday, I'll clean # all of the things like this up. $self->{_parent}->{_parent}->parent->addconn($self); return $self; } sub parse { my ($self) = shift; my ($sock); $sock = $self->{_socket}->accept; $self->{_parent}->{_socket} = $sock; $self->{_parent}->{_time} = time; if ($self->{_parent}->{_type} eq 'SEND') { # ok, to get the ball rolling, we send them the first packet. my $buf; unless (defined $self->{_parent}->{_fh}-> read($buf, $self->{_parent}->{_blocksize})) { return; } unless (defined $sock->send($buf)) { $sock->close; $self->{_parent}->{_fh}->close; $self->{_parent}->{_parent}->parent->removefh($sock); $self->{_parent}->handler(Net::IRC::Event->new('dcc_close', $self->{_nick}, $self->{_socket}, $self->{_type})); $self->{_socket}->close; return; } } $self->{_parent}->{_parent}->parent->addconn($self->{_parent}); $self->{_parent}->{_parent}->parent->removeconn($self); $self->{_parent}->{_parent}->handler(Net::IRC::Event-> new('dcc_open', $self->{_parent}->{_nick}, $self->{_parent}->{_socket}, $self->{_parent}->{_type}, $self->{_parent}->{_type}, $self->{_parent}->{_socket}) ); } 1; __END__ =head1 NAME Net::IRC::DCC - Object-oriented interface to a single DCC connection =head1 SYNOPSIS Hard hat area: This section under construction. =head1 DESCRIPTION This documentation is a subset of the main Net::IRC documentation. If you haven't already, please "perldoc Net::IRC" before continuing. Net::IRC::DCC defines a few subclasses that handle DCC CHAT, GET, and SEND requests for inter-client communication. DCC objects are created by Cnew_{chat,get,send}()> in much the same way that Cnewconn()> creates a new connection object. =head1 METHOD DESCRIPTIONS This section is under construction, but hopefully will be finally written up by the next release. Please see the C script and the source for details about this module. =head1 AUTHORS Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and Dennis Taylor Edennis@funkplanet.comE. Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. Currently being hacked on, hacked up, and worked over by the members of the Net::IRC developers mailing list. For details, see http://www.execpc.com/~corbeau/irc/list.html . =head1 URL Up-to-date source and information about the Net::IRC project can be found at http://netirc.betterbox.net/ . =head1 SEE ALSO =over =item * perl(1). =item * RFC 1459: The Internet Relay Chat Protocol =item * http://www.irchelp.org/, home of fine IRC resources. =back =cut Net-IRC-0.75/Connection.pm0100664000076600007660000014342307763735050015475 0ustar jmuhlichjmuhlich##################################################################### # # # 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; # 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>", }, }; bless $self, $proto; # do any necessary initialization here $self->connect(@_) if @_; return $self; } # Takes care of the methods in %autoloaded # Sets specified attribute, or returns its value if called without args. sub AUTOLOAD { my $self = @_; ## can't modify @_ for goto &name my $class = ref $self; ## die here if !ref($self) ? my $meth; # -- #perl was here! -- # absolute power corrupts absolutely, but it's a helluva lot # of fun. # =) ($meth = $AUTOLOAD) =~ s/^.*:://; ## strip fully qualified portion unless (exists $autoloaded{$meth}) { croak "No method called \"$meth\" for $class object."; } eval <{"_$meth"}; \$self->{"_$meth"} = shift; return \$old; } else { return \$self->{"_$meth"}; } } EOSub # no reason to play this game every time goto &$meth; } # This sub is the common backend to add_handler and add_global_handler # sub _add_generic_handler { my ($self, $event, $ref, $rp, $hash_ref, $real_name) = @_; my $ev; my %define = ( "replace" => 0, "before" => 1, "after" => 2 ); unless (@_ >= 3) { croak "Not enough arguments to $real_name()"; } unless (ref($ref) eq 'CODE') { croak "Second argument of $real_name isn't a coderef"; } # Translate REPLACE, BEFORE and AFTER. if (not defined $rp) { $rp = 0; } elsif ($rp =~ /^\D/) { $rp = $define{lc $rp} || 0; } foreach $ev (ref $event eq "ARRAY" ? @{$event} : $event) { # Translate numerics to names if ($ev =~ /^\d/) { $ev = Net::IRC::Event->trans($ev); unless ($ev) { carp "Unknown event type in $real_name: $ev"; return; } } $hash_ref->{lc $ev} = [ $ref, $rp ]; } return 1; } # This sub will assign a user's custom function to a particular event which # might be received by any Connection object. # Takes 3 args: the event to modify, as either a string or numeric code # If passed an arrayref, the array is assumed to contain # all event names which you want to set this handler for. # a reference to the code to be executed for the event # (optional) A value indicating whether the user's code should replace # the built-in handler, or be called with it. Possible values: # 0 - Replace the built-in handlers entirely. (the default) # 1 - Call this handler right before the default handler. # 2 - Call this handler right after the default handler. # These can also be referred to by the #define-like strings in %define. sub add_global_handler { my ($self, $event, $ref, $rp) = @_; return $self->_add_generic_handler($event, $ref, $rp, \%_udef, 'add_global_handler'); } # This sub will assign a user's custom function to a particular event which # this connection might receive. Same args as above. sub add_handler { my ($self, $event, $ref, $rp) = @_; return $self->_add_generic_handler($event, $ref, $rp, $self->{_handler}, 'add_handler'); } # Hooks every event we know about... sub add_default_handler { my ($self, $ref, $rp) = @_; foreach my $eventtype (keys(%Net::IRC::Event::_names)) { $self->_add_generic_handler($eventtype, $ref, $rp, $self->{_handler}, 'add_default_handler'); } return 1; } # Why do I even bother writing subs this simple? Sends an ADMIN command. # Takes 1 optional arg: the name of the server you want to query. sub admin { my $self = shift; # Thank goodness for AutoLoader, huh? # Perhaps we'll finally use it soon. $self->sl("ADMIN" . ($_[0] ? " $_[0]" : "")); } # Toggles away-ness with the server. Optionally takes an away message. sub away { my $self = shift; $self->sl("AWAY" . ($_[0] ? " :$_[0]" : "")); } # Attempts to connect to the specified IRC (server, port) with the specified # (nick, username, ircname). Will close current connection if already open. sub connect { my $self = shift; my ($password, $sock); if (@_) { my (%arg) = @_; $self->hostname($arg{'LocalAddr'}) if exists $arg{'LocalAddr'}; $password = $arg{'Password'} if exists $arg{'Password'}; $self->nick($arg{'Nick'}) if exists $arg{'Nick'}; $self->port($arg{'Port'}) if exists $arg{'Port'}; $self->server($arg{'Server'}) if exists $arg{'Server'}; $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'}; $self->username($arg{'Username'}) if exists $arg{'Username'}; $self->pacing($arg{'Pacing'}) if exists $arg{'Pacing'}; $self->ssl($arg{'SSL'}) if exists $arg{'SSL'}; } # Lots of error-checking claptrap first... unless ($self->server) { unless ($ENV{IRCSERVER}) { croak "No server address specified in connect()"; } $self->server( $ENV{IRCSERVER} ); } unless ($self->nick) { $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "WankerBot"); } unless ($self->port) { $self->port($ENV{IRCPORT} || 6667); } unless ($self->ircname) { $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] } || "Just Another Perl Hacker"); } unless ($self->username) { $self->username(eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "japh"); } # Now for the socket stuff... if ($self->connected) { $self->quit("Changing servers"); } if($self->ssl) { require IO::Socket::SSL; $self->socket(IO::Socket::SSL->new(PeerAddr => $self->server, PeerPort => $self->port, Proto => "tcp", LocalAddr => $self->hostname, )); } else { $self->socket(IO::Socket::INET->new(PeerAddr => $self->server, PeerPort => $self->port, Proto => "tcp", LocalAddr => $self->hostname, )); } if(!$self->socket) { carp (sprintf "Can't connect to %s:%s!", $self->server, $self->port); $self->error(1); return; } # Send a PASS command if they specified a password. According to # the RFC, we should do this as soon as we connect. if (defined $password) { $self->sl("PASS $password"); } # Now, log in to the server... unless ($self->sl('NICK ' . $self->nick()) and $self->sl(sprintf("USER %s %s %s :%s", $self->username(), "foo.bar.com", $self->server(), $self->ircname()))) { carp "Couldn't send introduction to server: $!"; $self->error(1); $! = "Couldn't send NICK/USER introduction to " . $self->server; return; } $self->{_connected} = 1; $self->parent->addconn($self); } # Returns a boolean value based on the state of the object's socket. sub connected { my $self = shift; return ( $self->{_connected} and $self->socket() ); } # Sends a CTCP request to some hapless victim(s). # Takes at least two args: the type of CTCP request (case insensitive) # the nick or channel of the intended recipient(s) # Any further args are arguments to CLIENTINFO, ERRMSG, or ACTION. sub ctcp { my ($self, $type, $target) = splice @_, 0, 3; $type = uc $type; unless ($target) { croak "Not enough arguments to ctcp()"; } if ($type eq "PING") { unless ($self->sl("PRIVMSG $target :\001PING " . int(time) . "\001")) { carp "Socket error sending $type request in ctcp()"; return; } } elsif (($type eq "CLIENTINFO" or $type eq "ACTION") and @_) { unless ($self->sl("PRIVMSG $target :\001$type " . CORE::join(" ", @_) . "\001")) { carp "Socket error sending $type request in ctcp()"; return; } } elsif ($type eq "ERRMSG") { unless (@_) { carp "Not enough arguments to $type in ctcp()"; return; } unless ($self->sl("PRIVMSG $target :\001ERRMSG " . CORE::join(" ", @_) . "\001")) { carp "Socket error sending $type request in ctcp()"; return; } } else { unless ($self->sl("PRIVMSG $target :\001$type " . CORE::join(" ",@_) . "\001")) { carp "Socket error sending $type request in ctcp()"; return; } } } # Sends replies to CTCP queries. Simple enough, right? # Takes 2 args: the target person or channel to send a reply to # the text of the reply sub ctcp_reply { my $self = shift; $self->notice($_[0], "\001" . $_[1] . "\001"); } # Sets or returns the debugging flag for this object. # Takes 1 optional arg: a new boolean value for the flag. sub debug { my $self = shift; if (@_) { $self->{_debug} = $_[0]; } return $self->{_debug}; } # Dequotes CTCP messages according to ctcp.spec. Nothing special. # Then it breaks them into their component parts in a flexible, ircII- # compatible manner. This is not quite as trivial. Oh, well. # Takes 1 arg: the line to be dequoted. sub dequote { my $line = shift; my ($order, @chunks) = (0, ()); # CHUNG! CHUNG! CHUNG! # Filter misplaced \001s before processing... (Thanks, Tom!) substr($line, rindex($line, "\001"), 1) = '\\a' unless ($line =~ tr/\001//) % 2 == 0; # Thanks to Abigail (abigail@fnx.com) for this clever bit. if (index($line, "\cP") >= 0) { # dequote low-level \n, \r, ^P, and \0. my (%h) = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP"); $line =~ s/\cP([nr0\cP])/$h{$1}/g; } $line =~ s/\\([^\\a])/$1/g; # dequote unnecessarily quoted characters. # If true, it's in odd order... ctcp commands start with first chunk. $order = 1 if index($line, "\001") == 0; @chunks = map { s/\\\\/\\/g; $_ } (split /\cA/, $line); return ($order, @chunks); } # Standard destructor method for the GC routines. (HAHAHAH! DIE! DIE! DIE!) sub DESTROY { my $self = shift; $self->handler("destroy", "nobody will ever use this"); $self->quit(); # anything else? } # Disconnects this Connection object cleanly from the server. # Takes at least 1 arg: the format and args parameters to Event->new(). sub disconnect { my $self = shift; $self->{_connected} = 0; $self->parent->removeconn($self); $self->socket( undef ); $self->handler(Net::IRC::Event->new( "disconnect", $self->server, '', @_ )); } # Tells IRC.pm if there was an error opening this connection. It's just # for sane error passing. # Takes 1 optional arg: the new value for $self->{'iserror'} sub error { my $self = shift; $self->{'iserror'} = $_[0] if @_; return $self->{'iserror'}; } # Lets the user set or retrieve a format for a message of any sort. # Takes at least 1 arg: the event whose format you're inquiring about # (optional) the new format to use for this event sub format { my ($self, $ev) = splice @_, 0, 2; unless ($ev) { croak "Not enough arguments to format()"; } if (@_) { $self->{'_format'}->{$ev} = $_[0]; } else { return ($self->{'_format'}->{$ev} || $self->{'_format'}->{'default'}); } } # Calls the appropriate handler function for a specified event. # Takes 2 args: the name of the event to handle # the arguments to the handler function sub handler { my ($self, $event) = splice @_, 0, 2; unless (defined $event) { croak 'Too few arguments to Connection->handler()'; } # Get name of event. my $ev; if (ref $event) { $ev = $event->type; } elsif (defined $event) { $ev = $event; $event = Net::IRC::Event->new($event, '', '', ''); } else { croak "Not enough arguments to handler()"; } print STDERR "Trying to handle event '$ev'.\n" if $self->{_debug}; my $handler = undef; if (exists $self->{_handler}->{$ev}) { $handler = $self->{_handler}->{$ev}; } elsif (exists $_udef{$ev}) { $handler = $_udef{$ev}; } else { return $self->_default($event, @_); } my ($code, $rp) = @{$handler}; # If we have args left, try to call the handler. if ($rp == 0) { # REPLACE &$code($self, $event, @_); } elsif ($rp == 1) { # BEFORE &$code($self, $event, @_); $self->_default($event, @_); } elsif ($rp == 2) { # AFTER $self->_default($event, @_); &$code($self, $event, @_); } else { confess "Bad parameter passed to handler(): rp=$rp"; } warn "Handler for '$ev' called.\n" if $self->{_debug}; return 1; } # Lets a user set hostmasks to discard certain messages from, or (if called # with only 1 arg), show a list of currently ignored hostmasks of that type. # Takes 2 args: type of ignore (public, msg, ctcp, etc) # (optional) [mask(s) to be added to list of specified type] sub ignore { my $self = shift; unless (@_) { croak "Not enough arguments to ignore()"; } if (@_ == 1) { if (exists $self->{_ignore}->{$_[0]}) { return @{ $self->{_ignore}->{$_[0]} }; } else { return (); } } elsif (@_ > 1) { # code defensively, remember... my $type = shift; # I moved this part further down as an Obsessive Efficiency # Initiative. It shouldn't be a problem if I do _parse right... # ... but those are famous last words, eh? unless (grep {$_ eq $type} qw(public msg ctcp notice channel nick other all)) { carp "$type isn't a valid type to ignore()"; return; } if ( exists $self->{_ignore}->{$type} ) { push @{$self->{_ignore}->{$type}}, @_; } else { $self->{_ignore}->{$type} = [ @_ ]; } } } # Yet Another Ridiculously Simple Sub. Sends an INFO command. # Takes 1 optional arg: the name of the server to query. sub info { my $self = shift; $self->sl("INFO" . ($_[0] ? " $_[0]" : "")); } # Invites someone to an invite-only channel. Whoop. # Takes 2 args: the nick of the person to invite # the channel to invite them to. # I hate the syntax of this command... always seemed like a protocol flaw. sub invite { my $self = shift; unless (@_ > 1) { croak "Not enough arguments to invite()"; } $self->sl("INVITE $_[0] $_[1]"); } # Checks if a particular nickname is in use. # Takes at least 1 arg: nickname(s) to look up. sub ison { my $self = shift; unless (@_) { croak 'Not enough args to ison().'; } $self->sl("ISON " . CORE::join(" ", @_)); } # Joins a channel on the current server if connected, eh?. # Corresponds to /JOIN command. # Takes 2 args: name of channel to join # optional channel password, for +k channels sub join { my $self = shift; unless ( $self->connected ) { carp "Can't join() -- not connected to a server"; return; } unless (@_) { croak "Not enough arguments to join()"; } return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : "")); } # Takes at least 2 args: the channel to kick the bastard from # the nick of the bastard in question # (optional) a parting comment to the departing bastard sub kick { my $self = shift; unless (@_ > 1) { croak "Not enough arguments to kick()"; } return $self->sl("KICK $_[0] $_[1]" . ($_[2] ? " :$_[2]" : "")); } # Gets a list of all the servers that are linked to another visible server. # Takes 2 optional args: it's a bitch to describe, and I'm too tired right # now, so read the RFC. sub links { my ($self) = (shift, undef); $self->sl("LINKS" . (scalar(@_) ? " " . CORE::join(" ", @_[0,1]) : "")); } # Requests a list of channels on the server, or a quick snapshot of the current # channel (the server returns channel name, # of users, and topic for each). sub list { my $self = shift; $self->sl("LIST " . CORE::join(",", @_)); } # Sends a request for some server/user stats. # Takes 1 optional arg: the name of a server to request the info from. sub lusers { my $self = shift; $self->sl("LUSERS" . ($_[0] ? " $_[0]" : "")); } # Gets and/or sets the max line length. The value previous to the sub # call will be returned. # Takes 1 (optional) arg: the maximum line length (in bytes) sub maxlinelen { my $self = shift; my $ret = $self->{_maxlinelen}; $self->{_maxlinelen} = shift if @_; return $ret; } # Sends an action to the channel/nick you specify. It's truly amazing how # many IRCers have no idea that /me's are actually sent via CTCP. # Takes 2 args: the channel or nick to bother with your witticism # the action to send (e.g., "weed-whacks billn's hand off.") sub me { my $self = shift; $self->ctcp("ACTION", $_[0], $_[1]); } # Change channel and user modes (this one is easy... the handler is a bitch.) # Takes at least 1 arg: the target of the command (channel or nick) # (optional) the mode string (i.e., "-boo+i") # (optional) operands of the mode string (nicks, hostmasks, etc.) sub mode { my $self = shift; unless (@_ >= 1) { croak "Not enough arguments to mode()"; } $self->sl("MODE $_[0] " . CORE::join(" ", @_[1..$#_])); } # Sends a MOTD command to a server. # Takes 1 optional arg: the server to query (defaults to current server) sub motd { my $self = shift; $self->sl("MOTD" . ($_[0] ? " $_[0]" : "")); } # Requests the list of users for a particular channel (or the entire net, if # you're a masochist). # Takes 1 or more optional args: name(s) of channel(s) to list the users from. sub names { my $self = shift; $self->sl("NAMES " . CORE::join(",", @_)); } # Was this the easiest sub in the world, or what? # Creates and returns a DCC CHAT object, analogous to IRC.pm's newconn(). # Takes at least 1 arg: An Event object for the DCC CHAT request. # OR A list or listref of args to be passed to new(), # consisting of: # - A boolean value indicating whether or not # you're initiating the CHAT connection. # - The nick of the chattee # - The address to connect to # - The port to connect on sub new_chat { my $self = shift; my ($init, $nick, $address, $port); if (ref($_[0]) =~ /Event/) { # If it's from an Event object, we can't be initiating, right? ($init, undef, undef, undef, $address, $port) = (0, $_[0]->args); $nick = $_[0]->nick; } elsif (ref($_[0]) eq "ARRAY") { ($init, $nick, $address, $port) = @{$_[0]}; } else { ($init, $nick, $address, $port) = @_; } Net::IRC::DCC::CHAT->new($self, $init, $nick, $address, $port); } # Creates and returns a DCC GET object, analogous to IRC.pm's newconn(). # Takes at least 1 arg: An Event object for the DCC SEND request. # OR A list or listref of args to be passed to new(), # consisting of: # - The nick of the file's sender # - The name of the file to receive # - The address to connect to # - The port to connect on # - The size of the incoming file # For all of the above, an extra argument should be added at the end: # An open filehandle to save the incoming file into, # in globref, FileHandle, or IO::* form. # If you wish to do a DCC RESUME, specify the offset in bytes that you # want to start downloading from as the last argument. sub new_get { my $self = shift; my ($nick, $name, $address, $port, $size, $offset, $handle); if (ref($_[0]) =~ /Event/) { (undef, undef, $name, $address, $port, $size) = $_[0]->args; $nick = $_[0]->nick; $handle = $_[1] if defined $_[1]; } elsif (ref($_[0]) eq "ARRAY") { ($nick, $name, $address, $port, $size) = @{$_[0]}; $handle = $_[1] if defined $_[1]; } else { ($nick, $name, $address, $port, $size, $handle) = @_; } unless (defined $handle and ref $handle and (ref $handle eq "GLOB" or $handle->can('print'))) { carp ("Filehandle argument to Connection->new_get() must be ". "a glob reference or object"); return; # is this behavior OK? } my $dcc = Net::IRC::DCC::GET->new( $self, $nick, $address, $port, $size, $name, $handle, $offset ); $self->parent->addconn($dcc) if $dcc; return $dcc; } # Creates and returns a DCC SEND object, analogous to IRC.pm's newconn(). # Takes at least 2 args: The nickname of the person to send to # The name of the file to send # (optional) The blocksize for the connection (default 1k) sub new_send { my $self = shift; my ($nick, $filename, $blocksize); if (ref($_[0]) eq "ARRAY") { ($nick, $filename, $blocksize) = @{$_[0]}; } else { ($nick, $filename, $blocksize) = @_; } Net::IRC::DCC::SEND->new($self, $nick, $filename, $blocksize); } # Selects nick for this object or returns currently set nick. # No default; must be set by user. # If changed while the object is already connected to a server, it will # automatically try to change nicks. # Takes 1 arg: the nick. (I bet you could have figured that out...) sub nick { my $self = shift; if (@_) { $self->{'_nick'} = shift; if ($self->connected) { return $self->sl("NICK " . $self->{'_nick'}); } } else { return $self->{'_nick'}; } } # Sends a notice to a channel or person. # Takes 2 args: the target of the message (channel or nick) # the text of the message to send # The message will be chunked if it is longer than the _maxlinelen # attribute, but it doesn't try to protect against flooding. If you # give it too much info, the IRC server will kick you off! sub notice { my ($self, $to) = splice @_, 0, 2; unless (@_) { croak "Not enough arguments to notice()"; } my ($buf, $length, $line) = (CORE::join("", @_), $self->{_maxlinelen}); while(length($buf) > 0) { ($line, $buf) = unpack("a$length a*", $buf); $self->sl("NOTICE $to :$line"); } } # Makes you an IRCop, if you supply the right username and password. # Takes 2 args: Operator's username # Operator's password sub oper { my $self = shift; unless (@_ > 1) { croak "Not enough arguments to oper()"; } $self->sl("OPER $_[0] $_[1]"); } # This function splits apart a raw server line into its component parts # (message, target, message type, CTCP data, etc...) and passes it to the # appropriate handler. Takes no args, really. sub parse { my ($self) = shift; my ($from, $type, $message, @stuff, $itype, $ev, @lines, $line); if (defined ($self->ssl ? $self->socket->read($line, 10240) : $self->socket->recv($line, 10240, 0)) and (length($self->{_frag}) + length($line)) > 0) { # grab any remnant from the last go and split into lines 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}; # 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) if (defined $line and index($line, "\001") >= 0) { $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 "join" or $type eq "part" or $type eq "mode" or $type eq "topic" or $type eq "kick") { $itype = "channel"; } 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); } 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} - 11 - 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; } return $rv; } # Tells any server that you're an oper on to disconnect from the IRC network. # Takes at least 1 arg: the name of the server to disconnect # (optional) a comment about why it was disconnected sub squit { my $self = shift; unless (@_) { croak "Not enough arguments to squit()"; } $self->sl("SQUIT $_[0]" . ($_[1] ? " :$_[1]" : "")); } # Gets various server statistics for the specified host. # Takes at least 2 arg: the type of stats to request [chiklmouy] # (optional) the server to request from (default is current server) sub stats { my $self = shift; unless (@_) { croak "Not enough arguments passed to stats()"; } $self->sl("STATS $_[0]" . ($_[1] ? " $_[1]" : "")); } # If anyone still has SUMMON enabled, this will implement it for you. # If not, well...heh. Sorry. First arg mandatory: user to summon. # Second arg optional: a server name. sub summon { my $self = shift; unless (@_) { croak "Not enough arguments passed to summon()"; } $self->sl("SUMMON $_[0]" . ($_[1] ? " $_[1]" : "")); } # Requests timestamp from specified server. Easy enough, right? # Takes 1 optional arg: a server name/mask to query # renamed to not collide with things... -- aburke sub timestamp { my ($self, $serv) = (shift, undef); $self->sl("TIME" . ($_[0] ? " $_[0]" : "")); } # Sends request for current topic, or changes it to something else lame. # Takes at least 1 arg: the channel whose topic you want to screw around with # (optional) the new topic you want to impress everyone with sub topic { my $self = shift; unless (@_) { croak "Not enough arguments to topic()"; } # Can you tell I've been reading the Nethack source too much? :) $self->sl("TOPIC $_[0]" . ($_[1] ? " :$_[1]" : "")); } # Sends a trace request to the server. Whoop. # Take 1 optional arg: the server or nickname to trace. sub trace { my $self = shift; $self->sl("TRACE" . ($_[0] ? " $_[0]" : "")); } # This method submitted by Dave Schmitt . Thanks, Dave! sub unignore { my $self = shift; croak "Not enough arguments to unignore()" unless @_; if (@_ == 1) { if (exists $self->{_ignore}->{$_[0]}) { return @{ $self->{_ignore}->{$_[0]} }; } else { return (); } } elsif (@_ > 1) { # code defensively, remember... my $type = shift; # I moved this part further down as an Obsessive Efficiency # Initiative. It shouldn't be a problem if I do _parse right... # ... but those are famous last words, eh? unless (grep {$_ eq $type} qw(public msg ctcp notice channel nick other all)) { carp "$type isn't a valid type to unignore()"; return; } if ( exists $self->{_ignore}->{$type} ) { # removes all specifed entries ala _Perl_Cookbook_ recipe 4.7 my @temp = @{$self->{_ignore}->{$type}}; @{$self->{_ignore}->{$type}}= (); my %seen = (); foreach my $item (@_) { $seen{$item}=1 } foreach my $item (@temp) { push(@{$self->{_ignore}->{$type}}, $item) unless ($seen{$item}); } } else { carp "no ignore entry for $type to remove"; } } } # Requests userhost info from the server. # Takes at least 1 arg: nickname(s) to look up. sub userhost { my $self = shift; unless (@_) { croak 'Not enough args to userhost().'; } $self->sl("USERHOST " . CORE::join (" ", @_)); } # Sends a users request to the server, which may or may not listen to you. # Take 1 optional arg: the server to query. sub users { my $self = shift; $self->sl("USERS" . ($_[0] ? " $_[0]" : "")); } # Asks the IRC server what version and revision of ircd it's running. Whoop. # Takes 1 optional arg: the server name/glob. (default is current server) sub version { my $self = shift; $self->sl("VERSION" . ($_[0] ? " $_[0]" : "")); } # Sends a message to all opers on the network. Hypothetically. # Takes 1 arg: the text to send. sub wallops { my $self = shift; unless ($_[0]) { croak 'No arguments passed to wallops()'; } $self->sl("WALLOPS :" . CORE::join("", @_)); } # Asks the server about stuff, you know. Whatever. Pass the Fritos, dude. # Takes 2 optional args: the bit of stuff to ask about # an "o" (nobody ever uses this...) sub who { my $self = shift; # Obfuscation! $self->sl("WHO" . (@_ ? " @_" : "")); } # If you've gotten this far, you probably already know what this does. # Takes at least 1 arg: nickmasks or channels to /whois sub whois { my $self = shift; unless (@_) { croak "Not enough arguments to whois()"; } return $self->sl("WHOIS " . CORE::join(",", @_)); } # Same as above, in the past tense. # Takes at least 1 arg: nick to do the /whowas on # (optional) max number of hits to display # (optional) server or servermask to query sub whowas { my $self = shift; unless (@_) { croak "Not enough arguments to whowas()"; } return $self->sl("WHOWAS $_[0]" . ($_[1] ? " $_[1]" : "") . (($_[1] && $_[2]) ? " $_[2]" : "")); } # This sub executes the default action for an event with no user-defined # handlers. It's all in one sub so that we don't have to make a bunch of # separate anonymous subs stuffed in a hash. sub _default { my ($self, $event) = @_; my $verbose = $self->verbose; # Users should only see this if the programmer (me) fucked up. unless ($event) { croak "You EEEEEDIOT!!! Not enough args to _default()!"; } # Reply to PING from server as quickly as possible. if ($event->type eq "ping") { $self->sl("PONG " . (CORE::join ' ', $event->args)); } elsif ($event->type eq "disconnect") { # I violate OO tenets. (It's consensual, of course.) unless (keys %{$self->parent->{_connhash}} > 0) { die "No active connections left, exiting...\n"; } } return 1; } 1; __END__ =head1 NAME Net::IRC::Connection - Object-oriented interface to a single IRC connection =head1 SYNOPSIS Hard hat area: This section under construction. =head1 DESCRIPTION This documentation is a subset of the main Net::IRC documentation. If you haven't already, please "perldoc Net::IRC" before continuing. Net::IRC::Connection defines a class whose instances are individual connections to a single IRC server. Several Net::IRC::Connection objects may be handled simultaneously by one Net::IRC object. =head1 METHOD DESCRIPTIONS This section is under construction, but hopefully will be finally written up by the next release. Please see the C script and the source for details about this module. =head1 AUTHORS Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and Dennis Taylor Edennis@funkplanet.comE. Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. Currently being hacked on, hacked up, and worked over by the members of the Net::IRC developers mailing list. For details, see http://www.execpc.com/~corbeau/irc/list.html . =head1 URL Up-to-date source and information about the Net::IRC project can be found at http://netirc.betterbox.net/ . =head1 SEE ALSO =over =item * perl(1). =item * RFC 1459: The Internet Relay Chat Protocol =item * http://www.irchelp.org/, home of fine IRC resources. =back =cut Net-IRC-0.75/t/0040775000076600007660000000000010044512665013266 5ustar jmuhlichjmuhlichNet-IRC-0.75/t/01_minimal.t0100664000076600007660000000021507647666032015411 0ustar jmuhlichjmuhlichuse strict; use Test; BEGIN { plan tests => 3 }; ok(eval { require Net::IRC; }); use Net::IRC; ok(1); my $irc = Net::IRC->new; ok($irc); Net-IRC-0.75/Event.pm0100664000076600007660000006245607734235304014460 0ustar jmuhlichjmuhlich##################################################################### # # # 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'}; } # 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 265 => "n_local", # 1997-10-16 -- tkil 266 => "n_global", # 1997-10-16 -- tkil 271 => "silelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 272 => "endofsilelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 275 => "statsdline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 280 => "glist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 281 => "endofglist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 290 => "helphdr", # UnrealIrcd, Hendrik Frenzel 291 => "helpop", # UnrealIrcd, Hendrik Frenzel 292 => "helptlr", # UnrealIrcd, Hendrik Frenzel 293 => "helphlp", # UnrealIrcd, Hendrik Frenzel 294 => "helpfwd", # UnrealIrcd, Hendrik Frenzel 295 => "helpign", # UnrealIrcd, Hendrik Frenzel 300 => "none", 301 => "away", 302 => "userhost", 303 => "ison", 304 => "rpl_text", # Bahamut IRCD 305 => "unaway", 306 => "nowaway", 307 => "userip", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 308 => "rulesstart", # UnrealIrcd, Hendrik Frenzel 309 => "endofrules", # UnrealIrcd, Hendrik Frenzel 310 => "whoishelp", # (July01-01)Austnet Extension, found by Andypoo 311 => "whoisuser", 312 => "whoisserver", 313 => "whoisoperator", 314 => "whowasuser", 315 => "endofwho", 316 => "whoischanop", 317 => "whoisidle", 318 => "endofwhois", 319 => "whoischannels", 320 => "whoisvworld", # (July01-01)Austnet Extension, found by Andypoo 321 => "liststart", 322 => "list", 323 => "listend", 324 => "channelmodeis", 329 => "channelcreate", # 1997-11-24 -- archon 331 => "notopic", 332 => "topic", 333 => "topicinfo", # 1997-11-24 -- archon 334 => "listusage", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 335 => "whoisbot", # UnrealIrcd, Hendrik Frenzel 341 => "inviting", 342 => "summoning", 346 => "invitelist", # UnrealIrcd, Hendrik Frenzel 347 => "endofinvitelist", # UnrealIrcd, Hendrik Frenzel 348 => "exlist", # UnrealIrcd, Hendrik Frenzel 349 => "endofexlist", # UnrealIrcd, Hendrik Frenzel 351 => "version", 352 => "whoreply", 353 => "namreply", 354 => "whospcrpl", # Undernet Extension, Kajetan@Hinner.com, 17/10/98 361 => "killdone", 362 => "closing", 363 => "closeend", 364 => "links", 365 => "endoflinks", 366 => "endofnames", 367 => "banlist", 368 => "endofbanlist", 369 => "endofwhowas", 371 => "info", 372 => "motd", 373 => "infostart", 374 => "endofinfo", 375 => "motdstart", 376 => "endofmotd", 377 => "motd2", # 1997-10-16 -- tkil 378 => "austmotd", # (July01-01)Austnet Extension, found by Andypoo 379 => "whoismodes", # UnrealIrcd, Hendrik Frenzel 381 => "youreoper", 382 => "rehashing", 383 => "youreservice", # UnrealIrcd, Hendrik Frenzel 384 => "myportis", 385 => "notoperanymore", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98 386 => "qlist", # UnrealIrcd, Hendrik Frenzel 387 => "endofqlist", # UnrealIrcd, Hendrik Frenzel 388 => "alist", # UnrealIrcd, Hendrik Frenzel 389 => "endofalist", # UnrealIrcd, Hendrik Frenzel 391 => "time", 392 => "usersstart", 393 => "users", 394 => "endofusers", 395 => "nousers", 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 999 => "numericerror", # Bahamut IRCD ); 1; __END__ =head1 NAME Net::IRC::Event - A class for passing event data between subroutines =head1 SYNOPSIS None yet. These docs are under construction. =head1 DESCRIPTION This documentation is a subset of the main Net::IRC documentation. If you haven't already, please "perldoc Net::IRC" before continuing. Net::IRC::Event defines a standard interface to the salient information for just about any event your client may witness on IRC. It's about as close as we can get in Perl to a struct, with a few extra nifty features thrown in. =head1 METHOD DESCRIPTIONS This section is under construction, but hopefully will be finally written up by the next release. Please see the C script and the source for details about this module. =head1 LIST OF EVENTS Net::IRC is an entirely event-based system, which takes some getting used to at first. To interact with the IRC server, you tell Net::IRC's server connection to listen for certain events and activate your own subroutines when they occur. Problem is, this doesn't help you much if you don't know what to tell it to look for. Below is a list of the possible events you can pass to Net::IRC, along with brief descriptions of each... hope this helps. =head2 Common events =over =item * nick The "nick" event is triggered when the client receives a NICK message, meaning that someone on a channel with the client has changed eir nickname. =item * quit The "quit" event is triggered upon receipt of a QUIT message, which means that someone on a channel with the client has disconnected. =item * join The "join" event is triggered upon receipt of a JOIN message, which means that someone has entered a channel that the client is on. =item * part The "part" event is triggered upon receipt of a PART message, which means that someone has left a channel that the client is on. =item * mode The "mode" event is triggered upon receipt of a MODE message, which means that someone on a channel with the client has changed the channel's parameters. =item * topic The "topic" event is triggered upon receipt of a TOPIC message, which means that someone on a channel with the client has changed the channel's topic. =item * kick The "kick" event is triggered upon receipt of a KICK message, which means that someone on a channel with the client (or possibly the client itself!) has been forcibly ejected. =item * public The "public" event is triggered upon receipt of a PRIVMSG message to an entire channel, which means that someone on a channel with the client has said something aloud. =item * msg The "msg" event is triggered upon receipt of a PRIVMSG message which is addressed to one or more clients, which means that someone is sending the client a private message. (Duh. :-) =item * notice The "notice" event is triggered upon receipt of a NOTICE message, which means that someone has sent the client a public or private notice. (Is that sufficiently vague?) =item * ping The "ping" event is triggered upon receipt of a PING message, which means that the IRC server is querying the client to see if it's alive. Don't confuse this with CTCP PINGs, explained later. =item * other The "other" event is triggered upon receipt of any number of unclassifiable miscellaneous messages, but you're not likely to see it often. =item * invite The "invite" event is triggered upon receipt of an INVITE message, which means that someone is permitting the client's entry into a +i channel. =item * kill The "kill" event is triggered upon receipt of a KILL message, which means that an IRC operator has just booted your sorry arse offline. Seeya! =item * disconnect The "disconnect" event is triggered when the client loses its connection to the IRC server it's talking to. Don't confuse it with the "leaving" event. (See below.) =item * leaving The "leaving" event is triggered just before the client deliberately closes a connection to an IRC server, in case you want to do anything special before you sign off. =item * umode The "umode" event is triggered when the client changes its personal mode flags. =item * error The "error" event is triggered when the IRC server complains to you about anything. Sort of the evil twin to the "other" event, actually. =back =head2 CTCP Requests =over =item * cping The "cping" event is triggered when the client receives a CTCP PING request from another user. See the irctest script for an example of how to properly respond to this common request. =item * cversion The "cversion" event is triggered when the client receives a CTCP VERSION request from another client, asking for version info about its IRC client program. =item * csource The "csource" event is triggered when the client receives a CTCP SOURCE request from another client, asking where it can find the source to its IRC client program. =item * ctime The "ctime" event is triggered when the client receives a CTCP TIME request from another client, asking for the local time at its end. =item * cdcc The "cdcc" event is triggered when the client receives a DCC request of any sort from another client, attempting to establish a DCC connection. =item * cuserinfo The "cuserinfo" event is triggered when the client receives a CTCP USERINFO request from another client, asking for personal information from the client's user. =item * cclientinfo The "cclientinfo" event is triggered when the client receives a CTCP CLIENTINFO request from another client, asking for whatever the hell "clientinfo" means. =item * cerrmsg The "cerrmsg" event is triggered when the client receives a CTCP ERRMSG request from another client, notifying it of a protocol error in a preceding CTCP communication. =item * cfinger The "cfinger" event is triggered when the client receives a CTCP FINGER request from another client. How to respond to this should best be left up to your own moral stance. =item * caction The "caction" event is triggered when the client receives a CTCP ACTION message from another client. I should hope you're getting the hang of how Net::IRC handles CTCP requests by now... =back =head2 CTCP Responses =over =item * crping The "crping" event is triggered when the client receives a CTCP PING response from another user. See the irctest script for an example of how to properly respond to this common event. =item * crversion The "crversion" event is triggered when the client receives a CTCP VERSION response from another client. =item * crsource The "crsource" event is triggered when the client receives a CTCP SOURCE response from another client. =item * crtime The "crtime" event is triggered when the client receives a CTCP TIME response from another client. =item * cruserinfo The "cruserinfo" event is triggered when the client receives a CTCP USERINFO response from another client. =item * crclientinfo The "crclientinfo" event is triggered when the client receives a CTCP CLIENTINFO response from another client. =item * crfinger The "crfinger" event is triggered when the client receives a CTCP FINGER response from another client. I'm not even going to consider making a joke about this one. =back =head2 DCC Events =over =item * dcc_open The "dcc_open" event is triggered when a DCC connection is established between the client and another client. =item * dcc_update The "dcc_update" event is triggered when any data flows over a DCC connection. Useful for doing things like monitoring file transfer progress, for instance. =item * dcc_close The "dcc_close" event is triggered when a DCC connection closes, whether from an error or from natural causes. =item * chat The "chat" event is triggered when the person on the other end of a DCC CHAT connection sends you a message. Think of it as the private equivalent of "msg", if you will. =back =head2 Numeric Events =over =item * There's a whole lot of them, and they're well-described elsewhere. Please see the IRC RFC (1495, at http://cs-ftp.bu.edu/pub/irc/support/IRC_RFC ) for a detailed description, or the Net::IRC::Event.pm source code for a quick list. =back =head1 AUTHORS Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and Dennis Taylor Edennis@funkplanet.comE. Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. Currently being hacked on, hacked up, and worked over by the members of the Net::IRC developers mailing list. For details, see http://www.execpc.com/~corbeau/irc/list.html . =head1 URL Up-to-date source and information about the Net::IRC project can be found at http://netirc.betterbox.net/ . =head1 SEE ALSO =over =item * perl(1). =item * RFC 1459: The Internet Relay Chat Protocol =item * http://www.irchelp.org/, home of fine IRC resources. =back =cut Net-IRC-0.75/EventQueue.pm0100664000076600007660000000256707647673747015506 0ustar jmuhlichjmuhlichpackage 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; Net-IRC-0.75/IRC.pm0100664000076600007660000005016710044512313013772 0ustar jmuhlichjmuhlich##################################################################### # # # 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.75"; 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 - Perl interface to the Internet Relay Chat protocol =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 Welcome to Net::IRC, a work in progress. First intended to be a quick tool for writing an IRC script in Perl, Net::IRC has grown into a comprehensive Perl implementation of the IRC protocol (RFC 1459), developed by several members of the EFnet IRC channel #perl, and maintained in channel #net-irc. There are 4 component modules which make up Net::IRC: =over =item * Net::IRC The wrapper for everything else, containing methods to generate Connection objects (see below) and a connection manager which does an event loop on all available filehandles. Sockets or files which are readable (or writable, or whatever you want it to select() for) get passed to user-supplied handler subroutines in other packages or in user code. =item * Net::IRC::Connection The big time sink on this project. Each Connection instance is a single connection to an IRC server. The module itself contains methods for every single IRC command available to users (Net::IRC isn't designed for writing servers, for obvious reasons), methods to set, retrieve, and call handler functions which the user can set (more on this later), and too many cute comments. Hey, what can I say, we were bored. =item * Net::IRC::Event Kind of a struct-like object for storing info about things that the IRC server tells you (server responses, channel talk, joins and parts, et cetera). It records who initiated the event, who it affects, the event type, and any other arguments provided for that event. Incidentally, the only argument passed to a handler function. =item * Net::IRC::DCC The analogous object to Connection.pm for connecting, sending and retrieving with the DCC protocol. Instances of DCC.pm are invoked from Cnew_{send,get,chat}> in the same way that Cnewconn> invokes Cnew>. This will make more sense later, we promise. =back The central concept that Net::IRC is built around is that of handlers (or hooks, or callbacks, or whatever the heck you feel like calling them). We tried to make it a completely event-driven model, a la Tk -- for every conceivable type of event that your client might see on IRC, you can give your program a custom subroutine to call. But wait, there's more! There are 3 levels of handler precedence: =over =item * Default handlers Considering that they're hardwired into Net::IRC, these won't do much more than the bare minimum needed to keep the client listening on the server, with an option to print (nicely formatted, of course) what it hears to whatever filehandles you specify (STDOUT by default). These get called only when the user hasn't defined any of his own handlers for this event. =item * User-definable global handlers The user can set up his own subroutines to replace the default actions for I IRC connection managed by your program. These only get invoked if the user hasn't set up a per-connection handler for the same event. =item * User-definable per-connection handlers Simple: this tells a single connection what to do if it gets an event of this type. Supersedes global handlers if any are defined for this event. =back And even better, you can choose to call your custom handlers before or after the default handlers instead of replacing them, if you wish. In short, it's not perfect, but it's about as good as you can get and still be documentable, given the sometimes horrendous complexity of the IRC protocol. =head1 GETTING STARTED =head2 Initialization To start a Net::IRC script, you need two things: a Net::IRC object, and a Net::IRC::Connection object. The Connection object does the dirty work of connecting to the server; the IRC object handles the input and output for it. To that end, say something like this: use Net::IRC; $irc = new Net::IRC; $conn = $irc->newconn(Nick => 'some_nick', Server => 'some.irc.server.com'); ...or something similar. Acceptable parameters to newconn() are: =over =item * Nick The nickname you'll be known by on IRC, often limited to a maximum of 9 letters. Acceptable characters for a nickname are C<[\w{}[]\`^|-]>. If you don't specify a nick, it defaults to your username. =item * Server The IRC server to connect to. There are dozens of them across several widely-used IRC networks, but the oldest and most popular is EFNet (Eris Free Net), home to #perl. See http://www.irchelp.org/ for lists of popular servers, or ask a friend. =item * Port The port to connect to this server on. By custom, the default is 6667. =item * Username On systems not running identd, you can set the username for your user@host to anything you wish. Note that some IRC servers won't allow connections from clients which don't run identd. =item * Ircname A short (maybe 60 or so chars) piece of text, originally intended to display your real name, which people often use for pithy quotes and URLs. Defaults to the contents of your GECOS field. =item * Password If the IRC server you're trying to write a bot for is password-protected, no problem. Just say "C 'foo'>" and you're set. =item * SSL If you wish to connect to an irc server which is using SSL, set this to a true value. Ie: "C 1>". =back =head2 Handlers Once that's over and done with, you need to set up some handlers if you want your bot to do anything more than sit on a connection and waste resources. Handlers are references to subroutines which get called when a specific event occurs. Here's a sample handler sub: # What to do when the bot successfully connects. sub on_connect { my $self = shift; print "Joining #IRC.pm..."; $self->join("#IRC.pm"); $self->privmsg("#IRC.pm", "Hi there."); } The arguments to a handler function are always the same: =over =item $_[0]: The Connection object that's calling it. =item $_[1]: An Event object (see below) that describes what the handler is responding to. =back Got it? If not, see the examples in the irctest script that came with this distribution. Anyhow, once you've defined your handler subroutines, you need to add them to the list of handlers as either a global handler (affects all Connection objects) or a local handler (affects only a single Connection). To do so, say something along these lines: $self->add_global_handler('376', \&on_connect); # global $self->add_handler('msg', \&on_msg); # local 376, incidentally, is the server number for "end of MOTD", which is an event that the server sends to you after you're connected. See Event.pm for a list of all possible numeric codes. The 'msg' event gets called whenever someone else on IRC sends your client a private message. For a big list of possible events, see the B section in the documentation for Net::IRC::Event. =head2 Getting Connected When you've set up all your handlers, the following command will put your program in an infinite loop, grabbing input from all open connections and passing it off to the proper handlers: $irc->start; Note that new connections can be added and old ones dropped from within your handlers even after you call this. Just don't expect any code below the call to C to ever get executed. If you're tying Net::IRC into another event-based module, such as perl/Tk, there's a nifty C method provided for your convenience. Calling C<$irc-Edo_one_loop()> runs through the IRC.pm event loop once, hands all ready filehandles over to the appropriate handler subs, then returns control to your program. =head1 METHOD DESCRIPTIONS This section contains only the methods in IRC.pm itself. Lists of the methods in Net::IRC::Connection, Net::IRC::Event, or Net::IRC::DCC are in their respective modules' documentation; just C (or Event or DCC or whatever) to read them. Functions take no arguments unless otherwise specified in their description. By the way, expect Net::IRC to use AutoLoader sometime in the future, once it becomes a little more stable. =over =item * addconn() Adds the specified object's socket to the select loop in C. This is mostly for the use of Connection and DCC objects (and for pre-0.5 compatibility)... for most (read: all) purposes, you can just use C, described below. Takes at least 1 arg: =over =item 0. An object whose socket needs to be added to the select loop =item 1. B A string consisting of one or more of the letters r, w, and e. Passed directly to C... see the description below for more info. =back =item * addfh() This sub takes a user's socket or filehandle and a sub to handle it with and merges it into C's list of select()able filehandles. This makes integration with other event-based systems (Tk, for instance) a good deal easier than in previous releases. Takes at least 2 args: =over =item 0. A socket or filehandle to monitor =item 1. A reference to a subroutine. When C determines that the filehandle is ready, it passes the filehandle to this (presumably user-supplied) sub, where you can read from it, write to it, etc. as your script sees fit. =item 2. B A string containing any combination of the letters r, w or e (standing for read, write, and error, respectively) which determines what conditions you're expecting on that filehandle. For example, this line select()s $fh (a filehandle, of course) for both reading and writing: $irc->addfh( $fh, \&callback, "rw" ); =back =item * do_one_loop() Cs on all open filehandles and passes any ready ones to the appropriate handler subroutines. Also responsible for executing scheduled events from Cschedule()> on time. =item * new() A fairly vanilla constructor which creates and returns a new Net::IRC object. =item * newconn() Creates and returns a new Connection object. All arguments are passed straight to Cnew()>; examples of common arguments can be found in the B or B sections. =item * removeconn() Removes the specified object's socket from C's list of select()able filehandles. This is mostly for the use of Connection and DCC objects (and for pre-0.5 compatibility)... for most (read: all) purposes, you can just use C, described below. Takes 1 arg: =over =item 0. An object whose socket or filehandle needs to be removed from the select loop =back =item * removefh() This method removes a given filehandle from C's list of selectable filehandles. Takes 1 arg: =over =item 0. A socket or filehandle to remove =back =item * start() Starts an infinite event loop which repeatedly calls C to read new events from all open connections and pass them off to any applicable handlers. =item * timeout() Sets or returns the current C timeout for the main event loop, in seconds (fractional amounts allowed). See the documentation for the C function for more info. Takes 1 optional arg: =over =item 0. B A new value for the C timeout for this IRC object. =back =item * flush_output_queue() Flushes any waiting messages in the output queue if pacing is enabled. This method will not return until the output queue is empty. =over =back =head1 AUTHORS =over =item * Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and Dennis Taylor Edennis@funkplanet.comE. =item * Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. =item * Currently being hacked on, hacked up, and worked over by the members of the Net::IRC developers mailing list. For details, see http://www.execpc.com/~corbeau/irc/list.html . =back =head1 URL Up-to-date source and information about the Net::IRC project can be found at http://www.sourceforge.net/projects/net-irc/ . =head1 SEE ALSO =over =item * perl(1). =item * RFC 1459: The Internet Relay Chat Protocol =item * http://www.irchelp.org/, home of fine IRC resources. =back =cut Net-IRC-0.75/MANIFEST0100664000076600007660000000014507564757040014164 0ustar jmuhlichjmuhlichChanges Connection.pm DCC.pm Event.pm IRC.pm irctest MANIFEST MANIFEST.SKIP Makefile.PL README TODO Net-IRC-0.75/MANIFEST.SKIP0100664000076600007660000000002507564757040014726 0ustar jmuhlichjmuhlichTODO$ Makefile$ ^CVS Net-IRC-0.75/Makefile.PL0100664000076600007660000000170607647665436015022 0ustar jmuhlichjmuhlich use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Net::IRC', 'PM' => { 'IRC.pm' => '$(INST_LIBDIR)/IRC.pm', 'Connection.pm' => '$(INST_LIBDIR)/IRC/Connection.pm', 'Event.pm' => '$(INST_LIBDIR)/IRC/Event.pm', 'DCC.pm' => '$(INST_LIBDIR)/IRC/DCC.pm', 'EventQueue.pm' => '$(INST_LIBDIR)/IRC/EventQueue.pm', 'Entry.pm' => '$(INST_LIBDIR)/IRC/EventQueue/Entry.pm', }, 'PREREQ_PM' => { 'IO::Select' => 0, 'Carp' => 0, 'Socket' => 0, 'IO::File' => 0, 'IO::Socket' => 0, 'Sys::Hostname' => 0, }, 'VERSION_FROM' => 'IRC.pm', # finds $VERSION 'dist' => { 'COMPRESS' => 'gzip --best' }, ); Net-IRC-0.75/README0100664000076600007660000001017707763736471013727 0ustar jmuhlichjmuhlichNet::IRC 0.72 README T.J. Eckman Mon Jul 02 00:00:00 GMT 2000 ============================================================================== Table of Contents ------------------------ 1. Introduction 2. Availability 3. Prerequisites 4. Installation +- 4.1 Windows Installation 5. Demonstration Script 6. Bugs 7. Disclaimer 8. Copyright 9. Developer Information 1. Introduction ------------------------ 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). 2. Availability ------------------------ CPAN, of course. http://www.perl.com/CPAN/modules/by-module/Net/ Also, Sourceforge: http://sourceforge.net/project/net-irc 3. Prerequisites ------------------------ Net::IRC requires Perl version 5.004 or higher to install and run. Hypothetically, it could run on 5.003_9something with IO::* installed, but you may as well upgrade anyhow. The latest version of Perl can be found at http://www.perl.com/CPAN/src/latest.tar.gz (for UNIX), or at http://www.perl.com/CPAN/ports/ for various non-Unix machines. Net::IRC tries to use the Time::HiRes module by default, but will fail silently if you do not have it. If you have Time::HiRes pacing settings and calls to schedule() can be fractional. 4. Installation ------------------------ Same old, same old. If you get through all these steps without anything emitting horrible dire warning messages, you're all set. In particular, the "perl Makefile.PL" will barf if run with older versions of Perl, but if you read the Prerequisites section of this README, you already know that, right? Do this, in the following order: perl Makefile.PL make make install We don't have any automated tests yet, but they might be in the not-too- distant future. You may instead wish to play around with the... => 4.1 Windows Installation If you don't have a copy of 'make' on your machine, the easiest way to install this module is to unzip the file into a local directory, and copy the component files like this: IRC.pm => path.to.perl/site/lib/Net/IRC.pm Connection.pm => path.to.perl/site/lib/Net/IRC/Connection.pm Event.pm => path.to.perl/site/lib/Net/IRC/Event.pm DCC.pm => path.to.perl/site/lib/Net/IRC/DCC.pm 5. Demonstration Script ------------------------ A sample Net::IRC script is included with the distribution, under the creative name "irctest". It doesn't do much more than connect to a server and print annoying messages to anyone who talks to it, but that should be enough to give you an idea of how the whole enchilada fits together until we actually get some real documentation written. Just don't be surprised if IRC admins get a clue about it and start killing it as soon as they see one log on... Oh, and by the way... if you say "Send me " to an irctest bot, it will send the specified file (if it can) as a demonstration of Net::IRC's DCC and scheduler interface. This is a potential security hole, so be careful. 6. Bugs ------------------------ Please submit bugs at the sourceforge project page for Net::IRC. See section 9 for the address. 7. Disclaimer ------------------------ This software is under no warranty, explicit or implied. Use at your own risk. 8. Copyright ------------------------ This module copyright (c) 1997 Greg Bacon & Dennis Taylor. All rights reserved. This module is free software; you can redistribute it and/or modify it under the terms of the Perl Artistic License, distributed with this module. Any changes after 0.70, but before 0.72, are copyright Peter Sergeant, and/or the people who submitted them. Any changes after 0.71 are copyright T.J. Eckman, and/or the people who submitted them. Any changes after 0.73 are under the ownership of their respective submitters. 9. Developer Information ------------------------ Maintenance is now handled via sourceforge: http://sourceforge.net/projects/net-irc/ Bug reports, feature requests and patches should be submitted at the above address. Net-IRC-0.75/TODO0100664000076600007660000000143707564757040013530 0ustar jmuhlichjmuhlichThis is the old ToDo file. New ToDo items are in the main README file now, but everything below still needs to be done... bleh. Things to do for the next revision: =================================== - Fix the funky parse case for Undernet "Closing Link" messages: Closing Link: Natsune[i.got.net] by NewBrunswick.NJ.US.Undernet.Org (Excess Flood) - Write more documentation. - Fix this case: QIUT QIUT :Unknown command - Test the server notice stuff. (both "NOTICE :foo" and ":server.com NOTICE :foo") - Allow chained handlers, and have add_handler return the old handler(s)? - Fix the colons-getting-lost problem in message parsing. - Allow users to do "MODE #channel" to retrieve current channel settings. - Fix Modes (mode -m causes problems) Net-IRC-0.75/irctest0100775000076600007660000002174607660776474014461 0ustar jmuhlichjmuhlich#!/usr/bin/perl -w # # irctest # Sample Net::IRC script that starts a vapid little annoybot. # Please don't test your bots in #perl... we are easily annoyed. # use strict; use Net::IRC; # # Create the IRC and Connection objects # my $irc = new Net::IRC; print "Creating connection to IRC server...\n"; my $conn = $irc->newconn(Server => ($ARGV[0] || 'irc.prison.net'), Port => 6667, Nick => 'Boolahman', Ircname => 'This bot brought to you by Net::IRC.', Username => 'quetzal') or die "irctest: Can't connect to IRC server.\n"; # # Here's some stuff to print at odd moments. # my @zippy = ( "I am a traffic light, and Alan Ginsberg kidnapped my laundry in 1927!", "I'm a GENIUS! I want to dispute sentence structure with SUSAN SONTAG!!", "Now I'm telling MISS PIGGY about MONEY MARKET FUNDS!", "I have a VISION! It's a RANCID double-FISHWICH on an ENRICHED BUN!!", "My pants just went on a wild rampage through a Long Island Bowling Alley!!", "I always liked FLAG DAY!!", "I will establish the first SHOPPING MALL in NUTLEY, New Jersey...", "I used to be STUPID, too..before I started watching UHF-TV!!", "I smell like a wet reducing clinic on Columbus Day!", "Just walk along and try NOT to think about your INTESTINES being almost FORTY YARDS LONG!!", "It's the RINSE CYCLE!! They've ALL IGNORED the RINSE CYCLE!!", "Yow! It's some people inside the wall! This is better than mopping!", "Is the EIGHTIES when they had ART DECO and GERALD McBOING-BOING lunch boxes??", "This PIZZA symbolizes my COMPLETE EMOTIONAL RECOVERY!!", "I call it a \"SARDINE ON WHEAT\"!", "Is it FUN to be a MIDGET?", "Someone in DAYTON, Ohio is selling USED CARPETS to a SERBO-CROATIAN!!", ); # # Here are the handler subroutines. Fascinating, huh? # # What to do when the bot successfully connects. sub on_connect { my $self = shift; print "Joining #IRC.pm...\n"; $self->join("#net-irc2"); $self->privmsg("#net-irc2", &pickrandom()); $self->topic("#net-irc2"); } # Handles some messages you get when you connect sub on_init { my ($self, $event) = @_; my (@args) = ($event->args); shift (@args); print "*** @args\n"; } # What to do when someone leaves a channel the bot is on. sub on_part { my ($self, $event) = @_; my ($channel) = ($event->to)[0]; printf "*** %s has left channel %s\n", $event->nick, $channel; } # What to do when someone joins a channel the bot is on. sub on_join { my ($self, $event) = @_; my ($channel) = ($event->to)[0]; printf "*** %s (%s) has joined channel %s\n", $event->nick, $event->userhost, $channel; if ($event->userhost =~ /^corbeau\@.*execpc\.com/) { # Auto-ops anyone who $self->mode("#IRC.pm", "+o", $event->nick); # matches hostmask. } } # What to do when we receive a private PRIVMSG. sub on_msg { my ($self, $event) = @_; my ($nick) = $event->nick; print "*$nick* ", ($event->args), "\n"; # $self->privmsg($nick, &pickrandom()); # Say a Zippy quote. } # What to do when we receive channel text. sub on_public { my ($self, $event) = @_; my @to = $event->to; my ($nick, $mynick) = ($event->nick, $self->nick); my ($arg) = ($event->args); # Note that $event->to() returns a list (or arrayref, in scalar # context) of the message's recipients, since there can easily be # more than one. print "<$nick> $arg\n"; if ($arg =~ /$mynick/i) { # Say a Zippy quote if our nick $self->privmsg([ @to ], &pickrandom()); # appears in the message. } if ($arg =~ /Go away/i) { # Tell him to leave, and he does. $self->quit("Yow!!"); exit 0; } if ($arg =~ /^chat/i) { # Request a DCC Chat initiation $self->new_chat(1, $event->nick, $event->host); } # You can invoke this next part with "Send me Filename" or # "Send Filename to me". It doesn't much like ending punctuation, though. $arg =~ s/[^"'\w]*?\b(to|me)\b[^'"\w]*?//g; if ($arg =~ /^send\s+(\S+)\s*/i) { if (-e $1) { $self->privmsg($nick, "Sending $1 in 10 seconds..."); $self->schedule(10, \&Net::IRC::Connection::new_send, $nick, $1); } else { $self->privmsg($nick, "No such file as $1, sorry."); } } } sub on_umode { my ($self, $event) = @_; my @to = $event->to; my ($nick, $mynick) = ($event->nick, $self->nick); my ($arg) = ($event->args); # Note that $event->to() returns a list (or arrayref, in scalar # context) of the message's recipients, since there can easily be # more than one. print "<$nick> $arg\n"; if ($arg =~ /$mynick/i) { # Say a Zippy quote if our nick $self->privmsg([ @to ], &pickrandom()); # appears in the message. } if ($arg =~ /Go away/i) { # Tell him to leave, and he does. $self->quit("Yow!!"); exit 0; } if ($arg =~ /^chat/i) { # Request a DCC Chat initiation $self->new_chat(1, $event->nick, $event->host); } # You can invoke this next part with "Send me Filename" or # "Send Filename to me". It doesn't much like ending punctuation, though. $arg =~ s/[^"'\w]*?\b(to|me)\b[^'"\w]*?//g; if ($arg =~ /^send\s+(\S+)\s*/i) { if (-e $1) { $self->privmsg($nick, "Sending $1 in 10 seconds..."); $self->schedule(10, \&Net::IRC::Connection::new_send, $nick, $1); } else { $self->privmsg($nick, "No such file as $1, sorry."); } } } # What to do when we receive a message via DCC CHAT. sub on_chat { my ($self, $event) = @_; my ($sock) = ($event->to)[0]; print '*' . $event->nick . '* ' . join(' ', $event->args), "\n"; $self->privmsg($sock, &pickrandom()); # Say a Zippy quote. } # Prints the names of people in a channel when we enter. sub on_names { my ($self, $event) = @_; my (@list, $channel) = ($event->args); # eat yer heart out, mjd! # splice() only works on real arrays. Sigh. ($channel, @list) = splice @list, 2; print "Users on $channel: @list\n"; } # What to do when we receive a DCC SEND or CHAT request. sub on_dcc { my ($self, $event) = @_; my $type = ($event->args)[1]; if (uc($type) eq 'SEND') { open TEST, ">/tmp/net-irc.dcctest" or do { warn "Can't open test file: $!"; return; }; $self->new_get($event, \*TEST); print "Saving incoming DCC SEND to /tmp/net-irc.dcctest\n"; } elsif(uc($type) eq 'CHAT') { $self->new_chat($event); } else { print STDERR ("Unknown DCC type: " . $type); } } # Yells about incoming CTCP PINGs. sub on_ping { my ($self, $event) = @_; my $nick = $event->nick; $self->ctcp_reply($nick, join (' ', ($event->args))); print "*** CTCP PING request from $nick received\n"; } # Gives lag results for outgoing PINGs. sub on_ping_reply { my ($self, $event) = @_; my ($args) = ($event->args)[1]; my ($nick) = $event->nick; $args = time - $args; print "*** CTCP PING reply from $nick: $args sec.\n"; } # Change our nick if someone stole it. sub on_nick_taken { my ($self) = shift; $self->nick(substr($self->nick, -1) . substr($self->nick, 0, 8)); } # Display formatted CTCP ACTIONs. sub on_action { my ($self, $event) = @_; my ($nick, @args) = ($event->nick, $event->args); print "* $nick @args\n"; } # Reconnect to the server when we die. sub on_disconnect { my ($self, $event) = @_; print "Disconnected from ", $event->from(), " (", ($event->args())[0], "). Attempting to reconnect...\n"; $self->connect(); } # Look at the topic for a channel you join. sub on_topic { my ($self, $event) = @_; my @args = $event->args(); # Note the use of the same handler sub for different events. if ($event->type() eq 'notopic') { print "No topic set for $args[1].\n"; # If it's being done _to_ the channel, it's a topic change. } elsif ($event->type() eq 'topic' and $event->to()) { print "Topic change for ", $event->to(), ": $args[0]\n"; } else { print "The topic for $args[1] is \"$args[2]\".\n"; } } sub pickrandom { # Choose a random quote from the @zippy array. return $zippy[ rand scalar @zippy ]; } sub blah { my ($self, $event) = @_; print "Got event of type: " . $event->type . "\n"; } print "Installing handler routines..."; #$conn->add_default_handler(\&blah); $conn->add_handler('cping', \&on_ping); $conn->add_handler('crping', \&on_ping_reply); $conn->add_handler('msg', \&on_msg); $conn->add_handler('chat', \&on_chat); $conn->add_handler('public', \&on_public); $conn->add_handler('caction', \&on_action); $conn->add_handler('join', \&on_join); $conn->add_handler('umode', \&on_umode); $conn->add_handler('part', \&on_part); $conn->add_handler('cdcc', \&on_dcc); $conn->add_handler('topic', \&on_topic); $conn->add_handler('notopic', \&on_topic); $conn->add_global_handler([ 251,252,253,254,302,255 ], \&on_init); $conn->add_global_handler('disconnect', \&on_disconnect); $conn->add_global_handler(376, \&on_connect); $conn->add_global_handler(433, \&on_nick_taken); $conn->add_global_handler(353, \&on_names); print " done.\n"; print "starting...\n"; $irc->start;