Net::IRC::DCC

Discussion in 'Perl Misc' started by n1zerd, Oct 14, 2003.

  1. n1zerd

    n1zerd Guest

    Does anyone know what the code should look like under Net::IRC::DCC::CHAT to add a close sub, so that I can allow a program to close a dcc chat session when it wants to?

    This is what Net::IRC::DCC::GET has, but I don't think it works for CHAT...if it does, I can't figure out the syntax in the program that calls it then...so far the whole program quits when trying to call this when pasted under CHAT...

    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;
    }



    here's the whole module DCC module:

    #####################################################################
    # #
    # 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__

    =head1 NAME

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

    =head1 SYNOPSIS

    Hard hat area: This section under construction.

    =head1 DESCRIPTION

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

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

    =head1 METHOD DESCRIPTIONS

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

    =head1 AUTHORS

    Conceived and initially developed by Greg Bacon E<lt><gt> and
    Dennis Taylor E<lt><gt>.

    Ideas and large amounts of code donated by Nat "King" Torkington E<lt><gt>.

    Currently being hacked on, hacked up, and worked over by the members of the
    Net::IRC developers mailing list. For details, see
    http://www.execpc.com/~corbeau/irc/list.html .

    =head1 URL

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

    =head1 SEE ALSO

    =over

    =item *

    perl(1).

    =item *

    RFC 1459: The Internet Relay Chat Protocol

    =item *

    http://www.irchelp.org/, home of fine IRC resources.

    =back

    =cut
    n1zerd, Oct 14, 2003
    #1
    1. Advertising

Want to reply to this thread or ask your own question?

It takes just 2 minutes to sign up (and it's free!). Just click the sign up button to choose a username and then you can ask your own questions on the forum.
Similar Threads
  1. vb asp.net IRC client test

    , Oct 5, 2004, in forum: ASP .Net
    Replies:
    0
    Views:
    1,314
  2. Daves
    Replies:
    3
    Views:
    5,587
  3. Wes James
    Replies:
    0
    Views:
    344
    Wes James
    Feb 17, 2010
  4. Anders K. Madsen

    ANNOUNCE: #ruby.dk @ irc.freenode.net

    Anders K. Madsen, Jul 19, 2004, in forum: Ruby
    Replies:
    0
    Views:
    78
    Anders K. Madsen
    Jul 19, 2004
  5. Ceil

    DCC Chat in irssi.

    Ceil, May 23, 2007, in forum: Perl Misc
    Replies:
    0
    Views:
    109
Loading...

Share This Page