From 984ebdffe927523b887dd972bced7482b602acb1 Mon Sep 17 00:00:00 2001 From: gmlb Date: Sun, 30 Jul 2000 00:01:47 +0000 Subject: [PATCH] Removing old doucments in /doc. They are archived in /doc/old. The newest documents will be on the website. See /doc/README_NOW for more information. git-svn-id: https://svn.code.sf.net/p/infobot/code/trunk/blootbot@16 c11ca15a-4712-0410-83d8-924469b57eb5 --- doc/BUGS | 104 --- doc/Connection.pm | 1951 --------------------------------------------- doc/EXAMPLES | 50 -- doc/FAQ | 23 - doc/Google.pm | 308 ------- doc/TODO | 111 --- doc/USAGE | 714 ----------------- doc/mysql.txt | 53 -- doc/notes.txt | 111 --- doc/pgsql.txt | 29 - 10 files changed, 3454 deletions(-) delete mode 100644 doc/BUGS delete mode 100644 doc/Connection.pm delete mode 100644 doc/EXAMPLES delete mode 100644 doc/FAQ delete mode 100644 doc/Google.pm delete mode 100644 doc/TODO delete mode 100644 doc/USAGE delete mode 100644 doc/mysql.txt delete mode 100644 doc/notes.txt delete mode 100644 doc/pgsql.txt diff --git a/doc/BUGS b/doc/BUGS deleted file mode 100644 index 9c45512..0000000 --- a/doc/BUGS +++ /dev/null @@ -1,104 +0,0 @@ - KNOWN PROBLEMS AND BUGS - -Problem #1: - 'topic [#channel] shuffle' will produce 1 in n! (where n - is number of subtopics in topic. IS THIS CORRECT PROBABILITY?) - chance that it will be the same as before. - - If someone wants to experiment a fix for this, do so. - Here is a hint: - 'while (!defined $newtopic || $topic{$talkchannel} eq $newtopic) {' - -Problem #2: [UPDATED 20000224] - A race condition is observed if the topic is changed very - quickly. If the bot is told to change the topic twice but - has not received notification of the new topic before - changing to the second modification of the topic, it - would use the absolute first (0) topic as a reference, - therefore missing out on the first alteration of the - topic. - - A very cheap solution exists. Edit IrcHooks.pl, search for - 'topic', alter '1' to '0'. This will only cache topics made by the - bot (I hope). I have a faint feeling that bot-only topics are - stored elsewhere (history I think) but I'm not quite sure. - - Yet another (ultimate and preferable) solution would be to have - topic queueing, altering the topic once the first alteration has - been done, changing the topic until the queue is empty. However, - topic floods will eventuate unfortunately. If a queue of 2 or more - is detected, no more topic changes are done until a time of - 5-10seconds (how can this be done?). This is a challenge to - implement. - -Problem #3: 19991110 - It appears that if the last string separated by a whitespace - of the topic will be chopped off (if it's "()") because the - ownership is null. At first I thought it was a bug in the regex - but it was okay. I guess it's a minor problem but why should - there be a semi-ownerless subtopic :) If it's annoying, please - investigate the &topicCipher() function in Topic.pl in relation to - &topicDecipher(). - -Problem #4: 199912xx - mysql overload... - - DBD::mysql::st execute failed: Duplicate entry 'xk' for key 1 at - ./src/Freshmeat.pl line 85. - when freshmeat.pl is building the table and something's said in the - channel... seen code tries to update table but fails. - - [UPDATE 20000224] - This may be eliminated by reducing 4-5 INSERT/UPDATE requests to - just 1 (total of 2), depending on the return of SELECT. If this - still persists and memory leaks are happening, first make - sure you are not using broken mysql tables, secondly bitch at the - mysql-perl author that there is a memory leak when a broken table - is in use. - -Problem #5: - doWarn is called when perl catches a "warning". - - => - [ 44] !WARN! PERL: Use of uninitialized value at ./src/Modules.pl line 316. - [ 45] !WARN! PERL: offending line => ' if ($query eq "") {'. - [ 46] !DEBUG! test1. - [ 47] !DEBUG! test2. - [ 48] !DEBUG! test3. - - ### From 'perlfunc'... - Note that this is quite safe and will not produce an endless loop, - since __WARN__ hooks are not called from inside one. - - ### From 'perlvar'... - Note that __DIE__/__WARN__ handlers are very special in one - respect: they may be called to report (probable) errors found by - the parser. In such a case the parser may be in inconsistent - state, so any attempt to evaluate Perl code from such a handler - will probably result in a segfault. - -Problem #6: -! 14! Debian: 12.87 sec to complete query. -! 15! Debian Search of 'testing' (2 shown): ... -[ 38] disconnect from irc.home.org (Connection reset by peer). -[ 39] reconnection... cleaning out channel cache. - - Solution #6: - Edit /usr/lib/perl5/Net/IRC.pm - Comment out *->quit() on 'sub DESTROY' - Alternatively, bitch at author of Net::IRC. - -Problem #7: why... - <\ifvoid> apt, cellwave? - i haven't a clue, \ifvoid - bugger all, i dunno, \ifvoid - -Problem #8: - apt: lart - * apt/#debian strangles with a doohicky mouse cord - -Problem #9: - [Flugh] i say 'rom, rom is a mud server', it says 'ok'. then - 'rom, rom?' it says 'yes? ' - -# info package dist doesn't recognise dist. diff --git a/doc/Connection.pm b/doc/Connection.pm deleted file mode 100644 index cd69be0..0000000 --- a/doc/Connection.pm +++ /dev/null @@ -1,1951 +0,0 @@ -##################################################################### -# # -# 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/doc/EXAMPLES b/doc/EXAMPLES deleted file mode 100644 index ef12862..0000000 --- a/doc/EXAMPLES +++ /dev/null @@ -1,50 +0,0 @@ - EXAMPLES - last updated 16.03.2000 - written by xk - - blootbot: test is testing - me: okay - blootbot: testing? - testing is testing - - blootbot: tests is testing - me: okay - blootbot: tests? - testing - - blootbot: cough is coughs - me: okay - blootbot: cough -* blootbot/#blootbot coughs - - blootbot: test is What's (one|two|three|four|five|six) - times (seven|eight|nine|ten|eleven|twelve)? - okay, me - blootbot: test - What's four times nine? - blootbot: test? - What's six times ten? - - blootbot: op me is Mode change "+o $nick" on channel - $channel by $ident - me: okay - blootbot: op me -* blootbot/#debian-bots Mode change "+o me" on channel #blootbot by - blootbot - - blootbot: no who am i is You are $nick!$user@$host on - $channel. - okay, me - blootbot: who am i - You are me!me@home.org on #blootbot. - - blootbot: who last spoke is To my knowledge, $lastspeaker - was the last to say something worthwhile. - me: okay - blootbot: who last spoke - To my knowledge, me was the last to say something worthwhile. - - blootbot: percentage is you are $randpercentage% lame - me: okay - blootbot: percentage - you are 79% lame diff --git a/doc/FAQ b/doc/FAQ deleted file mode 100644 index ac1aeef..0000000 --- a/doc/FAQ +++ /dev/null @@ -1,23 +0,0 @@ -Q: The bot exits after I run 'factstats testing' or 'kernel' or anything - that uses fork(). Is this a bug in the bot? - -A: No, this is not a bug in the bot but rather Net::IRC. A cheap hack is - to edit /usr/lib/perl5/Net/IRC/Connection.pm, search for DESTROY, and - comment out '$self->quit();' -A: Apply the patches in the patches/ directory. - - -Q: I notice that, in the bot logs, the bot attempts to close all current - DCC CHAT connections whenever a forked process ends. Why is this? - -A: Yet another bug in Net::IRC. Currently, DCC CHAT connections are not - closed because there is an endless-loop bug when it is done. - - -Q: I executed 'scripts/setup_user.pl' but it said 'connection refused to - localhost' - -A: Looks like a bug in the installation of mysqld. You need to reload or - restart the daemon. - reload => 'mysqladmin -u root -p reload' - restart => '/etc/init.d/mysql stop; /etc/init.d/mysql start' diff --git a/doc/Google.pm b/doc/Google.pm deleted file mode 100644 index 17a1e01..0000000 --- a/doc/Google.pm +++ /dev/null @@ -1,308 +0,0 @@ -########################################################## -# Google.pm -# by Jim Smyser -# Copyright (C) 1996-1999 by Jim Smyser & USC/ISI -# $Id$ -########################################################## - - -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; diff --git a/doc/TODO b/doc/TODO deleted file mode 100644 index 02da06c..0000000 --- a/doc/TODO +++ /dev/null @@ -1,111 +0,0 @@ -######### TODO. -### WISHLIST: SCHEDULER RELATED. -- if topic -CMD is used, schedule the change for 10seconds later. - $schedule{topicchange}{$chan} = SID. use 'dequeue' to delete. -- if 50% of netsplit victims come back, set a timer for 60seconds to - delete those who have not come back from the split. -- make first run of schedulers skip so they don't run all at once. - use 'return' if (ref($_[0]) eq ???); => won't work? -- use topic-queue for 'topic *'. -- Add &schedulerAdd() and &schedulerDel();, &scheduleIsInQueue(); -- rename &ScheduleThis() to &scheduleAdd(); - -### WISHLIST: COMMAND HOOKS. -- play around with 'hook' idea, see header of CommandStubs.pl. -- hook for ALL commands through MESSAGES. -- factoids to take arguments such as $1 $2 ... - => check all factoids for hooks then append to hook list. - -### WISHLIST: OLDE DBM SUPPORT // PGSQL. -- Thoroughly test both... core features done though. -- make a sql_common.pl file for 90% common stuff between mysql/pgsql. -- pgsql and mysql can be merged but I dunno anything about pgsql :) -- PGSQL - - EVERYTHING -- DBM - --- searchTable can be optimized by determining the correct offset - and use that from then on. - - Adding factoids [OK] - - Deleting factoids [OK] - - FactInfo [OK] - - Seen [OK] - - SearchTable [OK] -- "%","*" supported? - - Countdown [???] - - Freshmeat [???] -- &dbSetRow() should work, but slow. - - Factstats unrequested [???] - -### WISHLIST: SHOULD BE DONE... -- Change ""return 'NOREPLY';"" to ""return $noreply;"". -- make use of &status() in setup_*.pl -- Add quotes (Finance::Quote) support. -- Debian module doesn't search non-free or non-us properly. -- send DCC message when using 'op'. -- Schedule a 5min(??) interval to display stats in DCC - - kill if dcc chat == gone. -- if 25lines are logged within 1 second, throttle it (sleep 1) -- Add &botstatsUpdate() &botstatsGet(); -- Create startCheck(); for once off startup checks. -- Max size of logs to keep. -- split Process.pl's FactoidStuph() off to Factoids/FCommands.pl -- time when last executed commands like fm,/. Useless? -- if a dunno is issued, add an option to suggest a factiod - => IE: fm - - $fact =~ / blah|blah / or /\Wblah\W/ ?? - - debian package. ?? - - ... -- add a function to evaluate channels - - ie: 'ALL', 'ALL but #blah', '#blah1 #blah2', - => Added &makeChanList() but not using it yet. -- rename performStrictReply to performReplyAsIs() or something? -- show current stats for top 3 requesters and top 3 requests. - => when seen is used, show last factoid/cmd asked -- understand '\' in infobot.config. -- Create a script to insert initial factoids like 'status','hello'... - like the dbm script in the old days. -- Add 'heh' count, like on 'dpkg', to &on_public(). create generic table - to handle this and karma and probably total msg count. possibly - integrate with seen table? - .... UPDATE seen SET time=time+1 WHERE nick='xk'; - .... ERROR 1064: parse error near '+1 WHERE nick='xk'' at line 1 - => WHY? -- support for 'find blah 6' for items 6 and more (since the list is - ordered). requested by jim. -- support 'info package [dist] [section]', eg: 'info ssh non-free' or - support query for incoming, if dist!=incoming. -- ... - -### WISHLIST: something to be desired... -- 'tell' (Process.pl) to support commands. -- reject ' see' if redir factoid is too long. - need parsing of '||' and '(1|2|...)', too, for all possible - combinations (or permutations?). -- download *.dsc and *.changes file to generate the Incoming Packages - file. This will be fun :) -- Add 'OverwriteFromTxt' and other options for txt2mysql.pl. -- Set some variable to say "yes, I'm quitting" to prevent log compression - since it imposes a perl warning "unreferenced scalar"... -- Universal FROM<->TO conversion script for factoid table/db. -### CLEAN UP -- Split all the functions in Topic.pl to topic . First chunk of - commands should be "Internal", the next chunk "Helpers" and the - last one is "Main". -- Reduce number of global variables used. - => convert hash lists to arrays. - => convert scalar vars to hash lists. - -### CHALLENGE -- Better method to store topics. Should be very similiar to the - joinnextchan code, but a topic queue. _however_, topic may be lost with - netsplit + stuff which is another problem, oh well. - How do IRC clients do it? set a timer for 0.5s before any changes? -- Tree to show all variables in use. preliminary stuff there but - it's not all that helpful. good oreilly stuff in scripts/ -- Better netjoin detection code. -- Allow X number of repetition of messages, default cannot be changed due - to simplicity of current code. - -### EXTERNAL BUGS: -- Net::IRC doesn't know event 'pong'. - -### BROKEN: -- babelfish diff --git a/doc/USAGE b/doc/USAGE deleted file mode 100644 index 8f085ab..0000000 --- a/doc/USAGE +++ /dev/null @@ -1,714 +0,0 @@ -========================================================================== -= === ======== ==== === == ==== === = -= === == ======= === == === ===== ===== === == === ===== ==== -= === ======= === == === ===== ===== === === ===== ==== -= === == ======= === == === ===== ===== === == === ===== ==== -= === === ==== ====== ===== ==== ====== ==== -========================================================================== - - ====================================== - USER COMMANDS - ====================================== - -Command: 4op -============= -Description: - ... - -Usage: REQUIRES +o flag. - 4op ... - -Example: - ... - - -Command: dumpvars -============= -Description: - ... - -Usage: REQUIRES +o flag. - dumpvars ... - -Example: - ... - - -Command: kick -============= -Description: - ... - -Usage: REQUIRES +o flag. - kick ... - -Example: - ... - - -Command: ignore -============= -Description: - ... - -Usage: REQUIRES +o flag. - ignore ... - -Example: - ... - - -Command: ignorelist -============= -Description: - ... - -Usage: REQUIRES +o flag. - ignorelist ... - -Example: - ... - - -Command: unignore -============= -Description: - ... - -Usage: REQUIRES +o flag. - unignore ... - -Example: - ... - - -Command: clear ignorelist -============= -Description: - ... - -Usage: REQUIRES +o flag. - clear ignorelist ... - -Example: - ... - - -Command: lobotomy -============= -Description: - ... - -Usage: REQUIRES +o flag. - lobotomy ... - -Example: - ... - - -Command: unlobotomy -============= -Description: - ... - -Usage: - unlobotomy ... - -Example: - ... - - -Command: op -============= -Description: - ... - -Usage: REQUIRES +o flag. - op ... - -Example: - ... - - -Command: say -============= -Description: - ... - -Usage: REQUIRES +o flag. - say ... - -Example: - ... - - -Command: die -============= -Description: - ... - -Usage: REQUIRES +n flag. - die ... - -Example: - ... - - -Command: jump -============= -Description: - ... - -Usage: REQUIRES +n flag. - jump ... - -Example: - ... - - -Command: rehash -============= -Description: - ... - -Usage: REQUIRES +n flag. - rehash ... - -Example: - ... - - -Command: set -============= -Description: - ... - -Usage: REQUIRES +n flag. - set ... - -Example: - ... - - -Command: unset -============= -Description: - ... - -Usage: REQUIRES +n flag. - unset ... - -Example: - ... - - -Command: chanstats -============= -Description: - Channel statistics is gathered while the bot is operation in those - channels it is located. They include: join, part, kick, ban, and - countless others. - -Usage: - chanstats [#channel] - -Example: - > blootbot: chanstats - i am on 2 channels: #blootbot #debian - i've cached 5 users distributed over 2 channels. - - > blootbot: chanstats #blootbot - On #blootbot, there have been 1 Join, 1 Op and 20 - PublicMsgs. - At the moment, 3 Opped and 3 Total. - - -Command: cmdstats -============= -Description: - ... - -Usage: - cmdstats ... - -Example: - ... - - -Command: crypt -============= -Description: - ... - -Usage: - crypt ... - -Example: - ... - - -Command: factinfo -============= -Description: - ... - -Usage: - factinfo ... - -Example: - ... - - -Command: factstats -============= -Description: - ... - -Usage: - factstats ... - -Example: - ... - - -Command: karma -============= -Description: - ... - -Usage: - karma ... - -Example: - ... - - -Command: spell -============= -Description: - ... - -Usage: - spell ... - -Example: - ... - - -Command: nslookup -============= -Description: - ... - -Usage: - nslookup ... - -Example: - ... - - -Command: part -============= -Description: - ... - -Usage: - part ... - -Example: - ... - - -Command: rot13 -============= -Description: - ... - -Usage: - rot13 ... - -Example: - ... - - -Command: wantNick -============= -Description: - ... - -Usage: - wantNick ... - -Example: - ... - - -Command: join -============= -Description: - The bot can be commanded to join a channel if it is not already on - there in the case of a kick/ban, invite only or invalid key to - name a few typical case scenarios. - - The channels which the bot can join is governed by the - configuration parameter labelled 'join_channels'. However, this - is ignored for those users with the +o flag in the user table. - -Usage: - join <#channel>[,key] - -Example: - > blootbot: join #blootbot - [blootbot] joining #blootbot - *** join/#debian blootbot (bot@router.home.org) - > blootbot: join #blootbot - [blootbot] I'm already on #blootbot... - - - - ====================================== - MODULE COMMANDS - ====================================== - -Command: babelfish -============= -Description: - ... - -Usage: - x from [language]: phrase - -Example: - ... - - -Command: debian package -============= -Description: - ... - -Usage: - [] ... - -Example: - ... - - -Command: dict -============= -Description: - ... - -Usage: - dict ... - -Example: - ... - - -Command: freshmeat -============= -Description: - ... - -Usage: - freshmeat ... - -Example: - ... - - -Command: google -============= -Description: - ... - -Usage: - google ... - -Example: DOES NOT WORK YET(??) - ... - - -Command: insult -============= -Description: - ... - -Usage: - insult ... - -Example: - ... - - -Command: kernel -============= -Description: - ... - -Usage: - kernel ... - -Example: - ... - - -Command: lart -============= -Description: - ... - -Usage: - lart ... - -Example: - ... - - -Command: list{keys|vals} -============= -Description: - ... - -Usage: - list{keys|vals} ... - -Example: - ... - - -Command: nickometer -============= -Description: - ... - -Usage: - nickometer ... - -Example: - ... - - -Command: quotes -============= -Description: - ... - -Usage: - quotes ... - -Example: - ... - - -Command: rootwarn -============= -Description: - ... - -Usage: - rootwarn ... - -Example: - ... - - -Command: seen -============= -Description: - ... - -Usage: - seen ... - -Example: - ... - - -Command: listauth -============= -Description: - ... - -Usage: - listauth ... - -Example: - ... - - -Command: slashdot -============= -Description: - ... - -Usage: - slashdot ... - -Example: - ... - - -Command: debian contents -============= -Description: - ... - -Usage: - debian ... - -Example: - ... - - -Command: topic -============= -Description: - ... - -Usage: - topic ... - -Example: - ... - - -Command: countdown -============= -Description: - ... - -Usage: - countdown ... - -Example: - ... - - -Command: uptime -============= -Description: - ... - -Usage: - uptime ... - -Example: - ... - - -Command: weather -============= -Description: - ... - -Usage: - weather ... - -Example: DOES NOT WORK - ... - - -Command: whatis -============= -Description: - ... - -Usage: - whatis ... - -Example: DOES NOT WORK - ... - - - - ====================================== - MISCELLANEOUS/FACTOID COMMANDS - ====================================== - -Command: forget -============= -Description: - ... - -Usage: - forget ... - -Example: - ... - - -Command: {un|}lock -============= -Description: - ... - -Usage: - {un|}lock ... - -Example: - ... - - -Command: rename -============= -Description: - ... - -Usage: - rename ... - -Example: - ... - - -Command: substitution -============= -Description: - ... - -Usage: - $factoid =~ s/from/to/ - $factoid =~ s#te/st/#test#g - -Example: - ... - - -Command: karma set -============= -Description: - ... - -Usage: - $nick++ - $nick-- - -Example: - blootbot++ - infobot-- - - -Command: maths -============= -Description: - ... - -Usage: - 2 + 2 - -Example: - ... - - -Command: tell -============= -Description: - ... - -Usage: - tell about - -Example: - ... diff --git a/doc/mysql.txt b/doc/mysql.txt deleted file mode 100644 index f62c246..0000000 --- a/doc/mysql.txt +++ /dev/null @@ -1,53 +0,0 @@ -TABLE factoids - factoid key - CHAR($param{'maxKeySize') - max 256 - - factoid value - TEXT - max 65535 - - requested who by - CHAR(80) - max 256 - - requested time - INT - max 2147483647 - - requested count - SMALLINT UNSIGNED - max 65535 - - created who by - CHAR(80) - max 256 - - created time - INT - max 2147483647 - - modified who by - CHAR(80) - max 256 - - modified time - INT - max 2147483647 - - locked who by - CHAR(80) - max 256 - - locked time - INT - max 2147483647 - -###### -###### -###### TODO -###### -###### - -* make factoid_key index of table and only allow unique factoid_key - values in table. diff --git a/doc/notes.txt b/doc/notes.txt deleted file mode 100644 index 187ff71..0000000 --- a/doc/notes.txt +++ /dev/null @@ -1,111 +0,0 @@ -##### GLOBAL VARIABLES -### Scalar variable. -$who => Process.pl#7: -$msgType => Process.pl#7: -$message => Process.pl#7: -$origWho => Process.pl#12: untouched $who variable. -$origMessage => Process.pl#13: untouched $message variable. -$origIn => Question.pl#15: (my) successful (not repeated) asked factoid -$who => Process.pl#6: -$message => Process.pl#6: -$nuh => Irc.pl#279: nick-user-host -$userHandle => User.pl: handle which nick is registered under. -### Array. -### Hash lists. -%channels => $channels{$channel}{$mode}{$nick} -%chanstats => $chanstats{$channel}{TYPE} -%cmdstats => $cmdstats{TYPE} -%userList => $userList{$user}{$type} -%userList => $userList{$user}{'mask'}{$what} = 1; -##### - -### Thorough check and cleanup of... (comments need to be read though) -Process.pl 19991128 -Irc.pl 19991128 -Misc.pl 19991128 - - - -### Address testing with the "new" code. -### nick == $1, text = $' -blah erp good -blah erp erp good -blah:erp good... about time got it to work. -blah:erp erp good... ditto -blah :erp good -blah :erp erp good -blah : erp good -blah : erp erp good -blah : erp good -blah : erp erp good -blah : erp good -blah : erp erp good - -unfski erp good -unfski erp erp good -unfski:erp hrm... good :) -unfski:erp erp hrm... good :) -unfski :erp good -unfski :erp erp good -unfski : erp good -unfski : erp erp good -unfski : erp good -unfski : erp erp good -unfski : erp good -unfski : erp erp good - -### some notes... -&DoModes($chan,$modes,$targets); -&DeleteUserInfo($nick,@chans); -# NOTE: subhash list can only be deleted with "delete" not with "undef". -foreach $chan (keys %channels) { -foreach $mode (keys %{$channels{$chan}}) { -foreach $user (keys %{$channels{$chan}{$mode}}) { - -### &DeleteUserInfo(). -# DUI: type working fix -# part yes undef=>delete -# sign yes fe loops=>DUI($n,%c); -# nick yes undef=>delete -# kill ... ... -### - -### -### Soon to be new format of factoid.db, or at least infobot-extra.db -### -[factoid key] -> [created].[modified].[requests].[locked] - | | | | - [who by] [who by] [who by] [who by] - [time] [time] [time] [time] - [count] - -$db{'key'} = $created_by .$;. $created_time .$;$;. - $modified_by .$;. $modified_time .$;$;. - $request_by .$;. $request_time .$;. $request_count .$;$;. - $locked_by .$;. $locked_time; - -factoid can only be unlocked by creator. possibly need to be matched -against nick || user@*.x.org || user@x.y.z.* - -##### -# forget: factoid locking half-done TODO -# factoid query DONE. -# factoid update (2 create; 4 modify) DONE. -##### - -raw: ..... KICK #tnflesh damagick :i can do this too -940445681 [12632] >>> [1mtoo[0m was kicked off [1m#tnflesh damagick :i \ - can do this[0m by [1mChimmy[0m ([1mP[0m) -my ($kicker, $chan, $knick, $why) = @_; - $1 $2 $4 $5 - -("Op", yes -"Deop", yes -"Ban", yes -"Unban", yes -"Topic", yes -"Kick", yes -"PublicMsg" yes -"Part", yes -"SignOff", yes -"Join" yes diff --git a/doc/pgsql.txt b/doc/pgsql.txt deleted file mode 100644 index 5d8ce73..0000000 --- a/doc/pgsql.txt +++ /dev/null @@ -1,29 +0,0 @@ -##### EXAMPLE 1 -insert into customers values (0, 'MrHanky'); -insert into customers values (1, 'Chef'); - -##### EXAMPLE 2 -my $query = $conn->prepare( - "SELECT first_name, last_name, hired_at" . - " FROM employees" . - " ORDER BY last_name, first_name" - ); -$query->execute(); - -print sprintf("%-40s%-20s", "Name:", "Hired At:"), "\n"; -print "-" x 60 . "\n"; -while (@row = $query->fetchrow_array()) -{ - ($first_name, $last_name, $hired_at) = @row; - - print sprintf("%-40s%-20s", $first_name . " " . $last_name, -$hired_at), - "\n"; -} - -undef($query); -$conn->disconnect(); -$conn = undef; - -##### EXAMPEL 3. - -- 2.39.2