lib/PXElator/tftpd.pm

package tftpd;

use warnings;
use strict;

use Net::TFTPd 0.03 qw(%OPCODES);
use Data::Dump qw/dump/;

use server;

our $debug = server::debug;

our $dir  = "$server::base_dir/tftp";

sub path {
        my $glob = shift;
        my $path = (glob("$dir/$glob"))[0];
        die "can't find anything for $dir/$glob" unless $path;
warn $path;
        $path =~ s{^$dir}{};
        return $path;
}

sub transfer_status {
        my $req = shift;
        if( $req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'RRQ'} ) {
                printf "RRQ %u\/%u\r", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'};
        } elsif ( $req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'WRQ'} ) {
                die "WRQ disabled";
                printf "WRQ: %u\/%u\n", $req->{'_REQUEST_'}{'LASTBLK'}, $req->{'_REQUEST_'}{'LASTACK'};
        } else {
                warn "IGNORED: ", dump( $req );
        }
}

sub tftp_request {
        my $request = shift;

        if ( $request->{RootDir} ne $dir ) {
                $request->{RootDir} = $dir;
                warn "new root: $dir";
        }

        # 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();
        }

}

use server;

sub start {

        warn 'start';

        my $listener = Net::TFTPd->new(
                RootDir => $dir,
                Writable => 0,
                Timeout => 3600, 
                CallBack => \&transfer_status,
#               LocalAddr => $server::ip,
                LocalAddr => '0.0.0.0',
#               BlkSize => 8192,
#               BlkSize => 512,
                BlkSize => 1456,        # IBM GE seems to be picky
                Debug => 99,
        ) || die Net::TFTPd->error;

        warn 'listener: ',dump( $listener ) if $debug;

        while(1) {
        
                printf "TFTP listen %s:%d timeout: %d dir: $dir\n",
                        $listener->{LocalAddr},
                        $listener->{LocalPort},
                        $listener->{Timeout};

                # wait for any request (RRQ or WRQ)
                if(my $request = $listener->waitRQ()) {
                        tftp_request $request;
                } else {
                        warn Net::TFTPd->error;
                }

        }

}

warn "loaded";

1;
1	dpavlin	45	package tftpd;
2
3			use warnings;
4			use strict;
5
6			use Net::TFTPd 0.03 qw(%OPCODES);
7			use Data::Dump qw/dump/;
8
9	dpavlin	47	use server;
10	dpavlin	45
11	dpavlin	67	our $debug = server::debug;
12
13	dpavlin	47	our $dir = "$server::base_dir/tftp";
14
15	dpavlin	45	sub path {
16			my $glob = shift;
17	dpavlin	68	my $path = (glob("$dir/$glob"))[0];
18	dpavlin	45	die "can't find anything for $dir/$glob" unless $path;
19			warn $path;
20			$path =~ s{^$dir}{};
21			return $path;
22			}
23
24			sub transfer_status {
25			my $req = shift;
26			if( $req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'RRQ'} ) {
27			printf "RRQ %u\/%u\r", $req->{'_REQUEST_'}{'LASTACK'}, $req->{'_REQUEST_'}{'LASTBLK'};
28			} elsif ( $req->{'_REQUEST_'}{'OPCODE'} eq $OPCODES{'WRQ'} ) {
29			die "WRQ disabled";
30			printf "WRQ: %u\/%u\n", $req->{'_REQUEST_'}{'LASTBLK'}, $req->{'_REQUEST_'}{'LASTACK'};
31			} else {
32			warn "IGNORED: ", dump( $req );
33			}
34			}
35
36			sub tftp_request {
37			my $request = shift;
38
39			if ( $request->{RootDir} ne $dir ) {
40			$request->{RootDir} = $dir;
41			warn "new root: $dir";
42			}
43
44			# received request
45			printf "Received a %s for file '%s'\n", $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, $request->{'_REQUEST_'}{'FileName'};
46
47			# process the request
48			if( $request->processRQ() ) {
49			print "OK, transfer completed successfully\n";
50			} else {
51			warn Net::TFTPd->error;
52			$request->processRQ();
53			}
54
55			}
56
57			use server;
58
59			sub start {
60
61			warn 'start';
62
63			my $listener = Net::TFTPd->new(
64			RootDir => $dir,
65			Writable => 0,
66			Timeout => 3600,
67			CallBack => \&transfer_status,
68			# LocalAddr => $server::ip,
69	dpavlin	59	LocalAddr => '0.0.0.0',
70	dpavlin	45	# BlkSize => 8192,
71			# BlkSize => 512,
72			BlkSize => 1456, # IBM GE seems to be picky
73			Debug => 99,
74			) \|\| die Net::TFTPd->error;
75
76	dpavlin	67	warn 'listener: ',dump( $listener ) if $debug;
77	dpavlin	45
78			while(1) {
79
80			printf "TFTP listen %s:%d timeout: %d dir: $dir\n",
81			$listener->{LocalAddr},
82			$listener->{LocalPort},
83			$listener->{Timeout};
84
85			# wait for any request (RRQ or WRQ)
86			if(my $request = $listener->waitRQ()) {
87			tftp_request $request;
88			} else {
89			warn Net::TFTPd->error;
90			}
91
92			}
93
94			}
95
96			warn "loaded";
97
98			1;