--- /dev/null
+package Net::TFTPd;
+
+use 5.006;
+use Carp;
+use strict;
+use warnings;
+use IO::Socket;
+
+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.04';
+
+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,
+ );
+
+ # bind only to specified address
+ if($cfg{'LocalAddr'})
+ {
+ $params{'LocalAddr'} = $cfg{'LocalAddr'};
+ }
+
+ if(my $udpserver = IO::Socket::INET->new(%params))
+ {
+#removed for using this module with IO v. 1.2301 under SUSE 10.1, O.Z. 15.08.2007
+# $udpserver->setsockopt(SOL_SOCKET, SO_RCVBUF, 0);
+# $udpserver->setsockopt(SOL_SOCKET, SO_SNDBUF, 0);
+
+ 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
+ my($peerport, $peeraddr) = sockaddr_in($udpserver->peername);
+ $request->{'_REQUEST_'}{'PeerPort'} = $peerport;
+ $request->{'_REQUEST_'}{'PeerAddr'} = inet_ntoa($peeraddr);
+
+ # 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(my $udpserver = IO::Socket::INET->new(%params))
+ {
+#removed for using this module with IO v. 1.2301 under SUSE 10.1, O.Z. 15.08.2007
+# $udpserver->setsockopt(SOL_SOCKET, SO_RCVBUF, 0);
+# $udpserver->setsockopt(SOL_SOCKET, SO_SNDBUF, 0);
+
+ $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 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<Net::TFTPd> is a class implementing a simple I<Trivial File Transfer Protocol> server in Perl as described in RFC1350.
+
+C<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
+
+=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
+
+=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<undef> if timed out.
+
+If I<Timeout> 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 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 E<lt>VinceE<gt> for the NETASCII support and transferred bytes patch.
+
+=head1 AUTHOR
+
+Luigino Masarati, E<lt>lmasarati@hotmail.comE<gt>
+
+=head1 SEE ALSO
+
+L<Net::TFTP>.
+
+=cut
+
projects / pxelator / commitdiff