File Coverage

blib/lib/POE/Component/IRC/Plugin/DCC.pm
Criterion Covered Total %
statement 234 291 80.4
branch 80 118 67.8
condition 13 27 48.1
subroutine 31 32 96.8
pod 4 8 50.0
total 362 476 76.0


line stmt bran cond sub pod time code
1             package POE::Component::IRC::Plugin::DCC;
2             $POE::Component::IRC::Plugin::DCC::VERSION = '6.95';
3 79     79   535 use strict;
  79         148  
  79         3248  
4 79     79   426 use warnings FATAL => 'all';
  79         291  
  79         4755  
5 79     79   516 use Carp;
  79         174  
  79         6864  
6 79     79   575 use File::Basename qw(fileparse);
  79         170  
  79         4936  
7 79     79   519 use File::Glob ':glob';
  79         201  
  79         18716  
8 79     79   36769 use File::Spec::Functions 'rel2abs';
  79         67099  
  79         6890  
9 79         633 use POE qw(Driver::SysRW Filter::Line Filter::Stream
10 79     79   662 Wheel::ReadWrite Wheel::SocketFactory);
  79         227  
11 79     79   69461 use POE::Component::IRC::Plugin qw(:ALL);
  79         174  
  79         9946  
12 79     79   580 use Socket qw(INADDR_ANY unpack_sockaddr_in inet_aton inet_ntoa);
  79         139  
  79         6715  
13              
14             use constant {
15 79         395575 OUT_BLOCKSIZE => 1024, # Send DCC data in 1k chunks
16             IN_BLOCKSIZE => 10_240, # 10k per DCC socket read
17             LISTEN_TIMEOUT => 300, # Five minutes for listening DCCs
18 79     79   506 };
  79         199  
19              
20             sub new {
21 116     116 1 857 my ($package) = shift;
22 116 50       661 croak "$package requires an even number of arguments" if @_ & 1;
23 116         462 my %self = @_;
24 116         775 return bless \%self, $package;
25             }
26              
27             sub PCI_register {
28 116     116 0 6258 my ($self, $irc) = @_;
29              
30 116         598 $self->{irc} = $irc;
31              
32 116         2433 POE::Session->create(
33             object_states => [
34             $self => [qw(
35             _start
36             _dcc_read
37             _dcc_failed
38             _dcc_timeout
39             _dcc_up
40             _U_dcc
41             _U_dcc_accept
42             _U_dcc_chat
43             _U_dcc_close
44             _U_dcc_resume
45             _cancel_timeout
46             )],
47             ],
48             );
49              
50 116         22256 $irc->plugin_register($self, 'SERVER', qw(disconnected dcc_request));
51 116         6167 $irc->plugin_register($self, 'USER', qw(dcc dcc_accept dcc_chat dcc_close dcc_resume));
52              
53 116         5836 return 1;
54             }
55              
56             sub PCI_unregister {
57 116     116 0 25529 my ($self) = @_;
58 116         437 delete $self->{irc};
59 116         654 delete $self->{$_} for qw(wheelmap dcc);
60 116         2651 $poe_kernel->refcount_decrement($self->{session_id}, __PACKAGE__);
61 116         7872 return 1;
62             }
63              
64             sub _start {
65 116     116   44423 my ($kernel, $self) = @_[KERNEL, OBJECT];
66 116         540 $self->{session_id} = $_[SESSION]->ID();
67 116         1082 $kernel->refcount_increment($self->{session_id}, __PACKAGE__);
68 116         5727 return;
69             }
70              
71             # set the dcc ports
72             sub dccports {
73 0     0 1 0 my ($self, $value) = @_;
74 0         0 $self->{dccports} = $value;
75 0         0 return;
76             }
77              
78             # set the NAT address
79             sub nataddr {
80 2     2 1 7 my ($self, $value) = @_;
81 2         7 $self->{nataddr} = $value;
82 2         5 return;
83             }
84              
85             # returns information about a connection
86             sub dcc_info {
87 2     2 1 5 my ($self, $id) = @_;
88              
89 2 50       5 if (!$self->{dcc}->{$id}) {
90 0         0 warn "dcc_info: Unknown wheel ID: $id\n";
91 0         0 return;
92             }
93              
94 2         2 my %info;
95             @info{qw(nick type port file size done peeraddr)}
96 2         5 = @{ $self->{dcc}->{$id} }{qw(
  2         25  
97             nick type port file size done peeraddr
98             )};
99 2         3 return \%info;
100             }
101              
102             sub _quote_file {
103 10     10   29 my ($file) = @_;
104              
105 10 100       92 if ($file =~ /[\s"]/) {
106 1         2 $file =~ s|"|\\"|g;
107 1         3 $file = qq{"$file"};
108             }
109 10         31 return $file;
110             }
111              
112             sub S_disconnected {
113 89     89 0 4045 my ($self) = $_;
114             # clean up old cookies for any ignored RESUME requests
115 89         289 delete $self->{resuming};
116 89         295 return PCI_EAT_NONE;
117             }
118              
119             sub S_dcc_request {
120 10     10 0 434 my ($self, $irc) = splice @_, 0, 2;
121 10 100       31 my ($user, $type, $port, $cookie, $file, $size) = map { ref =~ /REF|SCALAR/ && ${ $_ } } @_;
  78         368  
  68         198  
122 10         58 my $nick = (split /!/, $user)[0];
123              
124 10 100 66     89 if ($type eq 'ACCEPT' && $self->{resuming}->{"$port+$nick"}) {
    100          
125             # the old cookie has the peer's address
126 1         5 my $old_cookie = delete $self->{resuming}->{"$port+$nick"};
127 1         5 $irc->yield(dcc_accept => $old_cookie);
128             }
129             elsif ($type eq 'RESUME') {
130 1         3 for my $cookie (values %{ $self->{dcc} }) {
  1         5  
131 1 50       6 next if $cookie->{nick} ne $nick;
132 1 50       5 next if $cookie->{port} ne $port;
133 1         5 $file = _quote_file($file);
134 1         3 $cookie->{done} = $size;
135 1         8 $irc->yield(ctcp => $nick => "DCC ACCEPT $file $port $size");
136 1         152 last;
137             }
138             }
139              
140 10         164 return PCI_EAT_NONE;
141             }
142              
143             # this is a stub handler for all U_dcc* events which redispatches them as
144             # events to our own POE session so that we can do stuff related to it,
145             # namely create wheels and set alarms/delays
146             sub _default {
147 26     26   17175 my ($self, $irc, $event) = splice @_, 0, 3;
148 26 50       256 return PCI_EAT_NONE if $event !~ /^U_dcc(?:_accept|_chat|_close|_resume)?$/;
149 26         119 $event =~ s/^U_/_U_/;
150 26         60 pop @_;
151 26         89 my @args = map { $$_ } @_;
  68         161  
152 26         146 $poe_kernel->call($self->{session_id}, $event, @args);
153 26         579 return PCI_EAT_NONE;
154             }
155              
156             # Attempt to initiate a DCC SEND or CHAT connection with another person.
157             sub _U_dcc {
158 8     8   634 my ($kernel, $self, $nick, $type, $file, $blocksize, $timeout)
159             = @_[KERNEL, OBJECT, ARG0..$#_];
160              
161 8 50       61 if (!defined $type) {
162 0         0 warn "The 'dcc' command requires at least two arguments\n";
163 0         0 return;
164             }
165              
166 8         25 my $irc = $self->{irc};
167 8         21 my ($bindport, $bindaddr, $factory, $port, $addr, $size);
168              
169 8         26 $type = uc $type;
170 8 100       39 if ($type eq 'CHAT') {
    50          
171 5         33 $file = 'chat'; # As per the semi-specification
172             }
173             elsif ($type eq 'SEND') {
174 3 50       11 if (!defined $file) {
175 0         0 warn "The 'dcc' command requires three arguments for a SEND\n";
176 0         0 return;
177             }
178 3         191 $file = rel2abs(bsd_glob($file));
179 3         213 $size = (stat $file)[7];
180 3 50       17 if (!defined $size) {
181 0         0 $irc->send_event(
182             'irc_dcc_error',
183             undef,
184             "Couldn't get ${file}'s size: $!",
185             $nick,
186             $type,
187             undef,
188             $file,
189             );
190 0         0 return;
191             }
192             }
193              
194 8         50 $bindaddr = $irc->localaddr();
195              
196 8 50       35 if ($self->{dccports}) {
197 0         0 $bindport = shift @{ $self->{dccports} };
  0         0  
198 0 0       0 if (!defined $bindport) {
199 0         0 warn "dcc: Can't allocate listen port for DCC $type\n";
200 0         0 return;
201             }
202             }
203              
204 8   50     115 $factory = POE::Wheel::SocketFactory->new(
205             BindAddress => $bindaddr || INADDR_ANY,
206             BindPort => $bindport,
207             SuccessEvent => '_dcc_up',
208             FailureEvent => '_dcc_failed',
209             Reuse => 'yes',
210             );
211              
212 8         5628 ($port, $addr) = unpack_sockaddr_in($factory->getsockname());
213 8 100       186 $addr = inet_aton($self->{nataddr}) if $self->{nataddr};
214              
215 8 50       32 if (!defined $addr) {
216 0         0 warn "dcc: Can't determine our IP address! ($!)\n";
217 0         0 return;
218             }
219 8         44 $addr = unpack 'N', $addr;
220              
221 8         330 my $basename = fileparse($file);
222 8         48 $basename = _quote_file($basename);
223              
224             # Tell the other end that we're waiting for them to connect.
225 8 100       88 $irc->yield(ctcp => $nick => "DCC $type $basename $addr $port" . ($size ? " $size" : ''));
226              
227 8   50     1103 my $alarm_id = $kernel->delay_set(
228             '_dcc_timeout', ($timeout || LISTEN_TIMEOUT), $factory->ID,
229             );
230              
231             # Store the state for this connection.
232 8   100     1222 $self->{dcc}->{ $factory->ID } = {
233             open => 0,
234             nick => $nick,
235             type => $type,
236             file => $file,
237             size => $size,
238             port => $port,
239             addr => $addr,
240             done => 0,
241             blocksize => ($blocksize || OUT_BLOCKSIZE),
242             listener => 1,
243             factory => $factory,
244             alarm_id => $alarm_id,
245             };
246              
247 8         102 return;
248             }
249              
250             # Accepts a proposed DCC connection to another client. See '_dcc_up' for
251             # the rest of the logic for this.
252             sub _U_dcc_accept {
253 6     6   461 my ($self, $cookie, $myfile) = @_[OBJECT, ARG0, ARG1];
254              
255 6 50       29 if (!defined $cookie) {
256 0         0 warn "The 'dcc_accept' command requires at least one argument\n";
257 0         0 return;
258             }
259              
260 6 100       27 if ($cookie->{type} eq 'SEND') {
261 3         10 $cookie->{type} = 'GET';
262 3 100       13 $cookie->{file} = $myfile if defined $myfile; # filename override
263             }
264              
265             my $factory = POE::Wheel::SocketFactory->new(
266             RemoteAddress => sprintf("%vd", pack("N", $cookie->{addr})),
267             RemotePort => $cookie->{port},
268 6         128 SuccessEvent => '_dcc_up',
269             FailureEvent => '_dcc_failed',
270             );
271              
272 6         4156 $self->{dcc}->{$factory->ID} = $cookie;
273 6         131 $self->{dcc}->{$factory->ID}->{factory} = $factory;
274              
275 6         42 return;
276             }
277              
278             # Send data over a DCC CHAT connection.
279             sub _U_dcc_chat {
280 7     7   468 my ($self, $id, @data) = @_[OBJECT, ARG0..$#_];
281              
282 7 50 33     47 if (!defined $id || !@data) {
283 0         0 warn "The 'dcc_chat' command requires at least two arguments\n";
284 0         0 return;
285             }
286              
287 7 50       21 if (!exists $self->{dcc}->{$id}) {
288 0         0 warn "dcc_chat: Unknown wheel ID: $id\n";
289 0         0 return;
290             }
291              
292 7 50       18 if (!exists $self->{dcc}->{$id}->{wheel}) {
293 0         0 warn "dcc_chat: No DCC wheel for id $id!\n";
294 0         0 return;
295             }
296              
297 7 50       32 if ($self->{dcc}->{$id}->{type} ne 'CHAT') {
298 0         0 warn "dcc_chat: id $id isn't associated with a DCC CHAT connection!\n";
299 0         0 return;
300             }
301              
302 7         42 $self->{dcc}->{$id}->{wheel}->put(join "\n", @data);
303 7         470 return;
304             }
305              
306             # Terminate a DCC connection manually.
307             sub _U_dcc_close {
308 5     5   2003060 my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0];
309 5         22 my $irc = $self->{irc};
310              
311 5 50       22 if (!defined $id) {
312 0         0 warn "The 'dcc_close' command requires an id argument\n";
313 0         0 return;
314             }
315              
316 5 50       22 if (!exists $self->{dcc}->{$id}) {
317 0         0 warn "dcc_close: Unknown wheel ID: $id\n";
318 0         0 return;
319             }
320              
321 5 50       19 if (!exists $self->{dcc}->{$id}->{wheel}) {
322 0         0 warn "dcc_close: No DCC wheel for id $id!\n";
323 0         0 return;
324             }
325              
326             # pending data, wait till it has been flushed
327 5 100       34 if ($self->{dcc}->{$id}->{wheel}->get_driver_out_octets()) {
328 1         10 $kernel->delay_set(_U_dcc_close => 2, $id);
329 1         101 return;
330             }
331              
332             $irc->send_event(
333             'irc_dcc_done',
334             $id,
335 4         25 @{ $self->{dcc}->{$id} }{qw(
  4         40  
336             nick type port file size done peeraddr
337             )},
338             );
339              
340             # Reclaim our port if necessary.
341 4 50 66     717 if ($self->{dcc}->{$id}->{listener} && $self->{dccports}) {
342 0         0 push ( @{ $self->{dccports} }, $self->{dcc}->{$id}->{port} );
  0         0  
343             }
344              
345 4         46 $self->_remove_dcc($id);
346 4         13 return;
347             }
348              
349             ## no critic (InputOutput::RequireBriefOpen)
350             sub _U_dcc_resume {
351 1     1   92 my ($self, $cookie, $myfile) = @_[OBJECT, ARG0, ARG1];
352 1         3 my $irc = $self->{irc};
353              
354 1         5 my $sender_file = _quote_file($cookie->{file});
355 1 50       6 $cookie->{file} = $myfile if defined $myfile;
356 1         28 $cookie->{done} = -s $cookie->{file};
357 1         5 $cookie->{resuming} = 1;
358              
359 1 50       49 if (open(my $handle, '>>', $cookie->{file})) {
360 1         12 $irc->yield(ctcp => $cookie->{nick} => "DCC RESUME $sender_file $cookie->{port} $cookie->{done}");
361 1         172 $self->{resuming}->{"$cookie->{port}+$cookie->{nick}"} = $cookie;
362             }
363             else {
364 0         0 warn "dcc_resume: Can't append to file '$cookie->{file}'\n";
365 0         0 return;
366             }
367              
368 1         23 return;
369             }
370              
371             # Accept incoming data on a DCC socket.
372             sub _dcc_read {
373 269     269   255438 my ($kernel, $self, $data, $id) = @_[KERNEL, OBJECT, ARG0, ARG1];
374 269         706 my $irc = $self->{irc};
375              
376 269         699 $id = $self->{wheelmap}->{$id};
377 269 100       1096 if ($self->{dcc}{$id}{alarm_id}) {
378 5         21 $kernel->call($self->{session_id}, '_cancel_timeout', $id);
379             }
380              
381 269 100       1095 if ($self->{dcc}->{$id}->{type} eq 'GET') {
    100          
382             # Acknowledge the received data.
383 131         215 print {$self->{dcc}->{$id}->{fh}} $data;
  131         1894  
384 131         427 $self->{dcc}->{$id}->{done} += length $data;
385             $self->{dcc}->{$id}->{wheel}->put(
386             pack 'N', $self->{dcc}->{$id}->{done}
387 131         1071 );
388              
389             # Send an event to let people know about the newly arrived data.
390             $irc->send_event(
391             'irc_dcc_get',
392             $id,
393 131         11916 @{ $self->{dcc}->{$id} }{qw(
  131         907  
394             nick port file size done peeraddr
395             )},
396             );
397             }
398             elsif ($self->{dcc}->{$id}->{type} eq 'SEND') {
399             # Record the client's download progress.
400 131         623 $self->{dcc}->{$id}->{done} = unpack 'N', substr( $data, -4 );
401              
402             $irc->send_event(
403             'irc_dcc_send',
404             $id,
405 131         305 @{ $self->{dcc}->{$id} }{qw(
  131         897  
406             nick port file size done peeraddr
407             )},
408             );
409              
410             # Are we done yet?
411 131 100       26392 if ($self->{dcc}->{$id}->{done} >= $self->{dcc}->{$id}->{size}) {
412             # Reclaim our port if necessary.
413 3 50 33     92 if ( $self->{dcc}->{$id}->{listener} && $self->{dccports}) {
414 0         0 push @{ $self->{dccports} }, $self->{dcc}->{$id}->{port};
  0         0  
415             }
416              
417             $irc->send_event(
418             'irc_dcc_done',
419             $id,
420 3         12 @{ $self->{dcc}->{$id} }{qw(
  3         20  
421             nick type port file size done peeraddr
422             )},
423             );
424              
425 3         447 $self->_remove_dcc($id);
426 3         13 return;
427             }
428              
429             # Send the next 'blocksize'-sized packet.
430             read $self->{dcc}->{$id}->{fh}, $data,
431 128         1403 $self->{dcc}->{$id}->{blocksize};
432 128         682 $self->{dcc}->{$id}->{wheel}->put( $data );
433             }
434             else {
435             $irc->send_event(
436             'irc_dcc_' . lc $self->{dcc}->{$id}->{type},
437             $id,
438 7         36 @{ $self->{dcc}->{$id} }{qw(nick port)},
439             $data,
440             $self->{dcc}->{$id}->{peeraddr},
441 7         23 );
442             }
443              
444 266         37857 return;
445             }
446              
447             # What happens when an attempted DCC connection fails.
448             sub _dcc_failed {
449 7     7   5450 my ($self, $operation, $errnum, $errstr, $id) = @_[OBJECT, ARG0 .. ARG3];
450 7         28 my $irc = $self->{irc};
451              
452 7 100       47 if (!exists $self->{dcc}->{$id}) {
453 5 50       24 if (exists $self->{wheelmap}->{$id}) {
454 5         17 $id = $self->{wheelmap}->{$id};
455             }
456             else {
457 0         0 warn "_dcc_failed: Unknown wheel ID: $id\n";
458 0         0 return;
459             }
460             }
461              
462             # Reclaim our port if necessary.
463 7 50 66     109 if ( $self->{dcc}->{$id}->{listener} && $self->{dccports}) {
464 0         0 push ( @{ $self->{dccports} }, $self->{dcc}->{$id}->{port} );
  0         0  
465             }
466              
467             DCC: {
468 7 50       168 last DCC if $errnum != 0;
  7         44  
469              
470             # Did the peer of a DCC GET connection close the socket after the file
471             # transfer finished? If so, it's not really an error.
472 7 100       37 if ($self->{dcc}->{$id}->{type} eq 'GET') {
473 3 50       16 if ($self->{dcc}->{$id}->{done} < $self->{dcc}->{$id}->{size}) {
474 0         0 last DCC;
475             }
476             }
477              
478 7 50       89 if ($self->{dcc}->{$id}->{type} =~ /^(GET|CHAT)$/) {
479             $irc->send_event(
480             'irc_dcc_done',
481             $id,
482 7         22 @{ $self->{dcc}->{$id} }{qw(
  7         77  
483             nick type port file size done peeraddr
484             )},
485             );
486              
487 7         1266 $self->_remove_dcc($id);
488             }
489              
490 7         48 return;
491             }
492              
493             # something went wrong
494 0 0 0     0 if ($errnum == 0 && $self->{dcc}->{$id}->{type} eq 'GET') {
495 0         0 $errstr = 'Aborted by sender';
496             }
497             else {
498 0 0       0 $errstr = $errstr
499             ? $errstr = "$operation error $errnum: $errstr"
500             : $errstr = "$operation error $errnum"
501             ;
502             }
503              
504             $irc->send_event(
505             'irc_dcc_error',
506             $id,
507             $errstr,
508 0         0 @{ $self->{dcc}->{$id} }{qw(
  0         0  
509             nick type port file size done peeraddr
510             )},
511             );
512              
513 0         0 $self->_remove_dcc($id);
514 0         0 return;
515             }
516              
517             # What happens when a DCC connection sits waiting for the other end to
518             # pick up the phone for too long.
519             sub _dcc_timeout {
520 2     2   5893920 my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0];
521              
522 2 50 33     38 if (exists $self->{dcc}->{$id} && !$self->{dcc}->{$id}->{open}) {
523 2         32 $kernel->yield(
524             '_dcc_failed',
525             'connection',
526             0,
527             'DCC connection timed out',
528             $id,
529             );
530             }
531 2         312 return;
532             }
533              
534             # This event occurs when a DCC connection is established.
535             ## no critic (InputOutput::RequireBriefOpen)
536             sub _dcc_up {
537 12     12   9361 my ($kernel, $self, $sock, $peeraddr, $id) =
538             @_[KERNEL, OBJECT, ARG0, ARG1, ARG3];
539 12         151 my $irc = $self->{irc};
540              
541             # Delete the listening socket and monitor the accepted socket
542             # for incoming data
543 12         71 delete $self->{dcc}->{$id}->{factory};
544 12         1642 $self->{dcc}->{$id}->{open} = 1;
545 12         82 $self->{dcc}->{$id}->{peeraddr} = inet_ntoa($peeraddr);
546              
547             $self->{dcc}->{$id}->{wheel} = POE::Wheel::ReadWrite->new(
548             Handle => $sock,
549             Driver => ($self->{dcc}->{$id}->{type} eq 'GET'
550             ? POE::Driver::SysRW->new( BlockSize => IN_BLOCKSIZE )
551             : POE::Driver::SysRW->new()
552             ),
553 12 100       177 Filter => ($self->{dcc}->{$id}->{type} eq 'CHAT'
    100          
554             ? POE::Filter::Line->new( Literal => "\012" )
555             : POE::Filter::Stream->new()
556             ),
557             InputEvent => '_dcc_read',
558             ErrorEvent => '_dcc_failed',
559             );
560              
561 12         5278 $self->{wheelmap}->{ $self->{dcc}->{$id}->{wheel}->ID } = $id;
562              
563 12         154 my $handle;
564 12 100       132 if ($self->{dcc}->{$id}->{type} eq 'GET') {
    100          
565             # check if we're resuming
566 3 100       53 my $mode = $self->{dcc}->{$id}->{resuming} ? '>>' : '>';
567              
568 3 50       360 if ( !open $handle, $mode, $self->{dcc}->{$id}->{file} ) {
569 0         0 $kernel->yield(_dcc_failed => 'open file', $! + 0, $!, $id);
570 0         0 return;
571             }
572              
573 3         12 binmode $handle;
574 3         12 $self->{dcc}->{$id}->{fh} = $handle;
575             }
576             elsif ($self->{dcc}->{$id}->{type} eq 'SEND') {
577 3 50       188 if (!open $handle, '<', $self->{dcc}->{$id}->{file}) {
578 0         0 $kernel->yield(_dcc_failed => 'open file', $! + 0, $!, $id);
579 0         0 return;
580             }
581              
582 3         11 binmode $handle;
583 3         20 seek $handle, $self->{dcc}{$id}{done}, 0;
584             # Send the first packet to get the ball rolling.
585 3         158 read $handle, my $buffer, $self->{dcc}->{$id}->{blocksize};
586 3         24 $self->{dcc}->{$id}->{wheel}->put($buffer);
587 3         331 $self->{dcc}->{$id}->{fh} = $handle;
588             }
589              
590             # Tell any listening sessions that the connection is up.
591             $irc->send_event(
592             'irc_dcc_start',
593             $id,
594 12         32 @{ $self->{dcc}->{$id} }{qw(
  12         116  
595             nick type port file size peeraddr
596             )},
597             );
598              
599 12         1711 return;
600             }
601              
602             sub _cancel_timeout {
603 8     8   422 my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0];
604 8         48 my $alarm_id = delete $self->{dcc}{$id}{alarm_id};
605 8         48 $kernel->alarm_remove($alarm_id);
606 8         890 return;
607             }
608              
609             sub _remove_dcc {
610 14     14   42 my ($self, $id) = @_;
611              
612 14 100       87 if (exists $self->{dcc}{$id}{alarm_id}) {
613 3         22 $poe_kernel->call($self->{session_id}, '_cancel_timeout', $id);
614             }
615              
616 14 100       178 if (exists $self->{dcc}{$id}{wheel}) {
617 12         63 delete $self->{wheelmap}{ $self->{dcc}{$id}{wheel}->ID };
618 12 50       160 if ($^O =~ /cygwin|MSWin/) {
619 0         0 $self->{dcc}{$id}{wheel}->$_ for qw(shutdown_input shutdown_output);
620             }
621             }
622              
623             # flush the filehandle
624 14 100       3068 close $self->{dcc}{$id}{fh} if $self->{dcc}{$id}{type} eq 'GET';
625              
626 14         221 delete $self->{dcc}{$id};
627 14         5117 return;
628             }
629              
630             1;
631              
632             =encoding utf8
633              
634             =head1 NAME
635              
636             POE::Component::IRC::Plugin::DCC - A PoCo-IRC plugin providing support for
637             DCC transfers
638              
639             =head1 SYNOPSIS
640              
641             # send a file
642             my $file = '/home/user/secret.pdf';
643             my $recipient = 'that_guy';
644             $irc->yield(dcc => $recipient => SEND => $file);
645              
646             # receive a file
647             sub irc_dcc_request {
648             my ($user, $type, $port, $cookie, $file, $size, $addr) = @_[ARG0..$#_];
649             return if $type ne 'SEND';
650              
651             my $irc = $_[SENDER]->get_heap();
652             my $nick = (split /!/, $user)[0];
653              
654             print "$nick wants to send me '$file' ($size bytes) from $addr:$port\n");
655             $irc->yield(dcc_accept => $cookie);
656             }
657              
658             =head1 DESCRIPTION
659              
660             This plugin provides the IRC commands needed to make use of DCC. It is used
661             internally by L so there's no
662             need to add it manually.
663              
664             =head1 METHODS
665              
666             =head2 C
667              
668             Takes no arguments.
669              
670             Returns a plugin object suitable for feeding to
671             L's C method.
672              
673             =head2 C
674              
675             Sets the TCP ports that can be used for DCC sends. Takes one argument,
676             an arrayref containing the port numbers.
677              
678             =head2 C
679              
680             Sets the public NAT address to be used for DCC sends.
681              
682             =head2 C
683              
684             Takes one argument, a DCC connection id (see below). Returns a hash of
685             information about the connection. The keys are: B<'nick'>, B<'type'>,
686             B<'port'>, B<'file'>, B<'size'>, B<'done,'>, and B<'peeraddr'>.
687              
688             =head1 COMMANDS
689              
690             The plugin responds to the following
691             L commands.
692              
693             =head2 C
694              
695             Send a DCC SEND or CHAT request to another person. Takes at least two
696             arguments: the nickname of the person to send the request to and the type
697             of DCC request (SEND or CHAT). For SEND requests, be sure to add a third
698             argument for the filename you want to send. Optionally, you can add a fourth
699             argument for the DCC transfer blocksize, but the default of 1024 should
700             usually be fine. The fifth (and optional) argument is the request timeout
701             value in seconds (default: 300).
702              
703             Incidentally, you can send other weird nonstandard kinds of DCCs too;
704             just put something besides 'SEND' or 'CHAT' (say, 'FOO') in the type
705             field, and you'll get back C events (with the same arguments as
706             L|/irc_dcc_chat>) when data arrives on its DCC connection.
707              
708             If you are behind a firewall or Network Address Translation, you may want to
709             consult L's
710             L|POE::Component::IRC/spawn> for some parameters that are
711             useful with this command.
712              
713             =head2 C
714              
715             Accepts an incoming DCC connection from another host. First argument:
716             the magic cookie from an L|/irc_dcc_request> event.
717             In the case of a DCC GET, the second argument can optionally specify a
718             new name for the destination file of the DCC transfer, instead of using
719             the sender's name for it. (See the L|/irc_dcc_request>
720             section below for more details.)
721              
722             =head2 C
723              
724             Resumes a DCC SEND file transfer. First argument: the magic cookie from an
725             L|/irc_dcc_request> event. An optional second argument
726             provides the name of the file to which you want to write.
727              
728             =head2 C
729              
730             Sends lines of data to the person on the other side of a DCC CHAT connection.
731             The first argument should be the wheel id of the connection which you got
732             from an L|/irc_dcc_start> event, followed by all the data
733             you wish to send (it'll be separated with newlines for you).
734              
735             =head2 C
736              
737             Terminates a DCC SEND or GET connection prematurely, and causes DCC CHAT
738             connections to close gracefully. Takes one argument: the wheel id of the
739             connection which you got from an L|/irc_dcc_start>
740             (or similar) event.
741              
742             =head1 OUTPUT EVENTS
743              
744             =head2 C
745              
746             B This event is actually emitted by
747             L, but documented here
748             to keep all the DCC documentation in one place. In case you were wondering.
749              
750             You receive this event when another IRC client sends you a DCC
751             (e.g. SEND or CHAT) request out of the blue. You can examine the request
752             and decide whether or not to accept it (with L|/dcc_accept>)
753             here. In the case of DCC SENDs, you can also request to resume the file with
754             L|/dcc_resume>.
755              
756             B DCC doesn't provide a way to explicitly reject requests, so if you
757             don't intend to accept one, just ignore it or send a
758             L or L
759             to the peer explaining why you're not going to accept.
760              
761             =over 4
762              
763             =item * C: the peer's nick!user@host
764              
765             =item * C: the DCC type (e.g. 'CHAT' or 'SEND')
766              
767             =item * C: the port which the peer is listening on
768              
769             =item * C: this connection's "magic cookie"
770              
771             =item * C: the file name (SEND only)
772              
773             =item * C: the file size (SEND only)
774              
775             =item * C: the IP address which the peer is listening on
776              
777             =back
778              
779             =head2 C
780              
781             This event notifies you that a DCC connection has been successfully
782             established.
783              
784             =over 4
785              
786             =item * C: the connection's wheel id
787              
788             =item * C: the peer's nickname
789              
790             =item * C: the DCC type
791              
792             =item * C: the port number
793              
794             =item * C: the file name (SEND/GET only)
795              
796             =item * C: the file size (SEND/GET only)
797              
798             =item * C: the peer's IP address
799              
800             =back
801              
802             =head2 C
803              
804             Notifies you that one line of text has been received from the
805             client on the other end of a DCC CHAT connection.
806              
807             =over 4
808              
809             =item * C: the connection's wheel id
810              
811             =item * C: the peer's nickname
812              
813             =item * C: the port number
814              
815             =item * C: the text they sent
816              
817             =item * C: the peer's IP address
818              
819             =back
820              
821             =head2 C
822              
823             Notifies you that another block of data has been successfully
824             transferred from the client on the other end of your DCC GET connection.
825              
826             =over 4
827              
828             =item * C: the connection's wheel id
829              
830             =item * C: the peer's nickname
831              
832             =item * C: the port number
833              
834             =item * C: the file name
835              
836             =item * C: the file size
837              
838             =item * C: transferred file size
839              
840             =item * C: the peer's IP address
841              
842             =back
843              
844             =head2 C
845              
846             Notifies you that another block of data has been successfully
847             transferred from you to the client on the other end of a DCC SEND
848             connection.
849              
850             =over 4
851              
852             =item * C: the connection's wheel id
853              
854             =item * C: the peer's nickname
855              
856             =item * C: the port number
857              
858             =item * C: the file name
859              
860             =item * C: the file size
861              
862             =item * C: transferred file size
863              
864             =item * C: the peer's IP address
865              
866             =back
867              
868             =head2 C
869              
870             You receive this event when a DCC connection terminates normally.
871             Abnormal terminations are reported by L|/irc_dcc_error>.
872              
873             =over 4
874              
875             =item * C: the connection's wheel id
876              
877             =item * C: the peer's nickname
878              
879             =item * C: the DCC type
880              
881             =item * C: the port number
882              
883             =item * C: the filename (SEND/GET only)
884              
885             =item * C: file size (SEND/GET only)
886              
887             =item * C: transferred file size (SEND/GET only)
888              
889             =item * C: the peer's IP address
890              
891             =back
892              
893             =head2 C
894              
895             You get this event whenever a DCC connection or connection attempt
896             terminates unexpectedly or suffers some fatal error. Some of the
897             following values might be undefined depending the stage at which
898             the connection/attempt failed.
899              
900             =over 4
901              
902             =item * C: the connection's wheel id
903              
904             =item * C: the error string
905              
906             =item * C: the peer's nickname
907              
908             =item * C: the DCC type
909              
910             =item * C: the port number
911              
912             =item * C: the file name
913              
914             =item * C: file size in bytes
915              
916             =item * C: transferred file size in bytes
917              
918             =item * C: the peer's IP address
919              
920             =back
921              
922             =head1 AUTHOR
923              
924             Dennis 'C' Taylor and Hinrik Ern SigurEsson, hinrik.sig@gmail.com
925              
926             =cut