Net-TFTP-0.1901/000755 000765 000765 00000000000 13054151074 012335 5ustar00gbarr000000 000000 Net-TFTP-0.1901/ChangeLog000644 000765 000765 00000004250 13054145712 014112 0ustar00gbarr000000 000000 0.1901 -- Fri Feb 24 18:11:22 CST 2017 * Fix Test::MockModule build_requires version [Ben Bullock] 0.19 -- Wed Nov 24 18:22:33 CST 2010 * Get rid of unlink [Maik Hentsche] * Fixed build_requires [Maik Hentsche] * fix BUILD_REQUIRES to more classical PREREQ_PM [Steffen Schwigon] 0.18 -- Mon May 31 10:38:13 CDT 2010 * Added support for IPv6 (patch from John Jason Brzozowski) * Added .gitignore file [Maik Hentsche] * added unit tests [Maik Hentsche] * added directory for unit test [Maik Hentsche] * handle unlink error [Maik Hentsche] * added unit test for missing host [Maik Hentsche] * Fix warning for new() without host argument [Maik Hentsche] Release 0.17 -- Wed Jul 18 06:30:05 CDT 2007 Enhancements * Added support for IPv6 (patch from John Jason Brzozowski) Change 746 on 2002/09/23 by (Graham Barr) Fix return logic for get and put (patch from Bruce Gray) Change 726 on 2002/05/27 by (Graham Barr) Release 0.15 Change 725 on 2002/05/27 by (Graham Barr) Fix 'Use of uninitialized' warning Change 693 on 2002/01/11 by (Graham Barr) Add O_TRUNC to open in get() so an existing file is truncated instead of unlinked and recreated Change 646 on 2001/09/17 by (Graham Barr) Ensure local files are in binmode when transfer is octet mode Avoid spurious Buffer underflow warning Change 633 on 2001/09/03 by (Graham Barr) Release 0.12 Change 614 on 2001/05/29 by (Graham Barr) Move TFTP out of libnet Change 469 on 2000/03/30 by (Graham Barr) Documentation updates Change 430 on 2000/03/29 by (Graham Barr) Net::TFTP - There is no quit method, so don't document one Change 264 on 1999/03/18 by (Graham Barr) Net::TFTP - Fix typo in CLOSE() Change 196 on 1998/10/16 by (Graham Barr) Net::TFTP - Initial public release Change 187 on 1998/09/02 by (Graham Barr) Net::TFTP - Some cleanup of the code - removed leading - from named args Change 185 on 1998/08/24 by (Graham Barr) Net::TFTP - Initial version Net-TFTP-0.1901/Makefile.PL000644 000765 000765 00000001213 13054144725 014311 0ustar00gbarr000000 000000 # This -*- perl -*- script makes the Makefile # $Id: //depot/asn/Makefile.PL#5 $ use 5.005; use ExtUtils::MakeMaker; WriteMakefile( VERSION_FROM => 'TFTP.pm', NAME => 'Net::TFTP', PREREQ_PM => { 'Test::More' => 0.8701, 'Test::MockModule' => '0.11', 'Test::Warn' => 0, }, (eval { ExtUtils::MakeMaker->VERSION(6.21) } ? (LICENSE => 'perl') : ()), ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? ( META_MERGE => { resources => { ## repository => 'http://github.com/gbarr/perl-net-tftp', }, } ) : () ), ); Net-TFTP-0.1901/MANIFEST000644 000765 000765 00000000555 13054151073 013472 0ustar00gbarr000000 000000 ChangeLog MANIFEST Makefile.PL README TFTP.pm META.yml Module meta-data (added by MakeMaker) t/00-load.t t/01-get.t t/02-new.t t/files/directory/empty t/files/source META.json Module JSON meta-data (added by MakeMaker) SIGNATURE Public-key signature (added by MakeMaker) Net-TFTP-0.1901/META.json000644 000765 000765 00000002071 13054151073 013755 0ustar00gbarr000000 000000 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Net-TFTP", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::MockModule" : "0.11", "Test::More" : "0.8701", "Test::Warn" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "http://github.com/gbarr/perl-net-tftp" } }, "version" : "0.1901", "x_serialization_backend" : "JSON::PP version 2.27300_01" } Net-TFTP-0.1901/META.yml000644 000765 000765 00000001151 13054151073 013603 0ustar00gbarr000000 000000 --- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Net-TFTP no_index: directory: - t - inc requires: Test::MockModule: '0.11' Test::More: '0.8701' Test::Warn: '0' resources: repository: http://github.com/gbarr/perl-net-tftp version: '0.1901' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Net-TFTP-0.1901/README000644 000765 000765 00000001235 11150571125 013214 0ustar00gbarr000000 000000 Net::TFTP was previously part of the libnet distribution. But has now been separated out to a distribution of its own. INSTALLATION Installastion is the same as any other MakeMaker packaged distribution from CPAN. perl Makefile.PL make make install If you are on a mchine where Makemaker does not run, or you do not have a copy of make, then you can simply copy the TFTP.pm file from this directory into a Net subdirectory in your perl installation library directory. COPYRIGHT © 1996-2001 Graham Barr. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Share and Enjoy! Net-TFTP-0.1901/SIGNATURE000644 000765 000765 00000003753 13054151074 013631 0ustar00gbarr000000 000000 This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.81. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA256 SHA1 5399494c9236e02bb609829f4075482def484f26 ChangeLog SHA1 a9352dbecbffdaf29cde1f2d58b3847fd2659d43 MANIFEST SHA1 c793957fbee32179e289a2b60098de470928db76 META.json SHA1 0527b8f8e881b8f4b63c7bedfd24b60674a946a6 META.yml SHA1 f9d8a6e97b84526cb0074b595b16913aff3eb746 Makefile.PL SHA1 9044bc5ec03ee5bee19c8b9c5c68a6a05f6fcb83 README SHA1 9efc7a893d595aec06a1f635937e6453d1848ec5 TFTP.pm SHA1 bf8966b89de40e8c1200ea7a12a831d1a77f78bf t/00-load.t SHA1 b62e4dd85e37ad5293d3cbc58930be6ceb5eaba4 t/01-get.t SHA1 10b3eb59c4a04696f21a30a85701b18227431e1b t/02-new.t SHA1 da39a3ee5e6b4b0d3255bfef95601890afd80709 t/files/directory/empty SHA1 e04ff2983499c33b1597bd03d23b30ec20d78a61 t/files/source -----BEGIN PGP SIGNATURE----- iQIcBAEBCAAGBQJYsNI8AAoJEF0awSLzqjNN3IQP/iBhLdbXQpYKKzzVqAnyfu2L TMKfJPCg2+DQnt4si97hxOSsVuy02chIYyDjOMDbyhSEivVBbR1SvY4EV4Ubb5HI snTLgjM+Iz/GVrrPHh44lHs+X1afzT5IEM57Ny8Xo/1Jnn5rk/MvKmZtFhWXn012 ocWm/7z1gXySRJQPM9Zuxpl/mbUqObz5gsXYwIRwTE7yK8BDf5va0ZhnUI9wTCG/ X72jUkBaFHrSG01iYlKeru/LM6VwwdQY3BSaq/GbHHZ1qrEqJe6Hu16brpyJPsrX VUTpcSaOEv/UNSObBqXBMu6R7lBjCHzGuUAn6b7gJKUBRGbh0IfKvvoMyoJF2/aC NhCHCRlSJeIvlwNF9P5ZzsTY12pYF9XzXqV7zEs0LJsr/lhYdb9bRkvFJBUf6vmv lvskd6Lk6Zwe+udAnM0tEp6apXz0UYkMcGse47d6NCOwPXdJWB65vOkO4M9ZKVIY 3TPuYG8DOx3eX+Zo0gIbIi763c8zDhCHo6YPrBjdgda+HqbagWfEQOsTo+U+iSw/ xqHdndGvhKyQ4abuP0rc6iVHTgrLp+3jGKsJVCUVwmkVlHgnMjGAmMxxIe4GEUpa jRCVfJKDoARhjCrFaDTntUIeoFuPs6efNBGilnHbDeG+C4Hn24TXjwjWhblDQhTY zY83P9ibLK1tlUOx6JVX =k1rr -----END PGP SIGNATURE----- Net-TFTP-0.1901/t/000755 000765 000765 00000000000 13054151073 012577 5ustar00gbarr000000 000000 Net-TFTP-0.1901/TFTP.pm000644 000765 000765 00000051315 13054146536 013464 0ustar00gbarr000000 000000 # Net::TFTP.pm # # Copyright (c) 1998,2007 Graham Barr . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package Net::TFTP; use strict; use vars qw($VERSION); use IO::File; $VERSION = "0.1901"; sub RRQ () { 01 } # read request sub WRQ () { 02 } # write request sub DATA () { 03 } # data packet sub ACK () { 04 } # acknowledgement sub ERROR () { 05 } # error code sub OACK () { 06 } # option acknowledgement my @NAME = qw(. RRQ WRQ DATA ACK ERR OACK); sub new { my $pkg = shift; my $host = shift; bless { Debug => 0, # Debug off Timeout => 5, # resend after 5 seconds Retries => 5, # resend max 5 times Port => 69, # tftp port number BlockSize => 0, # use default blocksize (512) IpMode => 'v4', # Operate in IPv6 mode, off by default Mode => 'netascii', # transfer in netascii @_, # user overrides Host => $host, # the hostname }, $pkg; } sub timeout { my $self = shift; my $v = $self->{'Timeout'}; $self->{'Timeout'} = 0 + shift if @_; $v } sub debug { my $self = shift; my $v = $self->{'Debug'}; $self->{'Debug'} = 0 + shift if @_; $v } sub port { my $self = shift; my $v = $self->{'Port'}; $self->{'Port'} = 0 + shift if @_; $v } sub retries { my $self = shift; my $v = $self->{'Retries'}; $self->{'Retries'} = 0 + shift if @_; $v } sub block_size { my $self = shift; my $v = $self->{'BlockSize'}; $self->{'BlockSize'} = 0 + shift if @_; $v } sub host { my $self = shift; my $v = $self->{'Host'}; $self->{'Host'} = shift if @_; $v } sub ip_mode { my $self = shift; my $v = $self->{'IpMode'}; $self->{'IpMode'} = shift if @_; $v } sub ascii { $_[0]->mode('netascii'); } sub binary { $_[0]->mode('octet'); } BEGIN { *netascii = \&ascii; *octet = \&binary; } sub mode { my $self = shift; my $v = $self->{'Mode'}; $self->{'Mode'} = lc($_[0]) eq "netascii" ? "netascii" : "octet" if @_; $v } sub error { my $self = shift; exists $self->{'error'} ? $self->{'error'} : undef; } sub get { my($self,$remote) = splice(@_,0,2); my $local = shift if @_ % 2; my %arg = ( %$self, @_ ); delete $self->{'error'}; my $io = Net::TFTP::IO->new($self,\%arg,RRQ,$remote); return $io unless defined($local) && defined($io); my $file = $local; unless(ref($local)) { $local = IO::File->new($file,O_WRONLY|O_TRUNC|O_CREAT); unless ($local) { $self->{'error'} = "Can not open $file: $!"; return undef; } } binmode $local if $self->{'Mode'} eq 'octet'; my($len,$pkt); while($len = sysread($io,$pkt,10240)) { if($len < 0) { $self->{'error'} = $io->error; last; } elsif(syswrite($local,$pkt,length($pkt)) < 0) { $self->{'error'} = "$!"; last; } } close($local) unless ref($file); $self->{'error'} = $io->error unless(close($io)); exists $self->{'error'} ? undef : 1; } sub put { my($self,$remote) = splice(@_,0,2); my $local; ($local,$remote) = ($remote,shift) if @_ %2; my %arg = (%$self,@_); delete $self->{'error'}; my $file; if (defined $local) { $file = $local; unless(ref($local)) { unless ($local = IO::File->new($file,O_RDONLY)) { $self->{'error'} = "$file: $!"; return undef; } } } my $io = Net::TFTP::IO->new($self,\%arg,WRQ,$remote); return $io unless defined($local) && defined($io); binmode $local if $self->{'Mode'} eq 'octet'; my($len,$pkt); while($len = sysread($local,$pkt,10240)) { if($len < 0) { $self->{'error'} = "$!"; last; } elsif(($len=syswrite($io,$pkt,length($pkt))) < 0) { $self->{'error'} = $io->error; last; } } close($local) unless ref($file); $self->{'error'} = $io->error unless(close($io)); exists $self->{'error'} ? undef : 1; } package Net::TFTP::IO; use vars qw(@ISA); use IO::Socket; use IO::Select; @ISA = qw(IO::Handle); sub new { my($pkg,$tftp,$opts,$op,$remote) = @_; my $io = $pkg->SUPER::new; $opts->{'Mode'} = lc($opts->{'Mode'}); $opts->{'IpMode'} = lc($opts->{'IpMode'}); $opts->{'Mode'} = "netascii" unless $opts->{'Mode'} eq "octet"; $opts->{'ascii'} = lc($opts->{'Mode'}) eq "netascii"; my $host = $opts->{'Host'}; do { $tftp->{'error'} = "No hostname given"; return undef; } unless defined($host); ## jjmb - had to make an adjustment here the logic used originally does not work well ## with IPv6. my $port = undef; if($opts->{'IpMode'} eq "v6") { require Socket6; require IO::Socket::INET6; $port = $opts->{'Port'}; } else { $port = $host =~ s/:(\d+)$// ? $1 : $opts->{'Port'}; } my $addr = inet_aton($host); ## jjmb - added some logic here for the time being to prevent some errors from showing if($opts->{'IpMode'} eq "v6") { # Skipping validation } else { unless($addr) { $tftp->{'error'} = "Bad hostname '$host'"; return undef; } } ## jjmb - need to construct different objects depending on the IP version used my $sock = undef; if($opts->{'IpMode'} eq "v6") { $sock = IO::Socket::INET6->new(PeerAddr => $opts->{'Host'}, Port => $opts->{'Port'}, Proto => 'udp'); } else { $sock = IO::Socket::INET->new(Proto => 'udp'); } my $mode = $opts->{'Mode'}; my $pkt = pack("n a* c a* c", $op, $remote, 0, $mode, 0); if($opts->{'BlockSize'} > 0) { $pkt .= sprintf("blksize\0%d\0",$opts->{'BlockSize'}); } my $read = $op == Net::TFTP::RRQ; my $sel = IO::Select->new($sock); @{$opts}{'read','sock','sel','pkt','blksize'} = ($read,$sock,$sel,$pkt,512); if($read) { # read @{$opts}{'ibuf','icr','blk'} = ('',0,1); } else { # write @{$opts}{'obuf','blk','ack'} = ('',0,-1); } if($tftp->{'IpMode'} eq "v6") { send($sock,$pkt,0,Socket6::sockaddr_in6($port,Socket6::inet_pton(AF_INET6,$host))); } else { send($sock,$pkt,0,pack_sockaddr_in($port,inet_aton($host))); } _dumppkt($sock,1,$pkt) if $opts->{'Debug'}; tie *$io, "Net::TFTP::IO",$opts; $io; } sub error { my $self = shift; my $tied = UNIVERSAL::isa($self,'GLOB') && tied(*$self) || $self; exists $tied->{'error'} ? $tied->{'error'} : undef; } sub TIEHANDLE { my $pkg = shift; bless shift , $pkg; } sub PRINT { my $self = shift; # Simulate print my $buf = join(defined($,) ? $, : "",@_) . defined($\) ? $\ : ""; # and with the proposed ?? syntax that would be # $buf = join($, ?? "", @_) . $\ ?? ""; $self->WRITE($buf,length($buf)); } sub WRITE { # $self, $buf, $len, $offset my $self = shift; my $buf = substr($_[0],$_[2] || 0,$_[1]); my $offset = 0; $buf =~ s/([\n\r])/$1 eq "\n" ? "\015\012" : "\015\0"/soge if ($self->{'ascii'}); $self->{'obuf'} .= substr($buf,$offset); while(length($self->{'obuf'}) >= $self->{'blksize'}) { return -1 if _write($self,1) < 0; } $_[1]; } sub READLINE { my $self = shift; # return undef (ie eof) unless we have an input buffer return undef if exists $self->{'error'} || !exists $self->{'ibuf'}; _read($self,0); while(1) { my $sep; # if $/ is undef then we slurp the whole file if(defined($sep = $/)) { # if $/ eq "" then we need to do paragraph mode unless(length($sep)) { # when doing paragraph mode remove all leading \n's $self->{'ibuf'} =~ s/^\n+//s; $sep = "\n\n"; } my $offset = index($self->{'ibuf'},$sep); if($offset >= 0) { my $len = $offset+length($sep); # With 5.005 I could use the 4-arg substr my $ret = substr($self->{'ibuf'},0,$len); substr($self->{'ibuf'},0,$len) = ""; return $ret; } } my $res = _read($self,1); next if $res > 0; # We have some more, but do we have enough ? if ($res < 0) { # We have encountered an error, so # force subsequent reads to return eof delete $self->{'ibuf'}; # And return undef (ie eof) return undef; } # $res == 0 so there is no more data to read, just return # the buffer contents return delete $self->{'ibuf'}; } # NOT REACHED return; } sub READ { # $self, $buf, $len, $offset my $self = shift; return undef if exists $self->{'error'}; return 0 unless exists $self->{'ibuf'}; my $ret = length($self->{'ibuf'}); unless ($self->{'eof'}) { # If there is any data waiting, read it and ask for more _read($self,0); # read until we have enough while(($ret = length($self->{'ibuf'})) < $_[1]) { last unless _read($self,1) > 0; } } # Did we encounter an error return undef if exists $self->{'error'}; # we may have too much $ret = $_[1] if $_[1] < $ret; # We are simulating read() so we may have to insert into $_[0] if($ret) { if($_[2]) { substr($_[0],$_[2]) = substr($self->{'ibuf'},0,$ret); } else { $_[0] = substr($self->{'ibuf'},0,$ret); } # remove what we placed into $_[0] substr($self->{'ibuf'},0,$ret) = ""; } # If we are returning less than what was asked for # then the next call must return eof delete $self->{'ibuf'} if $self->{'eof'} && length($self->{'ibuf'}) == 0 ; $ret; } sub CLOSE { my $self = shift; if (exists $self->{'sock'} && !exists $self->{'closing'}) { $self->{'closing'} = 1; if ($self->{'read'} ) { unless ($self->{'eof'}) { my $pkt = pack("nna*c",Net::TFTP::ERROR,0,"Premature close",0); _dumppkt($self->{'sock'},1,$pkt) if $self->{'Debug'}; send($self->{'sock'},$pkt,0,$self->{'peer'}) if $self->{'peer'}; } } else { # Clear the buffer unless(exists $self->{'error'}) { while(length($self->{'obuf'}) >= $self->{'blksize'}) { last if _write($self) < 0; } # Send the last block $self->{'blksize'} = length($self->{'obuf'}); _write($self) unless(exists $self->{'error'}); # buffer is empty so blksize=1 will ensure I do not send # another packet, but just wait for the ACK $self->{'blksize'} = 1; _write($self) unless(exists $self->{'error'}); } } close(delete $self->{'sock'}); } exists $self->{'error'} ? 0 : 1; } # _natoha($data,$cr) - Convert netascii -> host text # updates both input args sub _natoha { use vars qw($buf $cr); local *buf = \$_[0]; local *cr = \$_[1]; my $last = substr($buf,-1); if($cr) { my $ch = ord(substr($buf,0,1)); if($ch == 012) { # CR.LF => \n substr($buf,0,1) = "\n"; } elsif($ch == 0) { # CR.NUL => \r substr($buf,0,1) = "\r"; } else { # Hm, badly formed netascii substr($buf,0,0) = "\015"; } } if(ord($last) eq 015) { substr($buf,-1) = ""; $cr = 1; } else { $cr = 0; } $buf =~ s/\015\0/\r/sg; $buf =~ s/\015\012/\n/sg; 1; } sub _abort { my $self = shift; $self->{'error'} ||= 'Protocol error'; $self->{'eof'} = 1; my $pkt = pack("nna*c",Net::TFTP::ERROR,0,$self->{'error'},0); send($self->{'sock'},$pkt,0,$self->{'peer'}) if exists $self->{'peer'}; CLOSE($self); -1; } # _read: The guts of the reading # # returns # >0 size of data read # 0 eof # <0 error sub _read { my($self,$wait) = @_; return -1 if exists $self->{'error'}; return 0 if $self->{'eof'}; my $sock = $self->{'sock'} || return -1; my $select = $self->{'sel'}; my $timeout = $wait ? $self->{'Timeout'} : 0; my $retry = 0; while(1) { if($select->can_read($timeout)) { my $ipkt = ''; # will be filled by _recv my($peer,$code,$blk) = _recv($self,$ipkt) or return _abort($self); redo unless defined($peer); # do not send ACK to real peer if($code == Net::TFTP::DATA) { # If we receive a packet we are not expecting # then ACK the last packet again if($blk == $self->{'blk'}) { $self->{'blk'} = $blk+1; my $data = substr($ipkt,4); _natoha($data,$self->{'icr'}) if($self->{'ascii'}); $self->{'ibuf'} .= $data; my $opkt = $self->{'pkt'} = pack("nn", Net::TFTP::ACK,$blk); send($sock,$opkt,0,$peer); _dumppkt($sock,1,$opkt) if $self->{'Debug'}; $self->{'eof'} = 1 if ( length($ipkt) < ($self->{'blksize'} + 4) ); return length($data); } elsif($blk < $self->{'blk'}) { redo; # already got this data } } elsif($code == Net::TFTP::OACK) { my $opkt = $self->{'pkt'} = pack("nn", Net::TFTP::ACK,0); send($sock,$opkt,0,$peer); _dumppkt($sock,1,$opkt) if $self->{'Debug'}; return _read($self,$wait); } elsif($code == Net::TFTP::ERROR) { $self->{'error'} = substr($ipkt,4); $self->{'eof'} = 1; CLOSE($self); return -1; } return _abort($self); } last unless $wait; # Resend last packet, this will re ACK the last data packet if($retry++ >= $self->{'Retries'}) { $self->{'error'} = "Transfer Timeout"; return _abort($self); } send($sock,$self->{'pkt'},0,$self->{'peer'}) if $self->{'peer'}; if ($self->{'Debug'}) { print STDERR "${sock} << ---- retry=${retry}\n"; _dumppkt($sock,1,$self->{'pkt'}); } } # NOT REACHED } sub _recv { my $self = shift; my $sock = $self->{'sock'}; my $bsize = $self->{'blksize'}+4; $bsize = 516 if $bsize < 516; my $peer = recv($sock,$_[0],$bsize,0); # There is something on the socket, but not a udp packet. Prob. an icmp. return unless ($peer); _dumppkt($sock,0,$_[0]) if $self->{'Debug'}; # The struct in $peer can be bigger than needed for AF_INET # so could contain garbage at the end. unpacking and re-packing # will ensure it is zero filled (Thanks TomC) if($self->{'IpMode'} eq "v6") { $peer = Socket6::pack_sockaddr_in6(Socket6::unpack_sockaddr_in6($peer)); } else { $peer = pack_sockaddr_in(unpack_sockaddr_in($peer)); } $self->{'peer'} ||= $peer; # Remember first peer my($code,$blk) = unpack("nn",$_[0]); if($code == Net::TFTP::OACK) { my %o = split("\0",substr($_[0],2)); %$self = (%$self,%o); } if ($self->{'peer'} ne $peer) { # All packets must be from same peer # packet from someone else, send them an ERR packet my $err = pack("nna*c",Net::TFTP::ERROR, 5, "Unknown transfer ID",0); _dumppkt($sock,1,$err) if $self->{'Debug'}; send($sock,$err,0,$peer); $peer = undef; } ($peer,$code,$blk); } sub _send_data { my $self = shift; if(length($self->{'obuf'}) >= $self->{'blksize'}) { my $blk = ++$self->{'blk'}; my $opkt = $self->{'pkt'} = pack("nn", Net::TFTP::DATA,$blk) . substr($self->{'obuf'},0,$self->{'blksize'}); substr($self->{'obuf'},0,$self->{'blksize'}) = ''; my $sock = $self->{'sock'}; send($sock,$opkt,0,$self->{'peer'}); _dumppkt($sock,1,$opkt) if $self->{'Debug'}; } elsif (length($self->{'obuf'}) == 0 and $self->{'blksize'} == 1) { # ignore } elsif($^W) { require Carp; Carp::carp("Net::TFTP: Buffer underflow"); } 1; } sub _write { my($self) = @_; return -1 if exists $self->{'error'}; my $sock = $self->{'sock'} || return -1; my $select = $self->{'sel'}; my $timeout = $self->{'Timeout'}; my $retry = 0; return _send_data($self) if $self->{'ack'} == $self->{'blk'}; while(1) { if($select->can_read($timeout)) { my $ipkt=''; # will be filled by _recv my($peer,$code,$blk) = _recv($self,$ipkt) or return _abort($self); redo unless defined($peer); # do not send ACK to real peer if($code == Net::TFTP::OACK) { $code = Net::TFTP::ACK; $blk = 0; } if($code == Net::TFTP::ACK) { if ($self->{'blk'} == $blk) { $self->{'ack'} = $blk; return _send_data($self); } elsif ($self->{'blk'} > $blk) { redo; # duplicate ACK } } if($code == Net::TFTP::ERROR) { $self->{'error'} = substr($ipkt,4); CLOSE($self); return -1; } return _abort($self); } # Resend last packet, this will resend the last DATA packet if($retry++ >= $self->{'Retries'}) { $self->{'error'} = "Transfer Timeout"; return _abort($self); } send($sock,$self->{'pkt'},0,$self->{'peer'}); if ($self->{'Debug'}) { print STDERR "${sock} << ---- retry=${retry}\n"; _dumppkt($sock,1,$self->{'pkt'}); } } # NOT REACHED } sub _dumppkt { my($sock,$send) = @_; my($code,$blk) = unpack("nn",$_[2]); $send = $send ? "$sock <<" : "$sock >>"; my $str = sprintf "%s %-4s",$send,$NAME[$code]; $str .= sprintf " %s=%d",$code == Net::TFTP::ERROR ? "code" : "blk",$blk if $code == Net::TFTP::DATA || $code == Net::TFTP::ACK || $code == Net::TFTP::ERROR; printf STDERR "%s length=%d\n",$str,length($_[2]); if($code == Net::TFTP::RRQ || $code == Net::TFTP::WRQ || $code == Net::TFTP::OACK) { my @a = split("\0",substr($_[2],2)); printf STDERR "%s filename=%s mode=%s\n",$send,splice(@a,0,2) unless $code == Net::TFTP::OACK; my %a = @a; my($k,$v); while(($k,$v) = each %a) { printf STDERR "%s %s=%s\n",$send,$k,$v; } } printf STDERR "%s %s\n",$send,substr($_[2],4) if $code == Net::TFTP::ERROR; } 1; __END__ =head1 NAME Net::TFTP - TFTP Client class =head1 SYNOPSIS use Net::TFTP; $tftp = Net::TFTP->new("some.host.name", BlockSize => 1024); $tftp->ascii; $tftp->get("remotefile", "localfile"); $tftp->get("remotefile", \*STDOUT); $fh = $tftp->get("remotefile"); $tftp->binary; $tftp->put("localfile", "remotefile"); $tftp->put(\*STDOUT, "remotefile"); $fh = $tftp->put("remotefile"); $err = $tftp->error =head1 DESCRIPTION C is a class implementing a simple I client in Perl as described in RFC1350. C also supports the TFTP Option Extension (as described in RFC2347), with the following options RFC2348 Blocksize Option =head1 CONSTRUCTOR =over 4 =item new ( [ HOST ] [, OPTIONS ]) Create a new Net::TFTP object where HOST is the default host to connect to and OPTIONS are the default transfer options. Valid options are Option Description Default ------ ----------- ------- Timeout Timeout in seconds before retry 5 Retries Maximum number of retries 5 Port Port to send data to 69 Mode Mode to transfer data in, "octet" or "netascii" "netascii" BlockSize Negotiate size of blocks to use in the transfer 512 IpMode Indicates whether to operate in IPv6 mode "v4" =back =head1 METHODS =over 4 =item get ( REMOTE_FILE [, LOCAL ] [, OPTIONS ]) Get REMOTE_FILE from the server. OPTIONS can be any that are accepted by C plus the following Host Override default host If the LOCAL option is missing the get will return a filehandle. This filehandle must be read ASAP as the server will otherwise timeout. If the LOCAL option is given then it can be a file name or a reference. If it is a reference it is assumed to be a reference that is valid as a filehandle. C will return I if the transfer is successful and I otherwise. Valid filehandles are =over 4 =item * A sub-class of IO::Handle =item * A tied filehandle =item * A GLOB reference (eg C<\*STDOUT>) =back =item put ( [ LOCAL, ] REMOTE_FILE [, OPTIONS]) Put a file to the server as REMOTE_FILE. OPTIONS can be any that are accepted by C plus the following Host Override default host If the LOCAL option is missing the put will return a filehandle. This filehandle must be written to ASAP as the server will otherwise timeout. If the LOCAL option is given then it can be a file name or a reference. If it is a reference it is assumed to be a valid filehandle as described above. C will return I if the transfer is successful and I otherwise. =item error If there was an error then this method will return an error string. =item host ( [ HOST ] ) =item timeout ( [ TIMEOUT ] ) =item port ( [ PORT ] ) =item mode ( [ MODE ] ) =item retries ( [ VALUE ] ) =item block_size ( [ VALUE ] ) =item debug ( [ VALUE ] ) Set or get the values for the various options. If an argument is passed then a new value is set for that option and the previous value returned. If no value is passed then the current value is returned. =item ip_mode ( [ VALUE ] ) Set or get which verion of IP to use ("v4" or "v6") =item ascii =item netascii Set the transfer mode to C<"netascii"> =item binary =item octet Set the transfer mode to C<"octet"> =back =head1 AUTHOR Graham Barr =head1 COPYRIGHT Copyright (c) 1998,2007 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Net-TFTP-0.1901/t/00-load.t000644 000765 000765 00000000317 11400752050 014114 0ustar00gbarr000000 000000 use Test::More; use_ok Net::TFTP; $tftp = Net::TFTP->new("some.host.name", BlockSize => 1024); isa_ok($tftp, 'Net::TFTP', 'generated object'); can_ok($tftp, 'get'); can_ok($tftp, 'put'); done_testing(); Net-TFTP-0.1901/t/01-get.t000644 000765 000765 00000001101 11473326661 013764 0ustar00gbarr000000 000000 use Test::More; BEGIN{ use_ok Net::TFTP; } use Test::MockModule; my $mock_io = Test::MockModule->new('Net::TFTP::IO', no_auto => 1); $mock_io->mock('new', sub { open (my $fh, "<", 't/files/source' ) or die "Can not open t/files/source: $!"; return $fh; } ); $tftp = Net::TFTP->new("some.host.name", BlockSize => 1024); my $retval = $tftp->get('somefile','t/files/directory'); is($retval, undef, 'Error handled, no die'); like($tftp->{error}, qr(Can not open t/files/directory), 'Error message'); done_testing; Net-TFTP-0.1901/t/02-new.t000644 000765 000765 00000000431 11400752050 013765 0ustar00gbarr000000 000000 use Test::More; use Test::Warn; use Net::TFTP; # we test for warnings $^W = 1; my $tftp = Net::TFTP->new(); warnings_are { $tftp->get('somefile','t/files/directory') } [], 'Warnings for new' ; is($tftp->{error}, 'No hostname given', 'Missing hostname detected'); done_testing; Net-TFTP-0.1901/t/files/000755 000765 000765 00000000000 13054151073 013701 5ustar00gbarr000000 000000 Net-TFTP-0.1901/t/files/directory/000755 000765 000765 00000000000 13054151073 015705 5ustar00gbarr000000 000000 Net-TFTP-0.1901/t/files/source000644 000765 000765 00000000007 11400752050 015114 0ustar00gbarr000000 000000 source Net-TFTP-0.1901/t/files/directory/empty000644 000765 000765 00000000000 11400752050 016747 0ustar00gbarr000000 000000