mirror of
https://github.com/pragma-/pbot.git
synced 2024-12-25 04:02:37 +01:00
856 lines
25 KiB
Perl
856 lines
25 KiB
Perl
#####################################################################
|
|
# #
|
|
# 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 PBot::IRC::DCC; # pragma_ 2011/21/01
|
|
|
|
use strict;
|
|
|
|
use feature 'unicode_strings';
|
|
|
|
# --- #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 PBot::IRC::DCC::Connection; # pragma_ 2011/21/01
|
|
|
|
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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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 PBot::IRC::DCC::GET; # pragma_ 2011/21/01
|
|
|
|
use IO::Socket;
|
|
use Carp;
|
|
use strict;
|
|
|
|
@PBot::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
|
|
|
sub new {
|
|
|
|
my (
|
|
$class, $container, $nick, $address,
|
|
$port, $size, $filename, $handle, $offset
|
|
) = @_;
|
|
my ($sock, $fh);
|
|
|
|
# get the address into a dotted quad
|
|
$address = &PBot::IRC::DCC::Connection::fixaddr($address); # pragma_ 2011/21/01
|
|
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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_open', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$self->{_nick},
|
|
$self->{_socket},
|
|
$self->{_type}
|
|
)
|
|
);
|
|
$self->{_socket}->close;
|
|
return;
|
|
}
|
|
|
|
$self->{_parent}->handler(
|
|
PBot::IRC::Event->new(
|
|
'dcc_update', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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 PBot::IRC::DCC::SEND; # pragma_ 2011/21/01
|
|
@PBot::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
|
|
|
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 = PBot::IRC::DCC::Accept->new($sock, $self); # pragma_ 2011/21/01
|
|
|
|
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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$self->{_nick},
|
|
$self->{_socket},
|
|
$self->{_type}
|
|
)
|
|
);
|
|
$self->{_socket}->close;
|
|
return;
|
|
}
|
|
|
|
$self->{_bout} += length($buf);
|
|
|
|
$self->{_parent}->handler(
|
|
PBot::IRC::Event->new(
|
|
'dcc_update', # pragma_ 2011/21/01
|
|
$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 PBot::IRC::DCC::CHAT; # pragma_ 2011/21/01
|
|
@PBot::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
|
|
|
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 = PBot::IRC::DCC::Accept->new($sock, $self); # pragma_ 2011/21/01
|
|
|
|
unless (defined $sock) {
|
|
carp "Error in DCC CHAT connect: $!";
|
|
return;
|
|
}
|
|
|
|
} else { # we're connecting
|
|
$address = &PBot::IRC::DCC::Connection::fixaddr($address); # pragma_ 2011/21/01
|
|
return if $port < 1024 or not defined $address;
|
|
|
|
$sock = new IO::Socket::INET(
|
|
Proto => "tcp",
|
|
PeerAddr => "$address:$port"
|
|
);
|
|
|
|
if (defined $sock) {
|
|
$container->handler(
|
|
PBot::IRC::Event->new(
|
|
'dcc_open', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event->new(
|
|
'chat', # pragma_ 2011/21/01
|
|
$self->{_nick},
|
|
$self->{_socket},
|
|
'chat',
|
|
$line
|
|
)
|
|
);
|
|
|
|
$self->{_parent}->handler(
|
|
PBot::IRC::Event->new(
|
|
'dcc_update', # pragma_ 2011/21/01
|
|
$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 PBot::IRC::DCC::Accept; # pragma_ 2011/21/01
|
|
|
|
@PBot::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection); # pragma_ 2011/21/01
|
|
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(
|
|
PBot::IRC::Event->new(
|
|
'dcc_close', # pragma_ 2011/21/01
|
|
$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(
|
|
PBot::IRC::Event-> # pragma_ 2011/21/01
|
|
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
|