Revision 119

Date:
2009/08/03 08:53:47
Author:
dpavlin
Revision Log:
import Net::TFTPd for local modifications
Files:

Legend:

 
Added
 
Removed
 
Modified

  • lib/Net/TFTPd.pm

     
    1 package Net::TFTPd;
    2
    3 use 5.006;
    4 use Carp;
    5 use strict;
    6 use warnings;
    7 use IO::Socket;
    8
    9 require Exporter;
    10
    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;
    18
    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;
    25
    26 # Type Op # Format without header
    27 #
    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 # -----------------------------------
    36 # 2 bytes 2 bytes
    37 # ----------------------
    38 # ACK | 04 | Block # |
    39 # ----------------------
    40 # 2 bytes 2 bytes string 1 byte
    41 # ------------------------------------------
    42 # ERROR | 05 | ErrorCode | ErrMsg | 0 |
    43 # ------------------------------------------
    44
    45 our %OPCODES = (
    46 1 => 'RRQ',
    47 2 => 'WRQ',
    48 3 => 'DATA',
    49 4 => 'ACK',
    50 5 => 'ERROR',
    51 6 => 'OACK',
    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
    58 );
    59
    60 my %ERRORS = (
    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',
    68 7 => 'No such user',
    69 8 => 'Option negotiation'
    70 );
    71
    72 our @ISA = qw(Exporter);
    73
    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.
    77
    78 # This allows declaration use Net::TFTPd ':all';
    79 # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
    80 # will save memory.
    81 our %EXPORT_TAGS = (
    82 'all' => [ qw( %OPCODES ) ]
    83 );
    84
    85 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
    86
    87 our @EXPORT = qw( );
    88
    89 our $VERSION = '0.04';
    90
    91 our $LASTERROR;
    92
    93 my $debug;
    94
    95 #
    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
    98 #
    99 sub new
    100 {
    101 # create the future TFTPd object
    102 my $self = shift;
    103 my $class = ref($self) || $self;
    104
    105 # read parameters
    106 my %cfg = @_;
    107
    108 # setting defaults
    109 $cfg{'FileName'} or $cfg{'RootDir'} or croak "Usage: \$tftpdOBJ = Net::TFTPd->new(['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, [ LocalPort => portnum ] [, ...]] );";
    110
    111 if($cfg{'RootDir'} and not -d($cfg{'RootDir'}) )
    112 {
    113 $LASTERROR = sprintf 'RootDir \'%s\' not found or is not a valid directory name\n', $cfg{'RootDir'};
    114 return(undef);
    115 }
    116
    117 if($cfg{'FileName'} and not -e($cfg{'FileName'}) )
    118 {
    119 $LASTERROR = sprintf 'FileName \'%s\' not found or is not a valid filename\n', $cfg{'FileName'};
    120 return(undef);
    121 }
    122
    123 my %params = (
    124 'Proto' => 'udp',
    125 'LocalPort' => $cfg{'LocalPort'} || TFTP_DEFAULT_PORT,
    126 );
    127
    128 # bind only to specified address
    129 if($cfg{'LocalAddr'})
    130 {
    131 $params{'LocalAddr'} = $cfg{'LocalAddr'};
    132 }
    133
    134 if(my $udpserver = IO::Socket::INET->new(%params))
    135 {
    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);
    139
    140 return bless {
    141 'LocalPort' => TFTP_DEFAULT_PORT,
    142 'Timeout' => 10,
    143 'ACKtimeout' => 4,
    144 'ACKretries' => 4,
    145 'Readable' => 1,
    146 'Writable' => 0,
    147 'CallBack' => undef,
    148 'BlkSize' => TFTP_DEFAULT_BLKSIZE,
    149 'Debug' => 0,
    150 %cfg, # merge user parameters
    151 '_UDPSERVER_' => $udpserver
    152 }, $class;
    153 }
    154 else
    155 {
    156 $LASTERROR = "Error opening socket for listener: $@\n";
    157 return(undef);
    158 }
    159 }
    160
    161 #
    162 # Usage: $tftpdOBJ->waitRQ($timeout);
    163 # return requestOBJ if success, 0 if $timeout elapsed, undef if error
    164 #
    165 sub waitRQ
    166 {
    167 # the tftpd object
    168 # my $tftpd = shift;
    169
    170 my $self = shift;
    171 my $class = ref($self) || $self;
    172 # return bless {}, $class;
    173
    174 # clone the object
    175 my $request;
    176 foreach my $key (keys(%{$self}))
    177 {
    178 # everything but '_xxx_'
    179 $key =~ /^\_.+\_$/ and next;
    180 $request->{$key} = $self->{$key};
    181 }
    182
    183 # use $timeout or default from $tftpdOBJ
    184 my $Timeout = shift || $request->{'Timeout'};
    185
    186 my $udpserver = $self->{'_UDPSERVER_'};
    187
    188 my ($datagram, $opcode, $datain);
    189
    190 # vars for IO select
    191 my ($rin, $rout, $ein, $eout) = ('', '', '', '');
    192 vec($rin, fileno($udpserver), 1) = 1;
    193
    194 # check if a message is waiting
    195 if (select($rout=$rin, undef, $eout=$ein, $Timeout))
    196 {
    197 # read the message
    198 if($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4))
    199 {
    200 # decode the message
    201 ($opcode, $datain) = unpack("na*", $datagram);
    202
    203 $request->{'_REQUEST_'}{'OPCODE'} = $opcode;
    204
    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);
    209
    210 # get filename and transfer mode
    211 my @datain = split("\0", $datain);
    212
    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;
    220
    221 if(scalar(@datain) >= 2)
    222 {
    223 $request->{'_REQUEST_'}{'RFC2347'} = { @datain };
    224 }
    225
    226 return bless $request, $class;
    227 }
    228 else
    229 {
    230 $! = $udpserver->sockopt(SO_ERROR);
    231 $LASTERROR = sprintf "Socket RECV error: %s\n", $!;
    232 return(undef);
    233 }
    234 }
    235 else
    236 {
    237 $LASTERROR = "Timed out waiting for RRQ/WRQ";
    238 return(0);
    239 }
    240 }
    241
    242 #
    243 # Usage: $requestOBJ->processRQ();
    244 # return 1 if success, undef if error
    245 #
    246 sub processRQ
    247 {
    248 # the request object
    249 my $self = shift;
    250
    251 if(defined($self->newSOCK()))
    252 {
    253 # modified for supporting NETASCII transfers on 25/05/2009
    254 if(($self->{'_REQUEST_'}{'Mode'} ne 'OCTET') && ($self->{'_REQUEST_'}{'Mode'} ne 'NETASCII'))
    255 {
    256 #request is not OCTET
    257 $LASTERROR = sprintf "%s transfer mode is not supported\n", $self->{'_REQUEST_'}{'Mode'};
    258 $self->sendERR(0, $LASTERROR);
    259 return(undef);
    260 }
    261
    262 # new socket opened successfully
    263 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ)
    264 {
    265 #################
    266 # opcode is RRQ #
    267 #################
    268 if($self->{'Readable'})
    269 {
    270 # read is permitted
    271 if($self->{'_REQUEST_'}{'FileName'} =~ /\.\.[\\\/]/)
    272 {
    273 # requested file contains '..\' or '../'
    274 $LASTERROR = sprintf 'Access to \'%s\' is not permitted to %s', $self->{'_REQUEST_'}{'FileName'}, $self->{'_REQUEST_'}{'PeerAddr'};
    275 $self->sendERR(2);
    276 return(undef);
    277 }
    278
    279 if(defined($self->checkFILE()))
    280 {
    281 # file is present
    282 if(defined($self->negotiateOPTS()))
    283 {
    284 # RFC 2347 options negotiated
    285 if(defined($self->openFILE()))
    286 {
    287 # file opened for read, start the transfer
    288 if(defined($self->sendFILE()))
    289 {
    290 # file sent successfully
    291 return(1);
    292 }
    293 else
    294 {
    295 # error sending file
    296 return(undef);
    297 }
    298 }
    299 else
    300 {
    301 # error opening file
    302 return(undef);
    303 }
    304 }
    305 else
    306 {
    307 # error negotiating options
    308 $LASTERROR = "TFTP error 8: Option negotiation\n";
    309 $self->sendERR(8);
    310 return(undef);
    311 }
    312 }
    313 else
    314 {
    315 # file not found
    316 $LASTERROR = sprintf 'File \'%s\' not found', $self->{'_REQUEST_'}{'FileName'};
    317 $self->sendERR(1);
    318 return(undef);
    319 }
    320 }
    321 else
    322 {
    323 # if server is not readable
    324 $LASTERROR = "TFTP Error: Access violation";
    325 $self->sendERR(2);
    326 return(undef);
    327 }
    328 }
    329 elsif($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
    330 {
    331 #################
    332 # opcode is WRQ #
    333 #################
    334 if($self->{'Writable'})
    335 {
    336 # write is permitted
    337 if($self->{'_REQUEST_'}{'FileName'} =~ /\.\.[\\\/]/)
    338 {
    339 # requested file contains '..\' or '../'
    340 $LASTERROR = sprintf 'Access to \'%s\' is not permitted to %s', $self->{'_REQUEST_'}{'FileName'}, $self->{'_REQUEST_'}{'PeerAddr'};
    341 $self->sendERR(2);
    342 return(undef);
    343 }
    344
    345 if(!defined($self->checkFILE()))
    346 {
    347 # RFC 2347 options negotiated
    348 if(defined($self->openFILE()))
    349 {
    350 # file is not present
    351 if(defined($self->negotiateOPTS()))
    352 {
    353 # file opened for write, start the transfer
    354 if(defined($self->recvFILE()))
    355 {
    356 # file received successfully
    357 return(1);
    358 }
    359 else
    360 {
    361 # error receiving file
    362 return(undef);
    363 }
    364 }
    365 else
    366 {
    367 # error negotiating options
    368 $LASTERROR = "TFTP error 8: Option negotiation\n";
    369 $self->sendERR(8);
    370 return(undef);
    371 }
    372 }
    373 else
    374 {
    375 # error opening file
    376 $self->sendERR(3);
    377 return(undef);
    378 }
    379 }
    380 else
    381 {
    382 # file not found
    383 $LASTERROR = sprintf 'File \'%s\' already exists', $self->{'_REQUEST_'}{'FileName'};
    384 $self->sendERR(6);
    385 return(undef);
    386 }
    387 }
    388 else
    389 {
    390 # if server is not writable
    391 $LASTERROR = "TFTP Error: Access violation";
    392 $self->sendERR(2);
    393 return(undef);
    394 }
    395 }
    396 else
    397 {
    398 #################
    399 # other opcodes #
    400 #################
    401 $LASTERROR = sprintf "Opcode %d not supported as request", $self->{'_REQUEST_'}{'OPCODE'};
    402 $self->sendERR(4);
    403 return(undef);
    404 }
    405 }
    406 else
    407 {
    408 return(undef);
    409 }
    410 }
    411
    412 #
    413 # Usage: $requestOBJ->getTotalBytes();
    414 # returns the number of bytes transferred by the request
    415 #
    416 sub getTotalBytes
    417 {
    418 # the request object
    419 my $self = shift;
    420
    421 return $self->{'_REQUEST_'}{'TotalBytes'};
    422 }
    423
    424 #
    425 # Usage: $requestOBJ->getFileName();
    426 # returns the requested file name
    427 #
    428 sub getFileName
    429 {
    430 # the request object
    431 my $self = shift;
    432
    433 return $self->{'_REQUEST_'}{'FileName'};
    434 }
    435
    436 #
    437 # Usage: $requestOBJ->getMode();
    438 # returns the transfer mode for the request
    439 #
    440 sub getMode
    441 {
    442 # the request object
    443 my $self = shift;
    444
    445 return $self->{'_REQUEST_'}{'Mode'};
    446 }
    447
    448 #
    449 # Usage: $requestOBJ->getPeerAddr();
    450 # returns the address of the requesting client
    451 #
    452 sub getPeerAddr
    453 {
    454 # the request object
    455 my $self = shift;
    456
    457 return $self->{'_REQUEST_'}{'PeerAddr'};
    458 }
    459
    460 #
    461 # Usage: $requestOBJ->getPeerPort();
    462 # returns the port of the requesting client
    463 #
    464 sub getPeerPort
    465 {
    466 # the request object
    467 my $self = shift;
    468
    469 return $self->{'_REQUEST_'}{'PeerPort'};
    470 }
    471
    472 #
    473 # Usage: $requestOBJ->getBlkSize();
    474 # returns the block size used for the transfer
    475 #
    476 sub getBlkSize
    477 {
    478 # the request object
    479 my $self = shift;
    480
    481 return $self->{'_REQUEST_'}{'BlkSize'};
    482 }
    483
    484 #
    485 # Usage: $requestOBJ->newSOCK();
    486 # return 1 if success or undef if error
    487 #
    488 sub newSOCK
    489 {
    490 # the request object
    491 my $self = shift;
    492
    493 # set parameters for the new socket
    494 my %params = (
    495 'Proto' => 'udp',
    496 'PeerPort' => $self->{'_REQUEST_'}{'PeerPort'},
    497 'PeerAddr' => $self->{'_REQUEST_'}{'PeerAddr'}
    498 );
    499
    500 # bind only to specified address
    501 if($self->{'Address'})
    502 {
    503 $params{'LocalAddr'} = $self->{'Address'};
    504 }
    505
    506 # open socket
    507 if(my $udpserver = IO::Socket::INET->new(%params))
    508 {
    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);
    512
    513 $self->{'_UDPSERVER_'} = $udpserver;
    514 return(1);
    515 }
    516 else
    517 {
    518 $LASTERROR = "Error opening socket for reply: $@\n";
    519 return(undef);
    520 }
    521 }
    522
    523
    524 #
    525 # Usage: $requestOBJ->negotiateOPTS();
    526 # return 1 if success or undef if error
    527 #
    528 sub negotiateOPTS
    529 {
    530 # the request object
    531 my $self = shift;
    532
    533 if($self->{'_REQUEST_'}{'RFC2347'})
    534 {
    535 # parse RFC 2347 options if present
    536 foreach my $option (keys(%{ $self->{'_REQUEST_'}{'RFC2347'} }))
    537 {
    538 if(uc($option) eq 'BLKSIZE')
    539 {
    540 # Negotiate the blocksize
    541 if($self->{'_REQUEST_'}{'RFC2347'}{$option} > TFTP_MAX_BLKSIZE or $self->{'_REQUEST_'}{'RFC2347'}{$option} < TFTP_MIN_BLKSIZE)
    542 {
    543 $self->{'_REQUEST_'}{'RFC2347'}{$option} = $self->{'BlkSize'};
    544 }
    545 else
    546 {
    547 $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'_REQUEST_'}{'RFC2347'}{$option};
    548 $self->{'BlkSize'} = $self->{'_RESPONSE_'}{'RFC2347'}{$option};
    549 }
    550 }
    551 elsif(uc($option) eq 'TSIZE')
    552 {
    553 # Negotiate the transfer size
    554 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ)
    555 {
    556 $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'FileSize'};
    557 }
    558 else
    559 {
    560 $self->{'FileSize'} = $self->{'_REQUEST_'}{'RFC2347'}{$option};
    561 }
    562 }
    563 elsif(uc($option) eq 'TIMEOUT')
    564 {
    565 # Negotiate the transfer timeout
    566 if($self->{'_REQUEST_'}{'RFC2347'}{$option} > TFTP_MAX_TIMEOUT or $self->{'_REQUEST_'}{'RFC2347'}{$option} < TFTP_MIN_TIMEOUT)
    567 {
    568 $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'ACKtimeout'};
    569 }
    570 else
    571 {
    572 $self->{'_RESPONSE_'}{'RFC2347'}{$option} = $self->{'_REQUEST_'}{'RFC2347'}{$option};
    573 $self->{'ACKtimeout'} = $self->{'_REQUEST_'}{'RFC2347'}{$option};
    574 }
    575 }
    576 else
    577 {
    578 # Negotiate other options...
    579 }
    580 }
    581
    582 # post processing
    583 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
    584 {
    585 if($self->{'FileSize'} and $self->{'BlkSize'})
    586 {
    587 $self->{'_REQUEST_'}{'LASTACK'} = int($self->{'FileSize'} / $self->{'BlkSize'}) + 1;
    588 }
    589 }
    590
    591 # send OACK for RFC 2347 options
    592 return($self->sendOACK());
    593 }
    594 else
    595 {
    596 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
    597 {
    598 # opcode is WRQ: send ACK for datablock 0
    599 if($self->{'_UDPSERVER_'}->send(pack("nn", TFTP_OPCODE_ACK, 0)))
    600 {
    601 return(1);
    602 }
    603 else
    604 {
    605 $! = $self->{'_UDPSERVER_'}->sockopt(SO_ERROR);
    606 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
    607 return(undef);
    608 }
    609 }
    610 else
    611 {
    612 return(1);
    613 }
    614 }
    615 }
    616
    617
    618 #
    619 # Usage: $requestOBJ->readFILE(\$data);
    620 # return number of bytes read from file if success or undef if error
    621 #
    622 sub readFILE
    623 {
    624 my $self = shift;
    625 my $datablk = shift;
    626
    627 if($self->{'_REQUEST_'}{'PREVACK'} < $self->{'_REQUEST_'}{'LASTACK'})
    628 {
    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'});
    634 if(defined($bytes))
    635 {
    636 return($bytes);
    637 }
    638 else
    639 {
    640 $LASTERROR = sprintf "Error $! reading file '%s'", $self->{'_REQUEST_'}{'FileName'};
    641 return(undef);
    642 }
    643 }
    644 else
    645 {
    646 # if requested block is last block, return length of last block
    647 return(length($$datablk));
    648 }
    649 }
    650
    651
    652 #
    653 # Usage: $requestOBJ->writeFILE(\$data);
    654 # return number of bytes written to file if success or undef if error
    655 #
    656 sub writeFILE
    657 {
    658 my $self = shift;
    659 my $datablk = shift;
    660
    661 if($self->{'_REQUEST_'}{'PREVBLK'} > $self->{'_REQUEST_'}{'LASTBLK'})
    662 {
    663 # if last block is < than previous block, return length of last block
    664 return(length($$datablk));
    665 }
    666 elsif($self->{'_REQUEST_'}{'LASTBLK'} eq ($self->{'_REQUEST_'}{'PREVBLK'} + 1))
    667 {
    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);
    671 return($bytes);
    672 }
    673 else
    674 {
    675 $LASTERROR = sprintf "TFTP Error DATA block %d is out of sequence, expected block was %d", $self->{'_REQUEST_'}{'LASTBLK'}, $self->{'_REQUEST_'}{'PREVBLK'} + 1;
    676 $self->sendERR(5);
    677 return(undef);
    678 }
    679 }
    680
    681
    682 #
    683 # Usage: $requestOBJ->sendFILE();
    684 # return 1 if success or undef if error
    685 #
    686 sub sendFILE
    687 {
    688 my $self = shift;
    689
    690 while(1)
    691 {
    692 if($self->{'_REQUEST_'}{'LASTACK'} < $self->{'_REQUEST_'}{'LASTBLK'})
    693 {
    694 my $datablk = 0;
    695 if(defined($self->readFILE(\$datablk)))
    696 {
    697 # read from file successful
    698 # increment the transferred bytes counter
    699 $self->{'_REQUEST_'}{'TotalBytes'} += length($datablk);
    700 if($self->sendDATA(\$datablk))
    701 {
    702 # send to socket successful
    703 if($self->{'CallBack'})
    704 {
    705 &{$self->{'CallBack'}}($self);
    706 }
    707 }
    708 else
    709 {
    710 # error sending to socket
    711 return(undef);
    712 }
    713 }
    714 else
    715 {
    716 # error reading from file
    717 return(undef);
    718 }
    719 }
    720 else
    721 {
    722 # transfer completed
    723 return(1);
    724 }
    725 }
    726 }
    727
    728
    729 #
    730 # Usage: $requestOBJ->recvFILE();
    731 # return 1 if success or undef if error
    732 #
    733 sub recvFILE
    734 {
    735 my $self = shift;
    736
    737 $self->{'_REQUEST_'}{'LASTBLK'} = 0;
    738 $self->{'_REQUEST_'}{'PREVBLK'} = 0;
    739
    740 while(1)
    741 {
    742 my $datablk = 0;
    743 if($self->recvDATA(\$datablk))
    744 {
    745 # DATA received
    746 if(defined($self->writeFILE(\$datablk)))
    747 {
    748 # DATA written to file
    749 my $udpserver = $self->{'_UDPSERVER_'};
    750
    751 if(defined($udpserver->send(pack("nn", TFTP_OPCODE_ACK, $self->{'_REQUEST_'}{'LASTBLK'}))))
    752 {
    753 # sent ACK
    754 # increment the transferred bytes counter
    755 $self->{'_REQUEST_'}{'TotalBytes'} += length($datablk);
    756 if(length($datablk) < $self->{'BlkSize'})
    757 {
    758 return(1);
    759 }
    760 else
    761 {
    762 next;
    763 }
    764 }
    765 else
    766 {
    767 $! = $udpserver->sockopt(SO_ERROR);
    768 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
    769 return(undef);
    770 }
    771 }
    772 else
    773 {
    774 # error writing data
    775 return(undef);
    776 }
    777 }
    778 else
    779 {
    780 # timeout waiting for data
    781 return(undef);
    782 }
    783 }
    784 }
    785
    786 #
    787 # Usage: $requestOBJ->recvDATA(\$data);
    788 # return 1 if success or undef if error
    789 #
    790 sub recvDATA
    791 {
    792 my $self = shift;
    793 my $datablk = shift;
    794
    795 my ($datagram, $opcode, $datain);
    796
    797 my $udpserver = $self->{'_UDPSERVER_'};
    798
    799 # vars for IO select
    800 my ($rin, $rout, $ein, $eout) = ('', '', '', '');
    801 vec($rin, fileno($udpserver), 1) = 1;
    802
    803 # wait for data
    804 if(select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'}))
    805 {
    806 # read the message
    807 if($udpserver->recv($datagram, $self->{'BlkSize'} + 4))
    808 {
    809 # decode the message
    810 ($opcode, $datain) = unpack("na*", $datagram);
    811 if($opcode eq TFTP_OPCODE_DATA)
    812 {
    813 # message is DATA
    814 $self->{'_REQUEST_'}{'PREVBLK'} = $self->{'_REQUEST_'}{'LASTBLK'};
    815 ($self->{'_REQUEST_'}{'LASTBLK'}, $$datablk) = unpack("na*", $datain);
    816
    817 if($self->{'CallBack'})
    818 {
    819 &{$self->{'CallBack'}}($self);
    820 }
    821
    822 return(1);
    823 }
    824 elsif($opcode eq TFTP_OPCODE_ERROR)
    825 {
    826 # message is ERR
    827 $LASTERROR = sprintf "TFTP error message: %s", $datain;
    828 return(undef);
    829 }
    830 else
    831 {
    832 # other messages...
    833 $LASTERROR = sprintf "Opcode %d not supported waiting for DATA\n", $opcode;
    834 return(undef);
    835 }
    836 }
    837 else
    838 {
    839 $! = $udpserver->sockopt(SO_ERROR);
    840 $LASTERROR = sprintf "Socket RECV error: %s\n", $!;
    841 return(undef);
    842 }
    843 }
    844 else
    845 {
    846 $LASTERROR = sprintf "Timeout occurred on DATA packet %d\n", $self->{'_REQUEST_'}{'LASTBLK'} + 1;
    847 return(undef);
    848 }
    849 }
    850
    851
    852 #
    853 # Usage: $requestOBJ->sendDATA(\$data);
    854 # return 1 if success or undef if error
    855 #
    856 sub sendDATA
    857 {
    858 my $self = shift;
    859 my $datablk = shift;
    860
    861 my $udpserver = $self->{'_UDPSERVER_'};
    862 my $retry = 0;
    863
    864 my ($datagram, $opcode, $datain);
    865
    866 while($retry < $self->{'ACKretries'})
    867 {
    868 if($udpserver->send(pack("nna*", TFTP_OPCODE_DATA, $self->{'_REQUEST_'}{'LASTACK'} + 1, $$datablk)))
    869 {
    870 # vars for IO select
    871 my ($rin, $rout, $ein, $eout) = ('', '', '', '');
    872 vec($rin, fileno($udpserver), 1) = 1;
    873
    874 # wait for acknowledge
    875 if(select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'}))
    876 {
    877 # read the message
    878 if($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4))
    879 {
    880 # decode the message
    881 ($opcode, $datain) = unpack("na*", $datagram);
    882 if($opcode eq TFTP_OPCODE_ACK)
    883 {
    884 # message is 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'}++;
    889 };
    890 return(1);
    891 }
    892 elsif($opcode eq TFTP_OPCODE_ERROR)
    893 {
    894 # message is ERR
    895 $LASTERROR = sprintf "TFTP error message: %s", $datain;
    896 return(undef);
    897 }
    898 else
    899 {
    900 # other messages...
    901 $LASTERROR = sprintf "Opcode %d not supported as a reply to DATA\n", $opcode;
    902 return(undef);
    903 }
    904 }
    905 else
    906 {
    907 $! = $udpserver->sockopt(SO_ERROR);
    908 $LASTERROR = sprintf "Socket RECV error: %s\n", $!;
    909 return(undef);
    910 }
    911 }
    912 else
    913 {
    914 $LASTERROR = sprintf "Retry %d - timeout occurred on ACK packet %d\n", $retry, $self->{'_REQUEST_'}{'LASTACK'} + 1;
    915 $debug and carp($LASTERROR);
    916 $retry++;
    917 }
    918 }
    919 else
    920 {
    921 $! = $udpserver->sockopt(SO_ERROR);
    922 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
    923 return(undef);
    924 }
    925 }
    926 }
    927
    928 #
    929 # Usage: $requestOBJ->openFILE()
    930 # returns 1 if file is opened, undef if error
    931 #
    932 sub openFILE
    933 {
    934 # the request object
    935 my $self = shift;
    936
    937 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ)
    938 {
    939 ########################################
    940 # opcode is RRQ, open file for reading #
    941 ########################################
    942 if(open(RFH, "<".$self->{'_REQUEST_'}{'FileName'}))
    943 {
    944 # if OCTET mode, set FileHandle to binary mode...
    945 if($self->{'_REQUEST_'}{'Mode'} eq 'OCTET')
    946 {
    947 binmode(RFH);
    948 }
    949
    950 my $size = -s($self->{'_REQUEST_'}{'FileName'});
    951 $self->{'_REQUEST_'}{'LASTBLK'} = 1 + int($size / $self->{'BlkSize'});
    952
    953 # save the filehandle reference...
    954 $self->{'_REQUEST_'}{'_FH_'} = *RFH;
    955
    956 return(1);
    957 }
    958 else
    959 {
    960 $LASTERROR = sprintf "Error opening file \'%s\' for reading\n", $self->{'_REQUEST_'}{'FileName'};
    961 return(undef);
    962 }
    963 }
    964 elsif($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
    965 {
    966 ########################################
    967 # opcode is WRQ, open file for writing #
    968 ########################################
    969 if(open(WFH, ">".$self->{'_REQUEST_'}{'FileName'}))
    970 {
    971 # if OCTET mode, set FileHandle to binary mode...
    972 if($self->{'_REQUEST_'}{'Mode'} eq 'OCTET')
    973 {
    974 binmode(WFH);
    975 }
    976
    977 # save the filehandle reference...
    978 $self->{'_REQUEST_'}{'_FH_'} = *WFH;
    979
    980 return(1);
    981 }
    982 else
    983 {
    984 $LASTERROR = sprintf "Error opening file \'%s\' for writing\n", $self->{'_REQUEST_'}{'FileName'};
    985 return(undef);
    986 }
    987 }
    988 else
    989 {
    990 ############################
    991 # other opcodes are errors #
    992 ############################
    993 $LASTERROR = sprintf "OPCODE %d is not supported\n", $self->{'_REQUEST_'}{'OPCODE'};
    994 return(undef);
    995 }
    996 }
    997
    998 #
    999 # Usage: $requestOBJ->closeFILE()
    1000 # returns 1 if file is success, undef if error
    1001 #
    1002 sub closeFILE
    1003 {
    1004 my $self = shift;
    1005
    1006 if($self->{'_REQUEST_'}{'_FH_'})
    1007 {
    1008 if(close($self->{'_REQUEST_'}{'_FH_'}))
    1009 {
    1010 return(1);
    1011 }
    1012 else
    1013 {
    1014 $LASTERROR = "Error closing filehandle\n";
    1015 return(undef);
    1016 }
    1017 }
    1018 else
    1019 {
    1020 return(1);
    1021 }
    1022 }
    1023
    1024 #
    1025 # Usage: $requestOBJ->checkFILE()
    1026 # returns 1 if file is found, undef if file is not found
    1027 #
    1028 sub checkFILE
    1029 {
    1030 # the request object
    1031 my $self = shift;
    1032
    1033 # requested file
    1034 my $reqfile = $self->{'_REQUEST_'}{'FileName'};
    1035
    1036 if($self->{'FileName'})
    1037 {
    1038 # filename is fixed
    1039 $self->{'_REQUEST_'}{'FileName'} = $self->{'FileName'};
    1040
    1041 if(($self->{'FileName'} =~ /$reqfile/) and -e($self->{'FileName'}))
    1042 {
    1043 # fixed name contains requested file and file exists
    1044 $self->{'FileSize'} = -s($self->{'FileName'});
    1045 return(1);
    1046 }
    1047 }
    1048 elsif($self->{'RootDir'})
    1049 {
    1050 # rootdir is fixed
    1051 $reqfile = $self->{'RootDir'}.'/'.$reqfile;
    1052 $self->{'_REQUEST_'}{'FileName'} = $reqfile;
    1053
    1054 if(-e($reqfile))
    1055 {
    1056 # file exists in rootdir
    1057 $self->{'FileSize'} = -s($reqfile);
    1058 return(1);
    1059 }
    1060 }
    1061
    1062 return(undef);
    1063 }
    1064
    1065 #
    1066 # Usage: $requestOBJ->sendOACK();
    1067 # return 1 for success and undef for error (see $Net::TFTPd::LASTERROR for cause)
    1068 #
    1069 sub sendOACK
    1070 {
    1071 # the request object
    1072 my $self = shift;
    1073 my $udpserver = $self->{'_UDPSERVER_'};
    1074 my $retry = 0;
    1075
    1076 my ($datagram, $opcode, $datain);
    1077
    1078 while($retry < $self->{'ACKretries'})
    1079 {
    1080 # send oack
    1081 my $data = join("\0", %{ $self->{'_RESPONSE_'}{'RFC2347'} })."\0";
    1082 if($udpserver->send(pack("na*", TFTP_OPCODE_OACK, $data)))
    1083 {
    1084 # opcode is RRQ
    1085 if($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_RRQ)
    1086 {
    1087 # vars for IO select
    1088 my ($rin, $rout, $ein, $eout) = ('', '', '', '');
    1089 vec($rin, fileno($udpserver), 1) = 1;
    1090
    1091 # wait for acknowledge
    1092 if(select($rout=$rin, undef, $eout=$ein, $self->{'ACKtimeout'}))
    1093 {
    1094 # read the message
    1095 if($udpserver->recv($datagram, TFTP_MAX_BLKSIZE + 4))
    1096 {
    1097 # decode the message
    1098 ($opcode, $datain) = unpack("na*", $datagram);
    1099 if($opcode == TFTP_OPCODE_ACK)
    1100 {
    1101 # message is ACK
    1102 my $lastack = unpack("n", $datain);
    1103 if($lastack)
    1104 {
    1105 # ack is not for block 0... ERROR
    1106 $LASTERROR = sprintf "Received ACK for block %d instead of 0", $lastack;
    1107 return(undef);
    1108 }
    1109 return 1;
    1110 }
    1111 elsif($opcode == TFTP_OPCODE_ERROR)
    1112 {
    1113 # message is ERR
    1114 $LASTERROR = sprintf "TFTP error message: %s", $datain;
    1115 return(undef);
    1116 }
    1117 else
    1118 {
    1119 # other messages...
    1120 $LASTERROR = sprintf "Opcode %d not supported as a reply to OACK\n", $opcode;
    1121 return(undef);
    1122 }
    1123 }
    1124 else
    1125 {
    1126 $! = $udpserver->sockopt(SO_ERROR);
    1127 $LASTERROR = sprintf "Socket RECV error: %s\n", $!;
    1128 return (undef);
    1129 }
    1130 }
    1131 else
    1132 {
    1133 $LASTERROR = sprintf "Retry %d - timeout occurred waiting reply for OACK packet\n", $retry;
    1134 $debug and carp($LASTERROR);
    1135 $retry++;
    1136 }
    1137 }
    1138 elsif($self->{'_REQUEST_'}{'OPCODE'} eq TFTP_OPCODE_WRQ)
    1139 {
    1140 # opcode is WRQ
    1141 return(1);
    1142 }
    1143 }
    1144 else
    1145 {
    1146 $! = $udpserver->sockopt(SO_ERROR);
    1147 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
    1148 return(undef);
    1149 }
    1150 }
    1151 }
    1152
    1153 #
    1154 # Usage: $requestOBJ->sendERR($code, $message);
    1155 # returns 1 if success, undef if error
    1156 #
    1157 sub sendERR
    1158 {
    1159 my $self = shift;
    1160 my($errcode, $errmsg) = @_;
    1161 # modified for supporting NETASCII transfers on 25/05/2009
    1162 #$errmsg or $errmsg = '';
    1163 $errmsg or $errmsg = $ERRORS{$errcode};
    1164
    1165 my $udpserver = $self->{'_UDPSERVER_'};
    1166
    1167 if($udpserver->send(pack("nnZ*", 5, $errcode, $errmsg)))
    1168 {
    1169 return(1);
    1170 }
    1171 else
    1172 {
    1173 $! = $udpserver->sockopt(SO_ERROR);
    1174 $LASTERROR = sprintf "Socket SEND error: %s\n", $!;
    1175 return(undef);
    1176 }
    1177 }
    1178
    1179 sub error
    1180 {
    1181 return($LASTERROR);
    1182 }
    1183
    1184 # Preloaded methods go here.
    1185
    1186 1;
    1187 __END__
    1188
    1189 # Below is stub documentation for your module. You better edit it!
    1190
    1191 =head1 NAME
    1192
    1193 Net::TFTPd - Perl extension for Trivial File Transfer Protocol Server
    1194
    1195 =head1 SYNOPSIS
    1196
    1197 use strict;
    1198 use Net::TFTPd;
    1199
    1200 my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'path/to/files')
    1201 or die "Error creating TFTPd listener: %s", Net::TFTPd->error;
    1202
    1203 my $tftpRQ = $tftpdOBJ->waitRQ(10)
    1204 or die "Error waiting for TFTP request: %s", Net::TFTPd->error;
    1205
    1206 $tftpRQ->processRQ()
    1207 or die "Error processing TFTP request: %s", Net::TFTPd->error;
    1208
    1209 printf "%u bytes has been transferred", $tftpRQ->getTotalBytes() || 0;
    1210
    1211 =head1 DESCRIPTION
    1212
    1213 C<Net::TFTPd> is a class implementing a simple I<Trivial File Transfer Protocol> server in Perl as described in RFC1350.
    1214
    1215 C<Net::TFTPd> also supports the TFTP Option Extension (as described in RFC2347), with the following options:
    1216
    1217 RFC2348 TFTP Blocksize Option
    1218 RFC2349 TFTP Timeout Interval and Transfer Size Options
    1219
    1220 =head1 EXPORT
    1221
    1222 None by default.
    1223
    1224 =head2 %OPCODES
    1225
    1226 The %OPCODES tag exports the I<%OPCODES> hash:
    1227
    1228 %OPCODES = (
    1229 1 => 'RRQ',
    1230 2 => 'WRQ',
    1231 3 => 'DATA',
    1232 4 => 'ACK',
    1233 5 => 'ERROR',
    1234 6 => 'OACK',
    1235 'RRQ' => 1,
    1236 'WRQ' => 2,
    1237 'DATA' => 3,
    1238 'ACK' => 4,
    1239 'ERROR' => 5,
    1240 'OACK' => 6
    1241 );
    1242
    1243 =head1 Listener constructor
    1244
    1245 =head2 new()
    1246
    1247 $listener = new Net::TFTPd( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] );
    1248
    1249 or
    1250
    1251 $listener = Net::TFTPd->new( ['RootDir' => 'path/to/files' | 'FileName' => 'path/to/file'] [, OPTIONS ] );
    1252
    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
    1255 options.
    1256
    1257 Valid options are:
    1258
    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
    1271
    1272 =head2 CallBack
    1273
    1274 The CallBack code is called by processRQ method for each tranferred block.
    1275
    1276 The code receives (into @_ array) a reference to internal I<$request> object.
    1277
    1278 Example:
    1279
    1280 sub callback
    1281 {
    1282 my $req = shift;
    1283 printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'};
    1284 }
    1285
    1286 my $tftpdOBJ = Net::TFTPd->new('RootDir' => 'c:/temp', 'Timeout' => 60, 'CallBack' => \&callback) or die Net::TFTPd->error;
    1287
    1288 =head1 Listener methods
    1289
    1290 =head2 waitRQ()
    1291
    1292 $request = $listener->waitRQ([Timeout]);
    1293
    1294 Waits for a client request (RRQ or WRQ) and returns a I<$request> object or I<undef> if timed out.
    1295
    1296 If I<Timeout> is missing, the timeout defined for I<$listener> object is used instead.
    1297
    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.
    1299
    1300 =head1 Request methods
    1301
    1302 =head2 processRQ()
    1303
    1304 $ret = $request->processRQ();
    1305
    1306 Processes a request and returns 1 if success, undef if error.
    1307
    1308 =head2 getFileName()
    1309
    1310 $ret = $request->getFileName();
    1311
    1312 Returns the requested file name.
    1313
    1314 =head2 getMode()
    1315
    1316 $ret = $request->getMode();
    1317
    1318 Returns the transfer mode for the request.
    1319
    1320 =head2 getBlkSize()
    1321
    1322 $ret = $request->getBlkSize();
    1323
    1324 Returns the block size used for the transfer.
    1325
    1326 =head2 getPeerAddr()
    1327
    1328 $ret = $request->getPeerAddr();
    1329
    1330 Returns the address of the requesting client.
    1331
    1332 =head2 getPeerPort()
    1333
    1334 $ret = $request->getPeerMode();
    1335
    1336 Returns the port of the requesting client.
    1337
    1338 =head2 getTotalBytes()
    1339
    1340 $ret = $request->getTotalBytes();
    1341
    1342 Returns the number of bytes transferred for the request.
    1343
    1344 =head1 CREDITS
    1345
    1346 Thanks to E<lt>VinceE<gt> for the NETASCII support and transferred bytes patch.
    1347
    1348 =head1 AUTHOR
    1349
    1350 Luigino Masarati, E<lt>lmasarati@hotmail.comE<gt>
    1351
    1352 =head1 SEE ALSO
    1353
    1354 L<Net::TFTP>.
    1355
    1356 =cut
    1357