diff -Nru libnet-tftpd-perl-0.06/bin/simpleTFTPd.pl libnet-tftpd-perl-0.09/bin/simpleTFTPd.pl --- libnet-tftpd-perl-0.06/bin/simpleTFTPd.pl 1970-01-01 00:00:00.000000000 +0000 +++ libnet-tftpd-perl-0.09/bin/simpleTFTPd.pl 2012-10-11 08:29:16.000000000 +0000 @@ -0,0 +1,54 @@ +#!/usr/bin/perl +use strict; +use Net::TFTPd 0.05 qw(%OPCODES); + +# change ROOTDIR to your TFTP root directory +my $rootdir = $ARGV[0]; + +unless(-d $rootdir) +{ + print "\nUsage: simpleTFTPd.pl path/to/rootdir\n\n"; + exit 1; +} + +# callback sub used to print transfer status +sub callback +{ + my $req = shift; + if($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'RRQ'}) + { + # RRQ + printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'}; + } + elsif($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'WRQ'}) + { + # WRQ + printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTBLK'}, $req->{'_REQUEST_'}{'LASTACK'}; + } +} + +# create the listener +my $listener = Net::TFTPd->new('RootDir' => $rootdir, 'Writable' => 1, 'Timeout' => 10, 'CallBack' => \&callback) or die Net::TFTPd->error; +printf "TFTP listener is bound to %s:%d\nTFTP listener is waiting %d seconds for a request\n", $listener->{'LocalAddr'} ? $listener->{'LocalAddr'} : "'any address'", $listener->{'LocalPort'}, $listener->{'Timeout'}; + +# wait for any request (RRQ or WRQ) +if(my $request = $listener->waitRQ()) +{ + # received request + printf "Received a %s for file '%s'\n", $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, $request->getFileName(); + + # process the request + if($request->processRQ()) + { + printf "OK, transfer completed successfully for file %s, %u bytes transferred\n", $request->getFileName(), $request->getTotalBytes(); + } + else + { + die Net::TFTPd->error; + } +} +else +{ + # request not received (timed out waiting for request etc.) + die Net::TFTPd->error; +} diff -Nru libnet-tftpd-perl-0.06/bin/tftpd-simple.pl libnet-tftpd-perl-0.09/bin/tftpd-simple.pl --- libnet-tftpd-perl-0.06/bin/tftpd-simple.pl 1970-01-01 00:00:00.000000000 +0000 +++ libnet-tftpd-perl-0.09/bin/tftpd-simple.pl 2015-03-20 01:53:44.000000000 +0000 @@ -0,0 +1,149 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Getopt::Long qw(:config no_ignore_case); #bundling +use Pod::Usage; + +use Net::TFTPd qw( :all ); + +my %opt; +my ($opt_help, $opt_man); + +GetOptions( + '4!' => \$opt{4}, + '6!' => \$opt{6}, + 'directory=s' => \$opt{dir}, + 'interface:i' => \$opt{interface}, + 'time!' => \$opt{time}, + 'help!' => \$opt_help, + 'man!' => \$opt_man +) or pod2usage(-verbose => 0); + +pod2usage(-verbose => 1) if defined $opt_help; +pod2usage(-verbose => 2) if defined $opt_man; + +# Default to IPv4 +my $family = 4; +if ($opt{6}) { + $family = 6 +} + +$opt{time} = $opt{time} || 0; + +# -d is a directory, if it exists, assign it +if (defined $opt{dir}) { + + # replace \ with / for compatibility with UNIX/Windows + $opt{dir} =~ s/\\/\//g; + + # remove trailing / so we're sure it does NOT exist and we CAN put it in later + $opt{dir} =~ s/\/$//; + + if (!(-e $opt{dir})) { + print "$0: directory does not exist - $opt{dir}"; + exit 1 + } + $opt{write} = 1 if (!$opt{write}) +} else { + $opt{dir} = '.' +} + +if (defined $opt{interface}) { + if (!(($opt{interface} > 0) && ($opt{interface} < 65536))) { + print "$0: port not valid - $opt{interface}" + } +} else { + $opt{interface} = '69' +} + +my $tftpd = Net::TFTPd->new( + RootDir => $opt{dir}, + Writable => 1, + LocalPort => $opt{interface}, + Family => $family +); + +if (!$tftpd) { + printf "$0: Error creating TFTPd listener: %s", Net::TFTPd->error; + exit 1 +} + +printf "Listening on %s:%i\n" . + "TFTP Root Dir = %s\n\n", + $tftpd->{_UDPSERVER_}->sockhost, + $opt{interface}, + $opt{dir}; + +my $tftpdRQ; +while (1) { + if (!($tftpdRQ = $tftpd->waitRQ())) { next } + + my $p = sprintf "%s\t%s\t%i\t%s\t%s\t%s", ($opt{time} ? yyyymmddhhmmss() : time), $tftpdRQ->getPeerAddr, $tftpdRQ->getPeerPort, $OPCODES{$tftpdRQ->{_REQUEST_}->{OPCODE}}, $tftpdRQ->getMode, $tftpdRQ->getFileName; + print "$p\tSTARTED\n"; + + my $pid = fork(); + + if (!defined $pid) { + print "fork() Error!\n"; + exit + } elsif ($pid == 0) { + printf $p; + if (defined $tftpdRQ->processRQ()) { + printf "\tSUCCESS [%i bytes]\n", $tftpdRQ->getTotalBytes + } else { + print "\t" . Net::TFTPd->error . "\n" + } + exit + } else { + # parent + } +} + +sub yyyymmddhhmmss { + my @time = localtime(); + return (($time[5] + 1900) . ((($time[4] + 1) < 10)?("0" . ($time[4] + 1)):($time[4] + 1)) . (($time[3] < 10)?("0" . $time[3]):$time[3]) . (($time[2] < 10)?("0" . $time[2]):$time[2]) . (($time[1] < 10)?("0" . $time[1]):$time[1]) . (($time[0] < 10)?("0" . $time[0]):$time[0])) +} + +__END__ + +=head1 NAME + +TFTPD-SIMPLE - Simple TFTP Server + +=head1 SYNOPSIS + + tftpd-simple [options] + +=head1 DESCRIPTION + +Listens for TFTP requests and proccess them. + +=head1 OPTIONS + + -4 Force IPv4. + -6 Force IPv6 (overrides -4). + + -d TFTP root directory. + --directory DEFAULT: (or not specified) [Current]. + + -i # UDP Port to listen on. + --interface DEFAULT: (or not specified) 69. + + -t Print time in human-readable yyyymmddhhmmss format. + --time DEFAULT: (or not specified) Unix epoch. + +=head1 LICENSE + +This software is released under the same terms as Perl itself. +If you don't know what that means visit L. + +=head1 AUTHOR + +Copyright (C) Michael Vincent 2015 + +L + +All rights reserved + +=cut diff -Nru libnet-tftpd-perl-0.06/Changes libnet-tftpd-perl-0.09/Changes --- libnet-tftpd-perl-0.06/Changes 2012-10-17 09:16:00.000000000 +0000 +++ libnet-tftpd-perl-0.09/Changes 2015-03-20 01:23:47.000000000 +0000 @@ -1,18 +1,26 @@ Revision history for Perl extension Net::TFTPD. -0.01 Mon Oct 21 11:06:19 2002 - - original version; created by h2xs 1.21 with options - -AX -n Net::TFTPd +0.09 Thu Mar 19 20:30:00 2015 + - Top down Changes file. + - Moved files to proper module format with lib/ bin/ and t/ directories. + - Added t/ tests. + - Added bin/tftpd-simple.pl for more features. -0.02 Mon Aug 23 17:10:12 2004 - - project revision, added examples and POD documentation - first public release +0.08 Wed Mar 18 16:30:00 2015 + - Fixed v6Only tag when selecting IPv6 to account for Windows issues. -0.03 Mon Sep 17 07:41:00 2007 - - some fixes, thanks to Onigiusz Zarzycki: - - now work also on linux (tested on SUSE Linux 10.1) - - handling TFTP transmissions with more than 65535 packets - - handling TFTP transmissions with block size between 8 and 511 Bytes +0.07 Tue Nov 18 09:00:00 2014 + - Updated v6Only tag when selecting IPv6 to account for Linux issues. + +0.06 Wed Oct 17 11:13:00 2012 + - fix, thanks again to Michael Vincent: now supporting also Socket.pm + version which doesn't support IPv6 + +0.05 Thu Oct 11 09:30:00 2012 + - some changes, thanks again to Michael Vincent + - Changed to optional IO::Socket::IP and enabled IPv6 support, with + failback to IP::Socket::INET + - Added a server() accessor. 0.04 Mon May 25 15:00:00 2009 - some fixes, thanks to Michael Vincent @@ -21,12 +29,16 @@ of bytes transferred for the request - added various other request methods -0.05 Thu Oct 11 09:30:00 2012 - - some changes, thanks again to Michael Vincent - - Changed to optional IO::Socket::IP and enabled IPv6 support, with - failback to IP::Socket::INET - - Added a server() accessor. +0.03 Mon Sep 17 07:41:00 2007 + - some fixes, thanks to Onigiusz Zarzycki: + - now work also on linux (tested on SUSE Linux 10.1) + - handling TFTP transmissions with more than 65535 packets + - handling TFTP transmissions with block size between 8 and 511 Bytes -0.06 Wed Oct 17 11:13:00 2012 - - fix, thanks again to Michael Vincent: now supporting also Socket.pm - version which doesn't support IPv6 +0.02 Mon Aug 23 17:10:12 2004 + - project revision, added examples and POD documentation + first public release + +0.01 Mon Oct 21 11:06:19 2002 + - original version; created by h2xs 1.21 with options + -AX -n Net::TFTPd diff -Nru libnet-tftpd-perl-0.06/debian/changelog libnet-tftpd-perl-0.09/debian/changelog --- libnet-tftpd-perl-0.06/debian/changelog 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/changelog 2015-10-09 20:34:36.000000000 +0000 @@ -1,3 +1,27 @@ +libnet-tftpd-perl (0.09-1) unstable; urgency=low + + * Team upload + + [ Salvatore Bonaccorso ] + * Change Vcs-Git to canonical URI (git://anonscm.debian.org) + * Change search.cpan.org based URIs to metacpan.org based URIs + + [ gregor herrmann ] + * Strip trailing slash from metacpan URLs. + + [ Salvatore Bonaccorso ] + * Update Vcs-Browser URL to cgit web frontend + + [ Florian Schlichting ] + * Import upstream version 0.09 + * Ship bin directory as examples + * Drop doc-base metadata for html manual removed upstream + * Bump dh compat to level 9 + * Declare compliance with Debian Policy 3.9.6 + * Mark package autopkgtest-able + + -- Florian Schlichting Fri, 09 Oct 2015 22:29:44 +0200 + libnet-tftpd-perl (0.06-1) unstable; urgency=low [ gregor herrmann ] diff -Nru libnet-tftpd-perl-0.06/debian/compat libnet-tftpd-perl-0.09/debian/compat --- libnet-tftpd-perl-0.06/debian/compat 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/compat 2015-10-09 20:34:36.000000000 +0000 @@ -1 +1 @@ -8 +9 diff -Nru libnet-tftpd-perl-0.06/debian/control libnet-tftpd-perl-0.09/debian/control --- libnet-tftpd-perl-0.06/debian/control 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/control 2015-10-09 20:34:36.000000000 +0000 @@ -6,12 +6,13 @@ Ansgar Burchardt , Fabrizio Regalli , Xavier Guimard -Build-Depends: debhelper (>= 8) +Build-Depends: debhelper (>= 9) Build-Depends-Indep: perl -Standards-Version: 3.9.4 -Vcs-Browser: http://anonscm.debian.org/gitweb/?p=pkg-perl/packages/libnet-tftpd-perl.git -Vcs-Git: git://git.debian.org/pkg-perl/packages/libnet-tftpd-perl.git -Homepage: http://search.cpan.org/dist/Net-TFTPd/ +Standards-Version: 3.9.6 +Vcs-Browser: https://anonscm.debian.org/cgit/pkg-perl/packages/libnet-tftpd-perl.git +Vcs-Git: git://anonscm.debian.org/pkg-perl/packages/libnet-tftpd-perl.git +Homepage: https://metacpan.org/release/Net-TFTPd +Testsuite: autopkgtest-pkg-perl Package: libnet-tftpd-perl Architecture: all @@ -26,4 +27,3 @@ . - RFC2348 TFTP Blocksize Option - RFC2349 TFTP Timeout Interval and Transfer Size Options - . diff -Nru libnet-tftpd-perl-0.06/debian/copyright libnet-tftpd-perl-0.09/debian/copyright --- libnet-tftpd-perl-0.06/debian/copyright 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/copyright 2014-03-04 10:49:58.000000000 +0000 @@ -1,6 +1,6 @@ Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Upstream-Name: Net-TFTPd -Source: http://search.cpan.org/dist/Net-TFTPd/ +Source: https://metacpan.org/release/Net-TFTPd Upstream-Contact: Luigino Masarati, Files: * diff -Nru libnet-tftpd-perl-0.06/debian/libnet-tftpd-perl.doc-base libnet-tftpd-perl-0.09/debian/libnet-tftpd-perl.doc-base --- libnet-tftpd-perl-0.06/debian/libnet-tftpd-perl.doc-base 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/libnet-tftpd-perl.doc-base 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -Document: libnet-tftpd-perl -Title: libnet-tftpd-perl manual -Section: Programming/Perl - -Format: HTML -Index: /usr/share/doc/libnet-tftpd-perl/TFTPd.html -Files: /usr/share/doc/libnet-tftpd-perl/*.html diff -Nru libnet-tftpd-perl-0.06/debian/libnet-tftpd-perl.docs libnet-tftpd-perl-0.09/debian/libnet-tftpd-perl.docs --- libnet-tftpd-perl-0.06/debian/libnet-tftpd-perl.docs 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/libnet-tftpd-perl.docs 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -TFTPd.html - diff -Nru libnet-tftpd-perl-0.06/debian/libnet-tftpd-perl.examples libnet-tftpd-perl-0.09/debian/libnet-tftpd-perl.examples --- libnet-tftpd-perl-0.06/debian/libnet-tftpd-perl.examples 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/libnet-tftpd-perl.examples 2015-10-09 20:23:43.000000000 +0000 @@ -1 +1 @@ -simpleTFTPd.pl +bin/* diff -Nru libnet-tftpd-perl-0.06/debian/rules libnet-tftpd-perl-0.09/debian/rules --- libnet-tftpd-perl-0.06/debian/rules 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/rules 2015-10-09 20:34:36.000000000 +0000 @@ -8,4 +8,4 @@ override_dh_auto_install: dh_auto_install - rm $(TMP)/usr/share/perl5/Net/simpleTFTPd.pl + rm -r $(TMP)/usr/bin $(TMP)/usr/share/man/man1 diff -Nru libnet-tftpd-perl-0.06/debian/watch libnet-tftpd-perl-0.09/debian/watch --- libnet-tftpd-perl-0.06/debian/watch 2012-11-07 21:56:24.000000000 +0000 +++ libnet-tftpd-perl-0.09/debian/watch 2014-03-04 10:49:58.000000000 +0000 @@ -1,3 +1,3 @@ version=3 opts="uversionmangle=s/-withoutworldwriteables//" \ - http://search.cpan.org/dist/Net-TFTPd/ .*/Net-TFTPd-v?(\d[\d.-].*)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)$ +https://metacpan.org/release/Net-TFTPd .*/Net-TFTPd-v?(\d[\d.-].*)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)$ diff -Nru libnet-tftpd-perl-0.06/lib/Net/TFTPd.pm libnet-tftpd-perl-0.09/lib/Net/TFTPd.pm --- libnet-tftpd-perl-0.06/lib/Net/TFTPd.pm 1970-01-01 00:00:00.000000000 +0000 +++ libnet-tftpd-perl-0.09/lib/Net/TFTPd.pm 2015-03-20 01:40:23.000000000 +0000 @@ -0,0 +1,1458 @@ +package Net::TFTPd; + +use 5.006; +use Carp; +use strict; +use warnings; + +# modified by M.Vincent for IPv6 support +use Socket qw(AF_INET SO_ERROR); +my $AF_INET6 = eval { Socket::AF_INET6() }; +my $HAVE_IO_Socket_IP = 0; +eval "use IO::Socket::IP -register"; +if (!$@) +{ + $HAVE_IO_Socket_IP = 1; +} +else +{ + eval "use IO::Socket::INET"; +} + +require Exporter; + +# modified for supporting small block sizes, O.Z. 15.08.2007 +use constant TFTP_MIN_BLKSIZE => 8; +use constant TFTP_DEFAULT_BLKSIZE => 512; +use constant TFTP_MAX_BLKSIZE => 65464; +use constant TFTP_MIN_TIMEOUT => 1; +use constant TFTP_MAX_TIMEOUT => 60; +use constant TFTP_DEFAULT_PORT => 69; + +use constant TFTP_OPCODE_RRQ => 1; +use constant TFTP_OPCODE_WRQ => 2; +use constant TFTP_OPCODE_DATA => 3; +use constant TFTP_OPCODE_ACK => 4; +use constant TFTP_OPCODE_ERROR => 5; +use constant TFTP_OPCODE_OACK => 6; + +# Type Op # Format without header +# +# 2 bytes string 1 byte string 1 byte +# ------------------------------------------------- +# RRQ/ | 01/02 | Filename | 0 | Mode | 0 | +# WRQ ------------------------------------------------- +# 2 bytes 2 bytes n bytes +# ----------------------------------- +# DATA | 03 | Block # | Data | +# ----------------------------------- +# 2 bytes 2 bytes +# ---------------------- +# ACK | 04 | Block # | +# ---------------------- +# 2 bytes 2 bytes string 1 byte +# ------------------------------------------ +# ERROR | 05 | ErrorCode | ErrMsg | 0 | +# ------------------------------------------ + +our %OPCODES = ( + 1 => 'RRQ', + 2 => 'WRQ', + 3 => 'DATA', + 4 => 'ACK', + 5 => 'ERROR', + 6 => 'OACK', + 'RRQ' => TFTP_OPCODE_RRQ, + 'WRQ' => TFTP_OPCODE_WRQ, + 'DATA' => TFTP_OPCODE_DATA, + 'ACK' => TFTP_OPCODE_ACK, + 'ERROR' => TFTP_OPCODE_ERROR, + 'OACK' => TFTP_OPCODE_OACK +); + +my %ERRORS = ( + 0 => 'Not defined, see error message (if any)', + 1 => 'File not found', + 2 => 'Access violation', + 3 => 'Disk full or allocation exceeded', + 4 => 'Illegal TFTP operation', + 5 => 'Unknown transfer ID', + 6 => 'File already exists', + 7 => 'No such user', + 8 => 'Option negotiation' +); + +our @ISA = qw(Exporter); + +# Items to export into callers namespace by default. Note: do not export +# names by default without a very good reason. Use EXPORT_OK instead. +# Do not simply export all your public functions/methods/constants. + +# This allows declaration use Net::TFTPd ':all'; +# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( + 'all' => [ qw( %OPCODES ) ] +); + +our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +our @EXPORT = qw( ); + +our $VERSION = '0.09'; + +our $LASTERROR; + +my $debug; + +# +# Usage: $tftpdOBJ = Net::TFTPd->new( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] ); +# return the tftpdOBJ object if success or undef if error +# +sub new +{ + # create the future TFTPd object + my $self = shift; + my $class = ref($self) || $self; + + # read parameters + my %cfg = @_; + + # setting defaults + $cfg{'FileName'} or $cfg{'RootDir'} or croak "Usage: \$tftpdOBJ = Net::TFTPd->new(['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, [ LocalPort => portnum ] [, ...]] );"; + + if ($cfg{'RootDir'} and not -d($cfg{'RootDir'}) ) + { + $LASTERROR = sprintf 'RootDir \'%s\' not found or is not a valid directory name\n', $cfg{'RootDir'}; + return (undef); + } + + if ($cfg{'FileName'} and not -e($cfg{'FileName'}) ) + { + $LASTERROR = sprintf 'FileName \'%s\' not found or is not a valid filename\n', $cfg{'FileName'}; + return (undef); + } + + my %params = ( + 'Proto' => 'udp', + 'LocalPort' => $cfg{'LocalPort'} || TFTP_DEFAULT_PORT + ); + + # modified by M.Vincent for IPv6 support + if (defined($cfg{'Family'})) + { + if ($cfg{'Family'} =~ /^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/) + { + if ($cfg{'Family'} =~ /^(?:(?:(:?ip)?v?4)|${\AF_INET})$/) + { + $params{'Family'} = AF_INET; + } + else + { + if (!$HAVE_IO_Socket_IP) + { + $LASTERROR = "IO::Socket::IP required for IPv6"; + return (undef); + } + $params{'Family'} = $AF_INET6; + if ($^O ne 'MSWin32') { + $params{'V6Only'} = 1; + } + } + } + else + { + $LASTERROR = "Invalid family - $cfg{'Family'}"; + return (undef); + } + } + else + { + $params{'Family'} = AF_INET; + } + + # bind only to specified address + if ($cfg{'LocalAddr'}) + { + $params{'LocalAddr'} = $cfg{'LocalAddr'}; + } + + if ($HAVE_IO_Socket_IP) + { + if (my $udpserver = IO::Socket::IP->new(%params)) + { + return bless { + 'LocalPort' => TFTP_DEFAULT_PORT, + 'Timeout' => 10, + 'ACKtimeout' => 4, + 'ACKretries' => 4, + 'Readable' => 1, + 'Writable' => 0, + 'CallBack' => undef, + 'BlkSize' => TFTP_DEFAULT_BLKSIZE, + 'Debug' => 0, + %cfg, # merge user parameters + '_UDPSERVER_' => $udpserver + }, $class; + } + else + { + $LASTERROR = "Error opening socket for listener: $@\n"; + return (undef); + } + } + else + { + if (my $udpserver = IO::Socket::INET->new(%params)) + { + return bless { + 'LocalPort' => TFTP_DEFAULT_PORT, + 'Timeout' => 10, + 'ACKtimeout' => 4, + 'ACKretries' => 4, + 'Readable' => 1, + 'Writable' => 0, + 'CallBack' => undef, + 'BlkSize' => TFTP_DEFAULT_BLKSIZE, + 'Debug' => 0, + %cfg, # merge user parameters + '_UDPSERVER_' => $udpserver + }, $class; + } + else + { + $LASTERROR = "Error opening socket for listener: $@\n"; + return (undef); + } + } +} + +# +# Usage: $tftpdOBJ->waitRQ($timeout); +# return requestOBJ if success, 0 if $timeout elapsed, undef if error +# +sub waitRQ +{ + # the tftpd object +# my $tftpd = shift; + + my $self = shift; + my $class = ref($self) || $self; +# return bless {}, $class; + + # clone the object + my $request; + foreach my $key (keys(%{$self})) + { + # everything but '_xxx_' + $key =~ /^\_.+\_$/ and next; + $request->{$key} = $self->{$key}; + } + + # use $timeout or default from $tftpdOBJ + my $Timeout = shift || $request->{'Timeout'}; + + my $udpserver = $self->{'_UDPSERVER_'}; + + my ($datagram, $opcode, $datain); + + # vars for IO select + my ($rin, $rout, $ein, $eout) = ('', '', '', ''); + vec($rin, fileno($udpserver), 1) = 1; + + # check if a message is waiting + if (select($rout=$rin, undef, $eout=$ein, $Timeout)) + { + # read the message + if ($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4)) + { + # decode the message + ($opcode, $datain) = unpack("na*", $datagram); + + $request->{'_REQUEST_'}{'OPCODE'} = $opcode; + + # get peer port and address + $request->{'_REQUEST_'}{'PeerPort'} = $udpserver->peerport; + $request->{'_REQUEST_'}{'PeerAddr'} = $udpserver->peerhost; + + # get filename and transfer mode + my @datain = split("\0", $datain); + + $request->{'_REQUEST_'}{'FileName'} = shift(@datain); + $request->{'_REQUEST_'}{'Mode'} = uc(shift(@datain)); + $request->{'_REQUEST_'}{'BlkSize'} = TFTP_DEFAULT_BLKSIZE; + $request->{'_REQUEST_'}{'LASTACK'} = 0; + $request->{'_REQUEST_'}{'PREVACK'} = -1; + # counter for transferred bytes + $request->{'_REQUEST_'}{'TotalBytes'} = 0; + + if (scalar(@datain) >= 2) + { + $request->{'_REQUEST_'}{'RFC2347'} = { @datain }; + } + + return bless $request, $class; + } + else + { + $! = $udpserver->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket RECV error: %s\n", $!; + return (undef); + } + } + else + { + $LASTERROR = "Timed out waiting for RRQ/WRQ"; + return (0); + } +} + +# +# Usage: $requestOBJ->processRQ(); +# return 1 if success, undef if error +# +sub processRQ +{ + # the request object + my $self = shift; + + if (defined($self->newSOCK())) + { + # modified for supporting NETASCII transfers on 25/05/2009 + if (($self->{'_REQUEST_'}{'Mode'} ne 'OCTET') && ($self->{'_REQUEST_'}{'Mode'} ne 'NETASCII')) + { + #request is not OCTET + $LASTERROR = sprintf "%s transfer mode is not supported\n", $self->{'_REQUEST_'}{'Mode'}; + $self->sendERR(0, $LASTERROR); + return (undef); + } + + # new socket opened successfully + if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ) + { + ################# + # opcode is RRQ # + ################# + if ($self->{'Readable'}) + { + # read is permitted + if ($self->{'_REQUEST_'}{'FileName'} =~ /\.\.[\\\/]/) + { + # requested file contains '..\' or '../' + $LASTERROR = sprintf 'Access to \'%s\' is not permitted to %s', $self->{'_REQUEST_'}{'FileName'}, $self->{'_REQUEST_'}{'PeerAddr'}; + $self->sendERR(2); + return (undef); + } + + if (defined($self->checkFILE())) + { + # file is present + if (defined($self->negotiateOPTS())) + { + # RFC 2347 options negotiated + if (defined($self->openFILE())) + { + # file opened for read, start the transfer + if (defined($self->sendFILE())) + { + # file sent successfully + return (1); + } + else + { + # error sending file + return (undef); + } + } + else + { + # error opening file + return (undef); + } + } + else + { + # error negotiating options + $LASTERROR = "TFTP error 8: Option negotiation\n"; + $self->sendERR(8); + return (undef); + } + } + else + { + # file not found + $LASTERROR = sprintf 'File \'%s\' not found', $self->{'_REQUEST_'}{'FileName'}; + $self->sendERR(1); + return (undef); + } + } + else + { + # if server is not readable + $LASTERROR = "TFTP Error: Access violation"; + $self->sendERR(2); + return (undef); + } + } + elsif ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) + { + ################# + # opcode is WRQ # + ################# + if ($self->{'Writable'}) + { + # write is permitted + if ($self->{'_REQUEST_'}{'FileName'} =~ /\.\.[\\\/]/) + { + # requested file contains '..\' or '../' + $LASTERROR = sprintf 'Access to \'%s\' is not permitted to %s', $self->{'_REQUEST_'}{'FileName'}, $self->{'_REQUEST_'}{'PeerAddr'}; + $self->sendERR(2); + return (undef); + } + + if (!defined($self->checkFILE())) + { + # RFC 2347 options negotiated + if (defined($self->openFILE())) + { + # file is not present + if (defined($self->negotiateOPTS())) + { + # file opened for write, start the transfer + if (defined($self->recvFILE())) + { + # file received successfully + return (1); + } + else + { + # error receiving file + return (undef); + } + } + else + { + # error negotiating options + $LASTERROR = "TFTP error 8: Option negotiation\n"; + $self->sendERR(8); + return (undef); + } + } + else + { + # error opening file + $self->sendERR(3); + return (undef); + } + } + else + { + # file not found + $LASTERROR = sprintf 'File \'%s\' already exists', $self->{'_REQUEST_'}{'FileName'}; + $self->sendERR(6); + return (undef); + } + } + else + { + # if server is not writable + $LASTERROR = "TFTP Error: Access violation"; + $self->sendERR(2); + return (undef); + } + } + else + { + ################# + # other opcodes # + ################# + $LASTERROR = sprintf "Opcode %d not supported as request", $self->{'_REQUEST_'}{'OPCODE'}; + $self->sendERR(4); + return (undef); + } + } + else + { + return (undef); + } +} + +# +# Usage: $requestOBJ->getTotalBytes(); +# returns the number of bytes transferred by the request +# +sub getTotalBytes +{ + # the request object + my $self = shift; + + return $self->{'_REQUEST_'}{'TotalBytes'}; +} + +# +# Usage: $requestOBJ->getFileName(); +# returns the requested file name +# +sub getFileName +{ + # the request object + my $self = shift; + + return $self->{'_REQUEST_'}{'FileName'}; +} + +# +# Usage: $requestOBJ->getMode(); +# returns the transfer mode for the request +# +sub getMode +{ + # the request object + my $self = shift; + + return $self->{'_REQUEST_'}{'Mode'}; +} + +# +# Usage: $requestOBJ->getPeerAddr(); +# returns the address of the requesting client +# +sub getPeerAddr +{ + # the request object + my $self = shift; + + return $self->{'_REQUEST_'}{'PeerAddr'}; +} + +# +# Usage: $requestOBJ->getPeerPort(); +# returns the port of the requesting client +# +sub getPeerPort +{ + # the request object + my $self = shift; + + return $self->{'_REQUEST_'}{'PeerPort'}; +} + +# +# Usage: $requestOBJ->getBlkSize(); +# returns the block size used for the transfer +# +sub getBlkSize +{ + # the request object + my $self = shift; + + return $self->{'_REQUEST_'}{'BlkSize'}; +} + +# +# Usage: $requestOBJ->newSOCK(); +# return 1 if success or undef if error +# +sub newSOCK +{ + # the request object + my $self = shift; + + # set parameters for the new socket + my %params = ( + 'Proto' => 'udp', + 'PeerPort' => $self->{'_REQUEST_'}{'PeerPort'}, + 'PeerAddr' => $self->{'_REQUEST_'}{'PeerAddr'} + ); + + # bind only to specified address + if ($self->{'Address'}) + { + $params{'LocalAddr'} = $self->{'Address'}; + } + + # open socket + if ($HAVE_IO_Socket_IP) + { + if (my $udpserver = IO::Socket::IP->new(%params)) + { + $self->{'_UDPSERVER_'} = $udpserver; + return (1); + } + else + { + $LASTERROR = "Error opening socket for reply: $@\n"; + return (undef); + } + } + else + { + if (my $udpserver = IO::Socket::INET->new(%params)) + { + $self->{'_UDPSERVER_'} = $udpserver; + return (1); + } + else + { + $LASTERROR = "Error opening socket for reply: $@\n"; + return (undef); + } + } +} + + +# +# Usage: $requestOBJ->negotiateOPTS(); +# return 1 if success or undef if error +# +sub negotiateOPTS +{ + # the request object + my $self = shift; + + if ($self->{'_REQUEST_'}{'RFC2347'}) + { + # parse RFC 2347 options if present + foreach my $option (keys(%{ $self->{'_REQUEST_'}{'RFC2347'} })) + { + if (uc($option) eq 'BLKSIZE') + { + # Negotiate the blocksize + if ($self->{'_REQUEST_'}{'RFC2347'}{$option} > TFTP_MAX_BLKSIZE or $self->{'_REQUEST_'}{'RFC2347'}{$option} < TFTP_MIN_BLKSIZE) + { + $self->{'_REQUEST_'}{'RFC2347'}{$option} = $self->{'BlkSize'}; + } + else + { + $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'_REQUEST_'}{'RFC2347'}{$option}; + $self->{'BlkSize'} = $self->{'_RESPONSE_'}{'RFC2347'}{$option}; + } + } + elsif (uc($option) eq 'TSIZE') + { + # Negotiate the transfer size + if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ) + { + $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'FileSize'}; + } + else + { + $self->{'FileSize'} = $self->{'_REQUEST_'}{'RFC2347'}{$option}; + } + } + elsif (uc($option) eq 'TIMEOUT') + { + # Negotiate the transfer timeout + if ($self->{'_REQUEST_'}{'RFC2347'}{$option} > TFTP_MAX_TIMEOUT or $self->{'_REQUEST_'}{'RFC2347'}{$option} < TFTP_MIN_TIMEOUT) + { + $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'ACKtimeout'}; + } + else + { + $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'_REQUEST_'}{'RFC2347'}{$option}; + $self->{'ACKtimeout'} = $self->{'_REQUEST_'}{'RFC2347'}{$option}; + } + } + else + { + # Negotiate other options... + } + } + + # post processing + if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) + { + if ($self->{'FileSize'} and $self->{'BlkSize'}) + { + $self->{'_REQUEST_'}{'LASTACK'} = int($self->{'FileSize'} / $self->{'BlkSize'}) + 1; + } + } + + # send OACK for RFC 2347 options + return ($self->sendOACK()); + } + else + { + if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) + { + # opcode is WRQ: send ACK for datablock 0 + if ($self->{'_UDPSERVER_'}->send(pack("nn", TFTP_OPCODE_ACK, 0))) + { + return (1); + } + else + { + $! = $self->{'_UDPSERVER_'}->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket SEND error: %s\n", $!; + return (undef); + } + } + else + { + return (1); + } + } +} + + +# +# Usage: $requestOBJ->readFILE(\$data); +# return number of bytes read from file if success or undef if error +# +sub readFILE +{ + my $self = shift; + my $datablk = shift; + + if ($self->{'_REQUEST_'}{'PREVACK'} < $self->{'_REQUEST_'}{'LASTACK'}) + { + # if requested block is next block, read next block and return bytes read + my $fh = $self->{'_REQUEST_'}{'_FH_'}; + # modified for supporting NETASCII transfers on 25/05/2009 + # my $bytes = read ($fh, $$datablk, $self->{'BlkSize'}); + my $bytes = sysread($fh, $$datablk, $self->{'BlkSize'}); + if (defined($bytes)) + { + return ($bytes); + } + else + { + $LASTERROR = sprintf "Error $! reading file '%s'", $self->{'_REQUEST_'}{'FileName'}; + return (undef); + } + } + else + { + # if requested block is last block, return length of last block + return (length($$datablk)); + } +} + + +# +# Usage: $requestOBJ->writeFILE(\$data); +# return number of bytes written to file if success or undef if error +# +sub writeFILE +{ + my $self = shift; + my $datablk = shift; + + if ($self->{'_REQUEST_'}{'PREVBLK'} > $self->{'_REQUEST_'}{'LASTBLK'}) + { + # if last block is < than previous block, return length of last block + return (length($$datablk)); + } + elsif ($self->{'_REQUEST_'}{'LASTBLK'} eq ($self->{'_REQUEST_'}{'PREVBLK'} + 1)) + { + # if block is next block, write next block and return bytes written + my $fh = $self->{'_REQUEST_'}{'_FH_'}; + my $bytes = syswrite($fh, $$datablk); + return ($bytes); + } + else + { + $LASTERROR = sprintf "TFTP Error DATA block %d is out of sequence, expected block was %d", $self->{'_REQUEST_'}{'LASTBLK'}, $self->{'_REQUEST_'}{'PREVBLK'} + 1; + $self->sendERR(5); + return (undef); + } +} + + +# +# Usage: $requestOBJ->sendFILE(); +# return 1 if success or undef if error +# +sub sendFILE +{ + my $self = shift; + + while (1) + { + if ($self->{'_REQUEST_'}{'LASTACK'} < $self->{'_REQUEST_'}{'LASTBLK'}) + { + my $datablk = 0; + if (defined($self->readFILE(\$datablk))) + { + # read from file successful + # increment the transferred bytes counter + $self->{'_REQUEST_'}{'TotalBytes'} += length($datablk); + if ($self->sendDATA(\$datablk)) + { + # send to socket successful + if ($self->{'CallBack'}) + { + &{$self->{'CallBack'}}($self); + } + } + else + { + # error sending to socket + return (undef); + } + } + else + { + # error reading from file + return (undef); + } + } + else + { + # transfer completed + return (1); + } + } +} + + +# +# Usage: $requestOBJ->recvFILE(); +# return 1 if success or undef if error +# +sub recvFILE +{ + my $self = shift; + + $self->{'_REQUEST_'}{'LASTBLK'} = 0; + $self->{'_REQUEST_'}{'PREVBLK'} = 0; + + while (1) + { + my $datablk = 0; + if ($self->recvDATA(\$datablk)) + { + # DATA received + if (defined($self->writeFILE(\$datablk))) + { + # DATA written to file + my $udpserver = $self->{'_UDPSERVER_'}; + + if (defined($udpserver->send(pack("nn", TFTP_OPCODE_ACK, $self->{'_REQUEST_'}{'LASTBLK'})))) + { + # sent ACK + # increment the transferred bytes counter + $self->{'_REQUEST_'}{'TotalBytes'} += length($datablk); + if (length($datablk) < $self->{'BlkSize'}) + { + return (1); + } + else + { + next; + } + } + else + { + $! = $udpserver->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket SEND error: %s\n", $!; + return (undef); + } + } + else + { + # error writing data + return (undef); + } + } + else + { + # timeout waiting for data + return (undef); + } + } +} + +# +# Usage: $requestOBJ->recvDATA(\$data); +# return 1 if success or undef if error +# +sub recvDATA +{ + my $self = shift; + my $datablk = shift; + + my ($datagram, $opcode, $datain); + + my $udpserver = $self->{'_UDPSERVER_'}; + + # vars for IO select + my ($rin, $rout, $ein, $eout) = ('', '', '', ''); + vec($rin, fileno($udpserver), 1) = 1; + + # wait for data + if (select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'})) + { + # read the message + if ($udpserver->recv($datagram, $self->{'BlkSize'} + 4)) + { + # decode the message + ($opcode, $datain) = unpack("na*", $datagram); + if ($opcode eq TFTP_OPCODE_DATA) + { + # message is DATA + $self->{'_REQUEST_'}{'PREVBLK'} = $self->{'_REQUEST_'}{'LASTBLK'}; + ($self->{'_REQUEST_'}{'LASTBLK'}, $$datablk) = unpack("na*", $datain); + + if($self->{'CallBack'}) + { + &{$self->{'CallBack'}}($self); + } + + return (1); + } + elsif ($opcode eq TFTP_OPCODE_ERROR) + { + # message is ERR + $LASTERROR = sprintf "TFTP error message: %s", $datain; + return (undef); + } + else + { + # other messages... + $LASTERROR = sprintf "Opcode %d not supported waiting for DATA\n", $opcode; + return (undef); + } + } + else + { + $! = $udpserver->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket RECV error: %s\n", $!; + return (undef); + } + } + else + { + $LASTERROR = sprintf "Timeout occurred on DATA packet %d\n", $self->{'_REQUEST_'}{'LASTBLK'} + 1; + return (undef); + } +} + + +# +# Usage: $requestOBJ->sendDATA(\$data); +# return 1 if success or undef if error +# +sub sendDATA +{ + my $self = shift; + my $datablk = shift; + + my $udpserver = $self->{'_UDPSERVER_'}; + my $retry = 0; + + my ($datagram, $opcode, $datain); + + while ($retry < $self->{'ACKretries'}) + { + if ($udpserver->send(pack("nna*", TFTP_OPCODE_DATA, $self->{'_REQUEST_'}{'LASTACK'} + 1, $$datablk))) + { + # vars for IO select + my ($rin, $rout, $ein, $eout) = ('', '', '', ''); + vec($rin, fileno($udpserver), 1) = 1; + + # wait for acknowledge + if (select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'})) + { + # read the message + if ($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4)) + { + # decode the message + ($opcode, $datain) = unpack("na*", $datagram); + if ($opcode eq TFTP_OPCODE_ACK) + { + # message is ACK + # modified for supporting more blocks count than 65535, O.Z. 15.08.2007 + $self->{'_REQUEST_'}{'PREVACK'} = $self->{'_REQUEST_'}{'LASTACK'}; + if (int(($self->{'_REQUEST_'}{'LASTACK'}+1) % 65536) == unpack("n", $datain)){ + $self->{'_REQUEST_'}{'LASTACK'}++; + }; + return (1); + } + elsif ($opcode eq TFTP_OPCODE_ERROR) + { + # message is ERR + $LASTERROR = sprintf "TFTP error message: %s", $datain; + return (undef); + } + else + { + # other messages... + $LASTERROR = sprintf "Opcode %d not supported as a reply to DATA\n", $opcode; + return (undef); + } + } + else + { + $! = $udpserver->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket RECV error: %s\n", $!; + return (undef); + } + } + else + { + $LASTERROR = sprintf "Retry %d - timeout occurred on ACK packet %d\n", $retry, $self->{'_REQUEST_'}{'LASTACK'} + 1; + $debug and carp($LASTERROR); + $retry++; + } + } + else + { + $! = $udpserver->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket SEND error: %s\n", $!; + return (undef); + } + } +} + +# +# Usage: $requestOBJ->openFILE() +# returns 1 if file is opened, undef if error +# +sub openFILE +{ + # the request object + my $self = shift; + + if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ) + { + ######################################## + # opcode is RRQ, open file for reading # + ######################################## + if (open(RFH, "<".$self->{'_REQUEST_'}{'FileName'})) + { + # if OCTET mode, set FileHandle to binary mode... + if ($self->{'_REQUEST_'}{'Mode'} eq 'OCTET') + { + binmode(RFH); + } + + my $size = -s($self->{'_REQUEST_'}{'FileName'}); + $self->{'_REQUEST_'}{'LASTBLK'} = 1 + int($size / $self->{'BlkSize'}); + + # save the filehandle reference... + $self->{'_REQUEST_'}{'_FH_'} = *RFH; + + return (1); + } + else + { + $LASTERROR = sprintf "Error opening file \'%s\' for reading\n", $self->{'_REQUEST_'}{'FileName'}; + return (undef); + } + } + elsif ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) + { + ######################################## + # opcode is WRQ, open file for writing # + ######################################## + if (open(WFH, ">".$self->{'_REQUEST_'}{'FileName'})) + { + # if OCTET mode, set FileHandle to binary mode... + if ($self->{'_REQUEST_'}{'Mode'} eq 'OCTET') + { + binmode(WFH); + } + + # save the filehandle reference... + $self->{'_REQUEST_'}{'_FH_'} = *WFH; + + return (1); + } + else + { + $LASTERROR = sprintf "Error opening file \'%s\' for writing\n", $self->{'_REQUEST_'}{'FileName'}; + return (undef); + } + } + else + { + ############################ + # other opcodes are errors # + ############################ + $LASTERROR = sprintf "OPCODE %d is not supported\n", $self->{'_REQUEST_'}{'OPCODE'}; + return (undef); + } +} + +# +# Usage: $requestOBJ->closeFILE() +# returns 1 if file is success, undef if error +# +sub closeFILE +{ + my $self = shift; + + if ($self->{'_REQUEST_'}{'_FH_'}) + { + if (close($self->{'_REQUEST_'}{'_FH_'})) + { + return (1); + } + else + { + $LASTERROR = "Error closing filehandle\n"; + return (undef); + } + } + else + { + return (1); + } +} + +# +# Usage: $requestOBJ->checkFILE() +# returns 1 if file is found, undef if file is not found +# +sub checkFILE +{ + # the request object + my $self = shift; + + # requested file + my $reqfile = $self->{'_REQUEST_'}{'FileName'}; + + if ($self->{'FileName'}) + { + # filename is fixed + $self->{'_REQUEST_'}{'FileName'} = $self->{'FileName'}; + + if (($self->{'FileName'} =~ /$reqfile/) and -e($self->{'FileName'})) + { + # fixed name contains requested file and file exists + $self->{'FileSize'} = -s($self->{'FileName'}); + return (1); + } + } + elsif ($self->{'RootDir'}) + { + # rootdir is fixed + $reqfile = $self->{'RootDir'}.'/'.$reqfile; + $self->{'_REQUEST_'}{'FileName'} = $reqfile; + + if (-e($reqfile)) + { + # file exists in rootdir + $self->{'FileSize'} = -s($reqfile); + return (1); + } + } + + return (undef); +} + +# +# Usage: $requestOBJ->sendOACK(); +# return 1 for success and undef for error (see $Net::TFTPd::LASTERROR for cause) +# +sub sendOACK +{ + # the request object + my $self = shift; + my $udpserver = $self->{'_UDPSERVER_'}; + my $retry = 0; + + my ($datagram, $opcode, $datain); + + while ($retry < $self->{'ACKretries'}) + { + # send oack + my $data = join("\0", %{ $self->{'_RESPONSE_'}{'RFC2347'} })."\0"; + if ($udpserver->send(pack("na*", TFTP_OPCODE_OACK, $data))) + { + # opcode is RRQ + if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ) + { + # vars for IO select + my ($rin, $rout, $ein, $eout) = ('', '', '', ''); + vec($rin, fileno($udpserver), 1) = 1; + + # wait for acknowledge + if (select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'})) + { + # read the message + if ($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4)) + { + # decode the message + ($opcode, $datain) = unpack("na*", $datagram); + if ($opcode == TFTP_OPCODE_ACK) + { + # message is ACK + my $lastack = unpack("n", $datain); + if ($lastack) + { + # ack is not for block 0... ERROR + $LASTERROR = sprintf "Received ACK for block %d instead of 0", $lastack; + return (undef); + } + return 1; + } + elsif ($opcode == TFTP_OPCODE_ERROR) + { + # message is ERR + $LASTERROR = sprintf "TFTP error message: %s", $datain; + return (undef); + } + else + { + # other messages... + $LASTERROR = sprintf "Opcode %d not supported as a reply to OACK\n", $opcode; + return (undef); + } + } + else + { + $! = $udpserver->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket RECV error: %s\n", $!; + return (undef); + } + } + else + { + $LASTERROR = sprintf "Retry %d - timeout occurred waiting reply for OACK packet\n", $retry; + $debug and carp($LASTERROR); + $retry++; + } + } + elsif ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) + { + # opcode is WRQ + return (1); + } + } + else + { + $! = $udpserver->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket SEND error: %s\n", $!; + return (undef); + } + } +} + +# +# Usage: $requestOBJ->sendERR($code, $message); +# returns 1 if success, undef if error +# +sub sendERR +{ + my $self = shift; + my ($errcode, $errmsg) = @_; + # modified for supporting NETASCII transfers on 25/05/2009 + #$errmsg or $errmsg = ''; + $errmsg or $errmsg = $ERRORS{$errcode}; + + my $udpserver = $self->{'_UDPSERVER_'}; + + if ($udpserver->send(pack("nnZ*", 5, $errcode, $errmsg))) + { + return (1); + } + else + { + $! = $udpserver->sockopt(SO_ERROR); + $LASTERROR = sprintf "Socket SEND error: %s\n", $!; + return (undef); + } +} + +sub server +{ + my $self = shift; + return $self->{'_UDPSERVER_'}; +} + +sub error +{ + return ($LASTERROR); +} + +# Preloaded methods go here. + +1; +__END__ + +# Below is stub documentation for your module. You better edit it! + +=head1 NAME + +Net::TFTPd - Perl extension for Trivial File Transfer Protocol Server + +=head1 SYNOPSIS + + use strict; + use Net::TFTPd; + + my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'path/to/files') + or die "Error creating TFTPd listener: %s", Net::TFTPd->error; + + my $tftpRQ = $tftpdOBJ->waitRQ(10) + or die "Error waiting for TFTP request: %s", Net::TFTPd->error; + + $tftpRQ->processRQ() + or die "Error processing TFTP request: %s", Net::TFTPd->error; + + printf "%u bytes has been transferred", $tftpRQ->getTotalBytes() || 0; + +=head1 DESCRIPTION + +C is a class implementing a simple I server in Perl as described in RFC1350. + +C also supports the TFTP Option Extension (as described in RFC2347), with the following options: + + RFC2348 TFTP Blocksize Option + RFC2349 TFTP Timeout Interval and Transfer Size Options + +=head1 EXPORT + +None by default. + +=head2 %OPCODES + +The %OPCODES tag exports the I<%OPCODES> hash: + + %OPCODES = ( + 1 => 'RRQ', + 2 => 'WRQ', + 3 => 'DATA', + 4 => 'ACK', + 5 => 'ERROR', + 6 => 'OACK', + 'RRQ' => 1, + 'WRQ' => 2, + 'DATA' => 3, + 'ACK' => 4, + 'ERROR' => 5, + 'OACK' => 6 + ); + +=head1 Listener constructor + +=head2 new() + + $listener = new Net::TFTPd( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] ); + +or + + $listener = Net::TFTPd->new( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] ); + +Create a new Net::TFTPd object where 'path/to/files' is the default path to file repository +or 'path/to/file' is the single file allowed for download, and OPTIONS are the default server +options. + +Valid options are: + + Option Description Default + ------ ----------- ------- + LocalAddr Interface to bind to (for multi-homed server) any + LocalPort Port to bind server to 69 + Timeout Timeout in seconds to wait for a request 10 + ACKtimeout Timeout in seconds to wait for an ACK packet 4 + ACKretries Maximum number of retries waiting for ACK 4 + Readable Clients are allowed to read files 1 + Writable Clients are allowed to write files 0 + BlkSize Minimum blocksize to negotiate for transfers 512 + CallBack Reference to code executed for each transferred block - + Debug Activates debug mode (verbose) 0 + Family Address family IPv4/IPv6 IPv4 + Valid values for IPv4: + 4, v4, ip4, ipv4, AF_INET (constant) + Valid values for IPv6: + 6, v6, ip6, ipv6, AF_INET6 (constant) + +B: IPv6 requires B. Failback is B +and only IPv4 support. + +=head2 CallBack + +The CallBack code is called by processRQ method for each tranferred block. + +The code receives (into @_ array) a reference to internal I<$request> object. + +Example: + + sub callback + { + my $req = shift; + printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'}; + } + + my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'c:/temp', 'Timeout' => 60, 'CallBack' => \&callback) or die Net::TFTPd->error; + +=head1 Listener methods + +=head2 waitRQ() + + $request = $listener->waitRQ([Timeout]); + +Waits for a client request (RRQ or WRQ) and returns a I<$request> object or I if timed out. + +If I is missing, the timeout defined for I<$listener> object is used instead. + +When the method returns, the program should fork() and process the request invoking processRQ() while the parent process should re-start waiting for another request. + +=head1 Request methods + +=head2 processRQ() + + $ret = $request->processRQ(); + +Processes a request and returns 1 if success, undef if error. + +=head2 getFileName() + + $ret = $request->getFileName(); + +Returns the requested file name. + +=head2 getMode() + + $ret = $request->getMode(); + +Returns the transfer mode for the request. + +=head2 getBlkSize() + + $ret = $request->getBlkSize(); + +Returns the block size used for the transfer. + +=head2 server() + + $ret = $request->server(); + +Return B object for the created server. +All B accessors can then be called. + +=head2 getPeerAddr() + + $ret = $request->getPeerAddr(); + +Returns the address of the requesting client. + +=head2 getPeerPort() + + $ret = $request->getPeerMode(); + +Returns the port of the requesting client. + +=head2 getTotalBytes() + + $ret = $request->getTotalBytes(); + +Returns the number of bytes transferred for the request. + +=head1 CREDITS + +Thanks to Michael Vincent (EVINSWORLDE) for the NETASCII support, transferred bytes and IPv6 patches. + +=head1 AUTHOR + +Luigino Masarati, Elmasarati@hotmail.comE + +=head1 SEE ALSO + +L. + +=cut + diff -Nru libnet-tftpd-perl-0.06/Makefile.PL libnet-tftpd-perl-0.09/Makefile.PL --- libnet-tftpd-perl-0.06/Makefile.PL 2012-10-17 09:12:17.000000000 +0000 +++ libnet-tftpd-perl-0.09/Makefile.PL 2015-03-20 01:17:30.000000000 +0000 @@ -2,12 +2,13 @@ # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( - 'NAME' => 'Net::TFTPd', - 'VERSION_FROM' => 'TFTPd.pm', # finds $VERSION - 'BINARY_LOCATION' => 'Net-TFTPd-0.06.tar.gz', - 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 + NAME => 'Net::TFTPd', + VERSION_FROM => 'lib/Net/TFTPd.pm', # finds $VERSION + ($ExtUtils::MakeMaker::VERSION >= 6.3002) ? ('LICENSE' => 'perl', ) : (), + EXE_FILES => ['bin/tftpd-simple.pl', + 'bin/simpleTFTPd.pl'], + PREREQ_PM => {}, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 - (ABSTRACT_FROM => 'TFTPd.pm', # retrieve abstract from module - AUTHOR => 'Luigino Masarati ') : () - ) + (ABSTRACT_FROM => 'lib/Net/TFTPd.pm', # retrieve abstract from module + AUTHOR => 'Luigino Masarati ') : ()), ); diff -Nru libnet-tftpd-perl-0.06/MANIFEST libnet-tftpd-perl-0.09/MANIFEST --- libnet-tftpd-perl-0.06/MANIFEST 2007-09-17 05:51:07.000000000 +0000 +++ libnet-tftpd-perl-0.09/MANIFEST 2015-03-20 01:27:19.000000000 +0000 @@ -2,7 +2,10 @@ Makefile.PL MANIFEST README -test.pl -simpleTFTPd.pl -TFTPd.pm -TFTPd.html +bin/tftpd-simple.pl +bin/simpleTFTPd.pl +t/00-Net-TFTPd.t +t/03-test-pod.t +lib/Net/TFTPd.pm +META.yml Module meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff -Nru libnet-tftpd-perl-0.06/META.json libnet-tftpd-perl-0.09/META.json --- libnet-tftpd-perl-0.06/META.json 1970-01-01 00:00:00.000000000 +0000 +++ libnet-tftpd-perl-0.09/META.json 2015-03-20 02:02:12.000000000 +0000 @@ -0,0 +1,39 @@ +{ + "abstract" : "Perl extension for Trivial File Transfer Protocol Server", + "author" : [ + "Luigino Masarati " + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 6.72, CPAN::Meta::Converter version 2.132140", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Net-TFTPd", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : {} + } + }, + "release_status" : "stable", + "version" : "0.09" +} diff -Nru libnet-tftpd-perl-0.06/META.yml libnet-tftpd-perl-0.09/META.yml --- libnet-tftpd-perl-0.06/META.yml 1970-01-01 00:00:00.000000000 +0000 +++ libnet-tftpd-perl-0.09/META.yml 2015-03-20 02:02:10.000000000 +0000 @@ -0,0 +1,21 @@ +--- +abstract: 'Perl extension for Trivial File Transfer Protocol Server' +author: + - 'Luigino Masarati ' +build_requires: + ExtUtils::MakeMaker: 0 +configure_requires: + ExtUtils::MakeMaker: 0 +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 6.72, CPAN::Meta::Converter version 2.132140' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: Net-TFTPd +no_index: + directory: + - t + - inc +requires: {} +version: 0.09 diff -Nru libnet-tftpd-perl-0.06/README libnet-tftpd-perl-0.09/README --- libnet-tftpd-perl-0.06/README 2012-10-11 07:39:26.000000000 +0000 +++ libnet-tftpd-perl-0.09/README 2015-03-20 01:25:10.000000000 +0000 @@ -1,18 +1,19 @@ -Net/TFTPD version 0.05 -====================== - -INSTALLATION - -To install this module type the following: - - perl Makefile.PL - make - make install - -COPYRIGHT AND LICENCE - -Copyright (C) 2002-2012 Luigino Masarati - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - +Net/TFTPD +========= + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +COPYRIGHT AND LICENCE + +Copyright (C) 2002-2012 Luigino Masarati + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + diff -Nru libnet-tftpd-perl-0.06/simpleTFTPd.pl libnet-tftpd-perl-0.09/simpleTFTPd.pl --- libnet-tftpd-perl-0.06/simpleTFTPd.pl 2012-10-11 08:29:16.000000000 +0000 +++ libnet-tftpd-perl-0.09/simpleTFTPd.pl 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -#!/usr/bin/perl -use strict; -use Net::TFTPd 0.05 qw(%OPCODES); - -# change ROOTDIR to your TFTP root directory -my $rootdir = $ARGV[0]; - -unless(-d $rootdir) -{ - print "\nUsage: simpleTFTPd.pl path/to/rootdir\n\n"; - exit 1; -} - -# callback sub used to print transfer status -sub callback -{ - my $req = shift; - if($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'RRQ'}) - { - # RRQ - printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'}; - } - elsif($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'WRQ'}) - { - # WRQ - printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTBLK'}, $req->{'_REQUEST_'}{'LASTACK'}; - } -} - -# create the listener -my $listener = Net::TFTPd->new('RootDir' => $rootdir, 'Writable' => 1, 'Timeout' => 10, 'CallBack' => \&callback) or die Net::TFTPd->error; -printf "TFTP listener is bound to %s:%d\nTFTP listener is waiting %d seconds for a request\n", $listener->{'LocalAddr'} ? $listener->{'LocalAddr'} : "'any address'", $listener->{'LocalPort'}, $listener->{'Timeout'}; - -# wait for any request (RRQ or WRQ) -if(my $request = $listener->waitRQ()) -{ - # received request - printf "Received a %s for file '%s'\n", $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, $request->getFileName(); - - # process the request - if($request->processRQ()) - { - printf "OK, transfer completed successfully for file %s, %u bytes transferred\n", $request->getFileName(), $request->getTotalBytes(); - } - else - { - die Net::TFTPd->error; - } -} -else -{ - # request not received (timed out waiting for request etc.) - die Net::TFTPd->error; -} diff -Nru libnet-tftpd-perl-0.06/t/00-Net-TFTPd.t libnet-tftpd-perl-0.09/t/00-Net-TFTPd.t --- libnet-tftpd-perl-0.06/t/00-Net-TFTPd.t 1970-01-01 00:00:00.000000000 +0000 +++ libnet-tftpd-perl-0.09/t/00-Net-TFTPd.t 2015-03-20 01:24:49.000000000 +0000 @@ -0,0 +1,9 @@ +#!/usr/bin/perl + +use strict; +use Test::Simple tests => 1; + +use Net::TFTPd; +ok(1, "Loading Module"); # If we made it this far, we're ok. + +######################### diff -Nru libnet-tftpd-perl-0.06/t/03-test-pod.t libnet-tftpd-perl-0.09/t/03-test-pod.t --- libnet-tftpd-perl-0.06/t/03-test-pod.t 1970-01-01 00:00:00.000000000 +0000 +++ libnet-tftpd-perl-0.09/t/03-test-pod.t 2015-03-20 01:24:24.000000000 +0000 @@ -0,0 +1,9 @@ +eval "use Test::Pod 1.00"; +if ($@) { + use Test; + plan(tests => 1); + skip("Test::Pod 1.00 required for testing"); +} +else { + all_pod_files_ok(); +} diff -Nru libnet-tftpd-perl-0.06/test.pl libnet-tftpd-perl-0.09/test.pl --- libnet-tftpd-perl-0.06/test.pl 2007-09-17 05:51:07.000000000 +0000 +++ libnet-tftpd-perl-0.09/test.pl 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - -######################### - -# change 'tests => 1' to 'tests => last_test_to_print'; - -use Test; -BEGIN { plan tests => 1 }; -use Net::TFTPd; -ok(1); # If we made it this far, we're ok. - -######################### - -# Insert your test code below, the Test module is use()ed here so read -# its man page ( perldoc Test ) for help writing this test script. - diff -Nru libnet-tftpd-perl-0.06/TFTPd.html libnet-tftpd-perl-0.09/TFTPd.html --- libnet-tftpd-perl-0.06/TFTPd.html 2012-10-17 09:17:38.000000000 +0000 +++ libnet-tftpd-perl-0.09/TFTPd.html 1970-01-01 00:00:00.000000000 +0000 @@ -1,280 +0,0 @@ - - - - -Net::TFTPd - Perl extension for Trivial File Transfer Protocol Server - - - - - - - -
- Net::TFTPd - Perl extension for Trivial File Transfer Protocol Server -
- - - - - - -

-

-

NAME

-

Net::TFTPd - Perl extension for Trivial File Transfer Protocol Server

-

-

-
-

SYNOPSIS

-
-  use strict;
-  use Net::TFTPd;
-
-
-  my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'path/to/files')
-    or die "Error creating TFTPd listener: %s", Net::TFTPd->error;
-
-
-  my $tftpRQ = $tftpdOBJ->waitRQ(10)
-    or die "Error waiting for TFTP request: %s", Net::TFTPd->error;
-
-
-  $tftpRQ->processRQ()
-    or die "Error processing TFTP request: %s", Net::TFTPd->error;
-
-
-  printf "%u bytes has been transferred", $tftpRQ->getTotalBytes() || 0;
-
-

-

-
-

DESCRIPTION

-

Net::TFTPd is a class implementing a simple Trivial File Transfer Protocol server in Perl as described in RFC1350.

-

Net::TFTPd also supports the TFTP Option Extension (as described in RFC2347), with the following options:

-
-  RFC2348 TFTP Blocksize Option
-  RFC2349 TFTP Timeout Interval and Transfer Size Options
-

-

-
-

EXPORT

-

None by default.

-

-

-

%OPCODES

-

The %OPCODES tag exports the %OPCODES hash:

-
-  %OPCODES = (
-    1       => 'RRQ',
-    2       => 'WRQ',
-    3       => 'DATA',
-    4       => 'ACK',
-    5       => 'ERROR',
-    6       => 'OACK',
-    'RRQ'   => 1,
-    'WRQ'   => 2,
-    'DATA'  => 3,
-    'ACK'   => 4,
-    'ERROR' => 5,
-    'OACK'  => 6
-  );
-
-

-

-
-

Listener constructor

-

-

-

new()

-
-  $listener = new Net::TFTPd( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] );
-
-

or

-
-  $listener = Net::TFTPd->new( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] );
-
-

Create a new Net::TFTPd object where 'path/to/files' is the default path to file repository -or 'path/to/file' is the single file allowed for download, and OPTIONS are the default server -options.

-

Valid options are:

-
-  Option     Description                                        Default
-  ------     -----------                                        -------
-  LocalAddr  Interface to bind to (for multi-homed server)          any
-  LocalPort  Port to bind server to                                  69
-  Timeout    Timeout in seconds to wait for a request                10
-  ACKtimeout Timeout in seconds to wait for an ACK packet             4
-  ACKretries Maximum number of retries waiting for ACK                4
-  Readable   Clients are allowed to read files                        1
-  Writable   Clients are allowed to write files                       0
-  BlkSize    Minimum blocksize to negotiate for transfers           512
-  CallBack   Reference to code executed for each transferred block    -
-  Debug      Activates debug mode (verbose)                           0
-  Family     Address family IPv4/IPv6                              IPv4
-               Valid values for IPv4:
-                 4, v4, ip4, ipv4, AF_INET (constant)
-               Valid values for IPv6:
-                 6, v6, ip6, ipv6, AF_INET6 (constant)
-

NOTE: IPv6 requires IO::Socket::IP. Failback is IO::Socket::INET -and only IPv4 support.

-

-

-

CallBack

-

The CallBack code is called by processRQ method for each tranferred block.

-

The code receives (into @_ array) a reference to internal $request object.

-

Example:

-
-  sub callback
-  {
-    my $req = shift;
-    printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'};
-  }
-
-
-  my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'c:/temp', 'Timeout' => 60, 'CallBack' => \&callback) or die Net::TFTPd->error;
-
-

-

-
-

Listener methods

-

-

-

waitRQ()

-
-  $request = $listener->waitRQ([Timeout]);
-
-

Waits for a client request (RRQ or WRQ) and returns a $request object or undef if timed out.

-

If Timeout is missing, the timeout defined for $listener object is used instead.

-

When the method returns, the program should fork() and process the request invoking processRQ() while the parent process should re-start waiting for another request.

-

-

-
-

Request methods

-

-

-

processRQ()

-
-  $ret = $request->processRQ();
-
-

Processes a request and returns 1 if success, undef if error.

-

-

-

getFileName()

-
-  $ret = $request->getFileName();
-
-

Returns the requested file name.

-

-

-

getMode()

-
-  $ret = $request->getMode();
-
-

Returns the transfer mode for the request.

-

-

-

getBlkSize()

-
-  $ret = $request->getBlkSize();
-
-

Returns the block size used for the transfer.

-

-

-

server()

-
-  $ret = $request->server();
-
-

Return IO::Socket::* object for the created server. -All IO::Socket::* accessors can then be called.

-

-

-

getPeerAddr()

-
-  $ret = $request->getPeerAddr();
-
-

Returns the address of the requesting client.

-

-

-

getPeerPort()

-
-  $ret = $request->getPeerMode();
-
-

Returns the port of the requesting client.

-

-

-

getTotalBytes()

-
-  $ret = $request->getTotalBytes();
-
-

Returns the number of bytes transferred for the request.

-

-

-
-

CREDITS

-

Thanks to Michael Vincent (<VINSWORLD>) for the NETASCII support, transferred bytes and IPv6 patches.

-

-

-
-

AUTHOR

-

Luigino Masarati, <lmasarati@hotmail.com>

-

-

-
-

SEE ALSO

-

the Net::TFTP manpage.

- - -
- Net::TFTPd - Perl extension for Trivial File Transfer Protocol Server -
- - - - diff -Nru libnet-tftpd-perl-0.06/TFTPd.pm libnet-tftpd-perl-0.09/TFTPd.pm --- libnet-tftpd-perl-0.06/TFTPd.pm 2012-10-17 09:11:48.000000000 +0000 +++ libnet-tftpd-perl-0.09/TFTPd.pm 1970-01-01 00:00:00.000000000 +0000 @@ -1,1455 +0,0 @@ -package Net::TFTPd; - -use 5.006; -use Carp; -use strict; -use warnings; - -# modified by M.Vincent for IPv6 support -use Socket qw(AF_INET SO_ERROR); -my $AF_INET6 = eval { Socket::AF_INET6() }; -my $HAVE_IO_Socket_IP = 0; -eval "use IO::Socket::IP -register"; -if (!$@) -{ - $HAVE_IO_Socket_IP = 1; -} -else -{ - eval "use IO::Socket::INET"; -} - -require Exporter; - -# modified for supporting small block sizes, O.Z. 15.08.2007 -use constant TFTP_MIN_BLKSIZE => 8; -use constant TFTP_DEFAULT_BLKSIZE => 512; -use constant TFTP_MAX_BLKSIZE => 65464; -use constant TFTP_MIN_TIMEOUT => 1; -use constant TFTP_MAX_TIMEOUT => 60; -use constant TFTP_DEFAULT_PORT => 69; - -use constant TFTP_OPCODE_RRQ => 1; -use constant TFTP_OPCODE_WRQ => 2; -use constant TFTP_OPCODE_DATA => 3; -use constant TFTP_OPCODE_ACK => 4; -use constant TFTP_OPCODE_ERROR => 5; -use constant TFTP_OPCODE_OACK => 6; - -# Type Op # Format without header -# -# 2 bytes string 1 byte string 1 byte -# ------------------------------------------------- -# RRQ/ | 01/02 | Filename | 0 | Mode | 0 | -# WRQ ------------------------------------------------- -# 2 bytes 2 bytes n bytes -# ----------------------------------- -# DATA | 03 | Block # | Data | -# ----------------------------------- -# 2 bytes 2 bytes -# ---------------------- -# ACK | 04 | Block # | -# ---------------------- -# 2 bytes 2 bytes string 1 byte -# ------------------------------------------ -# ERROR | 05 | ErrorCode | ErrMsg | 0 | -# ------------------------------------------ - -our %OPCODES = ( - 1 => 'RRQ', - 2 => 'WRQ', - 3 => 'DATA', - 4 => 'ACK', - 5 => 'ERROR', - 6 => 'OACK', - 'RRQ' => TFTP_OPCODE_RRQ, - 'WRQ' => TFTP_OPCODE_WRQ, - 'DATA' => TFTP_OPCODE_DATA, - 'ACK' => TFTP_OPCODE_ACK, - 'ERROR' => TFTP_OPCODE_ERROR, - 'OACK' => TFTP_OPCODE_OACK -); - -my %ERRORS = ( - 0 => 'Not defined, see error message (if any)', - 1 => 'File not found', - 2 => 'Access violation', - 3 => 'Disk full or allocation exceeded', - 4 => 'Illegal TFTP operation', - 5 => 'Unknown transfer ID', - 6 => 'File already exists', - 7 => 'No such user', - 8 => 'Option negotiation' -); - -our @ISA = qw(Exporter); - -# Items to export into callers namespace by default. Note: do not export -# names by default without a very good reason. Use EXPORT_OK instead. -# Do not simply export all your public functions/methods/constants. - -# This allows declaration use Net::TFTPd ':all'; -# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK -# will save memory. -our %EXPORT_TAGS = ( - 'all' => [ qw( %OPCODES ) ] -); - -our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); - -our @EXPORT = qw( ); - -our $VERSION = '0.06'; - -our $LASTERROR; - -my $debug; - -# -# Usage: $tftpdOBJ = Net::TFTPd->new( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] ); -# return the tftpdOBJ object if success or undef if error -# -sub new -{ - # create the future TFTPd object - my $self = shift; - my $class = ref($self) || $self; - - # read parameters - my %cfg = @_; - - # setting defaults - $cfg{'FileName'} or $cfg{'RootDir'} or croak "Usage: \$tftpdOBJ = Net::TFTPd->new(['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, [ LocalPort => portnum ] [, ...]] );"; - - if ($cfg{'RootDir'} and not -d($cfg{'RootDir'}) ) - { - $LASTERROR = sprintf 'RootDir \'%s\' not found or is not a valid directory name\n', $cfg{'RootDir'}; - return (undef); - } - - if ($cfg{'FileName'} and not -e($cfg{'FileName'}) ) - { - $LASTERROR = sprintf 'FileName \'%s\' not found or is not a valid filename\n', $cfg{'FileName'}; - return (undef); - } - - my %params = ( - 'Proto' => 'udp', - 'LocalPort' => $cfg{'LocalPort'} || TFTP_DEFAULT_PORT - ); - - # modified by M.Vincent for IPv6 support - if (defined($cfg{'Family'})) - { - if ($cfg{'Family'} =~ /^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/) - { - if ($cfg{'Family'} =~ /^(?:(?:(:?ip)?v?4)|${\AF_INET})$/) - { - $params{'Family'} = AF_INET; - } - else - { - if (!$HAVE_IO_Socket_IP) - { - $LASTERROR = "IO::Socket::IP required for IPv6"; - return (undef); - } - $params{'Family'} = $AF_INET6; - } - } - else - { - $LASTERROR = "Invalid family - $cfg{'Family'}"; - return (undef); - } - } - else - { - $params{'Family'} = AF_INET; - } - - # bind only to specified address - if ($cfg{'LocalAddr'}) - { - $params{'LocalAddr'} = $cfg{'LocalAddr'}; - } - - if ($HAVE_IO_Socket_IP) - { - if (my $udpserver = IO::Socket::IP->new(%params)) - { - return bless { - 'LocalPort' => TFTP_DEFAULT_PORT, - 'Timeout' => 10, - 'ACKtimeout' => 4, - 'ACKretries' => 4, - 'Readable' => 1, - 'Writable' => 0, - 'CallBack' => undef, - 'BlkSize' => TFTP_DEFAULT_BLKSIZE, - 'Debug' => 0, - %cfg, # merge user parameters - '_UDPSERVER_' => $udpserver - }, $class; - } - else - { - $LASTERROR = "Error opening socket for listener: $@\n"; - return (undef); - } - } - else - { - if (my $udpserver = IO::Socket::INET->new(%params)) - { - return bless { - 'LocalPort' => TFTP_DEFAULT_PORT, - 'Timeout' => 10, - 'ACKtimeout' => 4, - 'ACKretries' => 4, - 'Readable' => 1, - 'Writable' => 0, - 'CallBack' => undef, - 'BlkSize' => TFTP_DEFAULT_BLKSIZE, - 'Debug' => 0, - %cfg, # merge user parameters - '_UDPSERVER_' => $udpserver - }, $class; - } - else - { - $LASTERROR = "Error opening socket for listener: $@\n"; - return (undef); - } - } -} - -# -# Usage: $tftpdOBJ->waitRQ($timeout); -# return requestOBJ if success, 0 if $timeout elapsed, undef if error -# -sub waitRQ -{ - # the tftpd object -# my $tftpd = shift; - - my $self = shift; - my $class = ref($self) || $self; -# return bless {}, $class; - - # clone the object - my $request; - foreach my $key (keys(%{$self})) - { - # everything but '_xxx_' - $key =~ /^\_.+\_$/ and next; - $request->{$key} = $self->{$key}; - } - - # use $timeout or default from $tftpdOBJ - my $Timeout = shift || $request->{'Timeout'}; - - my $udpserver = $self->{'_UDPSERVER_'}; - - my ($datagram, $opcode, $datain); - - # vars for IO select - my ($rin, $rout, $ein, $eout) = ('', '', '', ''); - vec($rin, fileno($udpserver), 1) = 1; - - # check if a message is waiting - if (select($rout=$rin, undef, $eout=$ein, $Timeout)) - { - # read the message - if ($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4)) - { - # decode the message - ($opcode, $datain) = unpack("na*", $datagram); - - $request->{'_REQUEST_'}{'OPCODE'} = $opcode; - - # get peer port and address - $request->{'_REQUEST_'}{'PeerPort'} = $udpserver->peerport; - $request->{'_REQUEST_'}{'PeerAddr'} = $udpserver->peerhost; - - # get filename and transfer mode - my @datain = split("\0", $datain); - - $request->{'_REQUEST_'}{'FileName'} = shift(@datain); - $request->{'_REQUEST_'}{'Mode'} = uc(shift(@datain)); - $request->{'_REQUEST_'}{'BlkSize'} = TFTP_DEFAULT_BLKSIZE; - $request->{'_REQUEST_'}{'LASTACK'} = 0; - $request->{'_REQUEST_'}{'PREVACK'} = -1; - # counter for transferred bytes - $request->{'_REQUEST_'}{'TotalBytes'} = 0; - - if (scalar(@datain) >= 2) - { - $request->{'_REQUEST_'}{'RFC2347'} = { @datain }; - } - - return bless $request, $class; - } - else - { - $! = $udpserver->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket RECV error: %s\n", $!; - return (undef); - } - } - else - { - $LASTERROR = "Timed out waiting for RRQ/WRQ"; - return (0); - } -} - -# -# Usage: $requestOBJ->processRQ(); -# return 1 if success, undef if error -# -sub processRQ -{ - # the request object - my $self = shift; - - if (defined($self->newSOCK())) - { - # modified for supporting NETASCII transfers on 25/05/2009 - if (($self->{'_REQUEST_'}{'Mode'} ne 'OCTET') && ($self->{'_REQUEST_'}{'Mode'} ne 'NETASCII')) - { - #request is not OCTET - $LASTERROR = sprintf "%s transfer mode is not supported\n", $self->{'_REQUEST_'}{'Mode'}; - $self->sendERR(0, $LASTERROR); - return (undef); - } - - # new socket opened successfully - if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ) - { - ################# - # opcode is RRQ # - ################# - if ($self->{'Readable'}) - { - # read is permitted - if ($self->{'_REQUEST_'}{'FileName'} =~ /\.\.[\\\/]/) - { - # requested file contains '..\' or '../' - $LASTERROR = sprintf 'Access to \'%s\' is not permitted to %s', $self->{'_REQUEST_'}{'FileName'}, $self->{'_REQUEST_'}{'PeerAddr'}; - $self->sendERR(2); - return (undef); - } - - if (defined($self->checkFILE())) - { - # file is present - if (defined($self->negotiateOPTS())) - { - # RFC 2347 options negotiated - if (defined($self->openFILE())) - { - # file opened for read, start the transfer - if (defined($self->sendFILE())) - { - # file sent successfully - return (1); - } - else - { - # error sending file - return (undef); - } - } - else - { - # error opening file - return (undef); - } - } - else - { - # error negotiating options - $LASTERROR = "TFTP error 8: Option negotiation\n"; - $self->sendERR(8); - return (undef); - } - } - else - { - # file not found - $LASTERROR = sprintf 'File \'%s\' not found', $self->{'_REQUEST_'}{'FileName'}; - $self->sendERR(1); - return (undef); - } - } - else - { - # if server is not readable - $LASTERROR = "TFTP Error: Access violation"; - $self->sendERR(2); - return (undef); - } - } - elsif ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) - { - ################# - # opcode is WRQ # - ################# - if ($self->{'Writable'}) - { - # write is permitted - if ($self->{'_REQUEST_'}{'FileName'} =~ /\.\.[\\\/]/) - { - # requested file contains '..\' or '../' - $LASTERROR = sprintf 'Access to \'%s\' is not permitted to %s', $self->{'_REQUEST_'}{'FileName'}, $self->{'_REQUEST_'}{'PeerAddr'}; - $self->sendERR(2); - return (undef); - } - - if (!defined($self->checkFILE())) - { - # RFC 2347 options negotiated - if (defined($self->openFILE())) - { - # file is not present - if (defined($self->negotiateOPTS())) - { - # file opened for write, start the transfer - if (defined($self->recvFILE())) - { - # file received successfully - return (1); - } - else - { - # error receiving file - return (undef); - } - } - else - { - # error negotiating options - $LASTERROR = "TFTP error 8: Option negotiation\n"; - $self->sendERR(8); - return (undef); - } - } - else - { - # error opening file - $self->sendERR(3); - return (undef); - } - } - else - { - # file not found - $LASTERROR = sprintf 'File \'%s\' already exists', $self->{'_REQUEST_'}{'FileName'}; - $self->sendERR(6); - return (undef); - } - } - else - { - # if server is not writable - $LASTERROR = "TFTP Error: Access violation"; - $self->sendERR(2); - return (undef); - } - } - else - { - ################# - # other opcodes # - ################# - $LASTERROR = sprintf "Opcode %d not supported as request", $self->{'_REQUEST_'}{'OPCODE'}; - $self->sendERR(4); - return (undef); - } - } - else - { - return (undef); - } -} - -# -# Usage: $requestOBJ->getTotalBytes(); -# returns the number of bytes transferred by the request -# -sub getTotalBytes -{ - # the request object - my $self = shift; - - return $self->{'_REQUEST_'}{'TotalBytes'}; -} - -# -# Usage: $requestOBJ->getFileName(); -# returns the requested file name -# -sub getFileName -{ - # the request object - my $self = shift; - - return $self->{'_REQUEST_'}{'FileName'}; -} - -# -# Usage: $requestOBJ->getMode(); -# returns the transfer mode for the request -# -sub getMode -{ - # the request object - my $self = shift; - - return $self->{'_REQUEST_'}{'Mode'}; -} - -# -# Usage: $requestOBJ->getPeerAddr(); -# returns the address of the requesting client -# -sub getPeerAddr -{ - # the request object - my $self = shift; - - return $self->{'_REQUEST_'}{'PeerAddr'}; -} - -# -# Usage: $requestOBJ->getPeerPort(); -# returns the port of the requesting client -# -sub getPeerPort -{ - # the request object - my $self = shift; - - return $self->{'_REQUEST_'}{'PeerPort'}; -} - -# -# Usage: $requestOBJ->getBlkSize(); -# returns the block size used for the transfer -# -sub getBlkSize -{ - # the request object - my $self = shift; - - return $self->{'_REQUEST_'}{'BlkSize'}; -} - -# -# Usage: $requestOBJ->newSOCK(); -# return 1 if success or undef if error -# -sub newSOCK -{ - # the request object - my $self = shift; - - # set parameters for the new socket - my %params = ( - 'Proto' => 'udp', - 'PeerPort' => $self->{'_REQUEST_'}{'PeerPort'}, - 'PeerAddr' => $self->{'_REQUEST_'}{'PeerAddr'} - ); - - # bind only to specified address - if ($self->{'Address'}) - { - $params{'LocalAddr'} = $self->{'Address'}; - } - - # open socket - if ($HAVE_IO_Socket_IP) - { - if (my $udpserver = IO::Socket::IP->new(%params)) - { - $self->{'_UDPSERVER_'} = $udpserver; - return (1); - } - else - { - $LASTERROR = "Error opening socket for reply: $@\n"; - return (undef); - } - } - else - { - if (my $udpserver = IO::Socket::INET->new(%params)) - { - $self->{'_UDPSERVER_'} = $udpserver; - return (1); - } - else - { - $LASTERROR = "Error opening socket for reply: $@\n"; - return (undef); - } - } -} - - -# -# Usage: $requestOBJ->negotiateOPTS(); -# return 1 if success or undef if error -# -sub negotiateOPTS -{ - # the request object - my $self = shift; - - if ($self->{'_REQUEST_'}{'RFC2347'}) - { - # parse RFC 2347 options if present - foreach my $option (keys(%{ $self->{'_REQUEST_'}{'RFC2347'} })) - { - if (uc($option) eq 'BLKSIZE') - { - # Negotiate the blocksize - if ($self->{'_REQUEST_'}{'RFC2347'}{$option} > TFTP_MAX_BLKSIZE or $self->{'_REQUEST_'}{'RFC2347'}{$option} < TFTP_MIN_BLKSIZE) - { - $self->{'_REQUEST_'}{'RFC2347'}{$option} = $self->{'BlkSize'}; - } - else - { - $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'_REQUEST_'}{'RFC2347'}{$option}; - $self->{'BlkSize'} = $self->{'_RESPONSE_'}{'RFC2347'}{$option}; - } - } - elsif (uc($option) eq 'TSIZE') - { - # Negotiate the transfer size - if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ) - { - $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'FileSize'}; - } - else - { - $self->{'FileSize'} = $self->{'_REQUEST_'}{'RFC2347'}{$option}; - } - } - elsif (uc($option) eq 'TIMEOUT') - { - # Negotiate the transfer timeout - if ($self->{'_REQUEST_'}{'RFC2347'}{$option} > TFTP_MAX_TIMEOUT or $self->{'_REQUEST_'}{'RFC2347'}{$option} < TFTP_MIN_TIMEOUT) - { - $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'ACKtimeout'}; - } - else - { - $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'_REQUEST_'}{'RFC2347'}{$option}; - $self->{'ACKtimeout'} = $self->{'_REQUEST_'}{'RFC2347'}{$option}; - } - } - else - { - # Negotiate other options... - } - } - - # post processing - if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) - { - if ($self->{'FileSize'} and $self->{'BlkSize'}) - { - $self->{'_REQUEST_'}{'LASTACK'} = int($self->{'FileSize'} / $self->{'BlkSize'}) + 1; - } - } - - # send OACK for RFC 2347 options - return ($self->sendOACK()); - } - else - { - if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) - { - # opcode is WRQ: send ACK for datablock 0 - if ($self->{'_UDPSERVER_'}->send(pack("nn", TFTP_OPCODE_ACK, 0))) - { - return (1); - } - else - { - $! = $self->{'_UDPSERVER_'}->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket SEND error: %s\n", $!; - return (undef); - } - } - else - { - return (1); - } - } -} - - -# -# Usage: $requestOBJ->readFILE(\$data); -# return number of bytes read from file if success or undef if error -# -sub readFILE -{ - my $self = shift; - my $datablk = shift; - - if ($self->{'_REQUEST_'}{'PREVACK'} < $self->{'_REQUEST_'}{'LASTACK'}) - { - # if requested block is next block, read next block and return bytes read - my $fh = $self->{'_REQUEST_'}{'_FH_'}; - # modified for supporting NETASCII transfers on 25/05/2009 - # my $bytes = read ($fh, $$datablk, $self->{'BlkSize'}); - my $bytes = sysread($fh, $$datablk, $self->{'BlkSize'}); - if (defined($bytes)) - { - return ($bytes); - } - else - { - $LASTERROR = sprintf "Error $! reading file '%s'", $self->{'_REQUEST_'}{'FileName'}; - return (undef); - } - } - else - { - # if requested block is last block, return length of last block - return (length($$datablk)); - } -} - - -# -# Usage: $requestOBJ->writeFILE(\$data); -# return number of bytes written to file if success or undef if error -# -sub writeFILE -{ - my $self = shift; - my $datablk = shift; - - if ($self->{'_REQUEST_'}{'PREVBLK'} > $self->{'_REQUEST_'}{'LASTBLK'}) - { - # if last block is < than previous block, return length of last block - return (length($$datablk)); - } - elsif ($self->{'_REQUEST_'}{'LASTBLK'} eq ($self->{'_REQUEST_'}{'PREVBLK'} + 1)) - { - # if block is next block, write next block and return bytes written - my $fh = $self->{'_REQUEST_'}{'_FH_'}; - my $bytes = syswrite($fh, $$datablk); - return ($bytes); - } - else - { - $LASTERROR = sprintf "TFTP Error DATA block %d is out of sequence, expected block was %d", $self->{'_REQUEST_'}{'LASTBLK'}, $self->{'_REQUEST_'}{'PREVBLK'} + 1; - $self->sendERR(5); - return (undef); - } -} - - -# -# Usage: $requestOBJ->sendFILE(); -# return 1 if success or undef if error -# -sub sendFILE -{ - my $self = shift; - - while (1) - { - if ($self->{'_REQUEST_'}{'LASTACK'} < $self->{'_REQUEST_'}{'LASTBLK'}) - { - my $datablk = 0; - if (defined($self->readFILE(\$datablk))) - { - # read from file successful - # increment the transferred bytes counter - $self->{'_REQUEST_'}{'TotalBytes'} += length($datablk); - if ($self->sendDATA(\$datablk)) - { - # send to socket successful - if ($self->{'CallBack'}) - { - &{$self->{'CallBack'}}($self); - } - } - else - { - # error sending to socket - return (undef); - } - } - else - { - # error reading from file - return (undef); - } - } - else - { - # transfer completed - return (1); - } - } -} - - -# -# Usage: $requestOBJ->recvFILE(); -# return 1 if success or undef if error -# -sub recvFILE -{ - my $self = shift; - - $self->{'_REQUEST_'}{'LASTBLK'} = 0; - $self->{'_REQUEST_'}{'PREVBLK'} = 0; - - while (1) - { - my $datablk = 0; - if ($self->recvDATA(\$datablk)) - { - # DATA received - if (defined($self->writeFILE(\$datablk))) - { - # DATA written to file - my $udpserver = $self->{'_UDPSERVER_'}; - - if (defined($udpserver->send(pack("nn", TFTP_OPCODE_ACK, $self->{'_REQUEST_'}{'LASTBLK'})))) - { - # sent ACK - # increment the transferred bytes counter - $self->{'_REQUEST_'}{'TotalBytes'} += length($datablk); - if (length($datablk) < $self->{'BlkSize'}) - { - return (1); - } - else - { - next; - } - } - else - { - $! = $udpserver->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket SEND error: %s\n", $!; - return (undef); - } - } - else - { - # error writing data - return (undef); - } - } - else - { - # timeout waiting for data - return (undef); - } - } -} - -# -# Usage: $requestOBJ->recvDATA(\$data); -# return 1 if success or undef if error -# -sub recvDATA -{ - my $self = shift; - my $datablk = shift; - - my ($datagram, $opcode, $datain); - - my $udpserver = $self->{'_UDPSERVER_'}; - - # vars for IO select - my ($rin, $rout, $ein, $eout) = ('', '', '', ''); - vec($rin, fileno($udpserver), 1) = 1; - - # wait for data - if (select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'})) - { - # read the message - if ($udpserver->recv($datagram, $self->{'BlkSize'} + 4)) - { - # decode the message - ($opcode, $datain) = unpack("na*", $datagram); - if ($opcode eq TFTP_OPCODE_DATA) - { - # message is DATA - $self->{'_REQUEST_'}{'PREVBLK'} = $self->{'_REQUEST_'}{'LASTBLK'}; - ($self->{'_REQUEST_'}{'LASTBLK'}, $$datablk) = unpack("na*", $datain); - - if($self->{'CallBack'}) - { - &{$self->{'CallBack'}}($self); - } - - return (1); - } - elsif ($opcode eq TFTP_OPCODE_ERROR) - { - # message is ERR - $LASTERROR = sprintf "TFTP error message: %s", $datain; - return (undef); - } - else - { - # other messages... - $LASTERROR = sprintf "Opcode %d not supported waiting for DATA\n", $opcode; - return (undef); - } - } - else - { - $! = $udpserver->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket RECV error: %s\n", $!; - return (undef); - } - } - else - { - $LASTERROR = sprintf "Timeout occurred on DATA packet %d\n", $self->{'_REQUEST_'}{'LASTBLK'} + 1; - return (undef); - } -} - - -# -# Usage: $requestOBJ->sendDATA(\$data); -# return 1 if success or undef if error -# -sub sendDATA -{ - my $self = shift; - my $datablk = shift; - - my $udpserver = $self->{'_UDPSERVER_'}; - my $retry = 0; - - my ($datagram, $opcode, $datain); - - while ($retry < $self->{'ACKretries'}) - { - if ($udpserver->send(pack("nna*", TFTP_OPCODE_DATA, $self->{'_REQUEST_'}{'LASTACK'} + 1, $$datablk))) - { - # vars for IO select - my ($rin, $rout, $ein, $eout) = ('', '', '', ''); - vec($rin, fileno($udpserver), 1) = 1; - - # wait for acknowledge - if (select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'})) - { - # read the message - if ($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4)) - { - # decode the message - ($opcode, $datain) = unpack("na*", $datagram); - if ($opcode eq TFTP_OPCODE_ACK) - { - # message is ACK - # modified for supporting more blocks count than 65535, O.Z. 15.08.2007 - $self->{'_REQUEST_'}{'PREVACK'} = $self->{'_REQUEST_'}{'LASTACK'}; - if (int(($self->{'_REQUEST_'}{'LASTACK'}+1) % 65536) == unpack("n", $datain)){ - $self->{'_REQUEST_'}{'LASTACK'}++; - }; - return (1); - } - elsif ($opcode eq TFTP_OPCODE_ERROR) - { - # message is ERR - $LASTERROR = sprintf "TFTP error message: %s", $datain; - return (undef); - } - else - { - # other messages... - $LASTERROR = sprintf "Opcode %d not supported as a reply to DATA\n", $opcode; - return (undef); - } - } - else - { - $! = $udpserver->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket RECV error: %s\n", $!; - return (undef); - } - } - else - { - $LASTERROR = sprintf "Retry %d - timeout occurred on ACK packet %d\n", $retry, $self->{'_REQUEST_'}{'LASTACK'} + 1; - $debug and carp($LASTERROR); - $retry++; - } - } - else - { - $! = $udpserver->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket SEND error: %s\n", $!; - return (undef); - } - } -} - -# -# Usage: $requestOBJ->openFILE() -# returns 1 if file is opened, undef if error -# -sub openFILE -{ - # the request object - my $self = shift; - - if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ) - { - ######################################## - # opcode is RRQ, open file for reading # - ######################################## - if (open(RFH, "<".$self->{'_REQUEST_'}{'FileName'})) - { - # if OCTET mode, set FileHandle to binary mode... - if ($self->{'_REQUEST_'}{'Mode'} eq 'OCTET') - { - binmode(RFH); - } - - my $size = -s($self->{'_REQUEST_'}{'FileName'}); - $self->{'_REQUEST_'}{'LASTBLK'} = 1 + int($size / $self->{'BlkSize'}); - - # save the filehandle reference... - $self->{'_REQUEST_'}{'_FH_'} = *RFH; - - return (1); - } - else - { - $LASTERROR = sprintf "Error opening file \'%s\' for reading\n", $self->{'_REQUEST_'}{'FileName'}; - return (undef); - } - } - elsif ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) - { - ######################################## - # opcode is WRQ, open file for writing # - ######################################## - if (open(WFH, ">".$self->{'_REQUEST_'}{'FileName'})) - { - # if OCTET mode, set FileHandle to binary mode... - if ($self->{'_REQUEST_'}{'Mode'} eq 'OCTET') - { - binmode(WFH); - } - - # save the filehandle reference... - $self->{'_REQUEST_'}{'_FH_'} = *WFH; - - return (1); - } - else - { - $LASTERROR = sprintf "Error opening file \'%s\' for writing\n", $self->{'_REQUEST_'}{'FileName'}; - return (undef); - } - } - else - { - ############################ - # other opcodes are errors # - ############################ - $LASTERROR = sprintf "OPCODE %d is not supported\n", $self->{'_REQUEST_'}{'OPCODE'}; - return (undef); - } -} - -# -# Usage: $requestOBJ->closeFILE() -# returns 1 if file is success, undef if error -# -sub closeFILE -{ - my $self = shift; - - if ($self->{'_REQUEST_'}{'_FH_'}) - { - if (close($self->{'_REQUEST_'}{'_FH_'})) - { - return (1); - } - else - { - $LASTERROR = "Error closing filehandle\n"; - return (undef); - } - } - else - { - return (1); - } -} - -# -# Usage: $requestOBJ->checkFILE() -# returns 1 if file is found, undef if file is not found -# -sub checkFILE -{ - # the request object - my $self = shift; - - # requested file - my $reqfile = $self->{'_REQUEST_'}{'FileName'}; - - if ($self->{'FileName'}) - { - # filename is fixed - $self->{'_REQUEST_'}{'FileName'} = $self->{'FileName'}; - - if (($self->{'FileName'} =~ /$reqfile/) and -e($self->{'FileName'})) - { - # fixed name contains requested file and file exists - $self->{'FileSize'} = -s($self->{'FileName'}); - return (1); - } - } - elsif ($self->{'RootDir'}) - { - # rootdir is fixed - $reqfile = $self->{'RootDir'}.'/'.$reqfile; - $self->{'_REQUEST_'}{'FileName'} = $reqfile; - - if (-e($reqfile)) - { - # file exists in rootdir - $self->{'FileSize'} = -s($reqfile); - return (1); - } - } - - return (undef); -} - -# -# Usage: $requestOBJ->sendOACK(); -# return 1 for success and undef for error (see $Net::TFTPd::LASTERROR for cause) -# -sub sendOACK -{ - # the request object - my $self = shift; - my $udpserver = $self->{'_UDPSERVER_'}; - my $retry = 0; - - my ($datagram, $opcode, $datain); - - while ($retry < $self->{'ACKretries'}) - { - # send oack - my $data = join("\0", %{ $self->{'_RESPONSE_'}{'RFC2347'} })."\0"; - if ($udpserver->send(pack("na*", TFTP_OPCODE_OACK, $data))) - { - # opcode is RRQ - if ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ) - { - # vars for IO select - my ($rin, $rout, $ein, $eout) = ('', '', '', ''); - vec($rin, fileno($udpserver), 1) = 1; - - # wait for acknowledge - if (select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'})) - { - # read the message - if ($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4)) - { - # decode the message - ($opcode, $datain) = unpack("na*", $datagram); - if ($opcode == TFTP_OPCODE_ACK) - { - # message is ACK - my $lastack = unpack("n", $datain); - if ($lastack) - { - # ack is not for block 0... ERROR - $LASTERROR = sprintf "Received ACK for block %d instead of 0", $lastack; - return (undef); - } - return 1; - } - elsif ($opcode == TFTP_OPCODE_ERROR) - { - # message is ERR - $LASTERROR = sprintf "TFTP error message: %s", $datain; - return (undef); - } - else - { - # other messages... - $LASTERROR = sprintf "Opcode %d not supported as a reply to OACK\n", $opcode; - return (undef); - } - } - else - { - $! = $udpserver->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket RECV error: %s\n", $!; - return (undef); - } - } - else - { - $LASTERROR = sprintf "Retry %d - timeout occurred waiting reply for OACK packet\n", $retry; - $debug and carp($LASTERROR); - $retry++; - } - } - elsif ($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ) - { - # opcode is WRQ - return (1); - } - } - else - { - $! = $udpserver->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket SEND error: %s\n", $!; - return (undef); - } - } -} - -# -# Usage: $requestOBJ->sendERR($code, $message); -# returns 1 if success, undef if error -# -sub sendERR -{ - my $self = shift; - my ($errcode, $errmsg) = @_; - # modified for supporting NETASCII transfers on 25/05/2009 - #$errmsg or $errmsg = ''; - $errmsg or $errmsg = $ERRORS{$errcode}; - - my $udpserver = $self->{'_UDPSERVER_'}; - - if ($udpserver->send(pack("nnZ*", 5, $errcode, $errmsg))) - { - return (1); - } - else - { - $! = $udpserver->sockopt(SO_ERROR); - $LASTERROR = sprintf "Socket SEND error: %s\n", $!; - return (undef); - } -} - -sub server -{ - my $self = shift; - return $self->{'_UDPSERVER_'}; -} - -sub error -{ - return ($LASTERROR); -} - -# Preloaded methods go here. - -1; -__END__ - -# Below is stub documentation for your module. You better edit it! - -=head1 NAME - -Net::TFTPd - Perl extension for Trivial File Transfer Protocol Server - -=head1 SYNOPSIS - - use strict; - use Net::TFTPd; - - my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'path/to/files') - or die "Error creating TFTPd listener: %s", Net::TFTPd->error; - - my $tftpRQ = $tftpdOBJ->waitRQ(10) - or die "Error waiting for TFTP request: %s", Net::TFTPd->error; - - $tftpRQ->processRQ() - or die "Error processing TFTP request: %s", Net::TFTPd->error; - - printf "%u bytes has been transferred", $tftpRQ->getTotalBytes() || 0; - -=head1 DESCRIPTION - -C is a class implementing a simple I server in Perl as described in RFC1350. - -C also supports the TFTP Option Extension (as described in RFC2347), with the following options: - - RFC2348 TFTP Blocksize Option - RFC2349 TFTP Timeout Interval and Transfer Size Options - -=head1 EXPORT - -None by default. - -=head2 %OPCODES - -The %OPCODES tag exports the I<%OPCODES> hash: - - %OPCODES = ( - 1 => 'RRQ', - 2 => 'WRQ', - 3 => 'DATA', - 4 => 'ACK', - 5 => 'ERROR', - 6 => 'OACK', - 'RRQ' => 1, - 'WRQ' => 2, - 'DATA' => 3, - 'ACK' => 4, - 'ERROR' => 5, - 'OACK' => 6 - ); - -=head1 Listener constructor - -=head2 new() - - $listener = new Net::TFTPd( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] ); - -or - - $listener = Net::TFTPd->new( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] ); - -Create a new Net::TFTPd object where 'path/to/files' is the default path to file repository -or 'path/to/file' is the single file allowed for download, and OPTIONS are the default server -options. - -Valid options are: - - Option Description Default - ------ ----------- ------- - LocalAddr Interface to bind to (for multi-homed server) any - LocalPort Port to bind server to 69 - Timeout Timeout in seconds to wait for a request 10 - ACKtimeout Timeout in seconds to wait for an ACK packet 4 - ACKretries Maximum number of retries waiting for ACK 4 - Readable Clients are allowed to read files 1 - Writable Clients are allowed to write files 0 - BlkSize Minimum blocksize to negotiate for transfers 512 - CallBack Reference to code executed for each transferred block - - Debug Activates debug mode (verbose) 0 - Family Address family IPv4/IPv6 IPv4 - Valid values for IPv4: - 4, v4, ip4, ipv4, AF_INET (constant) - Valid values for IPv6: - 6, v6, ip6, ipv6, AF_INET6 (constant) - -B: IPv6 requires B. Failback is B -and only IPv4 support. - -=head2 CallBack - -The CallBack code is called by processRQ method for each tranferred block. - -The code receives (into @_ array) a reference to internal I<$request> object. - -Example: - - sub callback - { - my $req = shift; - printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'}; - } - - my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'c:/temp', 'Timeout' => 60, 'CallBack' => \&callback) or die Net::TFTPd->error; - -=head1 Listener methods - -=head2 waitRQ() - - $request = $listener->waitRQ([Timeout]); - -Waits for a client request (RRQ or WRQ) and returns a I<$request> object or I if timed out. - -If I is missing, the timeout defined for I<$listener> object is used instead. - -When the method returns, the program should fork() and process the request invoking processRQ() while the parent process should re-start waiting for another request. - -=head1 Request methods - -=head2 processRQ() - - $ret = $request->processRQ(); - -Processes a request and returns 1 if success, undef if error. - -=head2 getFileName() - - $ret = $request->getFileName(); - -Returns the requested file name. - -=head2 getMode() - - $ret = $request->getMode(); - -Returns the transfer mode for the request. - -=head2 getBlkSize() - - $ret = $request->getBlkSize(); - -Returns the block size used for the transfer. - -=head2 server() - - $ret = $request->server(); - -Return B object for the created server. -All B accessors can then be called. - -=head2 getPeerAddr() - - $ret = $request->getPeerAddr(); - -Returns the address of the requesting client. - -=head2 getPeerPort() - - $ret = $request->getPeerMode(); - -Returns the port of the requesting client. - -=head2 getTotalBytes() - - $ret = $request->getTotalBytes(); - -Returns the number of bytes transferred for the request. - -=head1 CREDITS - -Thanks to Michael Vincent (EVINSWORLDE) for the NETASCII support, transferred bytes and IPv6 patches. - -=head1 AUTHOR - -Luigino Masarati, Elmasarati@hotmail.comE - -=head1 SEE ALSO - -L. - -=cut -