summaryrefslogtreecommitdiffstats
path: root/Net/IRC/DCC.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Net/IRC/DCC.pm')
-rw-r--r--Net/IRC/DCC.pm808
1 files changed, 0 insertions, 808 deletions
diff --git a/Net/IRC/DCC.pm b/Net/IRC/DCC.pm
deleted file mode 100644
index eccbba3..0000000
--- a/Net/IRC/DCC.pm
+++ /dev/null
@@ -1,808 +0,0 @@
-#####################################################################
-# #
-# 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>gbacon@adtran.comE<gt> and
-Dennis Taylor E<lt>dennis@funkplanet.comE<gt>.
-
-Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<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
generated by cgit v1.2.3 (git 2.46.0) at 2026-01-28 12:08:36 +0000