connection.pm

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

}

# -- #perl was here! --
# <Roderick> "Women were put on this earth to weaken us.  Drain our energy.
#            Laugh at us when they see us naked."
# <qw[jeff]> rod - maybe YOUR women...
#  <fimmtiu> jeff: Oh, just wait....
# <Roderick> "Love is a snowmobile racing across the tundra, which
#            suddenly flips over, pinning you underneath. At night,
#            the ice weasels come."
# <qw[jeff]> rod - where do you GET these things?!
# <Roderick> 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.
    # <tchrist>  randal disagrees, but i don't care.
    # <tchrist>  Randal isn't being flexible/imaginative.
    # <ChipDude> 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 should be added at the end:
#                         An open filehandle to save the incoming file into,
#                         in globref, FileHandle, or IO::* form.
# If you wish to do a DCC RESUME, specify the offset in bytes that you
# want to start downloading from as the last argument.
sub new_get {
    my $self = shift;
    my ($nick, $name, $address, $port, $size,  $offset, $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, $offset );

    $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!
# <fimmtiu> Eat flaming death, petey.
#   <I-Que> I'm only 22!
#   <I-Que> 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! --
#  <TorgoX> 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
# <Technik> TorgoX: on the Jerry Springer clips?
#  <TorgoX> 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.
# <Technik> TorgoX: you need to get better friends
#  <TorgoX> I was shamed.  I left town.
#  <TorgoX> grad school was just the pretext for the move.  this was the
#           real reason.
# <Technik> 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! --
    #   <Tkil2> hm.... any joy if you add a 'defined' to the test? like
    #           if (defined $sock...
    # <fimmtiu> 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;
    }
    
    PARSELOOP: 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 =~ /^:/;

            # Patch submitted for v.0.72
            # Fixes problems with IPv6 hostnames.
            # ($from, $line) = split ":", $line, 2;
	    ($from, $line) = $line =~ /^(?:|)(\S+\s+[^:]+):?(.*)/;

	    ($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;
		next PARSELOOP if $from =~ /$_/i;
	    }
	    
	    # 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);
		next;
		
	    }  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 ([e-mail]) has joined channel #perl