connection.pm

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

    
    # 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! --
#  <mandrake> the person at wendy's in front of me had a heart attack while
#             I was at lunch
#    <Stupid> mandrake:  Before or -after- they ate the food?
#    <DrForr> mandrake: What did he have?
#  <mandrake> 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... :)
# <fimmtiu> Is this spam-related?
#  <QDeath> no, actually, it's official school related.
# <fimmtiu> 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! --
# <Schwern> Wheat grass juice is properly served in a NyQuil sized cup, in
#           a NyQuil sized color with a NyQuil sized flavor.
#  <mendel> how big is nyquil's color
#  <foobah> often wheat grass is served mixed in with other fruit juices
#  <Sauvin> nyquil++
# <Schwern> mendel:  As BIG AS THE FUCKIN' Q!
# <yuckf00> this big <---------------------------------->
#  <foobah> 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! --
# <Sauvin>  Bigotry will never die.
# <billn>   yes it will
# <billn>   as soon as I'm allowed to buy weapons.
# <Schwern> billn++
# <rmah>    billn, baisc human nature has to change for bigotry to go away
# <billn>   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! --
#    <Murr> 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.
#  <DrForr> The tank flipped over -then- sank? Now that's rich.
#  <arkuat> what is this about?  cisco is building tanks now?
# <Winkola> arkuat: If they do, you can count on a lot of drowned newbie
#           net admins.
# <Winkola> "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! --
# <DragonFaX> Net::IRC is having my babies
#   <fimmtiu> DragonFax: Damn, man! She told me the child was MINE!
#  <Alpha232> Dragon: IRC has enough bastard children
# <DragonFaX> IRC has enough bastards?
#   <fimmtiu> New Frosted Lucky Bastards, they're magically delicious!
#    <archon> they're after me lucky bastards!


# This method submitted by Dave Schmitt <[e-mail]>. Thanks, Dave!
sub unignore {
    my $self = shift;

    croak "Not enough arguments to unignore()" unless @_;

    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 unignore()";
            return;                                                    
       }

       if ( exists $self->{_ignore}->{$type} )  {
           # removes all specifed entries ala _Perl_Cookbook_ recipe 4.7
           my @temp = @{$self->{_ignore}->{$type}};
           @{$self->{_ignore}->{$type}}= ();
           my %seen = ();
           foreach my $item (@_) { $seen{$item}=1 }
           foreach my $item (@temp) {
               push(@{$self->{_ignore}->{$type}}, $item)
                   unless ($seen{$item});
           }
      } else  {
           carp "no ignore entry for $type to remove";
       }
    }
}


# 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! --
#    <vald> Does anyone know how to modify a perl server that accepts
#           telnet to make it accept emails ?
#  <TorgoX> vald -- do you know how to modify a car so that it has six
#           legs, spins webs, and eats flies?
# <Schwern> Does a "perl server" serve perl?
#  <clintp> 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?
# <q[merlyn]>  yes... she's dead.
# <q[merlyn]>  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! --
#      <dnm> Fmh - do you want to telnet to one box and then ssh to another?
#      <Fmh> i realize an ssh proxy allows a man-in-the-middle attack.
# <gargoyle> that sounds kinda pleasant right now
#   gargoyle goes off to find a set of twins
#  <amagosa> 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! --
#   <veblen>  On the first day, God created Shrimp.
# * thoth parries the shrimp penis.
# * [petey rofls
#   <veblen>  On the second day, God created cocktail sauce.
# <URanalog>  "This is Chewbacca"
#      <Fmh>  do not covet thy neighbor's shrimp.
# * thoth pitches the shrimp penes on the barbie.
#    <thoth>  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! --
#  <fimmtiu>  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.
#  <fimmtiu>  'Night, all.
#    <regex>  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<irctest> script and the source for
details about this module.

=head1 AUTHORS

Conceived and initially developed by Greg Bacon E<lt>[e-mail]<gt> and
Dennis Taylor E<lt>[e-mail]<gt>.

Ideas and large amounts of code donated by Nat "King" Torkington E<lt>[e-mail]<gt>.

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