Net-TFTP-0.19/000755 000765 000765 00000000000 11473326606 013222 5ustar00gbarrgbarr000000 000000 Net-TFTP-0.19/ChangeLog000644 000765 000765 00000004101 11473326562 014771 0ustar00gbarrgbarr000000 000000 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.19/Makefile.PL000644 000765 000765 00000001206 11473326562 015174 0ustar00gbarrgbarr000000 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, '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.19/MANIFEST000644 000765 000765 00000000431 11473326604 014347 0ustar00gbarrgbarr000000 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 SIGNATURE Public-key signature (added by MakeMaker) Net-TFTP-0.19/META.yml000644 000765 000765 00000001061 11473326604 014467 0ustar00gbarrgbarr000000 000000 --- #YAML:1.0 name: Net-TFTP version: 0.19 abstract: ~ author: [] license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 requires: Test::MockModule: 0 Test::More: 0.8701 Test::Warn: 0 resources: repository: http://github.com/gbarr/perl-net-tftp no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.48 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Net-TFTP-0.19/README000644 000765 000765 00000001235 11150571125 014071 0ustar00gbarrgbarr000000 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.19/SIGNATURE000644 000765 000765 00000002523 11473326606 014510 0ustar00gbarrgbarr000000 000000 This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.64. 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: SHA1 SHA1 4f44ae237cb037daed9c72574eca4d5d2e418797 ChangeLog SHA1 cf14240dfe26c79eaf5f454c1943ddfec49fbe73 MANIFEST SHA1 c5446a747e4457b2b4e5e6080b566ad46c1faaea META.yml SHA1 4bc74fcc6c2129d01b26a89b0fda8b4dd51fb428 Makefile.PL SHA1 9044bc5ec03ee5bee19c8b9c5c68a6a05f6fcb83 README SHA1 4bcd1e87432f7c79f978234b29dd130957c4a69a 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----- Version: GnuPG v1.4.10 (Darwin) iEYEARECAAYFAkztrYQACgkQR0BL4gbYw3SIxQCePm0bSuLmjEN9dB9z4JizfjZ5 RNgAoIT1jl9Jh2ob8b7qFJyryzDJl4SY =luE7 -----END PGP SIGNATURE----- Net-TFTP-0.19/t/000755 000765 000765 00000000000 11473326603 013462 5ustar00gbarrgbarr000000 000000 Net-TFTP-0.19/TFTP.pm000644 000765 000765 00000051313 11473326562 014341 0ustar00gbarrgbarr000000 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.19"; 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.19/t/00-load.t000644 000765 000765 00000000317 11400752050 014771 0ustar00gbarrgbarr000000 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.19/t/01-get.t000644 000765 000765 00000001101 11473326562 014641 0ustar00gbarrgbarr000000 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.19/t/02-new.t000644 000765 000765 00000000431 11400752050 014642 0ustar00gbarrgbarr000000 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.19/t/files/000755 000765 000765 00000000000 11473326603 014564 5ustar00gbarrgbarr000000 000000 Net-TFTP-0.19/t/files/directory/000755 000765 000765 00000000000 11473326603 016570 5ustar00gbarrgbarr000000 000000 Net-TFTP-0.19/t/files/source000644 000765 000765 00000000007 11400752050 015771 0ustar00gbarrgbarr000000 000000 source Net-TFTP-0.19/t/files/directory/empty000644 000765 000765 00000000000 11400752050 017624 0ustar00gbarrgbarr000000 000000