lib/PXElator/tftpd.pm

package tftpd;

use warnings;
use strict;

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

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 if $debug;
        $path =~ s{^$dir}{};
        return $path;
}

STDERR->autoflush(1);

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

sub tftp_request {
        my $request = shift;

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

        config::for_ip();

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

        my $file = $request->{'_REQUEST_'}{'FileName'};
        # received request
        print $OPCODES{$request->{'_REQUEST_'}{'OPCODE'}}, " $file\n";

        # process the request
        if( $request->processRQ() ) {
                print "\nOK completed $file ", -s "$dir/$file", "\n";
        } else {
                print "ERROR ", Net::TFTPd->error, "\n";
                $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;

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

        while(1) {

                Module::Refresh->refresh;

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

        }

}

warn "loaded";

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