pxelator/bin/tftpd.pl

#!/usr/bin/perl
use strict;
use lib 'lib';
use Net::TFTPd 0.03 qw(%OPCODES);

die "need to run $0 as root like this\nsudo $0\n" unless $< == 0;

# change ROOTDIR to your TFTP root directory
my $rootdir = 'conf/' . readlink('conf/tftp.dir');
$rootdir =~ s{[^/]+/\.\./([^/]+)}{$1};

unless(-d $rootdir)
{
        print "$rootdir isn't directory!\nUsage: $0 path/to/rootdir\n\n";
        exit 1;
}

# callback sub used to print transfer status
sub callback
{
        my $req = shift;
        if($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'RRQ'})
        {
                # RRQ
                printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'};
        }
        elsif($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'WRQ'})
        {
                # WRQ
                printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTBLK'}, $req->{'_REQUEST_'}{'LASTACK'};
        } else {
                warn "IGNORED: ", dump( $req );
        }
}

# create the listener
my $listener = Net::TFTPd->new(
        'RootDir' => $rootdir,
        'Writable' => 0,
        'Timeout' => 3600, 
        'CallBack' => \&callback,
#       LocalAddr => '10.0.0.100',
#       BlkSize => 8192,
#       BlkSize => 512,
        BlkSize => 1456,        # IBM GE seems to be picky
        Debug => 99,
) or die Net::TFTPd->error;
printf "TFTP %s:%d [timeout %d s] $rootdir\n", $listener->{'LocalAddr'} ? $listener->{'LocalAddr'} : "'any address'",  $listener->{'LocalPort'}, $listener->{'Timeout'};

while(1) {

        # wait for any request (RRQ or WRQ)
        if(my $request = $listener->waitRQ()) {
                # received request
                printf "Received a %s for file '%s'\n", $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, $request->{'_REQUEST_'}{'FileName'};

                # process the request
                if($request->processRQ()) {
                        print "OK, transfer completed successfully\n";
                } else {
                        warn Net::TFTPd->error;
                        $request->processRQ();
                }
        } else {
                # request not received (timed out waiting for request etc.)
                warn Net::TFTPd->error;
        }

}
1	dpavlin	1	#!/usr/bin/perl
2			use strict;
3			use lib 'lib';
4			use Net::TFTPd 0.03 qw(%OPCODES);
5
6			die "need to run $0 as root like this\nsudo $0\n" unless $< == 0;
7
8			# change ROOTDIR to your TFTP root directory
9	dpavlin	13	my $rootdir = 'conf/' . readlink('conf/tftp.dir');
10			$rootdir =~ s{[^/]+/\.\./([^/]+)}{$1};
11	dpavlin	1
12			unless(-d $rootdir)
13			{
14	dpavlin	13	print "$rootdir isn't directory!\nUsage: $0 path/to/rootdir\n\n";
15	dpavlin	1	exit 1;
16			}
17
18			# callback sub used to print transfer status
19			sub callback
20			{
21			my $req = shift;
22			if($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'RRQ'})
23			{
24			# RRQ
25			printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'};
26			}
27			elsif($req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'WRQ'})
28			{
29			# WRQ
30			printf "block: %u\/%u\n", $req->{'_REQUEST_'}{'LASTBLK'}, $req->{'_REQUEST_'}{'LASTACK'};
31	dpavlin	13	} else {
32			warn "IGNORED: ", dump( $req );
33	dpavlin	1	}
34			}
35
36			# create the listener
37			my $listener = Net::TFTPd->new(
38			'RootDir' => $rootdir,
39			'Writable' => 0,
40			'Timeout' => 3600,
41			'CallBack' => \&callback,
42			# LocalAddr => '10.0.0.100',
43			# BlkSize => 8192,
44			# BlkSize => 512,
45			BlkSize => 1456, # IBM GE seems to be picky
46			Debug => 99,
47			) or die Net::TFTPd->error;
48	dpavlin	13	printf "TFTP %s:%d [timeout %d s] $rootdir\n", $listener->{'LocalAddr'} ? $listener->{'LocalAddr'} : "'any address'", $listener->{'LocalPort'}, $listener->{'Timeout'};
49	dpavlin	1
50			while(1) {
51
52			# wait for any request (RRQ or WRQ)
53			if(my $request = $listener->waitRQ()) {
54			# received request
55			printf "Received a %s for file '%s'\n", $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, $request->{'_REQUEST_'}{'FileName'};
56
57			# process the request
58			if($request->processRQ()) {
59			print "OK, transfer completed successfully\n";
60			} else {
61			warn Net::TFTPd->error;
62			$request->processRQ();
63			}
64			} else {
65			# request not received (timed out waiting for request etc.)
66			warn Net::TFTPd->error;
67			}
68
69			}