/[pxelator]/lib/PXElator/tftpd.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /lib/PXElator/tftpd.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 128 - (show annotations)
Mon Aug 3 19:59:08 2009 UTC (13 years, 5 months ago) by dpavlin
File size: 2108 byte(s)
added back refresh, this time in as server->refresh

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

  ViewVC Help
Powered by ViewVC 1.1.26