doc/Connection.pm

   1 #####################################################################
   2 #                                                                   #
   3 #   Net::IRC -- Object-oriented Perl interface to an IRC server     #
   4 #                                                                   #
   5 #   Connection.pm: The basic functions for a simple IRC connection  #
   6 #                                                                   #
   7 #                                                                   #
   8 #          Copyright (c) 1997 Greg Bacon & Dennis Taylor.           #
   9 #                       All rights reserved.                        #
  10 #                                                                   #
  11 #      This module is free software; you can redistribute or        #
  12 #      modify it under the terms of Perl's Artistic License.        #
  13 #                                                                   #
  14 #####################################################################
  15 # $Id$
  16
  17
  18 package Net::IRC::Connection;
  19
  20 use Net::IRC::Event;
  21 use Net::IRC::DCC;
  22 use Socket;
  23 use Symbol;
  24 use Carp;
  25 use strict;               # A little anal-retention never hurt...
  26 use vars (                # with a few exceptions...
  27           '$AUTOLOAD',    #   - the name of the sub in &AUTOLOAD
  28           '%_udef',       #   - the hash containing the user's global handlers
  29           '%autoloaded',  #   - the hash containing names of &AUTOLOAD methods
  30          );
  31
  32
  33 # The names of the methods to be handled by &AUTOLOAD.
  34 # It seems the values ought to be useful *somehow*...
  35 my %autoloaded = (
  36                   'ircname'  => undef,
  37                   'port'     => undef,
  38                   'username' => undef,
  39                   'socket'   => undef,
  40                   'verbose'  => undef,
  41                   'parent'   => undef,
  42                  );
  43
  44 # This hash will contain any global default handlers that the user specifies.
  45
  46 my %_udef = ();
  47
  48
  49
  50 #####################################################################
  51 #        Methods start here, arranged in alphabetical order.        #
  52 #####################################################################
  53
  54
  55 # This sub is the common backend to add_handler and add_global_handler
  56 #
  57 sub _add_generic_handler
  58 {
  59     my ($self, $event, $ref, $rp, $hash_ref, $real_name) = @_;
  60     my $ev;
  61     my %define = ( "replace" => 0, "before" => 1, "after" => 2 );
  62
  63     unless (@_ >= 3) {
  64         croak "Not enough arguments to $real_name()";
  65     }
  66     unless (ref($ref) eq 'CODE') {
  67         croak "Second argument of $real_name isn't a coderef";
  68     }
  69
  70     # Translate REPLACE, BEFORE and AFTER.
  71     if (not defined $rp) {
  72         $rp = 0;
  73     } elsif ($rp =~ /^\D/) {
  74         $rp = $define{lc $rp} || 0;
  75     }
  76
  77     foreach $ev (ref $event eq "ARRAY" ? @{$event} : $event) {
  78         # Translate numerics to names
  79         if ($ev =~ /^\d/) {
  80             $ev = Net::IRC::Event->trans($ev);
  81             unless ($ev) {
  82                 carp "Unknown event type in $real_name: $ev";
  83                 return;
  84             }
  85         }
  86
  87         $hash_ref->{lc $ev} = [ $ref, $rp ];
  88     }
  89     return 1;
  90 }
  91
  92 # This sub will assign a user's custom function to a particular event which
  93 # might be received by any Connection object.
  94 # Takes 3 args:  the event to modify, as either a string or numeric code
  95 #                   If passed an arrayref, the array is assumed to contain
  96 #                   all event names which you want to set this handler for.
  97 #                a reference to the code to be executed for the event
  98 #    (optional)  A value indicating whether the user's code should replace
  99 #                the built-in handler, or be called with it. Possible values:
 100 #                   0 - Replace the built-in handlers entirely. (the default)
 101 #                   1 - Call this handler right before the default handler.
 102 #                   2 - Call this handler right after the default handler.
 103 # These can also be referred to by the #define-like strings in %define.
 104 sub add_global_handler {
 105     my ($self, $event, $ref, $rp) = @_;
 106         return $self->_add_generic_handler($event, $ref, $rp,
 107                                            \%_udef, 'add_global_handler');
 108 }
 109
 110 # This sub will assign a user's custom function to a particular event which
 111 # this connection might receive.  Same args as above.
 112 sub add_handler {
 113     my ($self, $event, $ref, $rp) = @_;
 114         return $self->_add_generic_handler($event, $ref, $rp,
 115                                            $self->{_handler}, 'add_handler');
 116 }
 117
 118 # -- #perl was here! --
 119 #    fimmtiu: Oh, dear. There actually _is_ an alt.fan.jwz.
 120 #   Freiheit: "Join us. *whapdewhapwhap*  Join us now.  *whapdewhapwhap* Join
 121 #             us now and share the software."
 122 #   Freiheit: is that actually RMS singing or is it a voice-synthesizer?
 123
 124
 125 # Why do I even bother writing subs this simple? Sends an ADMIN command.
 126 # Takes 1 optional arg:  the name of the server you want to query.
 127 sub admin {
 128     my $self = shift;        # Thank goodness for AutoLoader, huh?
 129                              # Perhaps we'll finally use it soon.
 130
 131     $self->sl("ADMIN" . ($_[0] ? " $_[0]" : ""));
 132 }
 133
 134 # Takes care of the methods in %autoloaded
 135 # Sets specified attribute, or returns its value if called without args.
 136 sub AUTOLOAD {
 137     my $self = @_;  ## can't modify @_ for goto &name
 138     my $class = ref $self;  ## die here if !ref($self) ?
 139     my $meth;
 140
 141     # -- #perl was here! --
 142     #  <Teratogen> absolute power corrupts absolutely, but it's a helluva lot
 143     #              of fun.
 144     #  <Teratogen> =)
 145
 146     ($meth = $AUTOLOAD) =~ s/^.*:://;  ## strip fully qualified portion
 147
 148     unless (exists $autoloaded{$meth}) {
 149         croak "No method called \"$meth\" for $class object.";
 150     }
 151
 152     eval <<EOSub;
 153 sub $meth {
 154     my \$self = shift;
 155
 156     if (\@_) {
 157         my \$old = \$self->{"_$meth"};
 158
 159         \$self->{"_$meth"} = shift;
 160
 161         return \$old;
 162     }
 163     else {
 164         return \$self->{"_$meth"};
 165     }
 166 }
 167 EOSub
 168
 169     ## no reason to play this game every time
 170     goto &$meth;
 171 }
 172
 173
 174 # Toggles away-ness with the server.  Optionally takes an away message.
 175 sub away {
 176     my $self = shift;
 177     $self->sl("AWAY" . ($_[0] ? " :$_[0]" : ""));
 178 }
 179
 180
 181 # -- #perl was here! --
 182 # <crab> to irc as root demonstrates about the same brains as a man in a
 183 #        thunderstorm waving a lightning rod and standing in a copper tub
 184 #        of salt water yelling "ALL GODS ARE BASTARDS!"
 185 # DrForr saves that one.
 186
 187 # Attempts to connect to the specified IRC (server, port) with the specified
 188 #   (nick, username, ircname). Will close current connection if already open.
 189 sub connect {
 190     my $self = shift;
 191     my ($hostname, $password, $sock);
 192
 193     if (@_) {
 194         my (%arg) = @_;
 195
 196         $hostname = $arg{'LocalAddr'} if exists $arg{'LocalAddr'};
 197         $password = $arg{'Password'} if exists $arg{'Password'};
 198         $self->nick($arg{'Nick'}) if exists $arg{'Nick'};
 199         $self->port($arg{'Port'}) if exists $arg{'Port'};
 200         $self->server($arg{'Server'}) if exists $arg{'Server'};
 201         $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'};
 202         $self->username($arg{'Username'}) if exists $arg{'Username'};
 203     }
 204
 205     # Lots of error-checking claptrap first...
 206     unless ($self->server) {
 207         unless ($ENV{IRCSERVER}) {
 208             croak "No server address specified in connect()";
 209         }
 210         $self->server( $ENV{IRCSERVER} );
 211     }
 212     unless ($self->nick) {
 213         $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) }
 214                     || $ENV{USER} || $ENV{LOGNAME} || "WankerBot");
 215     }
 216     unless ($self->port) {
 217         $self->port($ENV{IRCPORT} || 6667);
 218     }
 219     unless ($self->ircname)  {
 220         $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] }
 221                        || "Just Another Perl Hacker");
 222     }
 223     unless ($self->username) {
 224         $self->username(eval { scalar getpwuid($>) } || $ENV{USER}
 225                         || $ENV{LOGNAME} || "japh");
 226     }
 227
 228     # Now for the socket stuff...
 229     if ($self->connected) {
 230         $self->quit("Changing servers");
 231     }
 232
 233 #    my $sock = IO::Socket::INET->new(PeerAddr => $self->server,
 234 #                                    PeerPort => $self->port,
 235 #                                    Proto    => "tcp",
 236 #                                   );
 237
 238     $sock = Symbol::gensym();
 239     unless (socket( $sock, PF_INET, SOCK_STREAM, getprotobyname('tcp') )) {
 240         carp ("Can't create a new socket: $!");
 241         $self->error(1);
 242         return;
 243     }
 244
 245     # This bind() stuff is so that people with virtual hosts can select
 246     # the hostname they want to connect with. For this, I dumped the
 247     # astonishingly gimpy IO::Socket. Talk about letting the interface
 248     # get in the way of the functionality...
 249
 250     if ($hostname) {
 251         unless (bind( $sock, sockaddr_in( 0, inet_aton($hostname) ) )) {
 252             carp "Can't bind to $hostname: $!";
 253             $self->error(1);
 254             return;
 255         }
 256     }
 257
 258     if (connect( $sock, sockaddr_in($self->port, inet_aton($self->server)) )) {
 259         $self->socket($sock);
 260
 261     } else {
 262         carp (sprintf "Can't connect to %s:%s!",
 263               $self->server, $self->port);
 264         $self->error(1);
 265         return;
 266     }
 267
 268     # Send a PASS command if they specified a password. According to
 269     # the RFC, we should do this as soon as we connect.
 270     if (defined $password) {
 271         $self->sl("PASS $password");
 272     }
 273
 274     # Now, log in to the server...
 275     unless ($self->sl('NICK ' . $self->nick()) and
 276             $self->sl(sprintf("USER %s %s %s :%s",
 277                               $self->username(),
 278                               "foo.bar.com",
 279                               $self->server(),
 280                               $self->ircname()))) {
 281         carp "Couldn't send introduction to server: $!";
 282         $self->error(1);
 283         $! = "Couldn't send NICK/USER introduction to " . $self->server;
 284         return;
 285     }
 286
 287     $self->{_connected} = 1;
 288     $self->parent->addconn($self);
 289 }
 290
 291 # Returns a boolean value based on the state of the object's socket.
 292 sub connected {
 293     my $self = shift;
 294
 295     return ( $self->{_connected} and $self->socket() );
 296 }
 297
 298 # Sends a CTCP request to some hapless victim(s).
 299 # Takes at least two args:  the type of CTCP request (case insensitive)
 300 #                           the nick or channel of the intended recipient(s)
 301 # Any further args are arguments to CLIENTINFO, ERRMSG, or ACTION.
 302 sub ctcp {
 303     my ($self, $type, $target) = splice @_, 0, 3;
 304     $type = uc $type;
 305
 306     unless ($target) {
 307         croak "Not enough arguments to ctcp()";
 308     }
 309
 310     if ($type eq "PING") {
 311         unless ($self->sl("PRIVMSG $target :\001PING " . time . "\001")) {
 312             carp "Socket error sending $type request in ctcp()";
 313             return;
 314         }
 315     } elsif (($type eq "CLIENTINFO" or $type eq "ACTION") and @_) {
 316         unless ($self->sl("PRIVMSG $target :\001$type " .
 317                         CORE::join(" ", @_) . "\001")) {
 318             carp "Socket error sending $type request in ctcp()";
 319             return;
 320         }
 321     } elsif ($type eq "ERRMSG") {
 322         unless (@_) {
 323             carp "Not enough arguments to $type in ctcp()";
 324             return;
 325         }
 326         unless ($self->sl("PRIVMSG $target :\001ERRMSG " .
 327                         CORE::join(" ", @_) . "\001")) {
 328             carp "Socket error sending $type request in ctcp()";
 329             return;
 330         }
 331     } else {
 332         unless ($self->sl("PRIVMSG $target :\001$type " .
 333                         CORE::join(" ",@_) . "\001")) {
 334             carp "Socket error sending $type request in ctcp()";
 335             return;
 336         }
 337     }
 338 }
 339
 340 # Sends replies to CTCP queries. Simple enough, right?
 341 # Takes 2 args:  the target person or channel to send a reply to
 342 #                the text of the reply
 343 sub ctcp_reply {
 344     my $self = shift;
 345
 346     $self->notice($_[0], "\001" . $_[1] . "\001");
 347 }
 348
 349
 350 # Sets or returns the debugging flag for this object.
 351 # Takes 1 optional arg: a new boolean value for the flag.
 352 sub debug {
 353     my $self = shift;
 354     if (@_) {
 355         $self->{_debug} = $_[0];
 356     }
 357     return $self->{_debug};
 358 }
 359
 360
 361 # Dequotes CTCP messages according to ctcp.spec. Nothing special.
 362 # Then it breaks them into their component parts in a flexible, ircII-
 363 # compatible manner. This is not quite as trivial. Oh, well.
 364 # Takes 1 arg:  the line to be dequoted.
 365 sub dequote {
 366     my $line = shift;
 367     my ($order, @chunks) = (0, ());    # CHUNG! CHUNG! CHUNG!
 368
 369     # Filter misplaced \001s before processing... (Thanks, Tom!)
 370     substr($line, rindex($line, "\001"), 1) = '\\a'
 371       unless ($line =~ tr/\001//) % 2 == 0;
 372
 373     # Thanks to Abigail (abigail@fnx.com) for this clever bit.
 374     if (index($line, "\cP") >= 0) {    # dequote low-level \n, \r, ^P, and \0.
 375         my (%h) = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP");
 376         $line =~ s/\cP([nr0\cP])/$h{$1}/g;
 377     }
 378     $line =~ s/\\([^\\a])/$1/g;  # dequote unnecessarily quoted characters.
 379
 380     # -- #perl was here! --
 381     #     roy7: Chip Chip he's our man!
 382     #  fimmtiu: If he can't do it, Larry can!
 383     # ChipDude: I thank you!  No applause, just throw RAM chips!
 384
 385     # If true, it's in odd order... ctcp commands start with first chunk.
 386     $order = 1 if index($line, "\001") == 0;
 387     @chunks = map { s/\\\\/\\/g; $_ } (split /\cA/, $line);
 388
 389     return ($order, @chunks);
 390 }
 391
 392 # Standard destructor method for the GC routines. (HAHAHAH! DIE! DIE! DIE!)
 393 sub DESTROY {
 394     my $self = shift;
 395     # how ironic.
 396     $self->handler("destroy", "nobody will ever use this");
 397 }
 398
 399
 400 # Disconnects this Connection object cleanly from the server.
 401 # Takes at least 1 arg:  the format and args parameters to Event->new().
 402 sub disconnect {
 403     my $self = shift;
 404
 405     $self->{_connected} = 0;
 406     $self->parent->removeconn($self);
 407     $self->socket( undef );
 408     $self->handler(Net::IRC::Event->new( "disconnect",
 409                                          $self->server,
 410                                          '',
 411                                          @_  ));
 412 }
 413
 414
 415 # Tells IRC.pm if there was an error opening this connection. It's just
 416 # for sane error passing.
 417 # Takes 1 optional arg:  the new value for $self->{'iserror'}
 418 sub error {
 419     my $self = shift;
 420
 421     $self->{'iserror'} = $_[0] if @_;
 422     return $self->{'iserror'};
 423 }
 424
 425 # -- #perl was here! --
 426 # <nocarrier> No, I commute Mon-Wed-Fri from Allentown.
 427 #   <rudefix> the billy joel and skinhead place
 428 # <nocarrier> that's what they say.
 429 #   <\lembit> it's hard to keep a good man down.
 430 #  <qw[jeff]> but only the good die young!
 431 #             \lembit won't be getting up today.
 432 #  <rudefix> because they're under too much pressure, jeff
 433 # <qw[jeff]> and it surely will catch up to them, somewhere along the line.
 434
 435
 436 # Lets the user set or retrieve a format for a message of any sort.
 437 # Takes at least 1 arg:  the event whose format you're inquiring about
 438 #           (optional)   the new format to use for this event
 439 sub format {
 440     my ($self, $ev) = splice @_, 0, 2;
 441
 442     unless ($ev) {
 443         croak "Not enough arguments to format()";
 444     }
 445
 446     if (@_) {
 447         $self->{'_format'}->{$ev} = $_[0];
 448     } else {
 449         return ($self->{'_format'}->{$ev} ||
 450                 $self->{'_format'}->{'default'});
 451     }
 452 }
 453
 454 # -- #perl was here! --
 455 # <q[merlyn]> \lem... know any good austin Perl hackers for hire?
 456 # <q[merlyn]> I'm on a hunt for one for a friend.
 457 #    <archon> for a job?
 458 #   <Stupid_> No, in his spare time merlyn bow-hunts for perl programmers
 459 #             by their scent.
 460
 461
 462 # Calls the appropriate handler function for a specified event.
 463 # Takes 2 args:  the name of the event to handle
 464 #                the arguments to the handler function
 465 sub handler {
 466     my ($self, $event) = splice @_, 0, 2;
 467
 468     unless (defined $event) {
 469         croak 'Too few arguments to Connection->handler()';
 470     }
 471
 472     # Get name of event.
 473     my $ev;
 474     if (ref $event) {
 475         $ev = $event->type;
 476     } elsif (defined $event) {
 477         $ev = $event;
 478         $event = Net::IRC::Event->new($event, '', '', '');
 479     } else {
 480         croak "Not enough arguments to handler()";
 481     }
 482
 483     print STDERR "Trying to handle event '$ev'.\n" if $self->{_debug};
 484
 485     # -- #perl was here! --
 486     #   <\lembit> tainted code...oh-oh..tainted code...sometimes I know I've
 487     #             got to (boink boink) run away...
 488     # <Excession> \lembit I'd ease up on the caffiene if I were you
 489
 490     my $handler = undef;
 491     if (exists $self->{_handler}->{$ev}) {
 492         $handler = $self->{_handler}->{$ev};
 493     } elsif (exists $_udef{$ev}) {
 494         $handler = $_udef{$ev};
 495     } else {
 496         return $self->_default($event, @_);
 497     }
 498
 499     my ($code, $rp) = @{$handler};
 500
 501     # If we have args left, try to call the handler.
 502     if ($rp == 0) {                      # REPLACE
 503         &$code($self, $event, @_);
 504     } elsif ($rp == 1) {                 # BEFORE
 505         &$code($self, $event, @_);
 506         $self->_default($event, @_);
 507     } elsif ($rp == 2) {                 # AFTER
 508         $self->_default($event, @_);
 509         &$code($self, $event, @_);
 510     } else {
 511         confess "Bad parameter passed to handler(): rp=$rp";
 512     }
 513
 514     warn "Handler for '$ev' called.\n" if $self->{_debug};
 515
 516     return 1;
 517 }
 518
 519 # -- #perl was here! --
 520 # <JavaJive> last night I dreamt I was flying over mountainous terrains
 521 #            which changed into curves and and valleys shooting everywhere
 522 #            and then finally into physical abominations which could never
 523 #            really exist in the material universe.
 524 # <JavaJive> then I realized it was just one of my perl data structures.
 525
 526
 527 # Lets a user set hostmasks to discard certain messages from, or (if called
 528 # with only 1 arg), show a list of currently ignored hostmasks of that type.
 529 # Takes 2 args:  type of ignore (public, msg, ctcp, etc)
 530 #    (optional)  [mask(s) to be added to list of specified type]
 531 sub ignore {
 532     my $self = shift;
 533
 534     unless (@_) {
 535         croak "Not enough arguments to ignore()";
 536     }
 537
 538     if (@_ == 1) {
 539         if (exists $self->{_ignore}->{$_[0]}) {
 540             return @{ $self->{_ignore}->{$_[0]} };
 541         } else {
 542             return ();
 543         }
 544     } elsif (@_ > 1) {     # code defensively, remember...
 545         my $type = shift;
 546
 547         # I moved this part further down as an Obsessive Efficiency
 548         # Initiative. It shouldn't be a problem if I do _parse right...
 549         # ... but those are famous last words, eh?
 550         unless (grep {$_ eq $type}
 551                 qw(public msg ctcp notice channel nick other all)) {
 552             carp "$type isn't a valid type to ignore()";
 553             return;
 554         }
 555
 556         if ( exists $self->{_ignore}->{$type} )  {
 557             push @{$self->{_ignore}->{$type}}, @_;
 558         } else  {
 559             $self->{_ignore}->{$type} = [ @_ ];
 560         }
 561     }
 562 }
 563
 564
 565 # -- #perl was here! --
 566 # <Moonlord> someone can tell me some web side for "hack" programs
 567 #  <fimmtiu> Moonlord: http://pinky.wtower.com/nethack/
 568 # <Moonlord> thank`s fimmtiu
 569 #    fimmtiu giggles maniacally.
 570
 571
 572 # Yet Another Ridiculously Simple Sub. Sends an INFO command.
 573 # Takes 1 optional arg: the name of the server to query.
 574 sub info {
 575     my $self = shift;
 576
 577     $self->sl("INFO" . ($_[0] ? " $_[0]" : ""));
 578 }
 579
 580
 581 # -- #perl was here! --
 582 #  <Teratogen> terminals in the night
 583 #  <Teratogen> exchanging ascii
 584 #  <Teratogen> oops, we dropped a byte
 585 #  <Teratogen> please hit the break key
 586 #  <Teratogen> doo be doo be doo
 587
 588
 589 # Invites someone to an invite-only channel. Whoop.
 590 # Takes 2 args:  the nick of the person to invite
 591 #                the channel to invite them to.
 592 # I hate the syntax of this command... always seemed like a protocol flaw.
 593 sub invite {
 594     my $self = shift;
 595
 596     unless (@_ > 1) {
 597         croak "Not enough arguments to invite()";
 598     }
 599
 600     $self->sl("INVITE $_[0] $_[1]");
 601 }
 602
 603 # Checks if a particular nickname is in use.
 604 # Takes at least 1 arg:  nickname(s) to look up.
 605 sub ison {
 606     my $self = shift;
 607
 608     unless (@_) {
 609         croak 'Not enough args to ison().';
 610     }
 611
 612     $self->sl("ISON " . CORE::join(" ", @_));
 613 }
 614
 615 # Joins a channel on the current server if connected, eh?.
 616 # Corresponds to /JOIN command.
 617 # Takes 2 args:  name of channel to join
 618 #                optional channel password, for +k channels
 619 sub join {
 620     my $self = shift;
 621
 622     unless ( $self->connected ) {
 623         carp "Can't join() -- not connected to a server";
 624         return;
 625     }
 626
 627     # -- #perl was here! --
 628     # *** careful is Starch@ncb.mb.ca (The WebMaster)
 629     # *** careful is on IRC via server irc.total.net (Montreal Hub &
 630     #        Client Server)
 631     # careful: well, it's hard to buy more books now too cause where the
 632     #          heck do you put them all? i have to move and my puter room is
 633     #          almost 400 square feet, it's the largest allowed in my basement
 634     #          without calling it a room and pay taxes, hehe
 635
 636     unless (@_) {
 637         croak "Not enough arguments to join()";
 638     }
 639
 640     #  \petey: paying taxes by the room?
 641     #          \petey boggles
 642     # careful: that's what they do for finished basements and stuff
 643     # careful: need an emergency exit and stuff
 644     #   jjohn: GOOD GOD! ARE THEY HEATHENS IN CANADA? DO THEY EAT THEIR
 645     #          OWN YOUNG?
 646
 647     return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : ""));
 648
 649     # \petey: "On the 'net nobody knows you're Canadian, eh?"
 650     #  jjohn: shut up, eh?
 651 }
 652
 653 # Opens a righteous can of whoop-ass on any luser foolish enough to ask a
 654 # CGI question in #perl. Eat flaming death, web wankers!
 655 # Takes at least 2 args:  the channel to kick the bastard from
 656 #                         the nick of the bastard in question
 657 #             (optional)  a parting comment to the departing bastard
 658 sub kick {
 659     my $self = shift;
 660
 661     unless (@_ > 1) {
 662         croak "Not enough arguments to kick()";
 663     }
 664     return $self->sl("KICK $_[0] $_[1]" . ($_[2] ? " :$_[2]" : ""));
 665 }
 666
 667 # -- #perl was here! --
 668 #  sputnik1 listens in glee to the high-pitched whine of the Pratt
 669 #           and Whitney generator heating up on the launcher of his
 670 #           AGM-88B HARM missile
 671 #     <lej> sputnik1: calm down, little commie satellite
 672
 673
 674 # Gets a list of all the servers that are linked to another visible server.
 675 # Takes 2 optional args:  it's a bitch to describe, and I'm too tired right
 676 #                         now, so read the RFC.
 677 sub links {
 678     my ($self) = (shift, undef);
 679
 680     $self->sl("LINKS" . (scalar(@_) ? " " . CORE::join(" ", @_[0,1]) : ""));
 681 }
 682
 683
 684 # Requests a list of channels on the server, or a quick snapshot of the current
 685 # channel (the server returns channel name, # of users, and topic for each).
 686 sub list {
 687     my $self = shift;
 688
 689     $self->sl("LIST " . CORE::join(",", @_));
 690 }
 691
 692 # -- #perl was here! --
 693 # <china`blu> see, neo?
 694 # <china`blu> they're crowded
 695 # <china`blu> i bet some programmers/coders might be here
 696 #   <fimmtiu> Nope. No programmers here. We're just Larry Wall groupies.
 697 # <china`blu> come on
 698 # <Kilbaniar> Larry Wall isn't as good in bed as you'd think.
 699 # <Kilbaniar> For the record...
 700
 701
 702 # -- #perl was here! --
 703 # <Skrewtape> Larry Wall is a lot sexier than Richard Stallman
 704 # <Skrewtape> But I've heard Stallman is better in bed.
 705 # <Schwern> Does he leave the halo on?
 706 # * aether cocks her head at skrew...uh...whatever?
 707 # <fimmtiu> Stallman's beard is a sex magnet.
 708 # <Skrewtape> Larry's moustache is moreso, Fimm.
 709 # <aether> oh yeah...women all over the world are hot for stallman....
 710 # <Skrewtape> Moustaches make my heart melt.
 711 # <Schwern> I dunno, there's something about a man in hawaiian shirts...
 712
 713
 714 # Sends a request for some server/user stats.
 715 # Takes 1 optional arg: the name of a server to request the info from.
 716 sub lusers {
 717     my $self = shift;
 718
 719     $self->sl("LUSERS" . ($_[0] ? " $_[0]" : ""));
 720 }
 721
 722 # Gets and/or sets the max line length.  The value previous to the sub
 723 # call will be returned.
 724 # Takes 1 (optional) arg: the maximum line length (in bytes)
 725 sub maxlinelen {
 726     my $self = shift;
 727
 728     my $ret = $self->{_maxlinelen};
 729
 730     $self->{_maxlinelen} = shift if @_;
 731
 732     return $ret;
 733 }
 734
 735 # -- #perl was here! --
 736 #  <KeithW>  Hey, actually, I just got a good idea for an April Fools-day
 737 #            emacs mode.
 738 #  <KeithW>  tchrist-mode
 739 # <amagosa>  Heh heh
 740 #  <KeithW>  When you finish typing a word, emacs automatically replaces it
 741 #            with the longest synonym from the online Merriam-Webster
 742 #            thesaurus.
 743
 744
 745 # Sends an action to the channel/nick you specify. It's truly amazing how
 746 # many IRCers have no idea that /me's are actually sent via CTCP.
 747 # Takes 2 args:  the channel or nick to bother with your witticism
 748 #                the action to send (e.g., "weed-whacks billn's hand off.")
 749 sub me {
 750     my $self = shift;
 751
 752     $self->ctcp("ACTION", $_[0], $_[1]);
 753 }
 754
 755 # -- #perl was here! --
 756 # *** china`blu (azizam@pm5-30.flinet.com) has joined channel #perl
 757 # <china`blu> hi guys
 758 # <china`blu> and girls
 759 #      <purl> I am NOT a lesbian!
 760
 761
 762 # Change channel and user modes (this one is easy... the handler is a bitch.)
 763 # Takes at least 1 arg:  the target of the command (channel or nick)
 764 #             (optional)  the mode string (i.e., "-boo+i")
 765 #             (optional)  operands of the mode string (nicks, hostmasks, etc.)
 766 sub mode {
 767     my $self = shift;
 768
 769     unless (@_ >= 1) {
 770         croak "Not enough arguments to mode()";
 771     }
 772     $self->sl("MODE $_[0] " . CORE::join(" ", @_[1..$#_]));
 773 }
 774
 775 # -- #perl was here! --
 776 # *** billnolio (billn@initiate.monk.org) has joined channel #perl
 777 # *** Mode change "+v billnolio" on channel #perl by select
 778 #     billnolio humps fimmtiu's leg
 779 # *** billnolio has left channel #perl
 780
 781
 782 # Sends a MOTD command to a server.
 783 # Takes 1 optional arg:  the server to query (defaults to current server)
 784 sub motd {
 785     my $self = shift;
 786
 787     $self->sl("MOTD" . ($_[0] ? " $_[0]" : ""));
 788 }
 789
 790 # -- #perl was here! --
 791 # <Roderick> "Women were put on this earth to weaken us.  Drain our energy.
 792 #            Laugh at us when they see us naked."
 793 # <qw[jeff]> rod - maybe YOUR women...
 794 #  <fimmtiu> jeff: Oh, just wait....
 795 # <Roderick> "Love is a snowmobile racing across the tundra, which
 796 #            suddenly flips over, pinning you underneath. At night,
 797 #            the ice weasels come."
 798 # <qw[jeff]> rod - where do you GET these things?!
 799 # <Roderick> They do tend to accumulate.  Clutter in the brain.
 800
 801
 802 # Requests the list of users for a particular channel (or the entire net, if
 803 # you're a masochist).
 804 # Takes 1 or more optional args:  name(s) of channel(s) to list the users from.
 805 sub names {
 806     my $self = shift;
 807
 808     $self->sl("NAMES " . CORE::join(",", @_));
 809
 810 }   # Was this the easiest sub in the world, or what?
 811
 812 # Creates a new IRC object and assigns some default attributes.
 813 sub new {
 814     my $proto = shift;
 815
 816     # -- #perl was here! --
 817     # <\merlyn>  just don't use ref($this) || $this;
 818     # <\merlyn>  tchrist's abomination.
 819     # <\merlyn>  lame lame lame.  frowned upon by any OO programmer I've seen.
 820     # <tchrist>  randal disagrees, but i don't care.
 821     # <tchrist>  Randal isn't being flexible/imaginative.
 822     # <ChipDude> fimm: WRT "ref ($proto) || $proto", I'm against. Class
 823     #            methods and object methods are distinct.
 824
 825     # my $class = ref($proto) || $proto;             # Man, am I confused...
 826
 827     my $self = {                # obvious defaults go here, rest are user-set
 828                 _debug      => $_[0]->{_debug},
 829                 _port       => 6667,
 830                 # Evals are for non-UNIX machines, just to make sure.
 831                 _username   => eval { scalar getpwuid($>) } || $ENV{USER}
 832                 || $ENV{LOGNAME} || "japh",
 833                 _ircname    => $ENV{IRCNAME} || eval { (getpwuid($>))[6] }
 834                 || "Just Another Perl Hacker",
 835                 _nick       => $ENV{IRCNICK} || eval { scalar getpwuid($>) }
 836                 || $ENV{USER} || $ENV{LOGNAME} || "WankerBot",  # heheh...
 837                 _ignore     => {},
 838                 _handler    => {},
 839                 _verbose    =>  0,       # Is this an OK default?
 840                 _parent     =>  shift,
 841                 _frag       =>  '',
 842                 _connected  =>  0,
 843                 _maxlinelen =>  510,     # The RFC says we shouldn't exceed this.
 844                 _format     => {
 845                     'default' => "[%f:%t]  %m  <%d>",
 846                 },
 847               };
 848
 849     bless $self, $proto;
 850     # do any necessary initialization here
 851     $self->connect(@_) if @_;
 852
 853     return $self;
 854 }
 855
 856 # Creates and returns a DCC CHAT object, analogous to IRC.pm's newconn().
 857 # Takes at least 1 arg:   An Event object for the DCC CHAT request.
 858 #                    OR   A list or listref of args to be passed to new(),
 859 #                         consisting of:
 860 #                           - A boolean value indicating whether or not
 861 #                             you're initiating the CHAT connection.
 862 #                           - The nick of the chattee
 863 #                           - The address to connect to
 864 #                           - The port to connect on
 865 sub new_chat {
 866     my $self = shift;
 867     my ($init, $nick, $address, $port);
 868
 869     if (ref($_[0]) =~ /Event/) {
 870         # If it's from an Event object, we can't be initiating, right?
 871         ($init, undef, undef, undef, $address, $port) = (0, $_[0]->args);
 872         $nick = $_[0]->nick;
 873
 874     } elsif (ref($_[0]) eq "ARRAY") {
 875         ($init, $nick, $address, $port) = @{$_[0]};
 876     } else {
 877         ($init, $nick, $address, $port) = @_;
 878     }
 879
 880     # -- #perl was here! --
 881     #          gnat snorts.
 882     #    gnat: no fucking microsoft products, thanks :)
 883     #  ^Pudge: what about non-fucking MS products?  i hear MS Bob is a virgin.
 884
 885     Net::IRC::DCC::CHAT->new($self, $init, $nick, $address, $port);
 886 }
 887
 888 # Creates and returns a DCC GET object, analogous to IRC.pm's newconn().
 889 # Takes at least 1 arg:   An Event object for the DCC SEND request.
 890 #                    OR   A list or listref of args to be passed to new(),
 891 #                         consisting of:
 892 #                           - The nick of the file's sender
 893 #                           - The name of the file to receive
 894 #                           - The address to connect to
 895 #                           - The port to connect on
 896 #                           - The size of the incoming file
 897 # For all of the above, an extra argument can be added at the end:
 898 #                         An open filehandle to save the incoming file into,
 899 #                         in globref, FileHandle, or IO::* form.
 900 sub new_get {
 901     my $self = shift;
 902     my ($nick, $name, $address, $port, $size, $handle);
 903
 904     if (ref($_[0]) =~ /Event/) {
 905         (undef, undef, $name, $address, $port, $size) = $_[0]->args;
 906         $nick = $_[0]->nick;
 907         $handle = $_[1] if defined $_[1];
 908     } elsif (ref($_[0]) eq "ARRAY") {
 909         ($nick, $name, $address, $port, $size) = @{$_[0]};
 910         $handle = $_[1] if defined $_[1];
 911     } else {
 912         ($nick, $name, $address, $port, $size, $handle) = @_;
 913     }
 914
 915     unless (defined $handle and ref $handle and
 916             (ref $handle eq "GLOB" or $handle->can('print')))
 917     {
 918         carp ("Filehandle argument to Connection->new_get() must be ".
 919               "a glob reference or object");
 920         return;                                # is this behavior OK?
 921     }
 922
 923     my $dcc = Net::IRC::DCC::GET->new($self, $nick, $address,
 924                                       $port, $size, $name, $handle);
 925
 926     $self->parent->addconn($dcc) if $dcc;
 927     return $dcc;
 928 }
 929
 930 # Creates and returns a DCC SEND object, analogous to IRC.pm's newconn().
 931 # Takes at least 2 args:  The nickname of the person to send to
 932 #                         The name of the file to send
 933 #             (optional)  The blocksize for the connection (default 1k)
 934 sub new_send {
 935     my $self = shift;
 936     my ($nick, $filename, $blocksize);
 937
 938     if (ref($_[0]) eq "ARRAY") {
 939         ($nick, $filename, $blocksize) = @{$_[0]};
 940     } else {
 941         ($nick, $filename, $blocksize) = @_;
 942     }
 943
 944     Net::IRC::DCC::SEND->new($self, $nick, $filename, $blocksize);
 945 }
 946
 947 # -- #perl was here! --
 948 #    [petey suspects I-Que of not being 1337!
 949 # <fimmtiu> Eat flaming death, petey.
 950 #   <I-Que> I'm only 22!
 951 #   <I-Que> not 1337
 952
 953
 954 # Selects nick for this object or returns currently set nick.
 955 # No default; must be set by user.
 956 # If changed while the object is already connected to a server, it will
 957 # automatically try to change nicks.
 958 # Takes 1 arg:  the nick. (I bet you could have figured that out...)
 959 sub nick {
 960     my $self = shift;
 961
 962     if (@_)  {
 963         $self->{'_nick'} = shift;
 964         if ($self->connected) {
 965             return $self->sl("NICK " . $self->{'_nick'});
 966         }
 967     } else {
 968         return $self->{'_nick'};
 969     }
 970 }
 971
 972 # Sends a notice to a channel or person.
 973 # Takes 2 args:  the target of the message (channel or nick)
 974 #                the text of the message to send
 975 # The message will be chunked if it is longer than the _maxlinelen
 976 # attribute, but it doesn't try to protect against flooding.  If you
 977 # give it too much info, the IRC server will kick you off!
 978 sub notice {
 979     my ($self, $to) = splice @_, 0, 2;
 980
 981     unless (@_) {
 982         croak "Not enough arguments to notice()";
 983     }
 984
 985     my ($buf, $length, $line) = (CORE::join("", @_), $self->{_maxlinelen});
 986
 987     while($buf) {
 988         ($line, $buf) = unpack("a$length a*", $buf);
 989         $self->sl("NOTICE $to :$line");
 990     }
 991 }
 992
 993 # -- #perl was here! --
 994 #  <TorgoX> this was back when I watched Talk Soup, before I had to stop
 995 #           because I saw friends of mine on it.
 996 #    [petey chuckles at TorgoX
 997 # <Technik> TorgoX: on the Jerry Springer clips?
 998 #  <TorgoX> I mean, when people you know appear on, like, some Springer
 999 #           knockoff, in a cheap disguise, and the Talk Soup host makes fun
1000 #           of them, you just have to stop.
1001 # <Technik> TorgoX: you need to get better friends
1002 #  <TorgoX> I was shamed.  I left town.
1003 #  <TorgoX> grad school was just the pretext for the move.  this was the
1004 #           real reason.
1005 # <Technik> lol
1006
1007
1008 # Makes you an IRCop, if you supply the right username and password.
1009 # Takes 2 args:  Operator's username
1010 #                Operator's password
1011 sub oper {
1012     my $self = shift;
1013
1014     unless (@_ > 1) {
1015         croak "Not enough arguments to oper()";
1016     }
1017
1018     $self->sl("OPER $_[0] $_[1]");
1019 }
1020
1021 # This function splits apart a raw server line into its component parts
1022 # (message, target, message type, CTCP data, etc...) and passes it to the
1023 # appropriate handler. Takes no args, really.
1024 sub parse {
1025     my ($self) = shift;
1026     my ($from, $type, $message, @stuff, $itype, $ev, @lines, $line);
1027
1028     # Read newly arriving data from $self->socket
1029     # -- #perl was here! --
1030     #   <Tkil2> hm.... any joy if you add a 'defined' to the test? like
1031     #           if (defined $sock...
1032     # <fimmtiu> Much joy now.
1033     #    archon rejoices
1034
1035     if (defined recv($self->socket, $line, 10240, 0) and
1036                 (length($self->{_frag}) + length($line)) > 0)  {
1037         # grab any remnant from the last go and split into lines
1038         my $chunk = $self->{_frag} . $line;
1039         @lines = split /\012/, $chunk;
1040
1041         # if the last line was incomplete, pop it off the chunk and
1042         # stick it back into the frag holder.
1043         $self->{_frag} = (substr($chunk, -1) ne "\012" ? pop @lines : '');
1044
1045     } else {
1046         # um, if we can read, i say we should read more than 0
1047         # besides, recv isn't returning undef on closed
1048         # sockets.  getting rid of this connection...
1049         $self->disconnect('error', 'Connection reset by peer');
1050         return;
1051     }
1052
1053     foreach $line (@lines) {
1054
1055         # Clean the lint filter every 2 weeks...
1056         $line =~ s/[\012\015]+$//;
1057         next unless $line;
1058
1059         print STDERR "<<< $line\n" if $self->{_debug};
1060
1061         # Like the RFC says: "respond as quickly as possible..."
1062         if ($line =~ /^PING/) {
1063             $ev = (Net::IRC::Event->new( "ping",
1064                                          $self->server,
1065                                          $self->nick,
1066                                          "serverping",   # FIXME?
1067                                          substr($line, 5)
1068                                          ));
1069
1070             # Had to move this up front to avoid a particularly pernicious bug.
1071         } elsif ($line =~ /^NOTICE/) {
1072             $ev = Net::IRC::Event->new( "snotice",
1073                                         $self->server,
1074                                         '',
1075                                         'server',
1076                                         (split /:/, $line, 2)[1] );
1077
1078
1079             # Spurious backslashes are for the benefit of cperl-mode.
1080             # Assumption:  all non-numeric message types begin with a letter
1081         } elsif ($line =~ /^:?
1082                  ([][}{\w\\\`^|\-]+?      # The nick (valid nickname chars)
1083                   !                       # The nick-username separator
1084                   .+?                     # The username
1085                   \@)?                    # Umm, duh...
1086                  \S+                      # The hostname
1087                  \s+                      # Space between mask and message type
1088                  [A-Za-z]                 # First char of message type
1089                  [^\s:]+?                 # The rest of the message type
1090                  /x)                      # That ought to do it for now...
1091         {
1092             $line = substr $line, 1 if $line =~ /^:/;
1093             ($from, $line) = split ":", $line, 2;
1094             ($from, $type, @stuff) = split /\s+/, $from;
1095             $type = lc $type;
1096
1097             # This should be fairly intuitive... (cperl-mode sucks, though)
1098             if (defined $line and index($line, "\001") >= 0) {
1099                 $itype = "ctcp";
1100                 unless ($type eq "notice") {
1101                     $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg");
1102                 }
1103             } elsif ($type eq "privmsg") {
1104                 $itype = $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg");
1105             } elsif ($type eq "notice") {
1106                 $itype = "notice";
1107             } elsif ($type eq "join" or $type eq "part" or
1108                      $type eq "mode" or $type eq "topic" or
1109                      $type eq "kick") {
1110                 $itype = "channel";
1111             } elsif ($type eq "nick") {
1112                 $itype = "nick";
1113             } else {
1114                 $itype = "other";
1115             }
1116
1117             # This goes through the list of ignored addresses for this message
1118             # type and drops out of the sub if it's from an ignored hostmask.
1119
1120             study $from;
1121             foreach ( $self->ignore($itype), $self->ignore("all") ) {
1122                 $_ = quotemeta; s/\\\*/.*/g;
1123                 return 1 if $from =~ /$_/;
1124             }
1125
1126             # It used to look a lot worse. Here was the original version...
1127             # the optimization above was proposed by Silmaril, for which I am
1128             # eternally grateful. (Mine still looks cooler, though. :)
1129
1130             # return if grep { $_ = join('.*', split(/\\\*/,
1131             #                  quotemeta($_)));  /$from/ }
1132             # ($self->ignore($type), $self->ignore("all"));
1133
1134             # Add $line to @stuff for the handlers
1135             push @stuff, $line if defined $line;
1136
1137             # Now ship it off to the appropriate handler and forget about it.
1138             if ( $itype eq "ctcp" ) {       # it's got CTCP in it!
1139                 $self->parse_ctcp($type, $from, $stuff[0], $line);
1140                 return 1;
1141
1142             }  elsif ($type eq "public" or $type eq "msg"   or
1143                       $type eq "notice" or $type eq "mode"  or
1144                       $type eq "join"   or $type eq "part"  or
1145                       $type eq "topic"  or $type eq "invite" ) {
1146
1147                 $ev = Net::IRC::Event->new( $type,
1148                                             $from,
1149                                             shift(@stuff),
1150                                             $type,
1151                                             @stuff,
1152                                             );
1153             } elsif ($type eq "quit" or $type eq "nick") {
1154
1155                 $ev = Net::IRC::Event->new( $type,
1156                                             $from,
1157                                             $from,
1158                                             $type,
1159                                             @stuff,
1160                                             );
1161             } elsif ($type eq "kick") {
1162
1163                 $ev = Net::IRC::Event->new( $type,
1164                                             $from,
1165                                             $stuff[1],
1166                                             $type,
1167                                             @stuff[0,2..$#stuff],
1168                                             );
1169
1170             } elsif ($type eq "kill") {
1171                 $ev = Net::IRC::Event->new($type,
1172                                            $from,
1173                                            '',
1174                                            $type,
1175                                            $line);   # Ahh, what the hell.
1176             } elsif ($type eq "wallops") {
1177                 $ev = Net::IRC::Event->new($type,
1178                                            $from,
1179                                            '',
1180                                            $type,
1181                                            $line);
1182             } else {
1183                carp "Unknown event type: $type";
1184             }
1185         }
1186
1187         # -- #perl was here! --
1188         # *** orwant (orwant@media.mit.edu) has joined channel #perl
1189         # orwant: Howdy howdy.
1190         # orwant: Just came back from my cartooning class.
1191         # orwant: I'm working on a strip for TPJ.
1192     #    njt: it's happy bouncy clown jon from clownland!  say 'hi' to
1193         #         the kiddies, jon!
1194         #         orwant splits open njt like a wet bag of groceries and
1195         #         dances on his sticky bones.
1196         #    njt: excuse me, ladies, but I've got to go eviscerate myself with
1197         #         a leaky biro.  don't wait up.
1198
1199         elsif ($line =~ /^:?       # Here's Ye Olde Numeric Handler!
1200                \S+?                 # the servername (can't assume RFC hostname)
1201                \s+?                # Some spaces here...
1202                \d+?                # The actual number
1203                \b/x                # Some other crap, whatever...
1204                ) {
1205             $ev = $self->parse_num($line);
1206
1207         } elsif ($line =~ /^:(\w+) MODE \1 /) {
1208             $ev = Net::IRC::Event->new( 'umode',
1209                                         $self->server,
1210                                         $self->nick,
1211                                         'server',
1212                                         substr($line, index($line, ':', 1) + 1));
1213
1214     } elsif ($line =~ /^:?       # Here's Ye Olde Server Notice handler!
1215                  .+?                 # the servername (can't assume RFC hostname)
1216                  \s+?                # Some spaces here...
1217                  NOTICE              # The server notice
1218                  \b/x                # Some other crap, whatever...
1219                 ) {
1220         $ev = Net::IRC::Event->new( 'snotice',
1221                                     $self->server,
1222                                     '',
1223                                     'server',
1224                                     (split /\s+/, $line, 3)[2] );
1225
1226
1227     } elsif ($line =~ /^ERROR/) {
1228         if ($line =~ /^ERROR :Closing [Ll]ink/) {   # is this compatible?
1229
1230             $ev = 'done';
1231             $self->disconnect( 'error', ($line =~ /(.*)/) );
1232
1233         } else {
1234             $ev = Net::IRC::Event->new( "error",
1235                                         $self->server,
1236                                         '',
1237                                         'error',
1238                                         (split /:/, $line, 2)[1]);
1239         }
1240     } elsif ($line =~ /^Closing [Ll]ink/) {
1241         $ev = 'done';
1242         $self->disconnect( 'error', ($line =~ /(.*)/) );
1243
1244     }
1245
1246         if ($ev) {
1247
1248             # We need to be able to fall through if the handler has
1249             # already been called (i.e., from within disconnect()).
1250
1251             $self->handler($ev) unless $ev eq 'done';
1252
1253         } else {
1254             # If it gets down to here, it's some exception I forgot about.
1255             carp "Funky parse case: $line\n";
1256         }
1257     }
1258 }
1259
1260 # The backend that parse() sends CTCP requests off to. Pay no attention
1261 # to the camel behind the curtain.
1262 # Takes 4 arguments:  the type of message
1263 #                     who it's from
1264 #                     the first bit of stuff
1265 #                     the line from the server.
1266 sub parse_ctcp {
1267     my ($self, $type, $from, $stuff, $line) = @_;
1268
1269     my ($one, $two);
1270     my ($odd, @foo) = (&dequote($line));
1271
1272     while (($one, $two) = (splice @foo, 0, 2)) {
1273
1274         ($one, $two) = ($two, $one) if $odd;
1275
1276         my ($ctype) = $one =~ /^(\w+)\b/;
1277         my $prefix = undef;
1278         if ($type eq 'notice') {
1279             $prefix = 'cr';
1280         } elsif ($type eq 'public' or
1281                  $type eq 'msg'   ) {
1282             $prefix = 'c';
1283         } else {
1284             carp "Unknown CTCP type: $type";
1285             return;
1286         }
1287
1288         if ($prefix) {
1289             my $handler = $prefix . lc $ctype;   # unit. value prob with $ctype
1290
1291             # -- #perl was here! --
1292             # fimmtiu: Words cannot describe my joy. Sil, you kick ass.
1293             # fimmtiu: I was passing the wrong arg to Event::new()
1294
1295             $self->handler(Net::IRC::Event->new($handler, $from, $stuff,
1296                                                 $handler, (split /\s/, $one)));
1297         }
1298
1299         # This next line is very likely broken somehow. Sigh.
1300         $self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two))
1301             if ($two);
1302     }
1303     return 1;
1304 }
1305
1306 # Does special-case parsing for numeric events. Separate from the rest of
1307 # parse() for clarity reasons (I can hear Tkil gasping in shock now. :-).
1308 # Takes 1 arg:  the raw server line
1309 sub parse_num {
1310     my ($self, $line) = @_;
1311
1312     ## Figlet protection?  This seems to be a bit closer to the RFC than
1313     ## the original version, which doesn't seem to handle :trailers quite
1314     ## correctly.
1315
1316     my ($from, $type, $stuff) = split(/\s+/, $line, 3);
1317     my ($blip, $space, $other, @stuff);
1318     while ($stuff) {
1319         ($blip, $space, $other) = split(/(\s+)/, $stuff, 2);
1320         $space = "" unless $space;
1321         $other = "" unless $other;    # I hate warnings. Thanks to jack velte...
1322         if ($blip =~ /^:/) {
1323                 push @stuff, $blip . $space . $other;
1324                 last;
1325         } else {
1326             push @stuff, $blip;
1327             $stuff = $other;
1328         }
1329     }
1330
1331     $from = substr $from, 1 if $from =~ /^:/;
1332
1333     return Net::IRC::Event->new( $type,
1334                                  $from,
1335                                  '',
1336                                  'server',
1337                                  @stuff );
1338 }
1339
1340 # -- #perl was here! --
1341 # <megas> heh, why are #windowsNT people so quiet? are they all blue screened?
1342 # <Hiro> they're busy flapping their arms and making swooshing jet noises
1343
1344
1345 # Helps you flee those hard-to-stand channels.
1346 # Takes at least one arg:  name(s) of channel(s) to leave.
1347 sub part {
1348     my $self = shift;
1349
1350     unless (@_) {
1351                 croak "No arguments provided to part()";
1352     }
1353     $self->sl("PART " . CORE::join(",", @_));    # "A must!"
1354 }
1355
1356
1357 # Tells what's on the other end of a connection. Returns a 2-element list
1358 # consisting of the name on the other end and the type of connection.
1359 # Takes no args.
1360 sub peer {
1361     my $self = shift;
1362
1363     return ($self->server(), "IRC connection");
1364 }
1365
1366
1367 # -- #perl was here! --
1368 # <thoth> We will have peace, when you and all your works have perished--
1369 #         and the works of your Dark Master, Mammon, to whom you would
1370 #         deliver us.  You are a strumpet, Fmh, and a corrupter of men's
1371 #         hearts.
1372 #   <Fmh> thoth, smile when you say that
1373 #   <Fmh> i'd much rather be thought of as a corrupter of women's hearts.
1374
1375
1376 # Prints a message to the defined error filehandle(s).
1377 # No further description should be necessary.
1378 sub printerr {
1379     shift;
1380     print STDERR @_, "\n";
1381 }
1382
1383
1384 # -- #perl was here! --
1385 # <_thoth> The hummer was like six feet up.
1386 # <_thoth> Humming.
1387 # <_thoth> The cat did this Flash trick.
1388 # <_thoth> And when the cat landed, there was a hummer in his mouth.
1389 # <_thoth> Once you see a cat pluck a hummer from the sky, you know why
1390 #          the dogs are scared.
1391
1392
1393 # Prints a message to the defined output filehandle(s).
1394 sub print {
1395     shift;
1396     print STDOUT @_, "\n";
1397 }
1398
1399 # Sends a message to a channel or person.
1400 # Takes 2 args:  the target of the message (channel or nick)
1401 #                the text of the message to send
1402 # Don't use this for sending CTCPs... that's what the ctcp() function is for.
1403 # The message will be chunked if it is longer than the _maxlinelen
1404 # attribute, but it doesn't try to protect against flooding.  If you
1405 # give it too much info, the IRC server will kick you off!
1406 sub privmsg {
1407     my ($self, $to) = splice @_, 0, 2;
1408
1409     unless (@_) {
1410         croak 'Not enough arguments to privmsg()';
1411     }
1412
1413     my $buf = CORE::join '', @_;
1414     my $length = $self->{_maxlinelen} - 11 - length($to);
1415     my $line;
1416
1417     # -- #perl was here! --
1418     #    <v0id_> i really haven't dug into Net::IRC yet.
1419     #    <v0id_> hell, i still need to figure out how to make it just say
1420     #            something on its current channel...
1421     #  <fimmtiu> $connection->privmsg('#channel', "Umm, hi.");
1422     #    <v0id_> but you have to know the channel already eh?
1423     #  <fimmtiu> Yes. This is how IRC works. :-)
1424     #    <v0id_> damnit, why can't everything be a default. :)
1425     # <happybob> v0id_: it can. you end up with things like a 1 button
1426     #            mouse then, though. :)
1427
1428     if (ref($to) =~ /^(GLOB|IO::Socket)/) {
1429         while($buf) {
1430             ($line, $buf) = unpack("a$length a*", $buf);
1431             send($to, $line . "\012", 0);
1432         }
1433     } else {
1434         while($buf) {
1435             ($line, $buf) = unpack("a$length a*", $buf);
1436             if (ref $to eq 'ARRAY') {
1437                 $self->sl("PRIVMSG ", CORE::join(',', @$to), " :$line");
1438             } else {
1439                 $self->sl("PRIVMSG $to :$line");
1440             }
1441         }
1442     }
1443 }
1444
1445
1446 # Closes connection to IRC server.  (Corresponding function for /QUIT)
1447 # Takes 1 optional arg:  parting message, defaults to "Leaving" by custom.
1448 sub quit {
1449     my $self = shift;
1450
1451     # Do any user-defined stuff before leaving
1452     $self->handler("leaving");
1453
1454     unless ( $self->connected ) {  return (1)  }
1455
1456     # Why bother checking for sl() errors now, after all?  :)
1457     # We just send the QUIT command and leave. The server will respond with
1458     # a "Closing link" message, and parse() will catch it, close the
1459     # connection, and throw a "disconnect" event. Neat, huh? :-)
1460
1461     $self->sl("QUIT :" . (defined $_[0] ? $_[0] : "Leaving"));
1462     return 1;
1463 }
1464
1465 # As per the RFC, ask the server to "re-read and process its configuration
1466 # file."  Your server may or may not take additional arguments.  Generally
1467 # requires IRCop status.
1468 sub rehash {
1469     my $self = shift;
1470     $self->sl("REHASH" . CORE::join(" ", @_));
1471 }
1472
1473
1474 # As per the RFC, "force a server restart itself."  (Love that RFC.)
1475 # Takes no arguments.  If it succeeds, you will likely be disconnected,
1476 # but I assume you already knew that.  This sub is too simple...
1477 sub restart {
1478     my $self = shift;
1479     $self->sl("RESTART");
1480 }
1481
1482 # Schedules an event to be executed after some length of time.
1483 # Takes at least 2 args:  the number of seconds to wait until it's executed
1484 #                         a coderef to execute when time's up
1485 # Any extra args are passed as arguments to the user's coderef.
1486 sub schedule {
1487     my ($self, $time, $code) = splice @_, 0, 3;
1488
1489     unless ($code) {
1490         croak 'Not enough arguments to Connection->schedule()';
1491     }
1492     unless (ref $code eq 'CODE') {
1493         croak 'Second argument to schedule() isn\'t a coderef';
1494     }
1495
1496     $time = time + int $time;
1497     $self->parent->queue($time, $code, $self, @_);
1498 }
1499
1500
1501 # -- #perl was here! --
1502 # <freeside> YOU V3GAN FIEND, J00 W1LL P4Y D3ARLY F0R TH1S TRESPASS!!!!!!!!!!!
1503 # <Netslave> be quiet freeside
1504 # <freeside> WE W1LL F0RCE PR0K DOWN YOUR V1RG1N THR0AT
1505 # <freeside> MAKE ME
1506 # <freeside> :-PPPPPPPPP
1507 # <freeside> FORCE IS THE LAST REFUGE OF THE WEAK
1508 # <freeside> I DIE, OH, HORATIO, I DIE!
1509 #    Che_Fox hugs freeside
1510 #  <initium> freeside (=
1511 #  <Che_Fox> I lurve you all :)
1512 #   freeside lashes himself to the M4ST.
1513 # <Netslave> freeside, why do you eat meat?
1514 # <freeside> 4NARCHY R00000LZ!!!!!  F1GHT TH3 P0W3R!!!!!!
1515 # <freeside> I 3AT M3AT S0 TH4T J00 D0N'T H4V3 TO!!!!!!!!!!!!
1516 # <freeside> I 3AT M3AT F0R J00000R SINS, NETSLAVE!!!!!!!!!!
1517 # <freeside> W0RSH1P M3333333!!!!!!!
1518 # *** t0fu (wasian@pm3l-12.pacificnet.net) joined #perl.
1519 #    Che_Fox giggles
1520 # *** t0fu (wasian@pm3l-12.pacificnet.net) left #perl.
1521 # <freeside> T0FU, MY SAV10UIRRRRRRRRRRRRR
1522 # <freeside> NOOOOOOOOOOOOOO
1523 # <freeside> COME BAAAAAAAAAACK
1524 #  <Che_Fox> no t0fu for you.
1525
1526
1527 # Lets J. Random IRCop connect one IRC server to another. How uninteresting.
1528 # Takes at least 1 arg:  the name of the server to connect your server with
1529 #            (optional)  the port to connect them on (default 6667)
1530 #            (optional)  the server to connect to arg #1. Used mainly by
1531 #                          servers to communicate with each other.
1532 sub sconnect {
1533     my $self = shift;
1534
1535     unless (@_) {
1536         croak "Not enough arguments to sconnect()";
1537     }
1538     $self->sl("CONNECT " . CORE::join(" ", @_));
1539 }
1540
1541 # Sets/changes the IRC server which this instance should connect to.
1542 # Takes 1 arg:  the name of the server (see below for possible syntaxes)
1543 #                                       ((syntaxen? syntaxi? syntaces?))
1544 sub server {
1545     my ($self) = shift;
1546
1547     if (@_)  {
1548         # cases like "irc.server.com:6668"
1549         if (index($_[0], ':') > 0) {
1550             my ($serv, $port) = split /:/, $_[0];
1551             if ($port =~ /\D/) {
1552                 carp "$port is not a valid port number in server()";
1553                 return;
1554             }
1555             $self->{_server} = $serv;
1556             $self->port($port);
1557
1558         # cases like ":6668"  (buried treasure!)
1559         } elsif (index($_[0], ':') == 0 and $_[0] =~ /^:(\d+)/) {
1560             $self->port($1);
1561
1562         # cases like "irc.server.com"
1563         } else {
1564             $self->{_server} = shift;
1565         }
1566         return (1);
1567
1568     } else {
1569         return $self->{_server};
1570     }
1571 }
1572
1573
1574 # Sends a raw IRC line to the server.
1575 # Corresponds to the internal sirc function of the same name.
1576 # Takes 1 arg:  string to send to server. (duh. :)
1577 sub sl {
1578     my $self = shift;
1579     my $line = CORE::join '', @_;
1580
1581     unless (@_) {
1582         croak "Not enough arguments to sl()";
1583     }
1584
1585     ### DEBUG DEBUG DEBUG
1586     if ($self->{_debug}) {
1587         print ">>> $line\n";
1588     }
1589
1590     # RFC compliance can be kinda nice...
1591     my $rv = send( $self->{_socket}, "$line\015\012", 0 );
1592     unless ($rv) {
1593         $self->handler("sockerror");
1594         return;
1595     }
1596     return $rv;
1597 }
1598
1599 # -- #perl was here! --
1600 #  <mandrake> the person at wendy's in front of me had a heart attack while
1601 #             I was at lunch
1602 #    <Stupid> mandrake:  Before or -after- they ate the food?
1603 #    <DrForr> mandrake: What did he have?
1604 #  <mandrake> DrForr: a big bacon classic
1605
1606 # Tells any server that you're an oper on to disconnect from the IRC network.
1607 # Takes at least 1 arg:  the name of the server to disconnect
1608 #            (optional)  a comment about why it was disconnected
1609 sub squit {
1610     my $self = shift;
1611
1612     unless (@_) {
1613         croak "Not enough arguments to squit()";
1614     }
1615
1616     $self->sl("SQUIT $_[0]" . ($_[1] ? " :$_[1]" : ""));
1617 }
1618
1619 # -- #perl was here! --
1620 # * QDeath is trying to compile a list of email addresses given a HUGE
1621 #      file of people's names... :)
1622 # <fimmtiu> Is this spam-related?
1623 #  <QDeath> no, actually, it's official school related.
1624 # <fimmtiu> Good. Was afraid I had been doing the devil's work for a second.
1625 # * Tkil sprinkles fimmtiu's terminal with holy water, just in case.
1626 # *** Signoff: billn (Fimmtiu is the devil's tool. /msg him and ask him
1627 #                     about it.)
1628 # *Fmh* are you the devil's "tool" ?
1629 # -> *fmh* Yep. All 6 feet of me.
1630
1631
1632 # Gets various server statistics for the specified host.
1633 # Takes at least 1 arg: the type of stats to request [chiklmouy]
1634 #            (optional) the server to request from (default is current server)
1635 sub stats {
1636     my $self = shift;
1637
1638     unless (@_) {
1639         croak "Not enough arguments passed to stats()";
1640     }
1641
1642     $self->sl("STATS $_[0]" . ($_[1] ? " $_[1]" : ""));
1643 }
1644
1645 # -- #perl was here! --
1646 # <Schwern> Wheat grass juice is properly served in a NyQuil sized cup, in
1647 #           a NyQuil sized color with a NyQuil sized flavor.
1648 #  <mendel> how big is nyquil's color
1649 #  <foobah> often wheat grass is served mixed in with other fruit juices
1650 #  <Sauvin> nyquil++
1651 # <Schwern> mendel:  As BIG AS THE FUCKIN' Q!
1652 # <yuckf00> this big <---------------------------------->
1653 #  <foobah> since by itself it can burn holes in your esophagus
1654
1655
1656
1657
1658 # If anyone still has SUMMON enabled, this will implement it for you.
1659 # If not, well...heh.  Sorry.  First arg mandatory: user to summon.
1660 # Second arg optional: a server name.
1661 sub summon {
1662     my $self = shift;
1663
1664     unless (@_) {
1665         croak "Not enough arguments passed to summon()";
1666     }
1667
1668     $self->sl("SUMMON $_[0]" . ($_[1] ? " $_[1]" : ""));
1669 }
1670
1671
1672 # -- #perl was here! --
1673 # <Sauvin>  Bigotry will never die.
1674 # <billn>   yes it will
1675 # <billn>   as soon as I'm allowed to buy weapons.
1676 # <Schwern> billn++
1677 # <rmah>    billn, baisc human nature has to change for bigotry to go away
1678 # <billn>   rmah: no, I just need bigger guns.
1679
1680
1681 # Requests timestamp from specified server. Easy enough, right?
1682 # Takes 1 optional arg:  a server name/mask to query
1683 sub time {
1684     my ($self, $serv) = (shift, undef);
1685
1686     $self->sl("TIME" . ($_[0] ? " $_[0]" : ""));
1687 }
1688
1689 # -- #perl was here! --
1690 #    <Murr> DrForr, presumably the tank crew *knew* how to swim, but not how
1691 #           to escape from a tank with open hatch that had turned on its roof
1692 #           before sinking.
1693 #  <DrForr> The tank flipped over -then- sank? Now that's rich.
1694 #  <arkuat> what is this about?  cisco is building tanks now?
1695 # <Winkola> arkuat: If they do, you can count on a lot of drowned newbie
1696 #           net admins.
1697 # <Winkola> "To report a drowning emergency, press 1, and hold for 27 minutes."
1698
1699
1700 # Sends request for current topic, or changes it to something else lame.
1701 # Takes at least 1 arg:  the channel whose topic you want to screw around with
1702 #            (optional)  the new topic you want to impress everyone with
1703 sub topic {
1704     my $self = shift;
1705
1706     unless (@_) {
1707         croak "Not enough arguments to topic()";
1708     }
1709
1710     # Can you tell I've been reading the Nethack source too much? :)
1711     $self->sl("TOPIC $_[0]" . ($_[1] ? " :$_[1]" : ""));
1712 }
1713
1714 # -- #perl was here! --
1715 # crimethnk: problem found.
1716 # crimethnk: log file was 2GB and i could not write to it anymore.
1717 # crimethnk: shit.  lost almost a week of stats.
1718 # vorsprung: crimethnk> i guess you'll have to rotate the logs more frequently
1719 # crimethnk: i usually rotate once a month.  i missed last month.
1720 # crimethnk: i thought i was pregnant.
1721
1722
1723 # Sends a trace request to the server. Whoop.
1724 # Take 1 optional arg:  the server or nickname to trace.
1725 sub trace {
1726     my $self = shift;
1727
1728     $self->sl("TRACE" . ($_[0] ? " $_[0]" : ""));
1729 }
1730
1731
1732 # -- #perl was here! --
1733 # <DragonFaX> Net::IRC is having my babies
1734 #   <fimmtiu> DragonFax: Damn, man! She told me the child was MINE!
1735 #  <Alpha232> Dragon: IRC has enough bastard children
1736 # <DragonFaX> IRC has enough bastards?
1737 #   <fimmtiu> New Frosted Lucky Bastards, they're magically delicious!
1738 #    <archon> they're after me lucky bastards!
1739
1740
1741 # Requests userhost info from the server.
1742 # Takes at least 1 arg: nickname(s) to look up.
1743 sub userhost {
1744     my $self = shift;
1745
1746     unless (@_) {
1747         croak 'Not enough args to userhost().';
1748     }
1749
1750     $self->sl("USERHOST " . CORE::join (" ", @_));
1751 }
1752
1753 # Sends a users request to the server, which may or may not listen to you.
1754 # Take 1 optional arg:  the server to query.
1755 sub users {
1756     my $self = shift;
1757
1758     $self->sl("USERS" . ($_[0] ? " $_[0]" : ""));
1759 }
1760
1761 # Asks the IRC server what version and revision of ircd it's running. Whoop.
1762 # Takes 1 optional arg:  the server name/glob. (default is current server)
1763 sub version {
1764     my $self = shift;
1765
1766     $self->sl("VERSION" . ($_[0] ? " $_[0]" : ""));
1767 }
1768
1769
1770 # -- #perl was here! --
1771 #    <vald> Does anyone know how to modify a perl server that accepts
1772 #           telnet to make it accept emails ?
1773 #  <TorgoX> vald -- do you know how to modify a car so that it has six
1774 #           legs, spins webs, and eats flies?
1775 # <Schwern> Does a "perl server" serve perl?
1776 #  <clintp> We all serve Perl.  Some days, it serves us.
1777
1778
1779 # Sends a message to all opers on the network. Hypothetically.
1780 # Takes 1 arg:  the text to send.
1781 sub wallops {
1782     my $self = shift;
1783
1784     unless ($_[0]) {
1785         croak 'No arguments passed to wallops()';
1786     }
1787
1788     $self->sl("WALLOPS :" . CORE::join("", @_));
1789 }
1790
1791 # Asks the server about stuff, you know. Whatever. Pass the Fritos, dude.
1792 # Takes 2 optional args:  the bit of stuff to ask about
1793 #                         an "o" (nobody ever uses this...)
1794 sub who {
1795     my $self = shift;
1796
1797     # Obfuscation!
1798     $self->sl("WHO" . (@_ ? " @_" : ""));
1799 }
1800
1801 # -- #perl was here! --
1802 #   <\lembit>  linda mccartney died yesterday, didn't she?
1803 # <q[merlyn]>  yes... she's dead.
1804 # <q[merlyn]>  WHY COULDN'T IT HAVE BEEN YOKO?
1805
1806
1807 # If you've gotten this far, you probably already know what this does.
1808 # Takes at least 1 arg:  nickmasks or channels to /whois
1809 sub whois {
1810     my $self = shift;
1811
1812     unless (@_) {
1813         croak "Not enough arguments to whois()";
1814     }
1815     return $self->sl("WHOIS " . CORE::join(",", @_));
1816 }
1817
1818 # -- #perl was here! --
1819 #      <dnm> Fmh - do you want to telnet to one box and then ssh to another?
1820 #      <Fmh> i realize an ssh proxy allows a man-in-the-middle attack.
1821 # <gargoyle> that sounds kinda pleasant right now
1822 #   gargoyle goes off to find a set of twins
1823 #  <amagosa> billn (=
1824
1825
1826 # Same as above, in the past tense.
1827 # Takes at least 1 arg:  nick to do the /whowas on
1828 #            (optional)  max number of hits to display
1829 #            (optional)  server or servermask to query
1830 sub whowas {
1831     my $self = shift;
1832
1833     unless (@_) {
1834         croak "Not enough arguments to whowas()";
1835     }
1836     return $self->sl("WHOWAS $_[0]" . ($_[1] ? " $_[1]" : "") .
1837                      (($_[1] && $_[2]) ? " $_[2]" : ""));
1838 }
1839
1840
1841 # -- #perl was here! --
1842 #   <veblen>  On the first day, God created Shrimp.
1843 # * thoth parries the shrimp penis.
1844 # * [petey rofls
1845 #   <veblen>  On the second day, God created cocktail sauce.
1846 # <URanalog>  "This is Chewbacca"
1847 #      <Fmh>  do not covet thy neighbor's shrimp.
1848 # * thoth pitches the shrimp penes on the barbie.
1849 #    <thoth>  UR: that's shrimp with penes, not shrimp with penne.
1850
1851
1852 # This sub executes the default action for an event with no user-defined
1853 # handlers. It's all in one sub so that we don't have to make a bunch of
1854 # separate anonymous subs stuffed in a hash.
1855 sub _default {
1856     my ($self, $event) = @_;
1857     my $verbose = $self->verbose;
1858
1859     # Users should only see this if the programmer (me) fucked up.
1860     unless ($event) {
1861         croak "You EEEEEDIOT!!! Not enough args to _default()!";
1862     }
1863
1864     # Reply to PING from server as quickly as possible.
1865     if ($event->type eq "ping") {
1866         $self->sl("PONG " . (CORE::join ' ', $event->args));
1867
1868     } elsif ($event->type eq "disconnect") {
1869
1870         # I violate OO tenets. (It's consensual, of course.)
1871         unless (keys %{$self->parent->{_connhash}} > 0) {
1872             die "No active connections left, exiting...\n";
1873         }
1874     }
1875
1876     return 1;
1877 }
1878
1879
1880
1881 # -- #perl was here! --
1882 #  <fimmtiu>  OK, once you've passed the point where caffeine no longer has
1883 #             any discernible effect on any part of your body but your
1884 #             bladder, it's time to sleep.
1885 #  <fimmtiu>  'Night, all.
1886 #    <regex>  Night, fimm
1887
1888 1;
1889
1890
1891 __END__
1892
1893 =head1 NAME
1894
1895 Net::IRC::Connection - Object-oriented interface to a single IRC connection
1896
1897 =head1 SYNOPSIS
1898
1899 Hard hat area: This section under construction.
1900
1901 =head1 DESCRIPTION
1902
1903 This documentation is a subset of the main Net::IRC documentation. If
1904 you haven't already, please "perldoc Net::IRC" before continuing.
1905
1906 Net::IRC::Connection defines a class whose instances are individual
1907 connections to a single IRC server. Several Net::IRC::Connection objects may
1908 be handled simultaneously by one Net::IRC object.
1909
1910 =head1 METHOD DESCRIPTIONS
1911
1912 This section is under construction, but hopefully will be finally written up
1913 by the next release. Please see the C<irctest> script and the source for
1914 details about this module.
1915
1916 =head1 AUTHORS
1917
1918 Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt> and
1919 Dennis Taylor E<lt>dennis@funkplanet.comE<gt>.
1920
1921 Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>.
1922
1923 Currently being hacked on, hacked up, and worked over by the members of the
1924 Net::IRC developers mailing list. For details, see
1925 http://www.execpc.com/~corbeau/irc/list.html .
1926
1927 =head1 URL
1928
1929 Up-to-date source and information about the Net::IRC project can be found at
1930 http://netirc.betterbox.net/ .
1931
1932 =head1 SEE ALSO
1933
1934 =over
1935
1936 =item *
1937
1938 perl(1).
1939
1940 =item *
1941
1942 RFC 1459: The Internet Relay Chat Protocol
1943
1944 =item *
1945
1946 http://www.irchelp.org/, home of fine IRC resources.
1947
1948 =back
1949
1950 =cut
1951