git.rot13.org Git - pxelator/blob - lib/PXElator/tftpd.pm

   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");
  18         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                 LocalAddr => '0.0.0.0',
  70 #               BlkSize => 8192,
  71 #               BlkSize => 512,
  72                 BlkSize => 1456,        # IBM GE seems to be picky
  73                 Debug => 99,
  74         ) || die Net::TFTPd->error;
  75
  76         warn 'listener: ',dump( $listener ) if $debug;
  77
  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;