11 # modified for supporting small block sizes, O.Z. 15.08.2007
12 use constant TFTP_MIN_BLKSIZE => 8;
13 use constant TFTP_DEFAULT_BLKSIZE => 512;
14 use constant TFTP_MAX_BLKSIZE => 65464;
15 use constant TFTP_MIN_TIMEOUT => 1;
16 use constant TFTP_MAX_TIMEOUT => 60;
17 use constant TFTP_DEFAULT_PORT => 69;
19 use constant TFTP_OPCODE_RRQ => 1;
20 use constant TFTP_OPCODE_WRQ => 2;
21 use constant TFTP_OPCODE_DATA => 3;
22 use constant TFTP_OPCODE_ACK => 4;
23 use constant TFTP_OPCODE_ERROR => 5;
24 use constant TFTP_OPCODE_OACK => 6;
26 # Type Op # Format without header
28 # 2 bytes string 1 byte string 1 byte
29 # -------------------------------------------------
30 # RRQ/ | 01/02 | Filename | 0 | Mode | 0 |
31 # WRQ -------------------------------------------------
32 # 2 bytes 2 bytes n bytes
33 # -----------------------------------
34 # DATA | 03 | Block # | Data |
35 # -----------------------------------
37 # ----------------------
38 # ACK | 04 | Block # |
39 # ----------------------
40 # 2 bytes 2 bytes string 1 byte
41 # ------------------------------------------
42 # ERROR | 05 | ErrorCode | ErrMsg | 0 |
43 # ------------------------------------------
52 'RRQ' => TFTP_OPCODE_RRQ,
53 'WRQ' => TFTP_OPCODE_WRQ,
54 'DATA' => TFTP_OPCODE_DATA,
55 'ACK' => TFTP_OPCODE_ACK,
56 'ERROR' => TFTP_OPCODE_ERROR,
57 'OACK' => TFTP_OPCODE_OACK
61 0 => 'Not defined, see error message (if any)',
62 1 => 'File not found',
63 2 => 'Access violation',
64 3 => 'Disk full or allocation exceeded',
65 4 => 'Illegal TFTP operation',
66 5 => 'Unknown transfer ID',
67 6 => 'File already exists',
69 8 => 'Option negotiation'
72 our @ISA = qw(Exporter);
74 # Items to export into callers namespace by default. Note: do not export
75 # names by default without a very good reason. Use EXPORT_OK instead.
76 # Do not simply export all your public functions/methods/constants.
78 # This allows declaration use Net::TFTPd ':all';
79 # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
82 'all' => [ qw( %OPCODES ) ]
85 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
89 our $VERSION = '0.04';
96 # Usage: $tftpdOBJ = Net::TFTPd->new( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] );
97 # return the tftpdOBJ object if success or undef if error
101 # create the future TFTPd object
103 my $class = ref($self) || $self;
109 $cfg{'FileName'} or $cfg{'RootDir'} or croak "Usage: \$tftpdOBJ = Net::TFTPd->new(['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, [ LocalPort => portnum ] [, ...]] );";
111 if($cfg{'RootDir'} and not -d($cfg{'RootDir'}) )
113 $LASTERROR = sprintf 'RootDir \'%s\' not found or is not a valid directory name\n', $cfg{'RootDir'};
117 if($cfg{'FileName'} and not -e($cfg{'FileName'}) )
119 $LASTERROR = sprintf 'FileName \'%s\' not found or is not a valid filename\n', $cfg{'FileName'};
125 'LocalPort' => $cfg{'LocalPort'} || TFTP_DEFAULT_PORT,
128 # bind only to specified address
129 if($cfg{'LocalAddr'})
131 $params{'LocalAddr'} = $cfg{'LocalAddr'};
134 if(my $udpserver = IO::Socket::INET->new(%params))
136 #removed for using this module with IO v. 1.2301 under SUSE 10.1, O.Z. 15.08.2007
137 # $udpserver->setsockopt(SOL_SOCKET, SO_RCVBUF, 0);
138 # $udpserver->setsockopt(SOL_SOCKET, SO_SNDBUF, 0);
141 'LocalPort' => TFTP_DEFAULT_PORT,
148 'BlkSize' => TFTP_DEFAULT_BLKSIZE,
150 %cfg, # merge user parameters
151 '_UDPSERVER_' => $udpserver
156 $LASTERROR = "Error opening socket for listener: $@\n";
162 # Usage: $tftpdOBJ->waitRQ($timeout);
163 # return requestOBJ if success, 0 if $timeout elapsed, undef if error
171 my $class = ref($self) || $self;
172 # return bless {}, $class;
176 foreach my $key (keys(%{$self}))
178 # everything but '_xxx_'
179 $key =~ /^\_.+\_$/ and next;
180 $request->{$key} = $self->{$key};
183 # use $timeout or default from $tftpdOBJ
184 my $Timeout = shift || $request->{'Timeout'};
186 my $udpserver = $self->{'_UDPSERVER_'};
188 my ($datagram, $opcode, $datain);
191 my ($rin, $rout, $ein, $eout) = ('', '', '', '');
192 vec($rin, fileno($udpserver), 1) = 1;
194 # check if a message is waiting
195 if (select($rout=$rin, undef, $eout=$ein, $Timeout))
198 if($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4))
201 ($opcode, $datain) = unpack("na*", $datagram);
203 $request->{'_REQUEST_'}{'OPCODE'} = $opcode;
205 # get peer port and address
206 my($peerport, $peeraddr) = sockaddr_in($udpserver->peername);
207 $request->{'_REQUEST_'}{'PeerPort'} = $peerport;
208 $request->{'_REQUEST_'}{'PeerAddr'} = inet_ntoa($peeraddr);
210 # get filename and transfer mode
211 my @datain = split("\0", $datain);
213 $request->{'_REQUEST_'}{'FileName'} = shift(@datain);
214 $request->{'_REQUEST_'}{'Mode'} = uc(shift(@datain));
215 $request->{'_REQUEST_'}{'BlkSize'} = TFTP_DEFAULT_BLKSIZE;
216 $request->{'_REQUEST_'}{'LASTACK'} = 0;
217 $request->{'_REQUEST_'}{'PREVACK'} = -1;
218 # counter for transferred bytes
219 $request->{'_REQUEST_'}{'TotalBytes'} = 0;
221 if(scalar(@datain) >= 2)
223 $request->{'_REQUEST_'}{'RFC2347'} = { @datain };
226 return bless $request, $class;
230 $! = $udpserver->sockopt(SO_ERROR);
231 $LASTERROR = sprintf "Socket RECV error: %s\n", $!;
237 $LASTERROR = "Timed out waiting for RRQ/WRQ";
243 # Usage: $requestOBJ->processRQ();
244 # return 1 if success, undef if error
251 if(defined($self->newSOCK()))
253 # modified for supporting NETASCII transfers on 25/05/2009
254 if(($self->{'_REQUEST_'}{'Mode'} ne 'OCTET') && ($self->{'_REQUEST_'}{'Mode'} ne 'NETASCII'))
256 #request is not OCTET
257 $LASTERROR = sprintf "%s transfer mode is not supported\n", $self->{'_REQUEST_'}{'Mode'};
258 $self->sendERR(0, $LASTERROR);
262 # new socket opened successfully
263 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ)
268 if($self->{'Readable'})
271 if($self->{'_REQUEST_'}{'FileName'} =~ /\.\.[\\\/]/)
273 # requested file contains '..\' or '../'
274 $LASTERROR = sprintf 'Access to \'%s\' is not permitted to %s', $self->{'_REQUEST_'}{'FileName'}, $self->{'_REQUEST_'}{'PeerAddr'};
279 if(defined($self->checkFILE()))
282 if(defined($self->negotiateOPTS()))
284 # RFC 2347 options negotiated
285 if(defined($self->openFILE()))
287 # file opened for read, start the transfer
288 if(defined($self->sendFILE()))
290 # file sent successfully
307 # error negotiating options
308 $LASTERROR = "TFTP error 8: Option negotiation\n";
316 $LASTERROR = sprintf 'File \'%s\' not found', $self->{'_REQUEST_'}{'FileName'};
323 # if server is not readable
324 $LASTERROR = "TFTP Error: Access violation";
329 elsif($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
334 if($self->{'Writable'})
337 if($self->{'_REQUEST_'}{'FileName'} =~ /\.\.[\\\/]/)
339 # requested file contains '..\' or '../'
340 $LASTERROR = sprintf 'Access to \'%s\' is not permitted to %s', $self->{'_REQUEST_'}{'FileName'}, $self->{'_REQUEST_'}{'PeerAddr'};
345 if(!defined($self->checkFILE()))
347 # RFC 2347 options negotiated
348 if(defined($self->openFILE()))
350 # file is not present
351 if(defined($self->negotiateOPTS()))
353 # file opened for write, start the transfer
354 if(defined($self->recvFILE()))
356 # file received successfully
361 # error receiving file
367 # error negotiating options
368 $LASTERROR = "TFTP error 8: Option negotiation\n";
383 $LASTERROR = sprintf 'File \'%s\' already exists', $self->{'_REQUEST_'}{'FileName'};
390 # if server is not writable
391 $LASTERROR = "TFTP Error: Access violation";
401 $LASTERROR = sprintf "Opcode %d not supported as request", $self->{'_REQUEST_'}{'OPCODE'};
413 # Usage: $requestOBJ->getTotalBytes();
414 # returns the number of bytes transferred by the request
421 return $self->{'_REQUEST_'}{'TotalBytes'};
425 # Usage: $requestOBJ->getFileName();
426 # returns the requested file name
433 return $self->{'_REQUEST_'}{'FileName'};
437 # Usage: $requestOBJ->getMode();
438 # returns the transfer mode for the request
445 return $self->{'_REQUEST_'}{'Mode'};
449 # Usage: $requestOBJ->getPeerAddr();
450 # returns the address of the requesting client
457 return $self->{'_REQUEST_'}{'PeerAddr'};
461 # Usage: $requestOBJ->getPeerPort();
462 # returns the port of the requesting client
469 return $self->{'_REQUEST_'}{'PeerPort'};
473 # Usage: $requestOBJ->getBlkSize();
474 # returns the block size used for the transfer
481 return $self->{'_REQUEST_'}{'BlkSize'};
485 # Usage: $requestOBJ->newSOCK();
486 # return 1 if success or undef if error
493 # set parameters for the new socket
496 'PeerPort' => $self->{'_REQUEST_'}{'PeerPort'},
497 'PeerAddr' => $self->{'_REQUEST_'}{'PeerAddr'}
500 # bind only to specified address
501 if($self->{'Address'})
503 $params{'LocalAddr'} = $self->{'Address'};
507 if(my $udpserver = IO::Socket::INET->new(%params))
509 #removed for using this module with IO v. 1.2301 under SUSE 10.1, O.Z. 15.08.2007
510 # $udpserver->setsockopt(SOL_SOCKET, SO_RCVBUF, 0);
511 # $udpserver->setsockopt(SOL_SOCKET, SO_SNDBUF, 0);
513 $self->{'_UDPSERVER_'} = $udpserver;
518 $LASTERROR = "Error opening socket for reply: $@\n";
525 # Usage: $requestOBJ->negotiateOPTS();
526 # return 1 if success or undef if error
533 if($self->{'_REQUEST_'}{'RFC2347'})
535 # parse RFC 2347 options if present
536 foreach my $option (keys(%{ $self->{'_REQUEST_'}{'RFC2347'} }))
538 if(uc($option) eq 'BLKSIZE')
540 # Negotiate the blocksize
541 if($self->{'_REQUEST_'}{'RFC2347'}{$option} > TFTP_MAX_BLKSIZE or $self->{'_REQUEST_'}{'RFC2347'}{$option} < TFTP_MIN_BLKSIZE)
543 $self->{'_REQUEST_'}{'RFC2347'}{$option} = $self->{'BlkSize'};
547 $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'_REQUEST_'}{'RFC2347'}{$option};
548 $self->{'BlkSize'} = $self->{'_RESPONSE_'}{'RFC2347'}{$option};
551 elsif(uc($option) eq 'TSIZE')
553 # Negotiate the transfer size
554 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ)
556 $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'FileSize'};
560 $self->{'FileSize'} = $self->{'_REQUEST_'}{'RFC2347'}{$option};
563 elsif(uc($option) eq 'TIMEOUT')
565 # Negotiate the transfer timeout
566 if($self->{'_REQUEST_'}{'RFC2347'}{$option} > TFTP_MAX_TIMEOUT or $self->{'_REQUEST_'}{'RFC2347'}{$option} < TFTP_MIN_TIMEOUT)
568 $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'ACKtimeout'};
572 $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'_REQUEST_'}{'RFC2347'}{$option};
573 $self->{'ACKtimeout'} = $self->{'_REQUEST_'}{'RFC2347'}{$option};
578 # Negotiate other options...
583 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
585 if($self->{'FileSize'} and $self->{'BlkSize'})
587 $self->{'_REQUEST_'}{'LASTACK'} = int($self->{'FileSize'} / $self->{'BlkSize'}) + 1;
591 # send OACK for RFC 2347 options
592 return($self->sendOACK());
596 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
598 # opcode is WRQ: send ACK for datablock 0
599 if($self->{'_UDPSERVER_'}->send(pack("nn", TFTP_OPCODE_ACK, 0)))
605 $! = $self->{'_UDPSERVER_'}->sockopt(SO_ERROR);
606 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
619 # Usage: $requestOBJ->readFILE(\$data);
620 # return number of bytes read from file if success or undef if error
627 if($self->{'_REQUEST_'}{'PREVACK'} < $self->{'_REQUEST_'}{'LASTACK'})
629 # if requested block is next block, read next block and return bytes read
630 my $fh = $self->{'_REQUEST_'}{'_FH_'};
631 # modified for supporting NETASCII transfers on 25/05/2009
632 # my $bytes = read($fh, $$datablk, $self->{'BlkSize'});
633 my $bytes = sysread($fh, $$datablk, $self->{'BlkSize'});
640 $LASTERROR = sprintf "Error $! reading file '%s'", $self->{'_REQUEST_'}{'FileName'};
646 # if requested block is last block, return length of last block
647 return(length($$datablk));
653 # Usage: $requestOBJ->writeFILE(\$data);
654 # return number of bytes written to file if success or undef if error
661 if($self->{'_REQUEST_'}{'PREVBLK'} > $self->{'_REQUEST_'}{'LASTBLK'})
663 # if last block is < than previous block, return length of last block
664 return(length($$datablk));
666 elsif($self->{'_REQUEST_'}{'LASTBLK'} eq ($self->{'_REQUEST_'}{'PREVBLK'} + 1))
668 # if block is next block, write next block and return bytes written
669 my $fh = $self->{'_REQUEST_'}{'_FH_'};
670 my $bytes = syswrite($fh, $$datablk);
675 $LASTERROR = sprintf "TFTP Error DATA block %d is out of sequence, expected block was %d", $self->{'_REQUEST_'}{'LASTBLK'}, $self->{'_REQUEST_'}{'PREVBLK'} + 1;
683 # Usage: $requestOBJ->sendFILE();
684 # return 1 if success or undef if error
692 if($self->{'_REQUEST_'}{'LASTACK'} < $self->{'_REQUEST_'}{'LASTBLK'})
695 if(defined($self->readFILE(\$datablk)))
697 # read from file successful
698 # increment the transferred bytes counter
699 $self->{'_REQUEST_'}{'TotalBytes'} += length($datablk);
700 if($self->sendDATA(\$datablk))
702 # send to socket successful
703 if($self->{'CallBack'})
705 &{$self->{'CallBack'}}($self);
710 # error sending to socket
716 # error reading from file
730 # Usage: $requestOBJ->recvFILE();
731 # return 1 if success or undef if error
737 $self->{'_REQUEST_'}{'LASTBLK'} = 0;
738 $self->{'_REQUEST_'}{'PREVBLK'} = 0;
743 if($self->recvDATA(\$datablk))
746 if(defined($self->writeFILE(\$datablk)))
748 # DATA written to file
749 my $udpserver = $self->{'_UDPSERVER_'};
751 if(defined($udpserver->send(pack("nn", TFTP_OPCODE_ACK, $self->{'_REQUEST_'}{'LASTBLK'}))))
754 # increment the transferred bytes counter
755 $self->{'_REQUEST_'}{'TotalBytes'} += length($datablk);
756 if(length($datablk) < $self->{'BlkSize'})
767 $! = $udpserver->sockopt(SO_ERROR);
768 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
780 # timeout waiting for data
787 # Usage: $requestOBJ->recvDATA(\$data);
788 # return 1 if success or undef if error
795 my ($datagram, $opcode, $datain);
797 my $udpserver = $self->{'_UDPSERVER_'};
800 my ($rin, $rout, $ein, $eout) = ('', '', '', '');
801 vec($rin, fileno($udpserver), 1) = 1;
804 if(select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'}))
807 if($udpserver->recv($datagram, $self->{'BlkSize'} + 4))
810 ($opcode, $datain) = unpack("na*", $datagram);
811 if($opcode eq TFTP_OPCODE_DATA)
814 $self->{'_REQUEST_'}{'PREVBLK'} = $self->{'_REQUEST_'}{'LASTBLK'};
815 ($self->{'_REQUEST_'}{'LASTBLK'}, $$datablk) = unpack("na*", $datain);
817 if($self->{'CallBack'})
819 &{$self->{'CallBack'}}($self);
824 elsif($opcode eq TFTP_OPCODE_ERROR)
827 $LASTERROR = sprintf "TFTP error message: %s", $datain;
833 $LASTERROR = sprintf "Opcode %d not supported waiting for DATA\n", $opcode;
839 $! = $udpserver->sockopt(SO_ERROR);
840 $LASTERROR = sprintf "Socket RECV error: %s\n", $!;
846 $LASTERROR = sprintf "Timeout occurred on DATA packet %d\n", $self->{'_REQUEST_'}{'LASTBLK'} + 1;
853 # Usage: $requestOBJ->sendDATA(\$data);
854 # return 1 if success or undef if error
861 my $udpserver = $self->{'_UDPSERVER_'};
864 my ($datagram, $opcode, $datain);
866 while($retry < $self->{'ACKretries'})
868 if($udpserver->send(pack("nna*", TFTP_OPCODE_DATA, $self->{'_REQUEST_'}{'LASTACK'} + 1, $$datablk)))
871 my ($rin, $rout, $ein, $eout) = ('', '', '', '');
872 vec($rin, fileno($udpserver), 1) = 1;
874 # wait for acknowledge
875 if(select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'}))
878 if($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4))
881 ($opcode, $datain) = unpack("na*", $datagram);
882 if($opcode eq TFTP_OPCODE_ACK)
885 # modified for supporting more blocks count than 65535, O.Z. 15.08.2007
886 $self->{'_REQUEST_'}{'PREVACK'} = $self->{'_REQUEST_'}{'LASTACK'};
887 if(int(($self->{'_REQUEST_'}{'LASTACK'}+1) % 65536) == unpack("n", $datain)){
888 $self->{'_REQUEST_'}{'LASTACK'}++;
892 elsif($opcode eq TFTP_OPCODE_ERROR)
895 $LASTERROR = sprintf "TFTP error message: %s", $datain;
901 $LASTERROR = sprintf "Opcode %d not supported as a reply to DATA\n", $opcode;
907 $! = $udpserver->sockopt(SO_ERROR);
908 $LASTERROR = sprintf "Socket RECV error: %s\n", $!;
914 $LASTERROR = sprintf "Retry %d - timeout occurred on ACK packet %d\n", $retry, $self->{'_REQUEST_'}{'LASTACK'} + 1;
915 $debug and carp($LASTERROR);
921 $! = $udpserver->sockopt(SO_ERROR);
922 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
929 # Usage: $requestOBJ->openFILE()
930 # returns 1 if file is opened, undef if error
937 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ)
939 ########################################
940 # opcode is RRQ, open file for reading #
941 ########################################
942 if(open(RFH, "<".$self->{'_REQUEST_'}{'FileName'}))
944 # if OCTET mode, set FileHandle to binary mode...
945 if($self->{'_REQUEST_'}{'Mode'} eq 'OCTET')
950 my $size = -s($self->{'_REQUEST_'}{'FileName'});
951 $self->{'_REQUEST_'}{'LASTBLK'} = 1 + int($size / $self->{'BlkSize'});
953 # save the filehandle reference...
954 $self->{'_REQUEST_'}{'_FH_'} = *RFH;
960 $LASTERROR = sprintf "Error opening file \'%s\' for reading\n", $self->{'_REQUEST_'}{'FileName'};
964 elsif($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
966 ########################################
967 # opcode is WRQ, open file for writing #
968 ########################################
969 if(open(WFH, ">".$self->{'_REQUEST_'}{'FileName'}))
971 # if OCTET mode, set FileHandle to binary mode...
972 if($self->{'_REQUEST_'}{'Mode'} eq 'OCTET')
977 # save the filehandle reference...
978 $self->{'_REQUEST_'}{'_FH_'} = *WFH;
984 $LASTERROR = sprintf "Error opening file \'%s\' for writing\n", $self->{'_REQUEST_'}{'FileName'};
990 ############################
991 # other opcodes are errors #
992 ############################
993 $LASTERROR = sprintf "OPCODE %d is not supported\n", $self->{'_REQUEST_'}{'OPCODE'};
999 # Usage: $requestOBJ->closeFILE()
1000 # returns 1 if file is success, undef if error
1006 if($self->{'_REQUEST_'}{'_FH_'})
1008 if(close($self->{'_REQUEST_'}{'_FH_'}))
1014 $LASTERROR = "Error closing filehandle\n";
1025 # Usage: $requestOBJ->checkFILE()
1026 # returns 1 if file is found, undef if file is not found
1030 # the request object
1034 my $reqfile = $self->{'_REQUEST_'}{'FileName'};
1036 if($self->{'FileName'})
1039 $self->{'_REQUEST_'}{'FileName'} = $self->{'FileName'};
1041 if(($self->{'FileName'} =~ /$reqfile/) and -e($self->{'FileName'}))
1043 # fixed name contains requested file and file exists
1044 $self->{'FileSize'} = -s($self->{'FileName'});
1048 elsif($self->{'RootDir'})
1051 $reqfile = $self->{'RootDir'}.'/'.$reqfile;
1052 $self->{'_REQUEST_'}{'FileName'} = $reqfile;
1056 # file exists in rootdir
1057 $self->{'FileSize'} = -s($reqfile);
1066 # Usage: $requestOBJ->sendOACK();
1067 # return 1 for success and undef for error (see $Net::TFTPd::LASTERROR for cause)
1071 # the request object
1073 my $udpserver = $self->{'_UDPSERVER_'};
1076 my ($datagram, $opcode, $datain);
1078 while($retry < $self->{'ACKretries'})
1081 my $data = join("\0", %{ $self->{'_RESPONSE_'}{'RFC2347'} })."\0";
1082 if($udpserver->send(pack("na*", TFTP_OPCODE_OACK, $data)))
1085 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ)
1087 # vars for IO select
1088 my ($rin, $rout, $ein, $eout) = ('', '', '', '');
1089 vec($rin, fileno($udpserver), 1) = 1;
1091 # wait for acknowledge
1092 if(select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'}))
1095 if($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4))
1097 # decode the message
1098 ($opcode, $datain) = unpack("na*", $datagram);
1099 if($opcode == TFTP_OPCODE_ACK)
1102 my $lastack = unpack("n", $datain);
1105 # ack is not for block 0... ERROR
1106 $LASTERROR = sprintf "Received ACK for block %d instead of 0", $lastack;
1111 elsif($opcode == TFTP_OPCODE_ERROR)
1114 $LASTERROR = sprintf "TFTP error message: %s", $datain;
1120 $LASTERROR = sprintf "Opcode %d not supported as a reply to OACK\n", $opcode;
1126 $! = $udpserver->sockopt(SO_ERROR);
1127 $LASTERROR = sprintf "Socket RECV error: %s\n", $!;
1133 $LASTERROR = sprintf "Retry %d - timeout occurred waiting reply for OACK packet\n", $retry;
1134 $debug and carp($LASTERROR);
1138 elsif($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
1146 $! = $udpserver->sockopt(SO_ERROR);
1147 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
1154 # Usage: $requestOBJ->sendERR($code, $message);
1155 # returns 1 if success, undef if error
1160 my($errcode, $errmsg) = @_;
1161 # modified for supporting NETASCII transfers on 25/05/2009
1162 #$errmsg or $errmsg = '';
1163 $errmsg or $errmsg = $ERRORS{$errcode};
1165 my $udpserver = $self->{'_UDPSERVER_'};
1167 if($udpserver->send(pack("nnZ*", 5, $errcode, $errmsg)))
1173 $! = $udpserver->sockopt(SO_ERROR);
1174 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
1184 # Preloaded methods go here.
1189 # Below is stub documentation for your module. You better edit it!
1193 Net::TFTPd - Perl extension for Trivial File Transfer Protocol Server
1200 my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'path/to/files')
1201 or die "Error creating TFTPd listener: %s", Net::TFTPd->error;
1203 my $tftpRQ = $tftpdOBJ->waitRQ(10)
1204 or die "Error waiting for TFTP request: %s", Net::TFTPd->error;
1206 $tftpRQ->processRQ()
1207 or die "Error processing TFTP request: %s", Net::TFTPd->error;
1209 printf "%u bytes has been transferred", $tftpRQ->getTotalBytes() || 0;
1213 C<Net::TFTPd> is a class implementing a simple I<Trivial File Transfer Protocol> server in Perl as described in RFC1350.
1215 C<Net::TFTPd> also supports the TFTP Option Extension (as described in RFC2347), with the following options:
1217 RFC2348 TFTP Blocksize Option
1218 RFC2349 TFTP Timeout Interval and Transfer Size Options
1226 The %OPCODES tag exports the I<%OPCODES> hash:
1243 =head1 Listener constructor
1247 $listener = new Net::TFTPd( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] );
1251 $listener = Net::TFTPd->new( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] );
1253 Create a new Net::TFTPd object where 'path/to/files' is the default path to file repository
1254 or 'path/to/file' is the single file allowed for download, and OPTIONS are the default server
1259 Option Description Default
1260 ------ ----------- -------
1261 LocalAddr Interface to bind to (for multi-homed server) any
1262 LocalPort Port to bind server to 69
1263 Timeout Timeout in seconds to wait for a request 10
1264 ACKtimeout Timeout in seconds to wait for an ACK packet 4
1265 ACKretries Maximum number of retries waiting for ACK 4
1266 Readable Clients are allowed to read files 1
1267 Writable Clients are allowed to write files 0
1268 BlkSize Minimum blocksize to negotiate for transfers 512
1269 CallBack Reference to code executed for each transferred block -
1270 Debug Activates debug mode (verbose) 0
1274 The CallBack code is called by processRQ method for each tranferred block.
1276 The code receives (into @_ array) a reference to internal I<$request> object.
1283 printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'};
1286 my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'c:/temp', 'Timeout' => 60, 'CallBack' => \&callback) or die Net::TFTPd->error;
1288 =head1 Listener methods
1292 $request = $listener->waitRQ([Timeout]);
1294 Waits for a client request (RRQ or WRQ) and returns a I<$request> object or I<undef> if timed out.
1296 If I<Timeout> is missing, the timeout defined for I<$listener> object is used instead.
1298 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.
1300 =head1 Request methods
1304 $ret = $request->processRQ();
1306 Processes a request and returns 1 if success, undef if error.
1308 =head2 getFileName()
1310 $ret = $request->getFileName();
1312 Returns the requested file name.
1316 $ret = $request->getMode();
1318 Returns the transfer mode for the request.
1322 $ret = $request->getBlkSize();
1324 Returns the block size used for the transfer.
1326 =head2 getPeerAddr()
1328 $ret = $request->getPeerAddr();
1330 Returns the address of the requesting client.
1332 =head2 getPeerPort()
1334 $ret = $request->getPeerMode();
1336 Returns the port of the requesting client.
1338 =head2 getTotalBytes()
1340 $ret = $request->getTotalBytes();
1342 Returns the number of bytes transferred for the request.
1346 Thanks to E<lt>VinceE<gt> for the NETASCII support and transferred bytes patch.
1350 Luigino Masarati, E<lt>lmasarati@hotmail.comE<gt>