libnet-tftpd-perl 0.10-1 / usr / share / perl5 / Net / TFTPd.pm

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.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<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
  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<NOTE>:  IPv6 requires B<IO::Socket::IP>.  Failback is B<IO::Socket::INET> 
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<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 server()

  $ret = $request->server();

Return B<IO::Socket::*> object for the created server.  
All B<IO::Socket::*> 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 (E<lt>VINSWORLDE<gt>) for the NETASCII support, transferred bytes and IPv6 patches.

=head1 AUTHOR

Luigino Masarati, E<lt>lmasarati@hotmail.comE<gt>

=head1 SEE ALSO

L<Net::TFTP>.

=cut