connection.pm

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

#####################################################################
#                                                                   #
#   Net::IRC -- Object-oriented Perl interface to an IRC server     #
#                                                                   #
#   Connection.pm: The basic functions for a simple IRC connection  #
#                                                                   #
#                                                                   #
#    Copyright (c) 2001 Pete Sergeant, Greg Bacon & Dennis Taylor.  #
#                       All rights reserved.                        #
#                                                                   #
#      This module is free software; you can redistribute or        #
#      modify it under the terms of Perl's Artistic License.        #
#                                                                   #
#####################################################################
#
# Net-IRC 0.72
# ------------
# 
# T.J. Eckman's Changelog
#
# December 14th 2001:
#       => Added patch to help with IPv6 handling
#
# Net-IRC 0.71
# ------------
#
# Pete Sergeant's Changelog
# 
# July 1st 2001:
#	=> Removed old DEBUG information in &parse_ctcp that got left
#		over and never cleaned up. My thanks to Joshua Swink,
#		Glen and Mike for pointing this out.
#	=> Allowed the bot to use the hostname you asked it to, and
#		cleaned out two declared vars that didn't need to be.
#		Thanks to Greg for spotting the hostname problem, and
#		Abigail for providing an elegant solution


package Net::IRC::Connection;

use Net::IRC::Event;
use Net::IRC::DCC;
use Sys::Hostname ();
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
);


# The names of the methods to be handled by &AUTOLOAD.
my %autoloaded = ( 'ircname'  => undef,
		   'port'     => undef,
		   'username' => undef,
		   'socket'   => undef,
		   'verbose'  => undef,
		   'parent'   => undef,
                   'hostname' => undef,
		 );

# 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! --
    #  <Teratogen> absolute power corrupts absolutely, but it's a helluva lot
    #              of fun.
    #  <Teratogen> =)
    
    ($meth = $AUTOLOAD) =~ s/^.*:://;  ## strip fully qualified portion

    unless (exists $autoloaded{$meth}) {
	croak "No method called \"$meth\" for $class object.";
    }
    
    eval <<EOSub;
sub $meth {
    my \$self = shift;
	
    if (\@_) {
	my \$old = \$self->{"_$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! --
# <crab> 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 ($password, $sock);

    if (@_) {
	my (%arg) = @_;

	$self->hostname($arg{'LocalAddr'}) if exists $arg{'LocalAddr'};
	$password = $arg{'Password'} if exists $arg{'Password'};
	$self->nick($arg{'Nick'}) if exists $arg{'Nick'};
	$self->port($arg{'Port'}) if exists $arg{'Port'};
	$self->server($arg{'Server'}) if exists $arg{'Server'};
	$self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'};
	$self->username($arg{'Username'}) if exists $arg{'Username'};
    }

    # 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->hostname) {
      my $host = Sys::Hostname::hostname();
      if ($host) {
	$self->hostname( $host );
      } else {
	croak "Can't determine this machine's hostname! Please specify your hostname with the LocalAddr parameter to connect().";
      }
    }
    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 ($self->hostname) {
#	unless (bind( $sock, sockaddr_in( 0, inet_aton($self->hostname) ) )) {
       unless (bind( $sock, sockaddr_in( 0, INADDR_ANY ) )) {
	    carp "Can't bind to ", $self->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 ([e-mail]) 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! --