Net-TFTPd-0.10/0000755000000000000000000000000012742453026011602 5ustar rootrootNet-TFTPd-0.10/t/0000755000000000000000000000000012742453021012040 5ustar rootrootNet-TFTPd-0.10/t/03-test-pod.t0000644000000000000000000000023512502673310014203 0ustar rootrooteval "use Test::Pod 1.00"; if ($@) { use Test; plan(tests => 1); skip("Test::Pod 1.00 required for testing"); } else { all_pod_files_ok(); } Net-TFTPd-0.10/t/00-Net-TFTPd.t0000644000000000000000000000024312502673341014111 0ustar rootroot#!/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. ######################### Net-TFTPd-0.10/Changes0000644000000000000000000000317212742452412013076 0ustar rootrootRevision history for Perl extension Net::TFTPD. 0.10 Fri Jul 16 20:30:00 2016 - Added V6Only feature to pass to IO::Socket::IP. 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.08 Wed Mar 18 16:30:00 2015 - Fixed v6Only tag when selecting IPv6 to account for Windows issues. 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 - support for NETASCII transfer mode - added $request->getTotalBytes() method to retrieve the number of bytes transferred for the request - added various other request methods 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.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 Net-TFTPd-0.10/bin/0000755000000000000000000000000012742453021012345 5ustar rootrootNet-TFTPd-0.10/bin/tftpd-simple.pl0000644000000000000000000000670312502676650015331 0ustar rootroot#!/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 Net-TFTPd-0.10/bin/simpleTFTPd.pl0000644000000000000000000000300212035501534015026 0ustar rootroot#!/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; } Net-TFTPd-0.10/META.json0000644000000000000000000000161312742453026013224 0ustar rootroot{ "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.10" } Net-TFTPd-0.10/MANIFEST0000644000000000000000000000044012502673567012741 0ustar rootrootChanges Makefile.PL MANIFEST README 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) Net-TFTPd-0.10/README0000644000000000000000000000047112502673366012471 0ustar rootrootNet/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. Net-TFTPd-0.10/Makefile.PL0000644000000000000000000000131112502672452013550 0ustar rootrootuse ExtUtils::MakeMaker; # 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 => '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 => 'lib/Net/TFTPd.pm', # retrieve abstract from module AUTHOR => 'Luigino Masarati ') : ()), ); Net-TFTPd-0.10/lib/0000755000000000000000000000000012742453021012343 5ustar rootrootNet-TFTPd-0.10/lib/Net/0000755000000000000000000000000012742453021013071 5ustar rootrootNet-TFTPd-0.10/lib/Net/TFTPd.pm0000644000000000000000000010160412742452654014365 0ustar rootrootpackage 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.10'; 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; } if (defined($cfg{'V6Only'})) { if (!$HAVE_IO_Socket_IP) { $LASTERROR = "IO::Socket::IP required for V6Only"; return (undef); } $params{'V6Only'} = $cfg{'V6Only'}; } # 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) V6Only Enable / disable v6only (see IO::Socket::IP) 1 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 Net-TFTPd-0.10/META.yml0000644000000000000000000000102112742453023013042 0ustar rootroot--- 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.10