File Coverage

blib/lib/Net/TFTP.pm
Criterion Covered Total %
statement 48 369 13.0
branch 7 252 2.7
condition 2 44 4.5
subroutine 11 37 29.7
pod 14 14 100.0
total 82 716 11.4


line stmt bran cond sub pod time code
1             # Net::TFTP.pm
2             #
3             # Copyright (c) 1998,2007 Graham Barr . All rights reserved.
4             # This program is free software; you can redistribute it and/or
5             # modify it under the same terms as Perl itself.
6              
7             package Net::TFTP;
8              
9 3     3   51299 use strict;
  3         7  
  3         105  
10 3     3   14 use vars qw($VERSION);
  3         3  
  3         163  
11 3     3   1818 use IO::File;
  3         30234  
  3         2135  
12              
13             $VERSION = "0.1901";
14              
15             sub RRQ () { 01 } # read request
16             sub WRQ () { 02 } # write request
17             sub DATA () { 03 } # data packet
18             sub ACK () { 04 } # acknowledgement
19             sub ERROR () { 05 } # error code
20             sub OACK () { 06 } # option acknowledgement
21              
22             my @NAME = qw(. RRQ WRQ DATA ACK ERR OACK);
23              
24             sub new {
25 3     3 1 541 my $pkg = shift;
26 3         6 my $host = shift;
27              
28 3         31 bless {
29             Debug => 0, # Debug off
30             Timeout => 5, # resend after 5 seconds
31             Retries => 5, # resend max 5 times
32             Port => 69, # tftp port number
33             BlockSize => 0, # use default blocksize (512)
34             IpMode => 'v4', # Operate in IPv6 mode, off by default
35             Mode => 'netascii', # transfer in netascii
36             @_, # user overrides
37             Host => $host, # the hostname
38             }, $pkg;
39             }
40              
41             sub timeout {
42 0     0 1 0 my $self = shift;
43 0         0 my $v = $self->{'Timeout'};
44 0 0       0 $self->{'Timeout'} = 0 + shift if @_;
45 0         0 $v
46             }
47              
48             sub debug {
49 0     0 1 0 my $self = shift;
50 0         0 my $v = $self->{'Debug'};
51 0 0       0 $self->{'Debug'} = 0 + shift if @_;
52 0         0 $v
53             }
54              
55             sub port {
56 0     0 1 0 my $self = shift;
57 0         0 my $v = $self->{'Port'};
58 0 0       0 $self->{'Port'} = 0 + shift if @_;
59 0         0 $v
60             }
61              
62             sub retries {
63 0     0 1 0 my $self = shift;
64 0         0 my $v = $self->{'Retries'};
65 0 0       0 $self->{'Retries'} = 0 + shift if @_;
66 0         0 $v
67             }
68              
69             sub block_size {
70 0     0 1 0 my $self = shift;
71 0         0 my $v = $self->{'BlockSize'};
72 0 0       0 $self->{'BlockSize'} = 0 + shift if @_;
73 0         0 $v
74             }
75              
76             sub host {
77 0     0 1 0 my $self = shift;
78 0         0 my $v = $self->{'Host'};
79 0 0       0 $self->{'Host'} = shift if @_;
80 0         0 $v
81             }
82              
83             sub ip_mode {
84 0     0 1 0 my $self = shift;
85 0         0 my $v = $self->{'IpMode'};
86 0 0       0 $self->{'IpMode'} = shift if @_;
87 0         0 $v
88             }
89              
90             sub ascii {
91 0     0 1 0 $_[0]->mode('netascii');
92             }
93              
94             sub binary {
95 0     0 1 0 $_[0]->mode('octet');
96             }
97              
98             BEGIN {
99 3     3   10 *netascii = \&ascii;
100 3         2293 *octet = \&binary;
101             }
102              
103             sub mode {
104 0     0 1 0 my $self = shift;
105 0         0 my $v = $self->{'Mode'};
106 0 0       0 $self->{'Mode'} = lc($_[0]) eq "netascii" ? "netascii" : "octet"
    0          
107             if @_;
108 0         0 $v
109             }
110              
111             sub error {
112 0     0 1 0 my $self = shift;
113             exists $self->{'error'}
114 0 0       0 ? $self->{'error'}
115             : undef;
116             }
117              
118             sub get {
119 2     2 1 52 my($self,$remote) = splice(@_,0,2);
120 2 50       8 my $local = shift if @_ % 2;
121 2         16 my %arg = ( %$self, @_ );
122              
123 2         8 delete $self->{'error'};
124              
125 2         13 my $io = Net::TFTP::IO->new($self,\%arg,RRQ,$remote);
126              
127 2 100 66     65 return $io
128             unless defined($local) && defined($io);
129              
130 1         1 my $file = $local;
131 1 50       4 unless(ref($local)) {
132 1         9 $local = IO::File->new($file,O_WRONLY|O_TRUNC|O_CREAT);
133 1 50       85 unless ($local) {
134 1         15 $self->{'error'} = "Can not open $file: $!";
135 1         9 return undef;
136             }
137             }
138              
139 0 0       0 binmode $local if $self->{'Mode'} eq 'octet';
140              
141 0         0 my($len,$pkt);
142 0         0 while($len = sysread($io,$pkt,10240)) {
143 0 0       0 if($len < 0) {
    0          
144 0         0 $self->{'error'} = $io->error;
145 0         0 last;
146             }
147             elsif(syswrite($local,$pkt,length($pkt)) < 0) {
148 0         0 $self->{'error'} = "$!";
149 0         0 last;
150             }
151             }
152              
153 0 0       0 close($local)
154             unless ref($file);
155              
156 0 0       0 $self->{'error'} = $io->error
157             unless(close($io));
158              
159 0 0       0 exists $self->{'error'} ? undef : 1;
160             }
161              
162             sub put {
163 0     0 1 0 my($self,$remote) = splice(@_,0,2);
164 0         0 my $local;
165 0 0       0 ($local,$remote) = ($remote,shift) if @_ %2;
166 0         0 my %arg = (%$self,@_);
167              
168 0         0 delete $self->{'error'};
169              
170 0         0 my $file;
171 0 0       0 if (defined $local) {
172 0         0 $file = $local;
173 0 0       0 unless(ref($local)) {
174 0 0       0 unless ($local = IO::File->new($file,O_RDONLY)) {
175 0         0 $self->{'error'} = "$file: $!";
176 0         0 return undef;
177             }
178             }
179             }
180              
181 0         0 my $io = Net::TFTP::IO->new($self,\%arg,WRQ,$remote);
182              
183 0 0 0     0 return $io
184             unless defined($local) && defined($io);
185              
186 0 0       0 binmode $local if $self->{'Mode'} eq 'octet';
187              
188 0         0 my($len,$pkt);
189 0         0 while($len = sysread($local,$pkt,10240)) {
190 0 0       0 if($len < 0) {
    0          
191 0         0 $self->{'error'} = "$!";
192 0         0 last;
193             }
194             elsif(($len=syswrite($io,$pkt,length($pkt))) < 0) {
195 0         0 $self->{'error'} = $io->error;
196 0         0 last;
197             }
198             }
199              
200 0 0       0 close($local)
201             unless ref($file);
202              
203 0 0       0 $self->{'error'} = $io->error
204             unless(close($io));
205              
206 0 0       0 exists $self->{'error'} ? undef : 1;
207             }
208              
209             package Net::TFTP::IO;
210              
211 3     3   26 use vars qw(@ISA);
  3         10  
  3         181  
212 3     3   2236 use IO::Socket;
  3         48623  
  3         14  
213 3     3   3415 use IO::Select;
  3         5014  
  3         5008  
214              
215             @ISA = qw(IO::Handle);
216              
217             sub new {
218 1     1   2 my($pkg,$tftp,$opts,$op,$remote) = @_;
219 1         11 my $io = $pkg->SUPER::new;
220              
221 1         22 $opts->{'Mode'} = lc($opts->{'Mode'});
222 1         3 $opts->{'IpMode'} = lc($opts->{'IpMode'});
223             $opts->{'Mode'} = "netascii"
224 1 50       6 unless $opts->{'Mode'} eq "octet";
225 1         3 $opts->{'ascii'} = lc($opts->{'Mode'}) eq "netascii";
226              
227 1         1 my $host = $opts->{'Host'};
228 1 50       5 do {
229 1         1 $tftp->{'error'} = "No hostname given";
230 1         5 return undef;
231             } unless defined($host);
232              
233             ## jjmb - had to make an adjustment here the logic used originally does not work well
234             ## with IPv6.
235 0           my $port = undef;
236 0 0         if($opts->{'IpMode'} eq "v6") {
237 0           require Socket6;
238 0           require IO::Socket::INET6;
239 0           $port = $opts->{'Port'};
240             } else {
241 0 0         $port = $host =~ s/:(\d+)$// ? $1 : $opts->{'Port'};
242             }
243 0           my $addr = inet_aton($host);
244              
245             ## jjmb - added some logic here for the time being to prevent some errors from showing
246 0 0         if($opts->{'IpMode'} eq "v6") {
247             # Skipping validation
248             } else {
249 0 0         unless($addr) {
250 0           $tftp->{'error'} = "Bad hostname '$host'";
251 0           return undef;
252             }
253             }
254              
255             ## jjmb - need to construct different objects depending on the IP version used
256 0           my $sock = undef;
257 0 0         if($opts->{'IpMode'} eq "v6") {
258 0           $sock = IO::Socket::INET6->new(PeerAddr => $opts->{'Host'}, Port => $opts->{'Port'}, Proto => 'udp');
259             } else {
260 0           $sock = IO::Socket::INET->new(Proto => 'udp');
261             }
262              
263 0           my $mode = $opts->{'Mode'};
264 0           my $pkt = pack("n a* c a* c", $op, $remote, 0, $mode, 0);
265              
266 0 0         if($opts->{'BlockSize'} > 0) {
267 0           $pkt .= sprintf("blksize\0%d\0",$opts->{'BlockSize'});
268             }
269              
270 0           my $read = $op == Net::TFTP::RRQ;
271              
272 0           my $sel = IO::Select->new($sock);
273              
274 0           @{$opts}{'read','sock','sel','pkt','blksize'}
  0            
275             = ($read,$sock,$sel,$pkt,512);
276              
277 0 0         if($read) { # read
278 0           @{$opts}{'ibuf','icr','blk'} = ('',0,1);
  0            
279             }
280             else { # write
281 0           @{$opts}{'obuf','blk','ack'} = ('',0,-1);
  0            
282             }
283              
284 0 0         if($tftp->{'IpMode'} eq "v6") {
285 0           send($sock,$pkt,0,Socket6::sockaddr_in6($port,Socket6::inet_pton(AF_INET6,$host)));
286             } else {
287 0           send($sock,$pkt,0,pack_sockaddr_in($port,inet_aton($host)));
288             }
289 0 0         _dumppkt($sock,1,$pkt) if $opts->{'Debug'};
290              
291 0           tie *$io, "Net::TFTP::IO",$opts;
292 0           $io;
293             }
294              
295             sub error {
296 0     0     my $self = shift;
297 0   0       my $tied = UNIVERSAL::isa($self,'GLOB') && tied(*$self) || $self;
298 0 0         exists $tied->{'error'} ? $tied->{'error'} : undef;
299             }
300              
301             sub TIEHANDLE {
302 0     0     my $pkg = shift;
303 0           bless shift , $pkg;
304             }
305              
306             sub PRINT {
307 0     0     my $self = shift;
308             # Simulate print
309 0 0         my $buf = join(defined($,) ? $, : "",@_) . defined($\) ? $\ : "";
    0          
310              
311             # and with the proposed ?? syntax that would be
312             # $buf = join($, ?? "", @_) . $\ ?? "";
313              
314 0           $self->WRITE($buf,length($buf));
315             }
316              
317             sub WRITE {
318             # $self, $buf, $len, $offset
319 0     0     my $self = shift;
320 0   0       my $buf = substr($_[0],$_[2] || 0,$_[1]);
321 0           my $offset = 0;
322              
323 0 0         $buf =~ s/([\n\r])/$1 eq "\n" ? "\015\012" : "\015\0"/soge
324 0 0         if ($self->{'ascii'});
325              
326 0           $self->{'obuf'} .= substr($buf,$offset);
327              
328 0           while(length($self->{'obuf'}) >= $self->{'blksize'}) {
329 0 0         return -1 if _write($self,1) < 0;
330             }
331              
332 0           $_[1];
333             }
334              
335             sub READLINE {
336 0     0     my $self = shift;
337              
338             # return undef (ie eof) unless we have an input buffer
339             return undef
340 0 0 0       if exists $self->{'error'} || !exists $self->{'ibuf'};
341              
342 0           _read($self,0);
343              
344 0           while(1) {
345 0           my $sep;
346             # if $/ is undef then we slurp the whole file
347 0 0         if(defined($sep = $/)) {
348             # if $/ eq "" then we need to do paragraph mode
349 0 0         unless(length($sep)) {
350             # when doing paragraph mode remove all leading \n's
351 0           $self->{'ibuf'} =~ s/^\n+//s;
352 0           $sep = "\n\n";
353             }
354 0           my $offset = index($self->{'ibuf'},$sep);
355 0 0         if($offset >= 0) {
356 0           my $len = $offset+length($sep);
357             # With 5.005 I could use the 4-arg substr
358 0           my $ret = substr($self->{'ibuf'},0,$len);
359 0           substr($self->{'ibuf'},0,$len) = "";
360              
361 0           return $ret;
362             }
363             }
364              
365 0           my $res = _read($self,1);
366              
367 0 0         next if $res > 0; # We have some more, but do we have enough ?
368              
369 0 0         if ($res < 0) {
370             # We have encountered an error, so
371             # force subsequent reads to return eof
372 0           delete $self->{'ibuf'};
373              
374             # And return undef (ie eof)
375 0           return undef;
376             }
377              
378             # $res == 0 so there is no more data to read, just return
379             # the buffer contents
380 0           return delete $self->{'ibuf'};
381             }
382              
383             # NOT REACHED
384 0           return;
385             }
386              
387             sub READ {
388             # $self, $buf, $len, $offset
389              
390 0     0     my $self = shift;
391              
392             return undef
393 0 0         if exists $self->{'error'};
394              
395             return 0
396 0 0         unless exists $self->{'ibuf'};
397              
398 0           my $ret = length($self->{'ibuf'});
399              
400 0 0         unless ($self->{'eof'}) {
401             # If there is any data waiting, read it and ask for more
402 0           _read($self,0);
403              
404             # read until we have enough
405 0           while(($ret = length($self->{'ibuf'})) < $_[1]) {
406 0 0         last unless _read($self,1) > 0;
407             }
408             }
409              
410             # Did we encounter an error
411             return undef
412 0 0         if exists $self->{'error'};
413              
414             # we may have too much
415 0 0         $ret = $_[1]
416             if $_[1] < $ret;
417              
418             # We are simulating read() so we may have to insert into $_[0]
419 0 0         if($ret) {
420 0 0         if($_[2]) {
421 0           substr($_[0],$_[2]) = substr($self->{'ibuf'},0,$ret);
422             }
423             else {
424 0           $_[0] = substr($self->{'ibuf'},0,$ret);
425             }
426              
427             # remove what we placed into $_[0]
428 0           substr($self->{'ibuf'},0,$ret) = "";
429             }
430              
431             # If we are returning less than what was asked for
432             # then the next call must return eof
433             delete $self->{'ibuf'}
434 0 0 0       if $self->{'eof'} && length($self->{'ibuf'}) == 0 ;
435              
436 0           $ret;
437             }
438              
439             sub CLOSE {
440 0     0     my $self = shift;
441              
442 0 0 0       if (exists $self->{'sock'} && !exists $self->{'closing'}) {
443 0           $self->{'closing'} = 1;
444 0 0         if ($self->{'read'} ) {
445 0 0         unless ($self->{'eof'}) {
446 0           my $pkt = pack("nna*c",Net::TFTP::ERROR,0,"Premature close",0);
447 0 0         _dumppkt($self->{'sock'},1,$pkt) if $self->{'Debug'};
448             send($self->{'sock'},$pkt,0,$self->{'peer'})
449 0 0         if $self->{'peer'};
450             }
451             }
452             else {
453             # Clear the buffer
454 0 0         unless(exists $self->{'error'}) {
455 0           while(length($self->{'obuf'}) >= $self->{'blksize'}) {
456 0 0         last if _write($self) < 0;
457             }
458              
459             # Send the last block
460 0           $self->{'blksize'} = length($self->{'obuf'});
461 0 0         _write($self) unless(exists $self->{'error'});
462              
463             # buffer is empty so blksize=1 will ensure I do not send
464             # another packet, but just wait for the ACK
465 0           $self->{'blksize'} = 1;
466 0 0         _write($self) unless(exists $self->{'error'});
467             }
468             }
469 0           close(delete $self->{'sock'});
470             }
471              
472 0 0         exists $self->{'error'} ? 0 : 1;
473             }
474              
475             # _natoha($data,$cr) - Convert netascii -> host text
476             # updates both input args
477             sub _natoha {
478 3     3   24 use vars qw($buf $cr);
  3         6  
  3         5845  
479 0     0     local *buf = \$_[0];
480 0           local *cr = \$_[1];
481 0           my $last = substr($buf,-1);
482 0 0         if($cr) {
483 0           my $ch = ord(substr($buf,0,1));
484 0 0         if($ch == 012) { # CR.LF => \n
    0          
485 0           substr($buf,0,1) = "\n";
486             }
487             elsif($ch == 0) { # CR.NUL => \r
488 0           substr($buf,0,1) = "\r";
489             }
490             else {
491             # Hm, badly formed netascii
492 0           substr($buf,0,0) = "\015";
493             }
494             }
495              
496 0 0         if(ord($last) eq 015) {
497 0           substr($buf,-1) = "";
498 0           $cr = 1;
499             }
500             else {
501 0           $cr = 0;
502             }
503              
504 0           $buf =~ s/\015\0/\r/sg;
505 0           $buf =~ s/\015\012/\n/sg;
506              
507 0           1;
508             }
509              
510             sub _abort {
511 0     0     my $self = shift;
512 0   0       $self->{'error'} ||= 'Protocol error';
513 0           $self->{'eof'} = 1;
514 0           my $pkt = pack("nna*c",Net::TFTP::ERROR,0,$self->{'error'},0);
515             send($self->{'sock'},$pkt,0,$self->{'peer'})
516 0 0         if exists $self->{'peer'};
517 0           CLOSE($self);
518 0           -1;
519             }
520              
521             # _read: The guts of the reading
522             #
523             # returns
524             # >0 size of data read
525             # 0 eof
526             # <0 error
527              
528             sub _read {
529 0     0     my($self,$wait) = @_;
530              
531 0 0         return -1 if exists $self->{'error'};
532 0 0         return 0 if $self->{'eof'};
533              
534 0   0       my $sock = $self->{'sock'} || return -1;
535 0           my $select = $self->{'sel'};
536 0 0         my $timeout = $wait ? $self->{'Timeout'} : 0;
537 0           my $retry = 0;
538              
539 0           while(1) {
540 0 0         if($select->can_read($timeout)) {
541 0           my $ipkt = ''; # will be filled by _recv
542 0 0         my($peer,$code,$blk) = _recv($self,$ipkt)
543             or return _abort($self);
544              
545 0 0         redo unless defined($peer); # do not send ACK to real peer
546              
547 0 0         if($code == Net::TFTP::DATA) {
    0          
    0          
548             # If we receive a packet we are not expecting
549             # then ACK the last packet again
550              
551 0 0         if($blk == $self->{'blk'}) {
    0          
552 0           $self->{'blk'} = $blk+1;
553 0           my $data = substr($ipkt,4);
554              
555             _natoha($data,$self->{'icr'})
556 0 0         if($self->{'ascii'});
557              
558 0           $self->{'ibuf'} .= $data;
559              
560 0           my $opkt = $self->{'pkt'} = pack("nn", Net::TFTP::ACK,$blk);
561 0           send($sock,$opkt,0,$peer);
562              
563             _dumppkt($sock,1,$opkt)
564 0 0         if $self->{'Debug'};
565              
566             $self->{'eof'} = 1
567 0 0         if ( length($ipkt) < ($self->{'blksize'} + 4) );
568              
569 0           return length($data);
570             }
571             elsif($blk < $self->{'blk'}) {
572 0           redo; # already got this data
573             }
574             }
575             elsif($code == Net::TFTP::OACK) {
576 0           my $opkt = $self->{'pkt'} = pack("nn", Net::TFTP::ACK,0);
577 0           send($sock,$opkt,0,$peer);
578              
579             _dumppkt($sock,1,$opkt)
580 0 0         if $self->{'Debug'};
581              
582 0           return _read($self,$wait);
583             }
584             elsif($code == Net::TFTP::ERROR) {
585 0           $self->{'error'} = substr($ipkt,4);
586 0           $self->{'eof'} = 1;
587 0           CLOSE($self);
588 0           return -1;
589             }
590              
591 0           return _abort($self);
592             }
593              
594 0 0         last unless $wait;
595             # Resend last packet, this will re ACK the last data packet
596 0 0         if($retry++ >= $self->{'Retries'}) {
597 0           $self->{'error'} = "Transfer Timeout";
598 0           return _abort($self);
599             }
600              
601             send($sock,$self->{'pkt'},0,$self->{'peer'})
602 0 0         if $self->{'peer'};
603              
604 0 0         if ($self->{'Debug'}) {
605 0           print STDERR "${sock} << ---- retry=${retry}\n";
606 0           _dumppkt($sock,1,$self->{'pkt'});
607             }
608             }
609              
610             # NOT REACHED
611             }
612              
613             sub _recv {
614 0     0     my $self = shift;
615 0           my $sock = $self->{'sock'};
616 0           my $bsize = $self->{'blksize'}+4;
617 0 0         $bsize = 516 if $bsize < 516;
618 0           my $peer = recv($sock,$_[0],$bsize,0);
619              
620             # There is something on the socket, but not a udp packet. Prob. an icmp.
621 0 0         return unless ($peer);
622              
623 0 0         _dumppkt($sock,0,$_[0]) if $self->{'Debug'};
624              
625             # The struct in $peer can be bigger than needed for AF_INET
626             # so could contain garbage at the end. unpacking and re-packing
627             # will ensure it is zero filled (Thanks TomC)
628 0 0         if($self->{'IpMode'} eq "v6") {
629 0           $peer = Socket6::pack_sockaddr_in6(Socket6::unpack_sockaddr_in6($peer));
630             } else {
631 0           $peer = pack_sockaddr_in(unpack_sockaddr_in($peer));
632             }
633              
634 0   0       $self->{'peer'} ||= $peer; # Remember first peer
635              
636 0           my($code,$blk) = unpack("nn",$_[0]);
637              
638 0 0         if($code == Net::TFTP::OACK) {
639 0           my %o = split("\0",substr($_[0],2));
640 0           %$self = (%$self,%o);
641             }
642              
643 0 0         if ($self->{'peer'} ne $peer) {
644             # All packets must be from same peer
645             # packet from someone else, send them an ERR packet
646 0           my $err = pack("nna*c",Net::TFTP::ERROR, 5, "Unknown transfer ID",0);
647             _dumppkt($sock,1,$err)
648 0 0         if $self->{'Debug'};
649 0           send($sock,$err,0,$peer);
650              
651 0           $peer = undef;
652             }
653              
654 0           ($peer,$code,$blk);
655             }
656              
657             sub _send_data {
658 0     0     my $self = shift;
659              
660 0 0 0       if(length($self->{'obuf'}) >= $self->{'blksize'}) {
    0          
    0          
661 0           my $blk = ++$self->{'blk'};
662             my $opkt = $self->{'pkt'} = pack("nn", Net::TFTP::DATA,$blk)
663 0           . substr($self->{'obuf'},0,$self->{'blksize'});
664 0           substr($self->{'obuf'},0,$self->{'blksize'}) = '';
665              
666 0           my $sock = $self->{'sock'};
667 0           send($sock,$opkt,0,$self->{'peer'});
668              
669             _dumppkt($sock,1,$opkt)
670 0 0         if $self->{'Debug'};
671             }
672             elsif (length($self->{'obuf'}) == 0 and $self->{'blksize'} == 1) {
673             # ignore
674             }
675             elsif($^W) {
676 0           require Carp;
677 0           Carp::carp("Net::TFTP: Buffer underflow");
678             }
679              
680 0           1;
681             }
682              
683             sub _write {
684 0     0     my($self) = @_;
685              
686 0 0         return -1 if exists $self->{'error'};
687              
688 0   0       my $sock = $self->{'sock'} || return -1;
689 0           my $select = $self->{'sel'};
690 0           my $timeout = $self->{'Timeout'};
691 0           my $retry = 0;
692              
693             return _send_data($self)
694 0 0         if $self->{'ack'} == $self->{'blk'};
695              
696 0           while(1) {
697 0 0         if($select->can_read($timeout)) {
698 0           my $ipkt=''; # will be filled by _recv
699 0 0         my($peer,$code,$blk) = _recv($self,$ipkt)
700             or return _abort($self);
701              
702 0 0         redo unless defined($peer); # do not send ACK to real peer
703              
704 0 0         if($code == Net::TFTP::OACK) {
705 0           $code = Net::TFTP::ACK;
706 0           $blk = 0;
707             }
708              
709 0 0         if($code == Net::TFTP::ACK) {
710 0 0         if ($self->{'blk'} == $blk) {
    0          
711 0           $self->{'ack'} = $blk;
712 0           return _send_data($self);
713             }
714             elsif ($self->{'blk'} > $blk) {
715 0           redo; # duplicate ACK
716             }
717             }
718              
719 0 0         if($code == Net::TFTP::ERROR) {
720 0           $self->{'error'} = substr($ipkt,4);
721 0           CLOSE($self);
722 0           return -1;
723             }
724              
725 0           return _abort($self);
726             }
727              
728             # Resend last packet, this will resend the last DATA packet
729 0 0         if($retry++ >= $self->{'Retries'}) {
730 0           $self->{'error'} = "Transfer Timeout";
731 0           return _abort($self);
732             }
733 0           send($sock,$self->{'pkt'},0,$self->{'peer'});
734              
735 0 0         if ($self->{'Debug'}) {
736 0           print STDERR "${sock} << ---- retry=${retry}\n";
737 0           _dumppkt($sock,1,$self->{'pkt'});
738             }
739             }
740             # NOT REACHED
741             }
742              
743             sub _dumppkt {
744 0     0     my($sock,$send) = @_;
745 0           my($code,$blk) = unpack("nn",$_[2]);
746 0 0         $send = $send ? "$sock <<" : "$sock >>";
747 0           my $str = sprintf "%s %-4s",$send,$NAME[$code];
748 0 0 0       $str .= sprintf " %s=%d",$code == Net::TFTP::ERROR ? "code" : "blk",$blk
    0 0        
749             if $code == Net::TFTP::DATA
750             || $code == Net::TFTP::ACK
751             || $code == Net::TFTP::ERROR;
752              
753 0           printf STDERR "%s length=%d\n",$str,length($_[2]);
754 0 0 0       if($code == Net::TFTP::RRQ || $code == Net::TFTP::WRQ || $code == Net::TFTP::OACK) {
      0        
755 0           my @a = split("\0",substr($_[2],2));
756 0 0         printf STDERR "%s filename=%s mode=%s\n",$send,splice(@a,0,2)
757             unless $code == Net::TFTP::OACK;
758 0           my %a = @a;
759 0           my($k,$v);
760 0           while(($k,$v) = each %a) {
761 0           printf STDERR "%s %s=%s\n",$send,$k,$v;
762             }
763              
764             }
765 0 0         printf STDERR "%s %s\n",$send,substr($_[2],4)
766             if $code == Net::TFTP::ERROR;
767             }
768              
769             1;
770              
771             __END__