our
$AUTHORITY
=
'cpan:HINRIK'
;
$POE::Component::IRC::Plugin::DCC::VERSION
=
'6.93'
;
use
POE
qw(Driver::SysRW Filter::Line Filter::Stream
Wheel::ReadWrite Wheel::SocketFactory)
;
use
Socket
qw(INADDR_ANY unpack_sockaddr_in inet_aton inet_ntoa)
;
OUT_BLOCKSIZE
=> 1024,
IN_BLOCKSIZE
=> 10_240,
LISTEN_TIMEOUT
=> 300,
};
sub
new {
my
(
$package
) =
shift
;
croak
"$package requires an even number of arguments"
if
@_
& 1;
my
%self
=
@_
;
return
bless
\
%self
,
$package
;
}
sub
PCI_register {
my
(
$self
,
$irc
) =
@_
;
$self
->{irc} =
$irc
;
POE::Session->create(
object_states
=> [
$self
=> [
qw(
_start
_dcc_read
_dcc_failed
_dcc_timeout
_dcc_up
_U_dcc
_U_dcc_accept
_U_dcc_chat
_U_dcc_close
_U_dcc_resume
_cancel_timeout
)
],
],
);
$irc
->plugin_register(
$self
,
'SERVER'
,
qw(disconnected dcc_request)
);
$irc
->plugin_register(
$self
,
'USER'
,
qw(dcc dcc_accept dcc_chat dcc_close dcc_resume)
);
return
1;
}
sub
PCI_unregister {
my
(
$self
) =
@_
;
delete
$self
->{irc};
delete
$self
->{
$_
}
for
qw(wheelmap dcc)
;
$poe_kernel
->refcount_decrement(
$self
->{session_id}, __PACKAGE__);
return
1;
}
sub
_start {
my
(
$kernel
,
$self
) =
@_
[KERNEL, OBJECT];
$self
->{session_id} =
$_
[SESSION]->ID();
$kernel
->refcount_increment(
$self
->{session_id}, __PACKAGE__);
return
;
}
sub
dccports {
my
(
$self
,
$value
) =
@_
;
$self
->{dccports} =
$value
;
return
;
}
sub
nataddr {
my
(
$self
,
$value
) =
@_
;
$self
->{nataddr} =
$value
;
return
;
}
sub
dcc_info {
my
(
$self
,
$id
) =
@_
;
if
(!
$self
->{dcc}->{
$id
}) {
warn
"dcc_info: Unknown wheel ID: $id\n"
;
return
;
}
my
%info
;
@info
{
qw(nick type port file size done peeraddr)
}
= @{
$self
->{dcc}->{
$id
} }{
qw(
nick type port file size done peeraddr
)
};
return
\
%info
;
}
sub
_quote_file {
my
(
$file
) =
@_
;
if
(
$file
=~ /[\s"]/) {
$file
=~ s|
"|\\"
|g;
$file
=
qq{"$file"}
;
}
return
$file
;
}
sub
S_disconnected {
my
(
$self
) =
$_
;
delete
$self
->{resuming};
return
PCI_EAT_NONE;
}
sub
S_dcc_request {
my
(
$self
,
$irc
) =
splice
@_
, 0, 2;
my
(
$user
,
$type
,
$port
,
$cookie
,
$file
,
$size
) =
map
{
ref
=~ /REF|SCALAR/ && ${
$_
} }
@_
;
my
$nick
= (
split
/!/,
$user
)[0];
if
(
$type
eq
'ACCEPT'
&&
$self
->{resuming}->{
"$port+$nick"
}) {
my
$old_cookie
=
delete
$self
->{resuming}->{
"$port+$nick"
};
$irc
->yield(
dcc_accept
=>
$old_cookie
);
}
elsif
(
$type
eq
'RESUME'
) {
for
my
$cookie
(
values
%{
$self
->{dcc} }) {
next
if
$cookie
->{nick} ne
$nick
;
next
if
$cookie
->{port} ne
$port
;
$file
= _quote_file(
$file
);
$cookie
->{done} =
$size
;
$irc
->yield(
ctcp
=>
$nick
=>
"DCC ACCEPT $file $port $size"
);
last
;
}
}
return
PCI_EAT_NONE;
}
sub
_default {
my
(
$self
,
$irc
,
$event
) =
splice
@_
, 0, 3;
return
PCI_EAT_NONE
if
$event
!~ /^U_dcc(?:_accept|_chat|_close|_resume)?$/;
$event
=~ s/^U_/_U_/;
pop
@_
;
my
@args
=
map
{
$$_
}
@_
;
$poe_kernel
->call(
$self
->{session_id},
$event
,
@args
);
return
PCI_EAT_NONE;
}
sub
_U_dcc {
my
(
$kernel
,
$self
,
$nick
,
$type
,
$file
,
$blocksize
,
$timeout
)
=
@_
[KERNEL, OBJECT, ARG0..
$#_
];
if
(!
defined
$type
) {
warn
"The 'dcc' command requires at least two arguments\n"
;
return
;
}
my
$irc
=
$self
->{irc};
my
(
$bindport
,
$bindaddr
,
$factory
,
$port
,
$addr
,
$size
);
$type
=
uc
$type
;
if
(
$type
eq
'CHAT'
) {
$file
=
'chat'
;
}
elsif
(
$type
eq
'SEND'
) {
if
(!
defined
$file
) {
warn
"The 'dcc' command requires three arguments for a SEND\n"
;
return
;
}
$file
= rel2abs(bsd_glob(
$file
));
$size
= (
stat
$file
)[7];
if
(!
defined
$size
) {
$irc
->send_event(
'irc_dcc_error'
,
undef
,
"Couldn't get ${file}'s size: $!"
,
$nick
,
$type
,
undef
,
$file
,
);
return
;
}
}
$bindaddr
=
$irc
->localaddr();
if
(
$self
->{dccports}) {
$bindport
=
shift
@{
$self
->{dccports} };
if
(!
defined
$bindport
) {
warn
"dcc: Can't allocate listen port for DCC $type\n"
;
return
;
}
}
$factory
= POE::Wheel::SocketFactory->new(
BindAddress
=>
$bindaddr
|| INADDR_ANY,
BindPort
=>
$bindport
,
SuccessEvent
=>
'_dcc_up'
,
FailureEvent
=>
'_dcc_failed'
,
Reuse
=>
'yes'
,
);
(
$port
,
$addr
) = unpack_sockaddr_in(
$factory
->
getsockname
());
$addr
= inet_aton(
$self
->{nataddr})
if
$self
->{nataddr};
if
(!
defined
$addr
) {
warn
"dcc: Can't determine our IP address! ($!)\n"
;
return
;
}
$addr
=
unpack
'N'
,
$addr
;
my
$basename
= fileparse(
$file
);
$basename
= _quote_file(
$basename
);
$irc
->yield(
ctcp
=>
$nick
=>
"DCC $type $basename $addr $port"
. (
$size
?
" $size"
:
''
));
my
$alarm_id
=
$kernel
->delay_set(
'_dcc_timeout'
, (
$timeout
|| LISTEN_TIMEOUT),
$factory
->ID,
);
$self
->{dcc}->{
$factory
->ID } = {
open
=> 0,
nick
=>
$nick
,
type
=>
$type
,
file
=>
$file
,
size
=>
$size
,
port
=>
$port
,
addr
=>
$addr
,
done
=> 0,
blocksize
=> (
$blocksize
|| OUT_BLOCKSIZE),
listener
=> 1,
factory
=>
$factory
,
alarm_id
=>
$alarm_id
,
};
return
;
}
sub
_U_dcc_accept {
my
(
$self
,
$cookie
,
$myfile
) =
@_
[OBJECT, ARG0, ARG1];
if
(!
defined
$cookie
) {
warn
"The 'dcc_accept' command requires at least one argument\n"
;
return
;
}
if
(
$cookie
->{type} eq
'SEND'
) {
$cookie
->{type} =
'GET'
;
$cookie
->{file} =
$myfile
if
defined
$myfile
;
}
my
$factory
= POE::Wheel::SocketFactory->new(
RemoteAddress
=>
sprintf
(
"%vd"
,
pack
(
"N"
,
$cookie
->{addr})),
RemotePort
=>
$cookie
->{port},
SuccessEvent
=>
'_dcc_up'
,
FailureEvent
=>
'_dcc_failed'
,
);
$self
->{dcc}->{
$factory
->ID} =
$cookie
;
$self
->{dcc}->{
$factory
->ID}->{factory} =
$factory
;
return
;
}
sub
_U_dcc_chat {
my
(
$self
,
$id
,
@data
) =
@_
[OBJECT, ARG0..
$#_
];
if
(!
defined
$id
|| !
@data
) {
warn
"The 'dcc_chat' command requires at least two arguments\n"
;
return
;
}
if
(!
exists
$self
->{dcc}->{
$id
}) {
warn
"dcc_chat: Unknown wheel ID: $id\n"
;
return
;
}
if
(!
exists
$self
->{dcc}->{
$id
}->{wheel}) {
warn
"dcc_chat: No DCC wheel for id $id!\n"
;
return
;
}
if
(
$self
->{dcc}->{
$id
}->{type} ne
'CHAT'
) {
warn
"dcc_chat: id $id isn't associated with a DCC CHAT connection!\n"
;
return
;
}
$self
->{dcc}->{
$id
}->{wheel}->put(
join
"\n"
,
@data
);
return
;
}
sub
_U_dcc_close {
my
(
$kernel
,
$self
,
$id
) =
@_
[KERNEL, OBJECT, ARG0];
my
$irc
=
$self
->{irc};
if
(!
defined
$id
) {
warn
"The 'dcc_close' command requires an id argument\n"
;
return
;
}
if
(!
exists
$self
->{dcc}->{
$id
}) {
warn
"dcc_close: Unknown wheel ID: $id\n"
;
return
;
}
if
(!
exists
$self
->{dcc}->{
$id
}->{wheel}) {
warn
"dcc_close: No DCC wheel for id $id!\n"
;
return
;
}
if
(
$self
->{dcc}->{
$id
}->{wheel}->get_driver_out_octets()) {
$kernel
->delay_set(
_U_dcc_close
=> 2,
$id
);
return
;
}
$irc
->send_event(
'irc_dcc_done'
,
$id
,
@{
$self
->{dcc}->{
$id
} }{
qw(
nick type port file size done peeraddr
)
},
);
if
(
$self
->{dcc}->{
$id
}->{listener} &&
$self
->{dccports}) {
push
( @{
$self
->{dccports} },
$self
->{dcc}->{
$id
}->{port} );
}
$self
->_remove_dcc(
$id
);
return
;
}
sub
_U_dcc_resume {
my
(
$self
,
$cookie
,
$myfile
) =
@_
[OBJECT, ARG0, ARG1];
my
$irc
=
$self
->{irc};
my
$sender_file
= _quote_file(
$cookie
->{file});
$cookie
->{file} =
$myfile
if
defined
$myfile
;
$cookie
->{done} = -s
$cookie
->{file};
$cookie
->{resuming} = 1;
if
(
open
(
my
$handle
,
'>>'
,
$cookie
->{file})) {
$irc
->yield(
ctcp
=>
$cookie
->{nick} =>
"DCC RESUME $sender_file $cookie->{port} $cookie->{done}"
);
$self
->{resuming}->{
"$cookie->{port}+$cookie->{nick}"
} =
$cookie
;
}
else
{
warn
"dcc_resume: Can't append to file '$cookie->{file}'\n"
;
return
;
}
return
;
}
sub
_dcc_read {
my
(
$kernel
,
$self
,
$data
,
$id
) =
@_
[KERNEL, OBJECT, ARG0, ARG1];
my
$irc
=
$self
->{irc};
$id
=
$self
->{wheelmap}->{
$id
};
if
(
$self
->{dcc}{
$id
}{alarm_id}) {
$kernel
->call(
$self
->{session_id},
'_cancel_timeout'
,
$id
);
}
if
(
$self
->{dcc}->{
$id
}->{type} eq
'GET'
) {
print
{
$self
->{dcc}->{
$id
}->{fh}}
$data
;
$self
->{dcc}->{
$id
}->{done} +=
length
$data
;
$self
->{dcc}->{
$id
}->{wheel}->put(
pack
'N'
,
$self
->{dcc}->{
$id
}->{done}
);
$irc
->send_event(
'irc_dcc_get'
,
$id
,
@{
$self
->{dcc}->{
$id
} }{
qw(
nick port file size done peeraddr
)
},
);
}
elsif
(
$self
->{dcc}->{
$id
}->{type} eq
'SEND'
) {
$self
->{dcc}->{
$id
}->{done} =
unpack
'N'
,
substr
(
$data
, -4 );
$irc
->send_event(
'irc_dcc_send'
,
$id
,
@{
$self
->{dcc}->{
$id
} }{
qw(
nick port file size done peeraddr
)
},
);
if
(
$self
->{dcc}->{
$id
}->{done} >=
$self
->{dcc}->{
$id
}->{size}) {
if
(
$self
->{dcc}->{
$id
}->{listener} &&
$self
->{dccports}) {
push
@{
$self
->{dccports} },
$self
->{dcc}->{
$id
}->{port};
}
$irc
->send_event(
'irc_dcc_done'
,
$id
,
@{
$self
->{dcc}->{
$id
} }{
qw(
nick type port file size done peeraddr
)
},
);
$self
->_remove_dcc(
$id
);
return
;
}
read
$self
->{dcc}->{
$id
}->{fh},
$data
,
$self
->{dcc}->{
$id
}->{blocksize};
$self
->{dcc}->{
$id
}->{wheel}->put(
$data
);
}
else
{
$irc
->send_event(
'irc_dcc_'
.
lc
$self
->{dcc}->{
$id
}->{type},
$id
,
@{
$self
->{dcc}->{
$id
} }{
qw(nick port)
},
$data
,
$self
->{dcc}->{
$id
}->{peeraddr},
);
}
return
;
}
sub
_dcc_failed {
my
(
$self
,
$operation
,
$errnum
,
$errstr
,
$id
) =
@_
[OBJECT, ARG0 .. ARG3];
my
$irc
=
$self
->{irc};
if
(!
exists
$self
->{dcc}->{
$id
}) {
if
(
exists
$self
->{wheelmap}->{
$id
}) {
$id
=
$self
->{wheelmap}->{
$id
};
}
else
{
warn
"_dcc_failed: Unknown wheel ID: $id\n"
;
return
;
}
}
if
(
$self
->{dcc}->{
$id
}->{listener} &&
$self
->{dccports}) {
push
( @{
$self
->{dccports} },
$self
->{dcc}->{
$id
}->{port} );
}
DCC: {
last
DCC
if
$errnum
!= 0;
if
(
$self
->{dcc}->{
$id
}->{type} eq
'GET'
) {
if
(
$self
->{dcc}->{
$id
}->{done} <
$self
->{dcc}->{
$id
}->{size}) {
last
DCC;
}
}
if
(
$self
->{dcc}->{
$id
}->{type} =~ /^(GET|CHAT)$/) {
$irc
->send_event(
'irc_dcc_done'
,
$id
,
@{
$self
->{dcc}->{
$id
} }{
qw(
nick type port file size done peeraddr
)
},
);
$self
->_remove_dcc(
$id
);
}
return
;
}
if
(
$errnum
== 0 &&
$self
->{dcc}->{
$id
}->{type} eq
'GET'
) {
$errstr
=
'Aborted by sender'
;
}
else
{
$errstr
=
$errstr
?
$errstr
=
"$operation error $errnum: $errstr"
:
$errstr
=
"$operation error $errnum"
;
}
$irc
->send_event(
'irc_dcc_error'
,
$id
,
$errstr
,
@{
$self
->{dcc}->{
$id
} }{
qw(
nick type port file size done peeraddr
)
},
);
$self
->_remove_dcc(
$id
);
return
;
}
sub
_dcc_timeout {
my
(
$kernel
,
$self
,
$id
) =
@_
[KERNEL, OBJECT, ARG0];
if
(
exists
$self
->{dcc}->{
$id
} && !
$self
->{dcc}->{
$id
}->{
open
}) {
$kernel
->yield(
'_dcc_failed'
,
'connection'
,
0,
'DCC connection timed out'
,
$id
,
);
}
return
;
}
sub
_dcc_up {
my
(
$kernel
,
$self
,
$sock
,
$peeraddr
,
$id
) =
@_
[KERNEL, OBJECT, ARG0, ARG1, ARG3];
my
$irc
=
$self
->{irc};
delete
$self
->{dcc}->{
$id
}->{factory};
$self
->{dcc}->{
$id
}->{
open
} = 1;
$self
->{dcc}->{
$id
}->{peeraddr} = inet_ntoa(
$peeraddr
);
$self
->{dcc}->{
$id
}->{wheel} = POE::Wheel::ReadWrite->new(
Handle
=>
$sock
,
Driver
=> (
$self
->{dcc}->{
$id
}->{type} eq
'GET'
? POE::Driver::SysRW->new(
BlockSize
=> IN_BLOCKSIZE )
: POE::Driver::SysRW->new()
),
Filter
=> (
$self
->{dcc}->{
$id
}->{type} eq
'CHAT'
? POE::Filter::Line->new(
Literal
=>
"\012"
)
: POE::Filter::Stream->new()
),
InputEvent
=>
'_dcc_read'
,
ErrorEvent
=>
'_dcc_failed'
,
);
$self
->{wheelmap}->{
$self
->{dcc}->{
$id
}->{wheel}->ID } =
$id
;
my
$handle
;
if
(
$self
->{dcc}->{
$id
}->{type} eq
'GET'
) {
my
$mode
=
$self
->{dcc}->{
$id
}->{resuming} ?
'>>'
:
'>'
;
if
( !
open
$handle
,
$mode
,
$self
->{dcc}->{
$id
}->{file} ) {
$kernel
->yield(
_dcc_failed
=>
'open file'
, $! + 0, $!,
$id
);
return
;
}
binmode
$handle
;
$self
->{dcc}->{
$id
}->{fh} =
$handle
;
}
elsif
(
$self
->{dcc}->{
$id
}->{type} eq
'SEND'
) {
if
(!
open
$handle
,
'<'
,
$self
->{dcc}->{
$id
}->{file}) {
$kernel
->yield(
_dcc_failed
=>
'open file'
, $! + 0, $!,
$id
);
return
;
}
binmode
$handle
;
seek
$handle
,
$self
->{dcc}{
$id
}{done}, 0;
read
$handle
,
my
$buffer
,
$self
->{dcc}->{
$id
}->{blocksize};
$self
->{dcc}->{
$id
}->{wheel}->put(
$buffer
);
$self
->{dcc}->{
$id
}->{fh} =
$handle
;
}
$irc
->send_event(
'irc_dcc_start'
,
$id
,
@{
$self
->{dcc}->{
$id
} }{
qw(
nick type port file size peeraddr
)
},
);
return
;
}
sub
_cancel_timeout {
my
(
$kernel
,
$self
,
$id
) =
@_
[KERNEL, OBJECT, ARG0];
my
$alarm_id
=
delete
$self
->{dcc}{
$id
}{alarm_id};
$kernel
->alarm_remove(
$alarm_id
);
return
;
}
sub
_remove_dcc {
my
(
$self
,
$id
) =
@_
;
if
(
exists
$self
->{dcc}{
$id
}{alarm_id}) {
$poe_kernel
->call(
$self
->{session_id},
'_cancel_timeout'
,
$id
);
}
if
(
exists
$self
->{dcc}{
$id
}{wheel}) {
delete
$self
->{wheelmap}{
$self
->{dcc}{
$id
}{wheel}->ID };
if
($^O =~ /cygwin|MSWin/) {
$self
->{dcc}{
$id
}{wheel}->
$_
for
qw(shutdown_input shutdown_output)
;
}
}
close
$self
->{dcc}{
$id
}{fh}
if
$self
->{dcc}{
$id
}{type} eq
'GET'
;
delete
$self
->{dcc}{
$id
};
return
;
}
1;