From: dms Date: Sat, 29 Jul 2000 16:11:38 +0000 (+0000) Subject: new/moved files X-Git-Url: https://git.donarmstrong.com/?p=infobot.git;a=commitdiff_plain;h=3839d311e8030bbea2b65901d37e5826b1cf9db2 new/moved files git-svn-id: https://svn.code.sf.net/p/infobot/code/trunk/blootbot@12 c11ca15a-4712-0410-83d8-924469b57eb5 --- diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..1ff7c1c --- /dev/null +++ b/AUTHORS @@ -0,0 +1,26 @@ +Infobot: + License: As perl (GPL & Artistic) + - Kevin A. Lenzo [oznoid] + - Patrick Cole [ltd] + +Blootbot: + License: Artistic + Main Author: + - David Sobon + Webpage, Random/Fix Patches: + - ??? [GmLB] + +Module-Reload: (idea taken) + License: Artistic + - Doug MacEachern + - Joshua Pritikin + +Module-Units: + License: GPL + - M-J. Dominus + +Patches: + - ... + +Quotes file (files/infobot.randtext): + - ??? Ask netgod/larne/is for dpkg's tcl diff --git a/patches/Connection.pm b/patches/Connection.pm new file mode 100644 index 0000000..cd69be0 --- /dev/null +++ b/patches/Connection.pm @@ -0,0 +1,1951 @@ +##################################################################### +# # +# Net::IRC -- Object-oriented Perl interface to an IRC server # +# # +# Connection.pm: The basic functions for a simple IRC connection # +# # +# # +# 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$ + + +package Net::IRC::Connection; + +use Net::IRC::Event; +use Net::IRC::DCC; +use Socket; +use Symbol; +use Carp; +use strict; # A little anal-retention never hurt... +use vars ( # with a few exceptions... + '$AUTOLOAD', # - the name of the sub in &AUTOLOAD + '%_udef', # - the hash containing the user's global handlers + '%autoloaded', # - the hash containing names of &AUTOLOAD methods + ); + + +# The names of the methods to be handled by &AUTOLOAD. +# It seems the values ought to be useful *somehow*... +my %autoloaded = ( + 'ircname' => undef, + 'port' => undef, + 'username' => undef, + 'socket' => undef, + 'verbose' => undef, + 'parent' => undef, + ); + +# This hash will contain any global default handlers that the user specifies. + +my %_udef = (); + + + +##################################################################### +# Methods start here, arranged in alphabetical order. # +##################################################################### + + +# 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'); +} + +# -- #perl was here! -- +# fimmtiu: Oh, dear. There actually _is_ an alt.fan.jwz. +# Freiheit: "Join us. *whapdewhapwhap* Join us now. *whapdewhapwhap* Join +# us now and share the software." +# Freiheit: is that actually RMS singing or is it a voice-synthesizer? + + +# 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]" : "")); +} + +# 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; +} + + +# Toggles away-ness with the server. Optionally takes an away message. +sub away { + my $self = shift; + $self->sl("AWAY" . ($_[0] ? " :$_[0]" : "")); +} + + +# -- #perl was here! -- +# to irc as root demonstrates about the same brains as a man in a +# thunderstorm waving a lightning rod and standing in a copper tub +# of salt water yelling "ALL GODS ARE BASTARDS!" +# DrForr saves that one. + +# 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 ($hostname, $password, $sock); + + if (@_) { + my (%arg) = @_; + + $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'}; + } + + # 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"); + } + +# my $sock = IO::Socket::INET->new(PeerAddr => $self->server, +# PeerPort => $self->port, +# Proto => "tcp", +# ); + + $sock = Symbol::gensym(); + unless (socket( $sock, PF_INET, SOCK_STREAM, getprotobyname('tcp') )) { + carp ("Can't create a new socket: $!"); + $self->error(1); + return; + } + + # This bind() stuff is so that people with virtual hosts can select + # the hostname they want to connect with. For this, I dumped the + # astonishingly gimpy IO::Socket. Talk about letting the interface + # get in the way of the functionality... + + if ($hostname) { + unless (bind( $sock, sockaddr_in( 0, inet_aton($hostname) ) )) { + carp "Can't bind to $hostname: $!"; + $self->error(1); + return; + } + } + + if (connect( $sock, sockaddr_in($self->port, inet_aton($self->server)) )) { + $self->socket($sock); + + } else { + 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 " . 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. + + # -- #perl was here! -- + # roy7: Chip Chip he's our man! + # fimmtiu: If he can't do it, Larry can! + # ChipDude: I thank you! No applause, just throw RAM chips! + + # 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; + # how ironic. + $self->handler("destroy", "nobody will ever use this"); +} + + +# 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'}; +} + +# -- #perl was here! -- +# No, I commute Mon-Wed-Fri from Allentown. +# the billy joel and skinhead place +# that's what they say. +# <\lembit> it's hard to keep a good man down. +# but only the good die young! +# \lembit won't be getting up today. +# because they're under too much pressure, jeff +# and it surely will catch up to them, somewhere along the line. + + +# 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'}); + } +} + +# -- #perl was here! -- +# \lem... know any good austin Perl hackers for hire? +# I'm on a hunt for one for a friend. +# for a job? +# No, in his spare time merlyn bow-hunts for perl programmers +# by their scent. + + +# 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}; + + # -- #perl was here! -- + # <\lembit> tainted code...oh-oh..tainted code...sometimes I know I've + # got to (boink boink) run away... + # \lembit I'd ease up on the caffiene if I were you + + 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; +} + +# -- #perl was here! -- +# last night I dreamt I was flying over mountainous terrains +# which changed into curves and and valleys shooting everywhere +# and then finally into physical abominations which could never +# really exist in the material universe. +# then I realized it was just one of my perl data structures. + + +# 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} = [ @_ ]; + } + } +} + + +# -- #perl was here! -- +# someone can tell me some web side for "hack" programs +# Moonlord: http://pinky.wtower.com/nethack/ +# thank`s fimmtiu +# fimmtiu giggles maniacally. + + +# 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]" : "")); +} + + +# -- #perl was here! -- +# terminals in the night +# exchanging ascii +# oops, we dropped a byte +# please hit the break key +# doo be doo be doo + + +# 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; + } + + # -- #perl was here! -- + # *** careful is Starch@ncb.mb.ca (The WebMaster) + # *** careful is on IRC via server irc.total.net (Montreal Hub & + # Client Server) + # careful: well, it's hard to buy more books now too cause where the + # heck do you put them all? i have to move and my puter room is + # almost 400 square feet, it's the largest allowed in my basement + # without calling it a room and pay taxes, hehe + + unless (@_) { + croak "Not enough arguments to join()"; + } + + # \petey: paying taxes by the room? + # \petey boggles + # careful: that's what they do for finished basements and stuff + # careful: need an emergency exit and stuff + # jjohn: GOOD GOD! ARE THEY HEATHENS IN CANADA? DO THEY EAT THEIR + # OWN YOUNG? + + return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : "")); + + # \petey: "On the 'net nobody knows you're Canadian, eh?" + # jjohn: shut up, eh? +} + +# Opens a righteous can of whoop-ass on any luser foolish enough to ask a +# CGI question in #perl. Eat flaming death, web wankers! +# 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]" : "")); +} + +# -- #perl was here! -- +# sputnik1 listens in glee to the high-pitched whine of the Pratt +# and Whitney generator heating up on the launcher of his +# AGM-88B HARM missile +# sputnik1: calm down, little commie satellite + + +# 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(",", @_)); +} + +# -- #perl was here! -- +# see, neo? +# they're crowded +# i bet some programmers/coders might be here +# Nope. No programmers here. We're just Larry Wall groupies. +# come on +# Larry Wall isn't as good in bed as you'd think. +# For the record... + + +# -- #perl was here! -- +# Larry Wall is a lot sexier than Richard Stallman +# But I've heard Stallman is better in bed. +# Does he leave the halo on? +# * aether cocks her head at skrew...uh...whatever? +# Stallman's beard is a sex magnet. +# Larry's moustache is moreso, Fimm. +# oh yeah...women all over the world are hot for stallman.... +# Moustaches make my heart melt. +# I dunno, there's something about a man in hawaiian shirts... + + +# 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; +} + +# -- #perl was here! -- +# Hey, actually, I just got a good idea for an April Fools-day +# emacs mode. +# tchrist-mode +# Heh heh +# When you finish typing a word, emacs automatically replaces it +# with the longest synonym from the online Merriam-Webster +# thesaurus. + + +# 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]); +} + +# -- #perl was here! -- +# *** china`blu (azizam@pm5-30.flinet.com) has joined channel #perl +# hi guys +# and girls +# I am NOT a lesbian! + + +# 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..$#_])); +} + +# -- #perl was here! -- +# *** billnolio (billn@initiate.monk.org) has joined channel #perl +# *** Mode change "+v billnolio" on channel #perl by select +# billnolio humps fimmtiu's leg +# *** billnolio has left channel #perl + + +# 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]" : "")); +} + +# -- #perl was here! -- +# "Women were put on this earth to weaken us. Drain our energy. +# Laugh at us when they see us naked." +# rod - maybe YOUR women... +# jeff: Oh, just wait.... +# "Love is a snowmobile racing across the tundra, which +# suddenly flips over, pinning you underneath. At night, +# the ice weasels come." +# rod - where do you GET these things?! +# They do tend to accumulate. Clutter in the brain. + + +# 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 a new IRC object and assigns some default attributes. +sub new { + my $proto = shift; + + # -- #perl was here! -- + # <\merlyn> just don't use ref($this) || $this; + # <\merlyn> tchrist's abomination. + # <\merlyn> lame lame lame. frowned upon by any OO programmer I've seen. + # randal disagrees, but i don't care. + # Randal isn't being flexible/imaginative. + # fimm: WRT "ref ($proto) || $proto", I'm against. Class + # methods and object methods are distinct. + + # my $class = ref($proto) || $proto; # Man, am I confused... + + 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", # heheh... + _ignore => {}, + _handler => {}, + _verbose => 0, # Is this an OK default? + _parent => shift, + _frag => '', + _connected => 0, + _maxlinelen => 510, # The RFC says we shouldn't exceed this. + _format => { + 'default' => "[%f:%t] %m <%d>", + }, + }; + + bless $self, $proto; + # do any necessary initialization here + $self->connect(@_) if @_; + + return $self; +} + +# 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) = @_; + } + + # -- #perl was here! -- + # gnat snorts. + # gnat: no fucking microsoft products, thanks :) + # ^Pudge: what about non-fucking MS products? i hear MS Bob is a virgin. + + 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 can be added at the end: +# An open filehandle to save the incoming file into, +# in globref, FileHandle, or IO::* form. +sub new_get { + my $self = shift; + my ($nick, $name, $address, $port, $size, $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); + + $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); +} + +# -- #perl was here! -- +# [petey suspects I-Que of not being 1337! +# Eat flaming death, petey. +# I'm only 22! +# not 1337 + + +# 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($buf) { + ($line, $buf) = unpack("a$length a*", $buf); + $self->sl("NOTICE $to :$line"); + } +} + +# -- #perl was here! -- +# this was back when I watched Talk Soup, before I had to stop +# because I saw friends of mine on it. +# [petey chuckles at TorgoX +# TorgoX: on the Jerry Springer clips? +# I mean, when people you know appear on, like, some Springer +# knockoff, in a cheap disguise, and the Talk Soup host makes fun +# of them, you just have to stop. +# TorgoX: you need to get better friends +# I was shamed. I left town. +# grad school was just the pretext for the move. this was the +# real reason. +# lol + + +# 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); + + # Read newly arriving data from $self->socket + # -- #perl was here! -- + # hm.... any joy if you add a 'defined' to the test? like + # if (defined $sock... + # Much joy now. + # archon rejoices + + if (defined recv($self->socket, $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; + } + + 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 =~ /^:/; + ($from, $line) = split ":", $line, 2; + ($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; + return 1 if $from =~ /$_/; + } + + # 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); + return 1; + + } 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"; + } + } + + # -- #perl was here! -- + # *** orwant (orwant@media.mit.edu) has joined channel #perl + # orwant: Howdy howdy. + # orwant: Just came back from my cartooning class. + # orwant: I'm working on a strip for TPJ. + # njt: it's happy bouncy clown jon from clownland! say 'hi' to + # the kiddies, jon! + # orwant splits open njt like a wet bag of groceries and + # dances on his sticky bones. + # njt: excuse me, ladies, but I've got to go eviscerate myself with + # a leaky biro. don't wait up. + + 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 + + # -- #perl was here! -- + # fimmtiu: Words cannot describe my joy. Sil, you kick ass. + # fimmtiu: I was passing the wrong arg to Event::new() + + $self->handler(Net::IRC::Event->new($handler, $from, $stuff, + $handler, (split /\s/, $one))); + } + + # This next line is very likely broken somehow. Sigh. + $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; # I hate warnings. 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 ); +} + +# -- #perl was here! -- +# heh, why are #windowsNT people so quiet? are they all blue screened? +# they're busy flapping their arms and making swooshing jet noises + + +# 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"); +} + + +# -- #perl was here! -- +# We will have peace, when you and all your works have perished-- +# and the works of your Dark Master, Mammon, to whom you would +# deliver us. You are a strumpet, Fmh, and a corrupter of men's +# hearts. +# thoth, smile when you say that +# i'd much rather be thought of as a corrupter of women's hearts. + + +# Prints a message to the defined error filehandle(s). +# No further description should be necessary. +sub printerr { + shift; + print STDERR @_, "\n"; +} + + +# -- #perl was here! -- +# <_thoth> The hummer was like six feet up. +# <_thoth> Humming. +# <_thoth> The cat did this Flash trick. +# <_thoth> And when the cat landed, there was a hummer in his mouth. +# <_thoth> Once you see a cat pluck a hummer from the sky, you know why +# the dogs are scared. + + +# 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; + + # -- #perl was here! -- + # i really haven't dug into Net::IRC yet. + # hell, i still need to figure out how to make it just say + # something on its current channel... + # $connection->privmsg('#channel', "Umm, hi."); + # but you have to know the channel already eh? + # Yes. This is how IRC works. :-) + # damnit, why can't everything be a default. :) + # v0id_: it can. you end up with things like a 1 button + # mouse then, though. :) + + if (ref($to) =~ /^(GLOB|IO::Socket)/) { + while($buf) { + ($line, $buf) = unpack("a$length a*", $buf); + send($to, $line . "\012", 0); + } + } else { + while($buf) { + ($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")); + 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, $time, $code) = splice @_, 0, 3; + + unless ($code) { + croak 'Not enough arguments to Connection->schedule()'; + } + unless (ref $code eq 'CODE') { + croak 'Second argument to schedule() isn\'t a coderef'; + } + + $time = time + int $time; + $self->parent->queue($time, $code, $self, @_); +} + + +# -- #perl was here! -- +# YOU V3GAN FIEND, J00 W1LL P4Y D3ARLY F0R TH1S TRESPASS!!!!!!!!!!! +# be quiet freeside +# WE W1LL F0RCE PR0K DOWN YOUR V1RG1N THR0AT +# MAKE ME +# :-PPPPPPPPP +# FORCE IS THE LAST REFUGE OF THE WEAK +# I DIE, OH, HORATIO, I DIE! +# Che_Fox hugs freeside +# freeside (= +# I lurve you all :) +# freeside lashes himself to the M4ST. +# freeside, why do you eat meat? +# 4NARCHY R00000LZ!!!!! F1GHT TH3 P0W3R!!!!!! +# I 3AT M3AT S0 TH4T J00 D0N'T H4V3 TO!!!!!!!!!!!! +# I 3AT M3AT F0R J00000R SINS, NETSLAVE!!!!!!!!!! +# W0RSH1P M3333333!!!!!!! +# *** t0fu (wasian@pm3l-12.pacificnet.net) joined #perl. +# Che_Fox giggles +# *** t0fu (wasian@pm3l-12.pacificnet.net) left #perl. +# T0FU, MY SAV10UIRRRRRRRRRRRRR +# NOOOOOOOOOOOOOO +# COME BAAAAAAAAAACK +# no t0fu for you. + + +# 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. +# Corresponds to the internal sirc function of the same name. +# Takes 1 arg: string to send to server. (duh. :) +sub sl { + my $self = shift; + my $line = CORE::join '', @_; + + unless (@_) { + croak "Not enough arguments to sl()"; + } + + ### DEBUG DEBUG DEBUG + if ($self->{_debug}) { + print ">>> $line\n"; + } + + # RFC compliance can be kinda nice... + my $rv = send( $self->{_socket}, "$line\015\012", 0 ); + unless ($rv) { + $self->handler("sockerror"); + return; + } + return $rv; +} + +# -- #perl was here! -- +# the person at wendy's in front of me had a heart attack while +# I was at lunch +# mandrake: Before or -after- they ate the food? +# mandrake: What did he have? +# DrForr: a big bacon classic + +# 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]" : "")); +} + +# -- #perl was here! -- +# * QDeath is trying to compile a list of email addresses given a HUGE +# file of people's names... :) +# Is this spam-related? +# no, actually, it's official school related. +# Good. Was afraid I had been doing the devil's work for a second. +# * Tkil sprinkles fimmtiu's terminal with holy water, just in case. +# *** Signoff: billn (Fimmtiu is the devil's tool. /msg him and ask him +# about it.) +# *Fmh* are you the devil's "tool" ? +# -> *fmh* Yep. All 6 feet of me. + + +# Gets various server statistics for the specified host. +# Takes at least 1 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]" : "")); +} + +# -- #perl was here! -- +# Wheat grass juice is properly served in a NyQuil sized cup, in +# a NyQuil sized color with a NyQuil sized flavor. +# how big is nyquil's color +# often wheat grass is served mixed in with other fruit juices +# nyquil++ +# mendel: As BIG AS THE FUCKIN' Q! +# this big <----------------------------------> +# since by itself it can burn holes in your esophagus + + + + +# 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]" : "")); +} + + +# -- #perl was here! -- +# Bigotry will never die. +# yes it will +# as soon as I'm allowed to buy weapons. +# billn++ +# billn, baisc human nature has to change for bigotry to go away +# rmah: no, I just need bigger guns. + + +# Requests timestamp from specified server. Easy enough, right? +# Takes 1 optional arg: a server name/mask to query +sub time { + my ($self, $serv) = (shift, undef); + + $self->sl("TIME" . ($_[0] ? " $_[0]" : "")); +} + +# -- #perl was here! -- +# DrForr, presumably the tank crew *knew* how to swim, but not how +# to escape from a tank with open hatch that had turned on its roof +# before sinking. +# The tank flipped over -then- sank? Now that's rich. +# what is this about? cisco is building tanks now? +# arkuat: If they do, you can count on a lot of drowned newbie +# net admins. +# "To report a drowning emergency, press 1, and hold for 27 minutes." + + +# 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]" : "")); +} + +# -- #perl was here! -- +# crimethnk: problem found. +# crimethnk: log file was 2GB and i could not write to it anymore. +# crimethnk: shit. lost almost a week of stats. +# vorsprung: crimethnk> i guess you'll have to rotate the logs more frequently +# crimethnk: i usually rotate once a month. i missed last month. +# crimethnk: i thought i was pregnant. + + +# 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]" : "")); +} + + +# -- #perl was here! -- +# Net::IRC is having my babies +# DragonFax: Damn, man! She told me the child was MINE! +# Dragon: IRC has enough bastard children +# IRC has enough bastards? +# New Frosted Lucky Bastards, they're magically delicious! +# they're after me lucky bastards! + + +# 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]" : "")); +} + + +# -- #perl was here! -- +# Does anyone know how to modify a perl server that accepts +# telnet to make it accept emails ? +# vald -- do you know how to modify a car so that it has six +# legs, spins webs, and eats flies? +# Does a "perl server" serve perl? +# We all serve Perl. Some days, it serves us. + + +# 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" . (@_ ? " @_" : "")); +} + +# -- #perl was here! -- +# <\lembit> linda mccartney died yesterday, didn't she? +# yes... she's dead. +# WHY COULDN'T IT HAVE BEEN YOKO? + + +# 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(",", @_)); +} + +# -- #perl was here! -- +# Fmh - do you want to telnet to one box and then ssh to another? +# i realize an ssh proxy allows a man-in-the-middle attack. +# that sounds kinda pleasant right now +# gargoyle goes off to find a set of twins +# billn (= + + +# 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]" : "")); +} + + +# -- #perl was here! -- +# On the first day, God created Shrimp. +# * thoth parries the shrimp penis. +# * [petey rofls +# On the second day, God created cocktail sauce. +# "This is Chewbacca" +# do not covet thy neighbor's shrimp. +# * thoth pitches the shrimp penes on the barbie. +# UR: that's shrimp with penes, not shrimp with penne. + + +# 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; +} + + + +# -- #perl was here! -- +# OK, once you've passed the point where caffeine no longer has +# any discernible effect on any part of your body but your +# bladder, it's time to sleep. +# 'Night, all. +# Night, fimm + +1; + + +__END__ + +=head1 NAME + +Net::IRC::Connection - Object-oriented interface to a single IRC connection + +=head1 SYNOPSIS + +Hard hat area: This section under construction. + +=head1 DESCRIPTION + +This documentation is a subset of the main Net::IRC documentation. If +you haven't already, please "perldoc Net::IRC" before continuing. + +Net::IRC::Connection defines a class whose instances are individual +connections to a single IRC server. Several Net::IRC::Connection objects may +be handled simultaneously by one Net::IRC object. + +=head1 METHOD DESCRIPTIONS + +This section is under construction, but hopefully will be finally written up +by the next release. Please see the C script and the source for +details about this module. + +=head1 AUTHORS + +Conceived and initially developed by Greg Bacon Egbacon@adtran.comE and +Dennis Taylor Edennis@funkplanet.comE. + +Ideas and large amounts of code donated by Nat "King" Torkington Egnat@frii.comE. + +Currently being hacked on, hacked up, and worked over by the members of the +Net::IRC developers mailing list. For details, see +http://www.execpc.com/~corbeau/irc/list.html . + +=head1 URL + +Up-to-date source and information about the Net::IRC project can be found at +http://netirc.betterbox.net/ . + +=head1 SEE ALSO + +=over + +=item * + +perl(1). + +=item * + +RFC 1459: The Internet Relay Chat Protocol + +=item * + +http://www.irchelp.org/, home of fine IRC resources. + +=back + +=cut + diff --git a/patches/Google.pm b/patches/Google.pm new file mode 100644 index 0000000..0f7aaec --- /dev/null +++ b/patches/Google.pm @@ -0,0 +1,308 @@ +########################################################## +# Google.pm +# by Jim Smyser +# Copyright (C) 1996-1999 by Jim Smyser & USC/ISI +# $Id: Google.pm,v 1.1.1.1 2000/07/27 16:10:23 blootbot Exp $ +########################################################## + + +package WWW::Search::Google; + + +=head1 NAME + +WWW::Search::Google - class for searching Google + + +=head1 SYNOPSIS + +use WWW::Search; +my $Search = new WWW::Search('Google'); # cAsE matters +my $Query = WWW::Search::escape_query("Where is Jimbo"); +$Search->native_query($Query); +while (my $Result = $Search->next_result()) { +print $Result->url, "\n"; +} + +=head1 DESCRIPTION + +This class is a Google specialization of WWW::Search. +It handles making and interpreting Google searches. +F. + +Googles returns 100 Hits per page. Custom Linux Only search capable. + +This class exports no public interface; all interaction should +be done through L objects. + +=head1 LINUX SEARCH + +For LINUX lovers like me, you can put Googles in a LINUX only search +mode by changing search URL from: + + 'search_url' => 'http://www.google.com/search', + +to: + + 'search_url' => 'http://www.google.com/linux', + +=head1 SEE ALSO + +To make new back-ends, see L. + +=head1 HOW DOES IT WORK? + +C is called (from C) +before we do anything. It initializes our private variables (which +all begin with underscore) and sets up a URL to the first results +page in C<{_next_url}>. + +C is called (from C) +whenever more hits are needed. It calls C +to fetch the page specified by C<{_next_url}>. +It then parses this page, appending any search hits it finds to +C<{cache}>. If it finds a ``next'' button in the text, +it sets C<{_next_url}> to point to the page for the next +set of results, otherwise it sets it to undef to indicate we''re done. + + +=head1 TESTING + +This module adheres to the C test suite mechanism. + +=head1 BUGS + +2.07 now parses for most of what Google produces, but not all. +Because Google does not produce universial formatting for all +results it produces, there are undoublty a few line formats yet +uncovered by the author. Different search terms creates various +differing format out puts for each line of results. Example, +searching for "visual basic" will create whacky url links, +whereas searching for "Visual C++" does not. It is a parsing +nitemare really! If you think you uncovered a BUG just remember +the above comments! + +With the above said, this back-end will produce proper formated +results for 96+% of what it is asked to produce. Your milage +will vary. + +=head1 AUTHOR + +This backend is maintained and supported by Jim Smyser. + + +=head1 BUGS + +2.09 seems now to parse all hits with the new format change so there really shouldn't be +any like there were with 2.08. + +=head1 VERSION HISTORY + +2.10 +removed warning on absence of description; new test case + +2.09 +Google NOW returning url and title on one line. + +2.07 +Added a new parsing routine for yet another found result line. +Added a substitute for whacky url links some queries can produce. +Added Kingpin's new hash_to_cgi_string() 10/12/99 + +2.06 +Fixed missing links / regexp crap. + +2.05 +Matching overhaul to get the code parsing right due to multiple +tags being used by google on the hit lines. 9/25/99 + +2.02 +Last Minute description changes 7/13/99 + +2.01 +New test mechanism 7/13/99 + +1.00 +First release 7/11/99 + +=head1 LEGALESE + +THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +=cut +#' + +##################################################################### +require Exporter; +@EXPORT = qw(); +@EXPORT_OK = qw(); +@ISA = qw(WWW::Search Exporter); +$VERSION = '2.10'; + +$MAINTAINER = 'Jim Smyser '; +$TEST_CASES = <<"ENDTESTCASES"; +# Google looks for partial words it can find results for so it will end up finding "Bogus" pages. +&test('Google', '$MAINTAINER', 'zero', '4036e7757s5', \$TEST_EXACTLY); +&test('Google', '$MAINTAINER', 'one_page', '+LS'.'AM +rep'.'lication', \$TEST_RANGE, 2,99); +&test('Google', '$MAINTAINER', 'multi', 'dir'.'ty ha'.'rr'.'y bimbo', \$TEST_GREATER_THAN, 101); +ENDTESTCASES + +use Carp (); +use WWW::Search(generic_option); +require WWW::SearchResult; + +sub native_setup_search { + my($self, $native_query, $native_options_ref) = @_; + $self->{_debug} = $native_options_ref->{'search_debug'}; + $self->{_debug} = 2 if ($native_options_ref->{'search_parse_debug'}); + $self->{_debug} = 0 if (!defined($self->{_debug})); + $self->{agent_e_mail} = 'jsmyser@bigfoot.com'; + $self->user_agent('user'); + $self->{_next_to_retrieve} = 1; + $self->{'_num_hits'} = 0; + if (!defined($self->{_options})) { + $self->{'search_base_url'} = 'http://www.google.com'; + $self->{_options} = { + 'search_url' => 'http://www.google.com/search', + 'num' => '100', + 'q' => $native_query, + }; + } + my $options_ref = $self->{_options}; + if (defined($native_options_ref)) + { + # Copy in new options. + foreach (keys %$native_options_ref) + { + $options_ref->{$_} = $native_options_ref->{$_}; + } # foreach + } # if + # Process the options. + my($options) = ''; + foreach (sort keys %$options_ref) + { + # printf STDERR "option: $_ is " . $options_ref->{$_} . "\n"; + next if (generic_option($_)); + $options .= $_ . '=' . $options_ref->{$_} . '&'; + } + chop $options; + # Finally figure out the url. + $self->{_next_url} = $self->{_options}{'search_url'} .'?'. $self->hash_to_cgi_string($self->{_options}); + } # native_setup_search + +# private +sub native_retrieve_some + { + my ($self) = @_; + print STDERR "**Google::native_retrieve_some()**\n" if $self->{_debug}; + # Fast exit if already done: + return undef if (!defined($self->{_next_url})); + + # If this is not the first page of results, sleep so as to not + # overload the server: + $self->user_agent_delay if 1 < $self->{'_next_to_retrieve'}; + + # Get some if were not already scoring somewhere else: + print STDERR "*Sending request (",$self->{_next_url},")\n" if $self->{_debug}; + my($response) = $self->http_request('GET', $self->{_next_url}); + $self->{response} = $response; + if (!$response->is_success) + { + return undef; + } + $self->{'_next_url'} = undef; + print STDERR "**Response\n" if $self->{_debug}; + + # parse the output + my ($HEADER, $START, $HITS, $NEXT) = qw(HE HI ST NX); + my $hits_found = 0; + my $state = $HEADER; + my $hit = (); + foreach ($self->split_lines($response->content())) + { + next if m@^$@; # short circuit for blank lines + print STDERR " $state ===$_=== " if 2 <= $self->{'_debug'}; + if (m|(\d+) matches|i) { + print STDERR "**Found Header Count**\n" if ($self->{_debug}); + $self->approximate_result_count($1); + $state = $START; + # set-up attempting the tricky task of + # fetching the very first HIT line + } + elsif ($state eq $START && m|Search took|i) + { + print STDERR "**Found Start Line**\n" if ($self->{_debug}); + $state = $HITS; + # Attempt to pull the very first hit line + } + if ($state eq $HITS) { + print "\n**state == HITS**\n" if 2 <= $self->{_debug}; + } + if ($state eq $HITS && m@^

(.*)@i) + { + print "**Found HIT**\n" if 2 <= $self->{_debug}; + my ($url, $title) = ($1,$2); + if (defined($hit)) + { + push(@{$self->{cache}}, $hit); + }; + $hit = new WWW::SearchResult; + # some queries *can* create internal junk in the url link + # remove them! + $url =~ s/\/url\?sa=U&start=\d+&q=//g; + $url =~ s/\&exp\=OneBoxNews //g; # ~20000510. + $url =~ s/\&e\=110 //g; # -20000528. + $hits_found++; + $hit->add_url($url); + $hit->title($title); + $state = $HITS; + } + if ($state eq $HITS && m@^
(.*)@i) + { + print "**Found First Description**\n" if 2 <= $self->{_debug}; + $mDesc = $1; + if (not $mDesc =~ m@ @) + { + $mDesc =~ s/<.*?>//g; + $mDesc = $mDesc . '
' if not $mDesc =~ m@
@; + $hit->description($mDesc); + $state = $HITS; + } + } + elsif ($state eq $HITS && + m@^(\.(.+))@i || + m@^
(.*)\s@i) { + print "**Found Second Description**\n" if 2 <= $self->{_debug}; + $sDesc = $1; + $sDesc ||= ''; + $sDesc = $mDesc . $sDesc if (defined $mDesc); + $hit->description($sDesc) if (defined $hit and $sDesc ne ''); + $sDesc =''; + $state = $HITS; + } + elsif ($state eq $HITS && + m|
<.*?>.*?|i) { + my $nexturl = $self->{'_next_url'}; + if (defined $nexturl) { + print STDERR "**Fetching Next URL-> ", $nexturl, "\n" if 2 <= $self->{_debug}; + } else { + print STDERR "**Fetching Next URL-> UNDEF\n" if 2 <= $self->{_debug}; + } + + my $iURL = $1; + $self->{'_next_url'} = $self->{'search_base_url'} . $iURL; + } + else + { + print STDERR "**Nothing matched.**\n" if 2 <= $self->{_debug}; + } + } + if (defined($hit)) + { + push(@{$self->{cache}}, $hit); + } + return $hits_found; + } # native_retrieve_some +1;