TFTP - TFTP Client class

    use TFTP;

    $tftp = new TFTP("some.host.name");
    $tftp->get("that.file");
    $tftp->octet;
    $tftp->put("this.file");
    $tftp->quit;

# TFTP.pm
#
# Copyright (c) 1998 G. S. Marzot <gmarzot@baynetworks.com>.
# All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#

package TFTP;

require 5.001;

use strict;
use vars qw(@ISA $VERSION);

use Socket 1.3;
use Time::localtime;

$VERSION = 1.00;

my $TftpPort = 69;

my $RRQ = 1;
my $WRQ = 2;
my $DATA = 3;
my $ACK = 4;
my $ERR = 5;
my @OPS = ('NA','RRQ','WRQ','DATA','ACK','ERR');

my $ErrUndef = 0;
my $ErrFileNotFound = 1;
my $ErrAccessViolation = 2;
my $ErrDiskFull = 3;
my $ErrIllegalOperation = 4;
my $ErrUnknownPort = 5;
my $ErrFileExists = 6;
my $ErrNoSuchUser = 7;

my $ModeNetAscii = 'NETASCII';
my $ModeOctet = 'OCTET';
my $ModeMail = 'MAIL';
my %decode = ("\012" => "\012", "\0" => "\015");
my %encode = ("\012" => "\012", "\015" => "\0");

my $TftpDataSize = 512;
my $TftpBufSize = $TftpDataSize + 4;

my $Timeout = 2;
my $MaxTimeout = 8;
my $Retries = 3;

sub new
{
    my $pkg  = shift;
    my $peer = shift;
    my %arg = @_;
    my $tftp = {};

    socket(SOCKET, PF_INET, SOCK_DGRAM, getprotobyname('udp')) or
	$tftp->{errstr} = "Could not create socket:$!\n", return undef;
    $tftp->{'sock'} = \*SOCKET;

    $tftp->{'host'} = $peer || 'localhost'; # Remote hostname
    $tftp->{'port'} = $arg{Port} || $TftpPort; # Remote port
    $tftp->{'mode'} = $arg{Mode} || $ModeNetAscii;
    $tftp->{'timeout'} = $arg{Timeout} || $Timeout;
    $tftp->{'max_timeout'} = $arg{MaxTimeout} || $MaxTimeout;
    $tftp->{'retries'} = $arg{Retries} || $Retries;
    $tftp->{'errstr'} = '';
    $tftp->{'debug'}= $arg{Debug};
    bless($tftp,$pkg);
}

sub DESTROY { shift->quit }

sub timeout
{
    my $self = shift;
    my $retry = shift;
    my $timeout = $self->{'timeout'};

    $timeout *= ($retry+1);
    return ($timeout > $MaxTimeout ? $MaxTimeout : $timeout);
}

##
## User interface methods
##

sub netascii  { shift->mode($ModeNetAscii); }
sub ascii  { shift->mode($ModeNetAscii); }
sub octet { shift->mode($ModeOctet); }
sub binary { shift->mode($ModeOctet); }

sub mode
{
    my $tftp = shift;
    my $mode = shift;
    my $oldval = $tftp->{'mode'};

    $tftp->{'mode'} = $mode if defined $mode;

    $oldval;
}

sub get
{
    my($tftp,$remote,$local) = @_;
    my($loc,$inlen,$inbuf,$outlen,$outbuf,$data,$lastcr);
    my($rin,$rout,$eout,$remote_iaddr,$remote_paddr,$last_paddr,$port,$host);
    my($count, $op, $block, $expected_block, $retry, $err);
    local *FD;
    # setup and open local file if needed
    if (ref($local)) {
	$loc = $local;
    } else {
	($local = $remote) =~ s!.*/!! unless defined $local;
	unless (open(FD,">$local")) {
	    $tftp->{'errstr'} = "Cannot open local file:$local:$!\n";
	    return undef;
	}
	$loc = \*FD;
    }
    # set binary mode if needed
    my $mode = $tftp->mode;
    if ($mode eq $ModeOctet and !binmode($loc)) {
	$tftp->{'errstr'} = "Cannot binmode Local file $local:$!";
	goto GET_ERR;
    }
    # fetch socket check that socket is defined
    my $sock = $tftp->{'sock'};
    unless (defined $sock) {
	$tftp->{'errstr'}="Socket closed: cannot initiate transfer";
	goto GET_ERR;
    }
    # make request packet
    my $flen = length($remote) + 1;
    my $mlen = length($mode) + 1;
    $outbuf = pack("na${flen}a${mlen}", $RRQ, $remote, $mode);
    # set up destination addr
    $remote_iaddr = inet_aton($tftp->{'host'});
    unless ($remote_iaddr) { $tftp->{'errstr'} = "Unknown host"; goto GET_ERR }
    $remote_paddr = sockaddr_in($tftp->{'port'}, $remote_iaddr);
    # send request packet
    $outlen = send($sock, $outbuf, 0, $remote_paddr);
    print STDERR "sent:$OPS[$RRQ]:$remote:$mode:$outlen\n" if $tftp->{'debug'};
    # prepare to wait for DATA
    print STDERR "fileno($sock) = ", fileno($sock),"\n"  if $tftp->{'debug'};
    vec($rin='', fileno($sock),1) = 1;
    $inlen = 0; $block = 0; $expected_block = 1; $retry = 0;
    while (1) {
       # wait for packet, or exception, or timeout
       $count = select($rout=$rin, undef, $eout=$rin, $tftp->timeout($retry));
       # abort after too many retries
       $tftp->{'errstr'} = "Transfer timeout", last
	   if $retry >= $tftp->{'retries'};
       # retry if timeout or exception
       $retry++, goto DO_GET_SEND
	   unless vec($rout,fileno($sock),1) and !vec($eout,fileno($sock),1);
       # recieve incoming packet
       print STDERR "trying recv:select returned $count:$!\n" if $tftp->{'debug'};
       $remote_paddr = recv($sock, $inbuf, $TftpBufSize,0);
       # check source, ignore if not from original source address
       ($port, $remote_iaddr) = sockaddr_in($remote_paddr);
       next if $last_paddr and $last_paddr ne $remote_paddr;
       $last_paddr ||= $remote_paddr;
       ($op,$block,$data) = unpack("nna*",$inbuf);
       $inlen = length($data);
       if ($tftp->{'debug'}) {
	   $host = gethostbyaddr($remote_iaddr, AF_INET);
	   print STDERR "recvd:$host:$port:$OPS[$op]:$block:$inlen:$!\n";
       }
       # check packet type
       if ($op == $ERR) { $tftp->{'errstr'} = $data; last } # abort on ERR
       next unless $op == $DATA; # ignore other non DATA packets
       # check block number of responses
       if ($block == $expected_block or $block == $expected_block-1) {
	  if ($mode eq $ModeNetAscii) {
	      # prepend cr from previous packet if there was one
	      substr($data,0,0) = $lastcr if $lastcr;
	      # decode cr lf => lf, cr nul => cr, and strip trailing cr
	      $data =~ s/\015([\012\0])(\015\Z(?!\n))?/$decode{$1}/sge;
#	      $data =~ s/\015([\012\0])(\015\Z(?!\n))?/($1?$1:\015)/sge;
              # save trailing cr if there was one
	      $lastcr = $2;
	  }
	  # write data to output file
	  syswrite($loc,$data,length($data)) 
	      if length($data) and $block == $expected_block;
          # prepare to ACK
          $outbuf = pack("nn",$ACK,$block); # ACK current block
          $expected_block = $block + 1; # expect the next one
          $retry = 0; # we are back on track sending good new ACKs
DO_GET_SEND:
	  # (re)send pending ACK (or RRQ)
          $outlen = send($sock, $outbuf, 0, $remote_paddr);
          print STDERR "sent:",$OPS[unpack("n",$outbuf)],":$block:$outlen:$!\n" if $tftp->{'debug'};
       } else {
	   $tftp->{'errstr'} = "Bad block:$block:expected:$expected_block";
	   last;
       }
       # done if not-first packet and packet size less than expected
       last if $inlen < $TftpDataSize and $block;
    } # while
GET_ERR:
    close($loc) unless ref($local); # close file unless filhandle passed in
    unlink($local) if $tftp->{'errstr'} and !ref($local); # delete file if err
    return ($tftp->{'errstr'} ? undef : $local);
}

sub put
{
    my($tftp,$local,$remote) = @_;
    my($loc,$inlen,$inbuf,$outlen,$outbuf,$localfd,$data,$c,$nextc);
    my($rin,$rout,$eout,$remote_iaddr,$remote_paddr,$last_paddr,$port,$host);
    my($op,$block,$expected_block,$retry,$count,$err);
    local *FD;

    # setup and open local file if needed
    if (ref($local)) {
	$loc = $local;
    } else {
	($remote = $local) =~ s!.*/!! unless defined $remote;
	unless (open(FD,"<$local")) {
	    $tftp->{'errstr'} = "Cannot open local file:$local:$!\n";
	    return undef;
	}
	$loc = \*FD;
    }
    # set binary mode if needed
    my $mode = $tftp->mode;
    if ($mode eq $ModeOctet and !binmode($loc)) {
	$tftp->{'errstr'} = "Cannot binmode Local file $local:$!";
	goto PUT_ERR;
    }
    # fetch socket check that socket is defined
    my $sock = $tftp->{'sock'};
    unless (defined $sock) {
	$tftp->{'errstr'}="Socket closed: cannot initiate transfer";
	goto PUT_ERR;
    }
    # make request packet
    my $flen = length($remote) + 1;
    my $mlen = length($mode) + 1;
    $outbuf = pack("na${flen}a${mlen}", $WRQ, $remote, $mode);
    # set up destination addr
    $remote_iaddr = inet_aton($tftp->{'host'});
    unless ($remote_iaddr) { $tftp->{'errstr'} = "Unknown host";goto PUT_ERR; }
    $remote_paddr = sockaddr_in($tftp->{'port'}, $remote_iaddr);
    # send request packet
    $outlen = send($sock, $outbuf, 0, $remote_paddr);
    print STDERR "sent:$OPS[$WRQ]:$remote:$mode:$outlen:$!\n" if $tftp->{'debug'};
    # prepare to wait for ACK
    vec($rin='', fileno($sock), 1) = 1;
    $inlen = 0; $block = 0; $expected_block = 0; $retry = 0;
    while (1) {
       # wait for packet, or exception, or timeout
       $count = select($rout=$rin, undef, $eout=$rin, $tftp->timeout($retry));
       # abort after too many retries
       $tftp->{'errstr'} = "Transfer timeout", last
	   if $retry >= $tftp->{'retries'};
       # retry if timeout or exception
       $retry++, goto DO_PUT_SEND
	   unless vec($rout,fileno($sock),1) and !vec($eout,fileno($sock),1);
       # recieve incoming packet
       print STDERR "trying recv:select returned $count:$!\n" if $tftp->{'debug'};
       $remote_paddr = recv($sock, $inbuf, $TftpBufSize,0);
       # check source, ignore if not from original source address
       ($port, $remote_iaddr) = sockaddr_in($remote_paddr);
       next if $last_paddr and $last_paddr ne $remote_paddr;
       $last_paddr ||= $remote_paddr;
       ($op,$block,$data) = unpack("nna*",$inbuf);
       $inlen = length($data);
       if ($tftp->{'debug'}) {
	   $host = gethostbyaddr($remote_iaddr, AF_INET);
	   print STDERR "recvd:$host:$port:$OPS[$op]:$block:$inlen:$!\n";
       }
       if ($op == $ERR) { $tftp->{'errstr'} = $data; last } # abort on ERR
       next unless $op == $ACK; # ignore other non ACK packets
       if ($block == $expected_block) {
           # done if not-first packet and packet size less than expected
	   last if $outlen < $TftpBufSize and $block;
	   # prepare to send DATA
	   if ($mode eq $ModeNetAscii) {
	       for ($outlen = 0; $outlen < $TftpDataSize; $outlen++) {
		   $data .= $nextc, undef($nextc), next if defined $nextc;
		   last unless $c = getc($loc);
		   $c = "\015" if defined($nextc = $encode{$c});
		   $data .= $c;
	       }
	   } else {
	       $outlen = sysread($loc,$data,$TftpDataSize);
	   }
	   $expected_block = $block + 1;
	   $outbuf = pack("nna${outlen}",$DATA,$expected_block,$data);
	   $retry = 0; # we are back on track sending good new DATA
DO_PUT_SEND:
	  # (re)send pending DATA (or WRQ)
	   $outlen = send($sock, $outbuf, 0, $remote_paddr);
	   print STDERR "sent:",$OPS[unpack("n",$outbuf)],":$expected_block:$outlen\n" if $tftp->{'debug'};
       } elsif ($block == $expected_block - 1) {
           print STDERR "duplicate ACK:$block\n" if $tftp->{'debug'};
	   next; # ignore duplicate ACK to avoid "sorcerer's apprentice"
       } else {
	   print STDERR "bad block:expected block:$expected_block\n" if $tftp->{'debug'};
	   $tftp->{'errstr'} = "Bad block:$block:expected:$expected_block";
	   last;
       }
    } # while
PUT_ERR:
    close($loc) unless ref($local); # close file if ours
    return ($tftp->{'errstr'} ? undef : $local);
}

sub quit
{
    my $tftp = shift;

    close($tftp->{'sock'});
    delete $tftp->{'sock'};
}

1;

__END__