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