connection.pm

AndyChat 是一种用Perl 来编写的多协议的控制台聊天程序。它的目的在于提供一种共同的控制台界面

    #     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;
    $self->handler("destroy", "nobody will ever use this");
    $self->quit();
    # anything else?
}


# Disconnects this Connection object cleanly from the server.
# Takes at least 1 arg:  the format and args parameters to Event->new().
sub disconnect {
    my $self = shift;
    
    $self->{_connected} = 0;
    $self->parent->removeconn($self);
    $self->socket( undef );
    $self->handler(Net::IRC::Event->new( "disconnect",
					 $self->server,
					 '',
					 @_  ));
}


# Tells IRC.pm if there was an error opening this connection. It's just
# for sane error passing.
# Takes 1 optional arg:  the new value for $self->{'iserror'}
sub error {
    my $self = shift;

    $self->{'iserror'} = $_[0] if @_;
    return $self->{'iserror'};
}

# -- #perl was here! --
# <nocarrier> No, I commute Mon-Wed-Fri from Allentown.
#   <rudefix> the billy joel and skinhead place
# <nocarrier> that's what they say.
#   <\lembit> it's hard to keep a good man down.
#  <qw[jeff]> but only the good die young!
#             \lembit won't be getting up today.
#  <rudefix> because they're under too much pressure, jeff
# <qw[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! --
# <q[merlyn]> \lem... know any good austin Perl hackers for hire?
# <q[merlyn]> I'm on a hunt for one for a friend.
#    <archon> for a job?
#   <Stupid_> 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...
    # <Excession> \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! --
# <JavaJive> 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.
# <JavaJive> 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! --
# <Moonlord> someone can tell me some web side for "hack" programs
#  <fimmtiu> Moonlord: http://pinky.wtower.com/nethack/
# <Moonlord> 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! --
#  <Teratogen> terminals in the night
#  <Teratogen> exchanging ascii
#  <Teratogen> oops, we dropped a byte
#  <Teratogen> please hit the break key
#  <Teratogen> 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 [e-mail] (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
#     <lej> 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! --
# <china`blu> see, neo?
# <china`blu> they're crowded
# <china`blu> i bet some programmers/coders might be here
#   <fimmtiu> Nope. No programmers here. We're just Larry Wall groupies.
# <china`blu> come on
# <Kilbaniar> Larry Wall isn't as good in bed as you'd think.
# <Kilbaniar> For the record...


# -- #perl was here! --
# <Skrewtape> Larry Wall is a lot sexier than Richard Stallman
# <Skrewtape> But I've heard Stallman is better in bed.
# <Schwern> Does he leave the halo on?
# * aether cocks her head at skrew...uh...whatever?
# <fimmtiu> Stallman's beard is a sex magnet.
# <Skrewtape> Larry's moustache is moreso, Fimm.
# <aether> oh yeah...women all over the world are hot for stallman....
# <Skrewtape> Moustaches make my heart melt.
# <Schwern> 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! --
#  <KeithW>  Hey, actually, I just got a good idea for an April Fools-day
#            emacs mode.
#  <KeithW>  tchrist-mode
# <amagosa>  Heh heh
#  <KeithW>  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 ([e-mail]) has joined channel #perl
# <china`blu> hi guys
# <china`blu> and girls
#      <purl> 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 ([e-mail]) 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]" : ""));