git.rot13.org Git - pxelator/blob - 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