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

use progress_bar;

sub transfer_status {
        my $request = shift;
        my $r = $request->{'_REQUEST_'} || die "no _REQUEST_ in ",dump( $request );

        if( $r->{'OPCODE'} eq $OPCODES{'RRQ'} ) {
                progress_bar::tick( $r->{FileName}, $r->{BlkSize} * $r->{LASTACK}, $r->{BlkSize} * $r->{LASTBLK} );
        } elsif ( $r->{'OPCODE'} eq $OPCODES{'WRQ'} ) {
                die "WRQ disabled";
        } else {
                warn "IGNORED: ", dump( $request );
        }
}

use config;

sub tftp_request {
        my $request = shift;

        server->refresh;

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

        config::for_ip( $request->{_REQUEST_}->{PeerAddr} );

        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";

        progress_bar::start;

        # 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) {

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