connection.pm

AndyChat 是一种用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

            # Return cunknown/crunknown for unknown (undefined by user) CTCP/responses
            # Andrew Macks <[e-mail]> -- Tue May 30 13:28:01 EST 2000
            if (! exists $self->{_handler}->{$handler} && ! exists $_udef{$handler}) {
              $handler = $prefix . "unknown";
            } else { # Stripping would be bad in the case of unknown for the obvious
             $one =~ s/^$ctype //i;  # strip the CTCP type off the args
            }

	    # -- #perl was here! --
	    # fimmtiu: Words cannot describe my joy. Sil, you kick ass.
	    # fimmtiu: I was passing the wrong arg to Event::new()
 
	    $one =~ s/^$ctype //i;  # strip the CTCP type off the args
	    $self->handler(Net::IRC::Event->new( $handler, $from, $stuff,
						 $handler, $one ));
	}

	$self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two))
	    if $two;
    }
    return 1;
}

# Does special-case parsing for numeric events. Separate from the rest of
# parse() for clarity reasons (I can hear Tkil gasping in shock now. :-).
# Takes 1 arg:  the raw server line
sub parse_num {
    my ($self, $line) = @_;

    # Figlet protection?  This seems to be a bit closer to the RFC than
    # the original version, which doesn't seem to handle :trailers quite
    # correctly. 
    
    my ($from, $type, $stuff) = split(/\s+/, $line, 3);
    my ($blip, $space, $other, @stuff);
    while ($stuff) {
	($blip, $space, $other) = split(/(\s+)/, $stuff, 2);
	$space = "" unless $space;
	$other = "" unless $other;       # Thanks to jack velte...
	if ($blip =~ /^:/) {
		push @stuff, $blip . $space . $other;
		last;
	} else {
	    push @stuff, $blip;
	    $stuff = $other;
	}
    }

    $from = substr $from, 1 if $from =~ /^:/;

    return Net::IRC::Event->new( $type,
				 $from,
				 '',
				 'server',
				 @stuff );
}

# -- #perl was here! --
# <megas> heh, why are #windowsNT people so quiet? are they all blue screened?
# <Hiro> 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! --
# <thoth> 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.
#   <Fmh> thoth, smile when you say that
#   <Fmh> 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! --
    #    <v0id_> i really haven't dug into Net::IRC yet.
    #    <v0id_> hell, i still need to figure out how to make it just say
    #            something on its current channel...
    #  <fimmtiu> $connection->privmsg('#channel', "Umm, hi.");
    #    <v0id_> but you have to know the channel already eh?
    #  <fimmtiu> Yes. This is how IRC works. :-)
    #    <v0id_> damnit, why can't everything be a default. :)
    # <happybob> 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! --
# <freeside> YOU V3GAN FIEND, J00 W1LL P4Y D3ARLY F0R TH1S TRESPASS!!!!!!!!!!!
# <Netslave> be quiet freeside
# <freeside> WE W1LL F0RCE PR0K DOWN YOUR V1RG1N THR0AT
# <freeside> MAKE ME
# <freeside> :-PPPPPPPPP
# <freeside> FORCE IS THE LAST REFUGE OF THE WEAK
# <freeside> I DIE, OH, HORATIO, I DIE!
#    Che_Fox hugs freeside
#  <initium> freeside (=
#  <Che_Fox> I lurve you all :)
#   freeside lashes himself to the M4ST.
# <Netslave> freeside, why do you eat meat?
# <freeside> 4NARCHY R00000LZ!!!!!  F1GHT TH3 P0W3R!!!!!!
# <freeside> I 3AT M3AT S0 TH4T J00 D0N'T H4V3 TO!!!!!!!!!!!!
# <freeside> I 3AT M3AT F0R J00000R SINS, NETSLAVE!!!!!!!!!!
# <freeside> W0RSH1P M3333333!!!!!!!
# *** t0fu ([e-mail]) joined #perl.
#    Che_Fox giggles
# *** t0fu ([e-mail]) left #perl.
# <freeside> T0FU, MY SAV10UIRRRRRRRRRRRRR
# <freeside> NOOOOOOOOOOOOOO
# <freeside> COME BAAAAAAAAAACK
#  <Che_Fox> 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";
    }