Net::IRC::DCC - Object-oriented interface to a single DCC connection

Net-IRC documentation Contained in the Net-IRC distribution.

Index

Code Index:

NAME

Top

Net::IRC::DCC - Object-oriented interface to a single DCC connection

SYNOPSIS

Top

Hard hat area: This section under construction.

DESCRIPTION

Top

This documentation is a subset of the main Net::IRC documentation. If you haven't already, please "perldoc Net::IRC" before continuing.

Net::IRC::DCC defines a few subclasses that handle DCC CHAT, GET, and SEND requests for inter-client communication. DCC objects are created by Connection->new_{chat,get,send}() in much the same way that IRC->newconn() creates a new connection object.

METHOD DESCRIPTIONS

Top

This section is under construction, but hopefully will be finally written up by the next release. Please see the irctest script and the source for details about this module.

AUTHORS

Top

Conceived and initially developed by Greg Bacon <gbacon@adtran.com> and Dennis Taylor <dennis@funkplanet.com>.

Ideas and large amounts of code donated by Nat "King" Torkington <gnat@frii.com>.

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 .

URL

Top

Up-to-date source and information about the Net::IRC project can be found at http://netirc.betterbox.net/ .

SEE ALSO

Top

Net-IRC documentation Contained in the Net-IRC distribution. 
#####################################################################
#                                                                   #
#   Net::IRC -- Object-oriented Perl interface to an IRC server     #
#                                                                   #
#   DCC.pm: An object for Direct Client-to-Client connections.      #
#                                                                   #
#          Copyright (c) 1997 Greg Bacon & Dennis Taylor.           #
#                       All rights reserved.                        #
#                                                                   #
#      This module is free software; you can redistribute or        #
#      modify it under the terms of Perl's Artistic License.        #
#                                                                   #
#####################################################################
# $Id: DCC.pm,v 1.1.1.1 2002/11/14 17:32:15 jmuhlich Exp $

package Net::IRC::DCC;

use strict;



# --- #perl was here! ---
#
# The comments scattered throughout this module are excerpts from a
# log saved from one particularly surreal night on #perl. Ahh, the
# trials of being young, single, and drunk...
#
# ---------------------
#           \merlyn has offered the shower to a randon guy he met in a bar.
#  fimmtiu: Shower?
#           \petey raises an eyebrow at \merlyn
#  \merlyn: but he seems like a nice trucker guy...
#   archon: you offered to shower with a random guy?


# Methods that can be shared between the various DCC classes.
package Net::IRC::DCC::Connection;

use Carp;
use Socket;  # need inet_ntoa...
use strict;

sub fixaddr {
    my ($address) = @_;

    chomp $address;     # just in case, sigh.
    if ($address =~ /^\d+$/) {
        return inet_ntoa(pack "N", $address);
    } elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) {
        return $address;
    } elsif ($address =~ tr/a-zA-Z//) {                    # Whee! Obfuscation!
        return inet_ntoa(((gethostbyname($address))[4])[0]);
    } else {
        return;
    }
}

sub bytes_in {
    return shift->{_bin};
}

sub bytes_out {
    return shift->{_bout};
}

sub nick {
    return shift->{_nick};
}

sub socket {
    return shift->{_socket};
}

sub time {
    return time - shift->{_time};
}

sub debug {
    return shift->{_debug};
}

# Changes here 1998-04-01 by MJD
# Optional third argument `$block'.
# If true, don't break the input into lines... just process it in blocks.
sub _getline {
    my ($self, $sock, $block) = @_;
    my ($input, $line);
    my $frag = $self->{_frag};

    if (defined $sock->recv($input, 10240)) {
	$frag .= $input;
	if (length($frag) > 0) {
	    
            warn "Got ". length($frag) ." bytes from $sock\n"
                if $self->{_debug};
            
	    if ($block) {          # Block mode (GET)
		return $input;
		
	    } else {               # Line mode (CHAT)
		# We're returning \n's 'cause DCC's need 'em
		my @lines = split /\012/, $frag, -1;
		$lines[-1] .= "\012";
		$self->{_frag} = ($frag !~ /\012$/) ? pop @lines : '';
		return (@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...
	    
            warn "recv() received 0 bytes in _getline, closing connection.\n"
                if $self->{_debug};
            
	    $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
							   $self->{_nick},
							   $self->{_socket},
							   $self->{_type}));
	    $self->{_parent}->parent->removefh($sock);
	    $self->{_socket}->close;
	    $self->{_fh}->close if $self->{_fh};
	    return;
	}
    } else {
	# Error, lets scrap this connection
	
        warn "recv() returned undef, socket error in _getline()\n"
            if $self->{_debug};
	
        $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
						       $self->{_nick},
						       $self->{_socket},
						       $self->{_type}));
	$self->{_parent}->parent->removefh($sock);
	$self->{_socket}->close;
	$self->{_fh}->close if $self->{_fh};
	return;
    }
}

sub DESTROY {
    my $self = shift;
    
    # Only do the Disconnection Dance of Death if the socket is still
    # live. Duplicate dcc_close events would be a Bad Thing.
    
    if ($self->{_socket}->opened) {
	$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
						       $self->{_nick},
						       $self->{_socket},
						       $self->{_type}));
	$self->{_socket}->close;
	close $self->{_fh} if $self->{_fh};
	$self->{_parent}->{_parent}->parent->removeconn($self);
    }
    
}

sub peer {
    return ( $_[0]->{_nick}, "DCC " . $_[0]->{_type} );
}

# -- #perl was here! --
#     orev: hehe...
# Silmaril: to, not with.
#   archon: heheh
# tmtowtdi: \merlyn will be hacked to death by a psycho
#   archon: yeah, but with is much more amusing


# Connection handling GETs
package Net::IRC::DCC::GET;

use IO::Socket;
use Carp;
use strict;

@Net::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection);

sub new {

    my ($class, $container, $nick, $address,
	$port, $size, $filename, $handle, $offset) = @_;
    my ($sock, $fh);

    # get the address into a dotted quad
    $address = &Net::IRC::DCC::Connection::fixaddr($address);
    return if $port < 1024 or not defined $address or $size < 1;

    $fh = defined $handle ? $handle : IO::File->new(">$filename");

    unless(defined $fh) {
        carp "Can't open $filename for writing: $!";
        $sock = new IO::Socket::INET( Proto    => "tcp",
				      PeerAddr => "$address:$port" ) and
        $sock->close();
        return;
    }

    binmode $fh;                     # I love this next line. :-)
    ref $fh eq 'GLOB' ? select((select($fh), $|++)[0]) : $fh->autoflush(1);
    
    $sock = new IO::Socket::INET( Proto    => "tcp",
				  PeerAddr => "$address:$port" );

    if (defined $sock) {
	$container->handler(Net::IRC::Event->new('dcc_open',
						 $nick,
						 $sock,
						 'get',
						 'get', $sock));
	
    } else {
        carp "Can't connect to $address: $!";
        close $fh;
        return;
    }
    
    $sock->autoflush(1);

    my $self = {
	_bin        =>  defined $offset ? $offset : 0, # bytes recieved so far
        _bout       =>  0,      # Bytes we've sent
        _connected  =>  1,
	_debug      =>  $container->debug,
        _fh         =>  $fh,    # FileHandle we will be writing to.
        _filename   =>  $filename,
	_frag       =>  '',
	_nick       =>  $nick,  # Nick of person on other end
        _parent     =>  $container,
        _size       =>  $size,  # Expected size of file
        _socket     =>  $sock,  # Socket we're reading from
        _time       =>  time, 
	_type       =>  'GET',
        };

    bless $self, $class;

    return $self;
}

# -- #perl was here! --
#  \merlyn: we were both ogling a bartender named arley
#  \merlyn: I mean carle
#  \merlyn: carly
# Silmaril: man merlyn
# Silmaril: you should have offered HER the shower.
#   \petey: all three of them?

sub parse {
    my ($self) = shift;

    my $line = $self->_getline($_[0], 'BLOCKS');

    next unless defined $line;
    unless(print {$self->{_fh}} $line) {
	carp ("Error writing to " . $self->{_filename} . ": $!");
	close $self->{_fh};
	$self->{_parent}->parent->removeconn($self);
	$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
						       $self->{_nick},
						       $self->{_socket},
						       $self->{_type}));
	$self->{_socket}->close;
	return;
    }
    
    $self->{_bin} += length($line);
    
    
    # confirm the packet we've just recieved
    unless ( $self->{_socket}->send( pack("N", $self->{_bin}) ) ) {
	carp "Error writing to DCC GET socket: $!";
	close $self->{_fh};
	$self->{_parent}->parent->removeconn($self);
	$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
						       $self->{_nick},
						       $self->{_socket},
						       $self->{_type}));
	$self->{_socket}->close;
	return;
    }
    
    $self->{_bout} += 4;

    # The file is done.
    # If we close the socket, the select loop gets screwy because
    # it won't remove its reference to the socket.
    if ( $self->{_size} and $self->{_size} <= $self->{_bin} ) {
        close $self->{_fh};
        $self->{_parent}->parent->removeconn($self);
        $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
                                                       $self->{_nick},
                                                       $self->{_socket},
                                                       $self->{_type}));
	$self->{_socket}->close;
        return;
    }
    
    $self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
                                                   $self->{_nick},
                                                   $self,
                                                   $self->{_type},
                                                   $self ));
}

sub filename {
    return shift->{_filename};
}

sub size {
    return shift->{_size};
}

sub close {
    my ($self, $sock) = @_;
    $self->{_fh}->close;
    $self->{_parent}->parent->removeconn($self);
    $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
                                                  $self->{_nick},
                                                  $self->{_socket},
                                                  $self->{_type}));
    $self->{_socket}->close;
    return;
}

# -- #perl was here! --
#  \merlyn: I can't type... she created a numbner of very good drinks
#  \merlyn: She's still at work
#           \petey resists mentioning that there's "No manual entry
#           for merlyn."
# Silmaril: Haven't you ever seen swingers?
#  \merlyn: she's off tomorrow... will meet me at the bar at 9:30
# Silmaril: AWWWWwwww yeeeaAAHH.
#   archon: waka chica waka chica


# Connection handling SENDs
package Net::IRC::DCC::SEND;
@Net::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection);

use IO::File;
use IO::Socket;
use Carp;
use strict;

sub new {

    my ($class, $container, $nick, $filename, $blocksize) = @_;
    my ($size, $port, $fh, $sock, $select);

    $blocksize ||= 1024;

    # Shell-safe DCC filename stuff. Trying to prank-proof this
    # module is rather difficult.
    $filename =~ tr/a-zA-Z.+0-9=&()[]%\-\\\/:,/_/c;
    $fh = new IO::File $filename;

    unless (defined $fh) {
        carp "Couldn't open $filename for reading: $!";
	return;
    }

    binmode $fh;
    $fh->seek(0, SEEK_END);
    $size = $fh->tell;
    $fh->seek(0, SEEK_SET);

    $sock = new IO::Socket::INET( Proto     => "tcp",
                                  Listen    => 1);

    unless (defined $sock) {
        carp "Couldn't open DCC SEND socket: $!";
        $fh->close;
        return;
    }    

    $container->ctcp('DCC SEND', $nick, $filename, 
                     unpack("N",inet_aton($container->hostname())),
		     $sock->sockport(), $size);

    $sock->autoflush(1);

    my $self = {
        _bin        =>  0,         # Bytes we've recieved thus far
        _blocksize  =>  $blocksize,       
        _bout       =>  0,         # Bytes we've sent
	_debug      =>  $container->debug,
        _fh         =>  $fh,       # FileHandle we will be reading from.
        _filename   =>  $filename,
	_frag       =>  '',
	_nick       =>  $nick,
        _parent     =>  $container,
        _size       =>  $size,     # Size of file
        _socket     =>  $sock,     # Socket we're writing to
        _time       =>  0,         # This gets set by Accept->parse() 
	_type       =>  'SEND',
    };

    bless $self, $class;
    
    $sock = Net::IRC::DCC::Accept->new($sock, $self);

    unless (defined $sock) {
        carp "Error in accept: $!";
        $fh->close;
        return;
    }

    return $self;
}

# -- #perl was here! --
#  fimmtiu: So a total stranger is using your shower?
#  \merlyn: yes... a total stranger is using my hotel shower
#           Stupid coulda sworn \merlyn was married...
#   \petey: and you have a date.
#  fimmtiu: merlyn isn't married.
#   \petey: not a bad combo......
#  \merlyn: perhaps a adate
#  \merlyn: not maerried
#  \merlyn: not even sober. --)

sub parse {
    my ($self, $sock) = @_;
    my $size = ($self->_getline($sock, 1))[0];
    my $buf;

    # i don't know how useful this is, but let's stay consistent
    $self->{_bin} += 4;

    unless (defined $size) {
	# Dang! The other end unexpectedly canceled.
        carp (($self->peer)[1] . " connection to " .
	      ($self->peer)[0] . " lost");
	$self->{_fh}->close;
	$self->{_parent}->parent->removefh($sock);
        $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
						       $self->{_nick},
						       $self->{_socket},
						       $self->{_type}));
	$self->{_socket}->close;
	return;
    }
    
    $size = unpack("N", $size);
    
    if ($size >= $self->{_size}) {

	if ($self->{_debug}) {
	    warn "Other end acknowledged entire file ($size >= ",
		$self->{_size}, ")";
	}
        # they've acknowledged the whole file,  we outtie
        $self->{_fh}->close;
        $self->{_parent}->parent->removeconn($self);
        $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
						       $self->{_nick},
						       $self->{_socket},
						       $self->{_type}));
	$self->{_socket}->close;
        return;
    } 

    # we're still waiting for acknowledgement, 
    # better not send any more
    return if $size < $self->{_bout};

    unless (defined $self->{_fh}->read($buf,$self->{_blocksize})) {

	if ($self->{_debug}) {
	    warn "Failed to read from source file in DCC SEND!";
	}
	$self->{_fh}->close;
        $self->{_parent}->parent->removeconn($self);
	$self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
						       $self->{_nick},
						       $self->{_socket},
						       $self->{_type}));
	$self->{_socket}->close;
        return;
    }

    unless($self->{_socket}->send($buf)) {

	if ($self->{_debug}) {
	    warn "send() failed horribly in DCC SEND"
	}
        $self->{_fh}->close;
        $self->{_parent}->parent->removeconn($self);
        $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
						       $self->{_nick},
						       $self->{_socket},
						       $self->{_type}));
	$self->{_socket}->close;
	return;
    }

    $self->{_bout} += length($buf);

    $self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
						   $self->{_nick},
						   $self,
						   $self->{_type},
						   $self ));
    
    return 1;
}

# -- #perl was here! --
#  fimmtiu: Man, merlyn, you must be drunk to type like that. :)
#  \merlyn: too many longislands.
#  \merlyn: she made them strong
#   archon: it's a plot
#  \merlyn: not even a good amoun tof coke
#   archon: she's in league with the guy in your shower
#   archon: she gets you drunk and he takes your wallet!


# handles CHAT connections
package Net::IRC::DCC::CHAT;
@Net::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection);

use IO::Socket;
use Carp;
use strict;

sub new {

    my ($class, $container, $type, $nick, $address, $port) = @_;
    my ($sock, $self);

    if ($type) {
        # we're initiating

        $sock = new IO::Socket::INET( Proto     => "tcp",
                                      Listen    => 1);
	
        unless (defined $sock) {
            carp "Couldn't open DCC CHAT socket: $!";
            return;
        }

	$sock->autoflush(1);
        $container->ctcp('DCC CHAT', $nick, 'chat',
                         unpack("N",inet_aton($container->hostname)),
						        $sock->sockport());

	$self = {
	    _bin        =>  0,      # Bytes we've recieved thus far
	    _bout       =>  0,      # Bytes we've sent
	    _connected  =>  1,
	    _debug      =>  $container->debug,
	    _frag       =>  '',
	    _nick       =>  $nick,  # Nick of the client on the other end
	    _parent     =>  $container,
	    _socket     =>  $sock,  # Socket we're reading from
	    _time       =>  0,      # This gets set by Accept->parse()
	    _type       =>  'CHAT',
	};
	
	bless $self, $class;
	
        $sock = Net::IRC::DCC::Accept->new($sock, $self);

	unless (defined $sock) {
	    carp "Error in DCC CHAT connect: $!";
	    return;
	}

    } else {      # we're connecting

        $address = &Net::IRC::DCC::Connection::fixaddr($address);
	return if $port < 1024 or not defined $address;

        $sock = new IO::Socket::INET( Proto    => "tcp",
				      PeerAddr => "$address:$port");

        if (defined $sock) {
	    $container->handler(Net::IRC::Event->new('dcc_open',
						     $nick,
						     $sock,
						     'chat',
						     'chat', $sock));
	} else {
	    carp "Error in DCC CHAT connect: $!";
	    return;
	}

	$sock->autoflush(1);

	$self = {
	    _bin        =>  0,      # Bytes we've recieved thus far
	    _bout       =>  0,      # Bytes we've sent
	    _connected  =>  1,
	    _nick       =>  $nick,  # Nick of the client on the other end
	    _parent     =>  $container,
	    _socket     =>  $sock,  # Socket we're reading from
	    _time       =>  time,
	    _type       =>  'CHAT',
	};
	
	bless $self, $class;
	
	$self->{_parent}->parent->addfh($self->socket,
					$self->can('parse'), 'r', $self);
    }

    return $self;
}

# -- #perl was here! --
#  \merlyn: tahtd be coole
#           KTurner bought the camel today, so somebody can afford one
#           more drink... ;)
# tmtowtdi: I've heard of things like this...
#  \merlyn: as an experience. that is.
#   archon: i can think of cooler things (;
#  \merlyn: I don't realiy have that mch in my wallet.

sub parse {
    my ($self, $sock) = @_;

    foreach my $line ($self->_getline($sock)) {
	return unless defined $line;
    
	$self->{_bin} += length($line);
	
	return undef if $line eq "\012";
	$self->{_bout} += length($line);

	$self->{_parent}->handler(Net::IRC::Event->new('chat',
						       $self->{_nick},
						       $self->{_socket},
						       'chat',
						       $line));
	
	$self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
						       $self->{_nick},
						       $self,
						       $self->{_type},
						       $self ));
    }
}

# Sends a message to a channel or person.
# Takes 2 args:  the target of the message (channel or nick)
#                the text of the message to send
sub privmsg {
    my ($self) = shift;

    unless (@_) {
	croak 'Not enough arguments to privmsg()';
    }
    
    # Don't send a CR over DCC CHAT -- it's not wanted.
    $self->socket->send(join('', @_) . "\012");
}


# -- #perl was here! --
#  \merlyn: this girl carly at the bar is aBABE
#   archon: are you sure? you don't sound like you're in a condition to
#           judge such things (;
# *** Stupid has set the topic on channel #perl to \merlyn is shit-faced
#     with a trucker in the shower.
# tmtowtdi: uh, yeah...
#  \merlyn: good topic


# Sockets waiting for accept() use this to shoehorn into the select loop.
package Net::IRC::DCC::Accept;

@Net::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection);
use Carp;
use Socket;   # we use a lot of Socket functions in parse()
use strict;


sub new {
    my ($class, $sock, $parent) = @_;
    my ($self);

    $self = { _debug    =>  $parent->debug,
	      _nonblock =>  1,
	      _socket   =>  $sock,
	      _parent   =>  $parent,
	      _type     =>  'accept',
	  };
    
    bless $self, $class;

    # Tkil's gonna love this one. :-)   But what the hell... it's safe to
    # assume that the only thing initiating DCCs will be Connections, right?
    # Boy, we're not built for extensibility, I guess. Someday, I'll clean
    # all of the things like this up.
    $self->{_parent}->{_parent}->parent->addconn($self);
    return $self;
}

sub parse {
    my ($self) = shift;
    my ($sock);

    $sock = $self->{_socket}->accept;
    $self->{_parent}->{_socket} = $sock;
    $self->{_parent}->{_time} = time;

    if ($self->{_parent}->{_type} eq 'SEND') {
	# ok, to get the ball rolling, we send them the first packet.
	my $buf;
	unless (defined $self->{_parent}->{_fh}->
		read($buf, $self->{_parent}->{_blocksize})) {
	    return;
	}
	unless (defined $sock->send($buf)) {
	    $sock->close;
	    $self->{_parent}->{_fh}->close;
	    $self->{_parent}->{_parent}->parent->removefh($sock);
	    $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
							   $self->{_nick},
							   $self->{_socket},
							   $self->{_type}));
	    $self->{_socket}->close;
	    return;
	}
    }
    
    $self->{_parent}->{_parent}->parent->addconn($self->{_parent});
    $self->{_parent}->{_parent}->parent->removeconn($self);

    $self->{_parent}->{_parent}->handler(Net::IRC::Event->
					 new('dcc_open',
					     $self->{_parent}->{_nick},
					     $self->{_parent}->{_socket},
					     $self->{_parent}->{_type},
					     $self->{_parent}->{_type},
					     $self->{_parent}->{_socket})
					 );
}



1;


__END__