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.92';
4 79     79   611 use strict;
  79         173  
  79         2642  
5 79     79   441 use warnings FATAL => 'all';
  79         164  
  79         2558  
6 79     79   427 use Carp;
  79         181  
  79         5316  
7 79     79   547 use File::Basename qw(fileparse);
  79         250  
  79         4158  
8 79     79   533 use File::Glob ':glob';
  79         171  
  79         17710  
9 79     79   39145 use File::Spec::Functions 'rel2abs';
  79         66596  
  79         5899  
10 79         565 use POE qw(Driver::SysRW Filter::Line Filter::Stream
11 79     79   666 Wheel::ReadWrite Wheel::SocketFactory);
  79         195  
12 79     79   64181 use POE::Component::IRC::Plugin qw(:ALL);
  79         199  
  79         8900  
13 79     79   676 use Socket qw(INADDR_ANY unpack_sockaddr_in inet_aton inet_ntoa);
  79         173  
  79         6399  
14              
15             use constant {
16 79         328446 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   583 };
  79         191  
20              
21             sub new {
22 116     116 1 794 my ($package) = shift;
23 116 50       838 croak "$package requires an even number of arguments" if @_ & 1;
24 116         399 my %self = @_;
25 116         731 return bless \%self, $package;
26             }
27              
28             sub PCI_register {
29 116     116 0 5612 my ($self, $irc) = @_;
30              
31 116         559 $self->{irc} = $irc;
32              
33 116         2189 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         21888 $irc->plugin_register($self, 'SERVER', qw(disconnected dcc_request));
52 116         5265 $irc->plugin_register($self, 'USER', qw(dcc dcc_accept dcc_chat dcc_close dcc_resume));
53              
54 116         5231 return 1;
55             }
56              
57             sub PCI_unregister {
58 116     116 0 21416 my ($self) = @_;
59 116         343 delete $self->{irc};
60 116         516 delete $self->{$_} for qw(wheelmap dcc);
61 116         617 $poe_kernel->refcount_decrement($self->{session_id}, __PACKAGE__);
62 116         7342 return 1;
63             }
64              
65             sub _start {
66 116     116   39121 my ($kernel, $self) = @_[KERNEL, OBJECT];
67 116         434 $self->{session_id} = $_[SESSION]->ID();
68 116         1050 $kernel->refcount_increment($self->{session_id}, __PACKAGE__);
69 116         5614 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 5 my ($self, $value) = @_;
82 2         4 $self->{nataddr} = $value;
83 2         15 return;
84             }
85              
86             # returns information about a connection
87             sub dcc_info {
88 2     2 1 5 my ($self, $id) = @_;
89              
90 2 50       8 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         6 = @{ $self->{dcc}->{$id} }{qw(
  2         13  
98             nick type port file size done peeraddr
99             )};
100 2         7 return \%info;
101             }
102              
103             sub _quote_file {
104 10     10   35 my ($file) = @_;
105              
106 10 100       73 if ($file =~ /[\s"]/) {
107 1         4 $file =~ s|"|\\"|g;
108 1         4 $file = qq{"$file"};
109             }
110 10         30 return $file;
111             }
112              
113             sub S_disconnected {
114 89     89 0 3597 my ($self) = $_;
115             # clean up old cookies for any ignored RESUME requests
116 89         238 delete $self->{resuming};
117 89         266 return PCI_EAT_NONE;
118             }
119              
120             sub S_dcc_request {
121 10     10 0 468 my ($self, $irc) = splice @_, 0, 2;
122 10 100       36 my ($user, $type, $port, $cookie, $file, $size) = map { ref =~ /REF|SCALAR/ && ${ $_ } } @_;
  78         489  
  68         240  
123 10         63 my $nick = (split /!/, $user)[0];
124              
125 10 100 66     130 if ($type eq 'ACCEPT' && $self->{resuming}->{"$port+$nick"}) {
    100          
126             # the old cookie has the peer's address
127 1         7 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         2 for my $cookie (values %{ $self->{dcc} }) {
  1         17  
132 1 50       11 next if $cookie->{nick} ne $nick;
133 1 50       6 next if $cookie->{port} ne $port;
134 1         7 $file = _quote_file($file);
135 1         4 $cookie->{done} = $size;
136 1         10 $irc->yield(ctcp => $nick => "DCC ACCEPT $file $port $size");
137 1         107 last;
138             }
139             }
140              
141 10         149 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   16395 my ($self, $irc, $event) = splice @_, 0, 3;
149 26 50       326 return PCI_EAT_NONE if $event !~ /^U_dcc(?:_accept|_chat|_close|_resume)?$/;
150 26         158 $event =~ s/^U_/_U_/;
151 26         71 pop @_;
152 26         72 my @args = map { $$_ } @_;
  68         169  
153 26         146 $poe_kernel->call($self->{session_id}, $event, @args);
154 26         630 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   676 my ($kernel, $self, $nick, $type, $file, $blocksize, $timeout)
160             = @_[KERNEL, OBJECT, ARG0..$#_];
161              
162 8 50       42 if (!defined $type) {
163 0         0 warn "The 'dcc' command requires at least two arguments\n";
164 0         0 return;
165             }
166              
167 8         37 my $irc = $self->{irc};
168 8         31 my ($bindport, $bindaddr, $factory, $port, $addr, $size);
169              
170 8         26 $type = uc $type;
171 8 100       49 if ($type eq 'CHAT') {
    50          
172 5         14 $file = 'chat'; # As per the semi-specification
173             }
174             elsif ($type eq 'SEND') {
175 3 50       12 if (!defined $file) {
176 0         0 warn "The 'dcc' command requires three arguments for a SEND\n";
177 0         0 return;
178             }
179 3         216 $file = rel2abs(bsd_glob($file));
180 3         273 $size = (stat $file)[7];
181 3 50       21 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         55 $bindaddr = $irc->localaddr();
196              
197 8 50       38 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     153 $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         4945 ($port, $addr) = unpack_sockaddr_in($factory->getsockname());
214 8 100       219 $addr = inet_aton($self->{nataddr}) if $self->{nataddr};
215              
216 8 50       38 if (!defined $addr) {
217 0         0 warn "dcc: Can't determine our IP address! ($!)\n";
218 0         0 return;
219             }
220 8         57 $addr = unpack 'N', $addr;
221              
222 8         372 my $basename = fileparse($file);
223 8         58 $basename = _quote_file($basename);
224              
225             # Tell the other end that we're waiting for them to connect.
226 8 100       132 $irc->yield(ctcp => $nick => "DCC $type $basename $addr $port" . ($size ? " $size" : ''));
227              
228 8   50     1076 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     1223 $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         79 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   481 my ($self, $cookie, $myfile) = @_[OBJECT, ARG0, ARG1];
255              
256 6 50       33 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       33 if ($cookie->{type} eq 'SEND') {
262 3         19 $cookie->{type} = 'GET';
263 3 100       16 $cookie->{file} = $myfile if defined $myfile; # filename override
264             }
265              
266             my $factory = POE::Wheel::SocketFactory->new(
267             RemoteAddress => sprintf("%vd", pack("N", $cookie->{addr})),
268             RemotePort => $cookie->{port},
269 6         154 SuccessEvent => '_dcc_up',
270             FailureEvent => '_dcc_failed',
271             );
272              
273 6         4422 $self->{dcc}->{$factory->ID} = $cookie;
274 6         61 $self->{dcc}->{$factory->ID}->{factory} = $factory;
275              
276 6         46 return;
277             }
278              
279             # Send data over a DCC CHAT connection.
280             sub _U_dcc_chat {
281 7     7   491 my ($self, $id, @data) = @_[OBJECT, ARG0..$#_];
282              
283 7 50 33     76 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       39 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       26 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       25 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         525 return;
305             }
306              
307             # Terminate a DCC connection manually.
308             sub _U_dcc_close {
309 5     5   2001430 my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0];
310 5         16 my $irc = $self->{irc};
311              
312 5 50       23 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       20 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       32 if ($self->{dcc}->{$id}->{wheel}->get_driver_out_octets()) {
329 1         9 $kernel->delay_set(_U_dcc_close => 2, $id);
330 1         77 return;
331             }
332              
333             $irc->send_event(
334             'irc_dcc_done',
335             $id,
336 4         33 @{ $self->{dcc}->{$id} }{qw(
  4         36  
337             nick type port file size done peeraddr
338             )},
339             );
340              
341             # Reclaim our port if necessary.
342 4 50 66     710 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         18 return;
348             }
349              
350             ## no critic (InputOutput::RequireBriefOpen)
351             sub _U_dcc_resume {
352 1     1   76 my ($self, $cookie, $myfile) = @_[OBJECT, ARG0, ARG1];
353 1         3 my $irc = $self->{irc};
354              
355 1         7 my $sender_file = _quote_file($cookie->{file});
356 1 50       16 $cookie->{file} = $myfile if defined $myfile;
357 1         25 $cookie->{done} = -s $cookie->{file};
358 1         7 $cookie->{resuming} = 1;
359              
360 1 50       46 if (open(my $handle, '>>', $cookie->{file})) {
361 1         13 $irc->yield(ctcp => $cookie->{nick} => "DCC RESUME $sender_file $cookie->{port} $cookie->{done}");
362 1         130 $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         18 return;
370             }
371              
372             # Accept incoming data on a DCC socket.
373             sub _dcc_read {
374 269     269   184320 my ($kernel, $self, $data, $id) = @_[KERNEL, OBJECT, ARG0, ARG1];
375 269         570 my $irc = $self->{irc};
376              
377 269         579 $id = $self->{wheelmap}->{$id};
378 269 100       824 if ($self->{dcc}{$id}{alarm_id}) {
379 5         28 $kernel->call($self->{session_id}, '_cancel_timeout', $id);
380             }
381              
382 269 100       903 if ($self->{dcc}->{$id}->{type} eq 'GET') {
    100          
383             # Acknowledge the received data.
384 131         216 print {$self->{dcc}->{$id}->{fh}} $data;
  131         1387  
385 131         353 $self->{dcc}->{$id}->{done} += length $data;
386             $self->{dcc}->{$id}->{wheel}->put(
387             pack 'N', $self->{dcc}->{$id}->{done}
388 131         854 );
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 131         9326 @{ $self->{dcc}->{$id} }{qw(
  131         602  
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 131         573 $self->{dcc}->{$id}->{done} = unpack 'N', substr( $data, -4 );
402              
403             $irc->send_event(
404             'irc_dcc_send',
405             $id,
406 131         274 @{ $self->{dcc}->{$id} }{qw(
  131         669  
407             nick port file size done peeraddr
408             )},
409             );
410              
411             # Are we done yet?
412 131 100       16648 if ($self->{dcc}->{$id}->{done} >= $self->{dcc}->{$id}->{size}) {
413             # Reclaim our port if necessary.
414 3 50 33     74 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         17 @{ $self->{dcc}->{$id} }{qw(
  3         25  
422             nick type port file size done peeraddr
423             )},
424             );
425              
426 3         446 $self->_remove_dcc($id);
427 3         13 return;
428             }
429              
430             # Send the next 'blocksize'-sized packet.
431             read $self->{dcc}->{$id}->{fh}, $data,
432 128         1041 $self->{dcc}->{$id}->{blocksize};
433 128         488 $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         41 @{ $self->{dcc}->{$id} }{qw(nick port)},
440             $data,
441             $self->{dcc}->{$id}->{peeraddr},
442 7         27 );
443             }
444              
445 266         27038 return;
446             }
447              
448             # What happens when an attempted DCC connection fails.
449             sub _dcc_failed {
450 7     7   4888 my ($self, $operation, $errnum, $errstr, $id) = @_[OBJECT, ARG0 .. ARG3];
451 7         29 my $irc = $self->{irc};
452              
453 7 100       37 if (!exists $self->{dcc}->{$id}) {
454 5 50       29 if (exists $self->{wheelmap}->{$id}) {
455 5         18 $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     84 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       27 last DCC if $errnum != 0;
  7         32  
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       42 if ($self->{dcc}->{$id}->{type} eq 'GET') {
474 3 50       20 if ($self->{dcc}->{$id}->{done} < $self->{dcc}->{$id}->{size}) {
475 0         0 last DCC;
476             }
477             }
478              
479 7 50       118 if ($self->{dcc}->{$id}->{type} =~ /^(GET|CHAT)$/) {
480             $irc->send_event(
481             'irc_dcc_done',
482             $id,
483 7         30 @{ $self->{dcc}->{$id} }{qw(
  7         68  
484             nick type port file size done peeraddr
485             )},
486             );
487              
488 7         1139 $self->_remove_dcc($id);
489             }
490              
491 7         33 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   5915954 my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0];
522              
523 2 50 33     81 if (exists $self->{dcc}->{$id} && !$self->{dcc}->{$id}->{open}) {
524 2         23 $kernel->yield(
525             '_dcc_failed',
526             'connection',
527             0,
528             'DCC connection timed out',
529             $id,
530             );
531             }
532 2         285 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   5555 my ($kernel, $self, $sock, $peeraddr, $id) =
539             @_[KERNEL, OBJECT, ARG0, ARG1, ARG3];
540 12         39 my $irc = $self->{irc};
541              
542             # Delete the listening socket and monitor the accepted socket
543             # for incoming data
544 12         90 delete $self->{dcc}->{$id}->{factory};
545 12         1850 $self->{dcc}->{$id}->{open} = 1;
546 12         100 $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       152 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         5220 $self->{wheelmap}->{ $self->{dcc}->{$id}->{wheel}->ID } = $id;
563              
564 12         65 my $handle;
565 12 100       78 if ($self->{dcc}->{$id}->{type} eq 'GET') {
    100          
566             # check if we're resuming
567 3 100       31 my $mode = $self->{dcc}->{$id}->{resuming} ? '>>' : '>';
568              
569 3 50       279 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         15 binmode $handle;
575 3         14 $self->{dcc}->{$id}->{fh} = $handle;
576             }
577             elsif ($self->{dcc}->{$id}->{type} eq 'SEND') {
578 3 50       245 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         15 binmode $handle;
584 3         34 seek $handle, $self->{dcc}{$id}{done}, 0;
585             # Send the first packet to get the ball rolling.
586 3         113 read $handle, my $buffer, $self->{dcc}->{$id}->{blocksize};
587 3         35 $self->{dcc}->{$id}->{wheel}->put($buffer);
588 3         287 $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         43 @{ $self->{dcc}->{$id} }{qw(
  12         79  
596             nick type port file size peeraddr
597             )},
598             );
599              
600 12         1977 return;
601             }
602              
603             sub _cancel_timeout {
604 8     8   451 my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0];
605 8         36 my $alarm_id = delete $self->{dcc}{$id}{alarm_id};
606 8         58 $kernel->alarm_remove($alarm_id);
607 8         1035 return;
608             }
609              
610             sub _remove_dcc {
611 14     14   54 my ($self, $id) = @_;
612              
613 14 100       70 if (exists $self->{dcc}{$id}{alarm_id}) {
614 3         21 $poe_kernel->call($self->{session_id}, '_cancel_timeout', $id);
615             }
616              
617 14 100       75 if (exists $self->{dcc}{$id}{wheel}) {
618 12         62 delete $self->{wheelmap}{ $self->{dcc}{$id}{wheel}->ID };
619 12 50       164 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       381 close $self->{dcc}{$id}{fh} if $self->{dcc}{$id}{type} eq 'GET';
626              
627 14         197 delete $self->{dcc}{$id};
628 14         4986 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