sjero.net Git - wget/blob - tests/FTPServer.pm

   1 #!/usr/bin/perl -w
   2
   3 # Part of this code was borrowed from Richard Jones's Net::FTPServer
   4 # http://www.annexia.org/freeware/netftpserver
   5
   6 package FTPServer;
   7
   8 use strict;
   9
  10 use Cwd;
  11 use Socket;
  12 use IO::Socket::INET;
  13 use IO::Seekable;
  14 use POSIX qw(strftime);
  15
  16 my $log        = undef;
  17 my $GOT_SIGURG = 0;
  18
  19 # CONSTANTS
  20
  21 # connection states
  22 my %_connection_states = (
  23     'NEWCONN'  => 0x01,
  24     'WAIT4PWD' => 0x02,
  25     'LOGGEDIN' => 0x04,
  26     'TWOSOCKS' => 0x08,
  27 );
  28
  29 # subset of FTP commands supported by these server and the respective
  30 # connection states in which they are allowed
  31 my %_commands = (
  32     # Standard commands from RFC 959.
  33     'CWD'  => $_connection_states{LOGGEDIN} |
  34               $_connection_states{TWOSOCKS},
  35 #   'EPRT' => $_connection_states{LOGGEDIN},
  36 #   'EPSV' => $_connection_states{LOGGEDIN},
  37     'LIST' => $_connection_states{TWOSOCKS},
  38 #   'LPRT' => $_connection_states{LOGGEDIN},
  39 #   'LPSV' => $_connection_states{LOGGEDIN},
  40     'PASS' => $_connection_states{WAIT4PWD},
  41     'PASV' => $_connection_states{LOGGEDIN},
  42     'PORT' => $_connection_states{LOGGEDIN},
  43     'PWD'  => $_connection_states{LOGGEDIN} |
  44               $_connection_states{TWOSOCKS},
  45     'QUIT' => $_connection_states{LOGGEDIN} |
  46               $_connection_states{TWOSOCKS},
  47     'REST' => $_connection_states{TWOSOCKS},
  48     'RETR' => $_connection_states{TWOSOCKS},
  49     'SYST' => $_connection_states{LOGGEDIN},
  50     'TYPE' => $_connection_states{LOGGEDIN} |
  51               $_connection_states{TWOSOCKS},
  52     'USER' => $_connection_states{NEWCONN},
  53     # From ftpexts Internet Draft.
  54     'SIZE' => $_connection_states{LOGGEDIN} |
  55               $_connection_states{TWOSOCKS},
  56 );
  57
  58
  59
  60 # COMMAND-HANDLING ROUTINES
  61
  62 sub _CWD_command
  63 {
  64     my ($conn, $cmd, $path) = @_;
  65
  66     local $_;
  67     my $newdir = $conn->{dir};
  68
  69     # If the path starts with a "/" then it's an absolute path.
  70     if (substr ($path, 0, 1) eq "/") {
  71         $newdir = "";
  72         $path =~ s,^/+,,;
  73     }
  74
  75     # Split the path into its component parts and process each separately.
  76     my @elems = split /\//, $path;
  77
  78     foreach (@elems) {
  79         if ($_ eq "" || $_ eq ".") {
  80             # Ignore these.
  81             next;
  82         } elsif ($_ eq "..") {
  83             # Go to parent directory.
  84             if ($newdir eq "") {
  85                 print {$conn->{socket}} "550 Directory not found.\r\n";
  86                 return;
  87             }
  88             $newdir = substr ($newdir, 0, rindex ($newdir, "/"));
  89         } else {
  90             # Go into subdirectory, if it exists.
  91             $newdir .= ("/" . $_);
  92             if (! -d $conn->{rootdir} . $newdir) {
  93                 print {$conn->{socket}} "550 Directory not found.\r\n";
  94                 return;
  95             }
  96         }
  97     }
  98
  99     $conn->{dir} = $newdir;
 100 }
 101
 102 sub _LIST_command
 103 {
 104     my ($conn, $cmd, $path) = @_;
 105
 106     # This is something of a hack. Some clients expect a Unix server
 107     # to respond to flags on the 'ls command line'. Remove these flags
 108     # and ignore them. This is particularly an issue with ncftp 2.4.3.
 109     $path =~ s/^-[a-zA-Z0-9]+\s?//;
 110
 111     my $dir = $conn->{dir};
 112
 113     print STDERR "_LIST_command - dir is: $dir\n";
 114
 115     # Absolute path?
 116     if (substr ($path, 0, 1) eq "/") {
 117         $dir = "/";
 118         $path =~ s,^/+,,;
 119     }
 120
 121     # Parse the first elements of the path until we find the appropriate
 122     # working directory.
 123     my @elems = split /\//, $path;
 124     my ($wildcard, $filename);
 125     local $_;
 126
 127     for (my $i = 0; $i < @elems; ++$i) {
 128         $_ = $elems[$i];
 129         my $lastelement = $i == @elems-1;
 130
 131         if ($_ eq "" || $_ eq ".") { next } # Ignore these.
 132         elsif ($_ eq "..") {
 133             # Go to parent directory.
 134             unless ($dir eq "/") {
 135                 $dir = substr ($dir, 0, rindex ($dir, "/"));
 136             }
 137         } else {
 138             if (!$lastelement) { # These elements can only be directories.
 139                 unless (-d $conn->{rootdir} . $dir . $_) {
 140                     print {$conn->{socket}} "550 File or directory not found.\r\n";
 141                     return;
 142                 }
 143                 $dir .= $_;
 144             } else { # It's the last element: check if it's a file, directory or wildcard.
 145                 if (-f $conn->{rootdir} . $dir . $_) {
 146                     # It's a file.
 147                     $filename = $_;
 148                 } elsif (-d $conn->{rootdir} . $dir . $_) {
 149                     # It's a directory.
 150                     $dir .= $_;
 151                 } elsif (/\*/ || /\?/) {
 152                     # It is a wildcard.
 153                     $wildcard = $_;
 154                 } else {
 155                     print {$conn->{socket}} "550 File or directory not found.\r\n";
 156                     return;
 157                 }
 158             }
 159         }
 160     }
 161
 162     print STDERR "_LIST_command - dir is: $dir\n" if $log;
 163
 164     print {$conn->{socket}} "150 Opening data connection for file listing.\r\n";
 165
 166     # Open a path back to the client.
 167     my $sock = __open_data_connection ($conn);
 168
 169     unless ($sock) {
 170         print {$conn->{socket}} "425 Can't open data connection.\r\n";
 171         return;
 172     }
 173
 174     # If the path contains a directory name, extract it so that
 175     # we can prefix it to every filename listed.
 176     my $prefix = (($filename || $wildcard) && $path =~ /(.*\/).*/) ? $1 : "";
 177
 178     print STDERR "_LIST_command - prefix is: $prefix\n" if $log;
 179
 180     # OK, we're either listing a full directory, listing a single
 181     # file or listing a wildcard.
 182     if ($filename) {            # Single file.
 183         __list_file ($sock, $prefix . $filename);
 184     } else {                    # Wildcard or full directory $dirh.
 185         unless ($wildcard) {
 186             # Synthesize (fake) "total" field for directory listing.
 187             print $sock "total 1 \r\n";
 188         }
 189
 190         foreach (__get_file_list ($conn->{rootdir} . $dir, $wildcard)) {
 191             __list_file ($sock, $prefix . $_);
 192         }
 193     }
 194
 195     unless ($sock->close) {
 196         print {$conn->{socket}} "550 Error closing data connection: $!\r\n";
 197         return;
 198     }
 199
 200     print {$conn->{socket}} "226 Listing complete. Data connection has been closed.\r\n";
 201 }
 202
 203 sub _PASS_command
 204 {
 205     my ($conn, $cmd, $pass) = @_;
 206
 207     # TODO: implement authentication?
 208
 209     print STDERR "switching to LOGGEDIN state\n" if $log;
 210     $conn->{state} = $_connection_states{LOGGEDIN};
 211
 212     if ($conn->{username} eq "anonymous") {
 213         print {$conn->{socket}} "202 Anonymous user access is always granted.\r\n";
 214     } else {
 215         print {$conn->{socket}} "230 Authentication not implemented yet, access is always granted.\r\n";
 216     }
 217 }
 218
 219 sub _PASV_command
 220 {
 221     my ($conn, $cmd, $rest) = @_;
 222
 223     # Open a listening socket - but don't actually accept on it yet.
 224     "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
 225     my $sock = IO::Socket::INET->new (LocalHost => '127.0.0.1',
 226                                       LocalPort => '0',
 227                                       Listen => 1,
 228                                       Reuse => 1,
 229                                       Proto => 'tcp',
 230                                       Type => SOCK_STREAM);
 231
 232     unless ($sock) {
 233         # Return a code 550 here, even though this is not in the RFC. XXX
 234         print {$conn->{socket}} "550 Can't open a listening socket.\r\n";
 235         return;
 236     }
 237
 238     $conn->{passive} = 1;
 239     $conn->{passive_socket} = $sock;
 240
 241     # Get our port number.
 242     my $sockport = $sock->sockport;
 243
 244     # Split the port number into high and low components.
 245     my $p1 = int ($sockport / 256);
 246     my $p2 = $sockport % 256;
 247
 248     $conn->{state} = $_connection_states{TWOSOCKS};
 249
 250     # We only accept connections from localhost.
 251     print {$conn->{socket}} "227 Entering Passive Mode (127,0,0,1,$p1,$p2)\r\n";
 252 }
 253
 254 sub _PORT_command
 255 {
 256     my ($conn, $cmd, $rest) = @_;
 257
 258     # The arguments to PORT are a1,a2,a3,a4,p1,p2 where a1 is the
 259     # most significant part of the address (eg. 127,0,0,1) and
 260     # p1 is the most significant part of the port.
 261     unless ($rest =~ /^\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3}),\s*(\d{1,3})/) {
 262         print {$conn->{socket}} "501 Syntax error in PORT command.\r\n";
 263         return;
 264     }
 265
 266     # Check host address.
 267     unless ($1  > 0 && $1 < 224 &&
 268             $2 >= 0 && $2 < 256 &&
 269             $3 >= 0 && $3 < 256 &&
 270             $4 >= 0 && $4 < 256) {
 271         print {$conn->{socket}} "501 Invalid host address.\r\n";
 272         return;
 273     }
 274
 275     # Construct host address and port number.
 276     my $peeraddrstring = "$1.$2.$3.$4";
 277     my $peerport = $5 * 256 + $6;
 278
 279     # Check port number.
 280     unless ($peerport > 0 && $peerport < 65536) {
 281         print {$conn->{socket}} "501 Invalid port number.\r\n";
 282     }
 283
 284     $conn->{peeraddrstring} = $peeraddrstring;
 285     $conn->{peeraddr} = inet_aton ($peeraddrstring);
 286     $conn->{peerport} = $peerport;
 287     $conn->{passive} = 0;
 288
 289     $conn->{state} = $_connection_states{TWOSOCKS};
 290
 291     print {$conn->{socket}} "200 PORT command OK.\r\n";
 292 }
 293
 294 sub _PWD_command
 295 {
 296     my ($conn, $cmd, $rest) = @_;
 297
 298     # See RFC 959 Appendix II and draft-ietf-ftpext-mlst-11.txt section 6.2.1.
 299     my $pathname = $conn->{dir};
 300     $pathname =~ s,/+$,, unless $pathname eq "/";
 301     $pathname =~ tr,/,/,s;
 302
 303     print {$conn->{socket}} "257 \"$pathname\"\r\n";
 304 }
 305
 306 sub _REST_command
 307 {
 308     my ($conn, $cmd, $restart_from) = @_;
 309
 310     unless ($restart_from =~ /^([1-9][0-9]*|0)$/) {
 311         print {$conn->{socket}} "501 REST command needs a numeric argument.\r\n";
 312         return;
 313     }
 314
 315     $conn->{restart} = $1;
 316
 317     print {$conn->{socket}} "350 Restarting next transfer at $1.\r\n";
 318 }
 319
 320 sub _RETR_command
 321 {
 322     my ($conn, $cmd, $path) = @_;
 323
 324     my $dir = $conn->{dir};
 325
 326     # Absolute path?
 327     if (substr ($path, 0, 1) eq "/") {
 328         $dir = "/";
 329         $path =~ s,^/+,,;
 330         $path = "." if $path eq "";
 331     }
 332
 333     # Parse the first elements of path until we find the appropriate
 334     # working directory.
 335     my @elems = split /\//, $path;
 336     my $filename = pop @elems;
 337
 338     foreach (@elems) {
 339         if ($_ eq "" || $_ eq ".") {
 340             next # Ignore these.
 341         } elsif ($_ eq "..") {
 342             # Go to parent directory.
 343             unless ($dir eq "/") {
 344                 $dir = substr ($dir, 0, rindex ($dir, "/"));
 345             }
 346         } else {
 347             unless (-d $conn->{rootdir} . $dir . $_) {
 348                 print {$conn->{socket}} "550 File or directory not found.\r\n";
 349                 return;
 350             }
 351             $dir .= $_;
 352         }
 353     }
 354
 355     unless (defined $filename && length $filename) {
 356         print {$conn->{socket}} "550 File or directory not found.\r\n";
 357             return;
 358     }
 359
 360     if ($filename eq "." || $filename eq "..") {
 361         print {$conn->{socket}} "550 RETR command is not supported on directories.\r\n";
 362             return;
 363     }
 364
 365     my $fullname = $conn->{rootdir} . $dir . $filename;
 366     unless (-f $fullname) {
 367         print {$conn->{socket}} "550 RETR command is only supported on plain files.\r\n";
 368         return;
 369     }
 370
 371     # Try to open the file.
 372     unless (open (FILE, '<', $fullname)) {
 373         print {$conn->{socket}} "550 File or directory not found.\r\n";
 374         return;
 375     }
 376
 377     print {$conn->{socket}} "150 Opening " .
 378         ($conn->{type} eq 'A' ? "ASCII mode" : "BINARY mode") .
 379         " data connection for file $filename.\r\n";
 380
 381     # Open a path back to the client.
 382     my $sock = __open_data_connection ($conn);
 383
 384     unless ($sock) {
 385         print {$conn->{socket}} "425 Can't open data connection.\r\n";
 386         return;
 387     }
 388
 389     # What mode are we sending this file in?
 390     unless ($conn->{type} eq 'A') # Binary type.
 391     {
 392         my ($r, $buffer, $n, $w);
 393
 394         # Restart the connection from previous point?
 395         if ($conn->{restart}) {
 396             # VFS seek method only required to support relative forward seeks
 397             #
 398             # In Perl = 5.00503, SEEK_CUR is exported by IO::Seekable,
 399             # in Perl >= 5.6, SEEK_CUR is exported by both IO::Seekable
 400             # and Fcntl. Hence we 'use IO::Seekable' at the top of the
 401             # file to get this symbol reliably in both cases.
 402             sysseek (FILE, $conn->{restart}, SEEK_CUR);
 403             $conn->{restart} = 0;
 404         }
 405
 406         # Copy data.
 407         while ($r = sysread (FILE, $buffer, 65536))
 408         {
 409             # Restart alarm clock timer.
 410             alarm $conn->{idle_timeout};
 411
 412             for ($n = 0; $n < $r; )
 413             {
 414                 $w = syswrite ($sock, $buffer, $r - $n, $n);
 415
 416                 # Cleanup and exit if there was an error.
 417                 unless (defined $w) {
 418                     close $sock;
 419                     close FILE;
 420                     print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n";
 421                     return;
 422                 }
 423
 424                 $n += $w;
 425             }
 426
 427             # Transfer aborted by client?
 428             if ($GOT_SIGURG) {
 429                 $GOT_SIGURG = 0;
 430                 close $sock;
 431                 close FILE;
 432                 print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n";
 433                 return;
 434             }
 435         }
 436
 437         # Cleanup and exit if there was an error.
 438         unless (defined $r) {
 439             close $sock;
 440             close FILE;
 441             print {$conn->{socket}} "426 File retrieval error: $!. Data connection has been closed.\r\n";
 442             return;
 443         }
 444     } else { # ASCII type.
 445         # Restart the connection from previous point?
 446         if ($conn->{restart}) {
 447             for (my $i = 0; $i < $conn->{restart}; ++$i) {
 448                 getc FILE;
 449             }
 450             $conn->{restart} = 0;
 451         }
 452
 453         # Copy data.
 454         while (defined ($_ = <FILE>)) {
 455             # Remove any native line endings.
 456             s/[\n\r]+$//;
 457
 458             # Restart alarm clock timer.
 459             alarm $conn->{idle_timeout};
 460
 461             # Write the line with telnet-format line endings.
 462             print $sock "$_\r\n";
 463
 464             # Transfer aborted by client?
 465             if ($GOT_SIGURG) {
 466                 $GOT_SIGURG = 0;
 467                 close $sock;
 468                 close FILE;
 469                 print {$conn->{socket}} "426 Transfer aborted. Data connection closed.\r\n";
 470                 return;
 471             }
 472         }
 473     }
 474
 475     unless (close ($sock) && close (FILE)) {
 476         print {$conn->{socket}} "550 File retrieval error: $!.\r\n";
 477         return;
 478     }
 479
 480     print {$conn->{socket}} "226 File retrieval complete. Data connection has been closed.\r\n";
 481 }
 482
 483 sub _SIZE_command
 484 {
 485     my ($conn, $cmd, $path) = @_;
 486
 487     my $dir = $conn->{dir};
 488
 489     # Absolute path?
 490     if (substr ($path, 0, 1) eq "/") {
 491         $dir = "/";
 492         $path =~ s,^/+,,;
 493         $path = "." if $path eq "";
 494     }
 495
 496     # Parse the first elements of path until we find the appropriate
 497     # working directory.
 498     my @elems = split /\//, $path;
 499     my $filename = pop @elems;
 500
 501     foreach (@elems) {
 502         if ($_ eq "" || $_ eq ".") {
 503             next # Ignore these.
 504         } elsif ($_ eq "..") {
 505             # Go to parent directory.
 506             unless ($dir eq "/") {
 507                 $dir = substr ($dir, 0, rindex ($dir, "/"));
 508             }
 509         } else {
 510             unless (-d $conn->{rootdir} . $dir . $_) {
 511                 print {$conn->{socket}} "550 File or directory not found.\r\n";
 512                 return;
 513             }
 514             $dir .= $_;
 515         }
 516     }
 517
 518     unless (defined $filename && length $filename) {
 519         print {$conn->{socket}} "550 File or directory not found.\r\n";
 520             return;
 521     }
 522
 523     if ($filename eq "." || $filename eq "..") {
 524         print {$conn->{socket}} "550 SIZE command is not supported on directories.\r\n";
 525             return;
 526     }
 527
 528     my $fullname = $conn->{rootdir} . $dir . $filename;
 529     unless (-f $fullname) {
 530         print {$conn->{socket}} "550 SIZE command is only supported on plain files.\r\n";
 531         return;
 532     }
 533
 534     my $size = 0;
 535     if ($conn->{type} eq 'A') {
 536         # ASCII mode: we have to count the characters by hand.
 537         unless (open (FILE, '<', $filename)) {
 538             print {$conn->{socket}} "550 Cannot calculate size of $filename.\r\n";
 539             return;
 540         }
 541         $size++ while (defined (getc(FILE)));
 542         close FILE;
 543     } else {
 544         # BINARY mode: we can use stat
 545         $size = (stat($filename))[7];
 546     }
 547
 548     print {$conn->{socket}} "213 $size\r\n";
 549 }
 550
 551 sub _SYST_command
 552 {
 553     my ($conn, $cmd, $dummy) = @_;
 554
 555     print {$conn->{socket}} "215 UNIX Type: L8\r\n";
 556 }
 557
 558 sub _TYPE_command
 559 {
 560     my ($conn, $cmd, $type) = @_;
 561
 562     # See RFC 959 section 5.3.2.
 563     if ($type =~ /^([AI])$/i) {
 564         $conn->{type} = 'A';
 565     } elsif ($type =~ /^([AI])\sN$/i) {
 566         $conn->{type} = 'A';
 567     } elsif ($type =~ /^L\s8$/i) {
 568         $conn->{type} = 'L8';
 569     } else {
 570         print {$conn->{socket}} "504 This server does not support TYPE $type.\r\n";
 571         return;
 572     }
 573
 574     print {$conn->{socket}} "200 TYPE changed to $type.\r\n";
 575 }
 576
 577 sub _USER_command
 578 {
 579     my ($conn, $cmd, $username) = @_;
 580
 581     print STDERR "username: $username\n" if $log;
 582     $conn->{username} = $username;
 583
 584     print STDERR "switching to WAIT4PWD state\n" if $log;
 585     $conn->{state} = $_connection_states{WAIT4PWD};
 586
 587     if ($conn->{username} eq "anonymous") {
 588         print {$conn->{socket}} "230 Anonymous user access granted.\r\n";
 589     } else {
 590         print {$conn->{socket}} "331 Password required.\r\n";
 591     }
 592 }
 593
 594
 595 # HELPER ROUTINES
 596
 597 sub __open_data_connection
 598 {
 599     my $conn = shift;
 600
 601     my $sock;
 602
 603     if ($conn->{passive}) {
 604         # Passive mode - wait for a connection from the client.
 605         accept ($sock, $conn->{passive_socket}) or return undef;
 606     } else {
 607         # Active mode - connect back to the client.
 608         "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
 609         $sock = IO::Socket::INET->new (LocalAddr => '127.0.0.1',
 610                                        PeerAddr => $conn->{peeraddrstring},
 611                                        PeerPort => $conn->{peerport},
 612                                        Proto => 'tcp',
 613                                        Type => SOCK_STREAM) or return undef;
 614     }
 615
 616     return $sock;
 617 }
 618
 619
 620 sub __list_file
 621 {
 622     my $sock = shift;
 623     my $filename = shift;
 624
 625     # Get the status information.
 626     my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
 627         $atime, $mtime, $ctime, $blksize, $blocks)
 628       = lstat $filename;
 629
 630     # If the file has been removed since we created this
 631     # handle, then $dev will be undefined. Return immediately.
 632     return unless defined $dev;
 633
 634     # Generate printable user/group.
 635     my $user = getpwuid ($uid) || "-";
 636     my $group = getgrgid ($gid) || "-";
 637
 638     # Permissions from mode.
 639     my $perms = $mode & 0777;
 640
 641     # Work out the mode using special "_" operator which causes Perl
 642     # to use the result of the previous stat call.
 643     $mode = (-f _ ? 'f' :
 644              (-d _ ? 'd' :
 645               (-l _ ? 'l' :
 646                (-p _ ? 'p' :
 647                 (-S _ ? 's' :
 648                  (-b _ ? 'b' :
 649                   (-c _ ? 'c' : '?')))))));
 650
 651     # Generate printable date (this logic is taken from GNU fileutils:
 652     # src/ls.c: print_long_format).
 653     my $time = time;
 654     my $fmt;
 655     if ($time > $mtime + 6 * 30 * 24 * 60 * 60 || $time < $mtime - 60 * 60) {
 656         $fmt = "%b %e  %Y";
 657     } else {
 658         $fmt = "%b %e %H:%M";
 659     }
 660
 661     my $fmt_time = strftime $fmt, localtime ($mtime);
 662
 663     # Generate printable permissions.
 664     my $fmt_perms = join "",
 665       ($perms & 0400 ? 'r' : '-'),
 666       ($perms & 0200 ? 'w' : '-'),
 667       ($perms & 0100 ? 'x' : '-'),
 668       ($perms & 040 ? 'r' : '-'),
 669       ($perms & 020 ? 'w' : '-'),
 670       ($perms & 010 ? 'x' : '-'),
 671       ($perms & 04 ? 'r' : '-'),
 672       ($perms & 02 ? 'w' : '-'),
 673       ($perms & 01 ? 'x' : '-');
 674
 675     # Printable file type.
 676     my $fmt_mode = $mode eq 'f' ? '-' : $mode;
 677
 678     # If it's a symbolic link, display the link.
 679     my $link;
 680     if ($mode eq 'l') {
 681         $link = readlink $filename;
 682         die "readlink: $!" unless defined $link;
 683     }
 684     my $fmt_link = defined $link ? " -> $link" : "";
 685
 686     # Display the file.
 687     my $line = sprintf
 688       ("%s%s%4d %-8s %-8s %8d %s %s%s\r\n",
 689        $fmt_mode,
 690        $fmt_perms,
 691        $nlink,
 692        $user,
 693        $group,
 694        $size,
 695        $fmt_time,
 696        $filename,
 697        $fmt_link);
 698     $sock->print ($line);
 699 }
 700
 701
 702 sub __get_file_list
 703 {
 704     my $dir = shift;
 705     my $wildcard = shift;
 706
 707     opendir (DIRHANDLE, $dir)
 708         or die "Cannot open directory!!!";
 709
 710     my @allfiles = readdir DIRHANDLE;
 711     my @filenames = ();
 712
 713     if ($wildcard) {
 714         # Get rid of . and ..
 715         @allfiles = grep !/^\.{1,2}$/, @allfiles;
 716
 717         # Convert wildcard to a regular expression.
 718         $wildcard = __wildcard_to_regex ($wildcard);
 719
 720         @filenames = grep /$wildcard/, @allfiles;
 721     } else {
 722         @filenames = @allfiles;
 723     }
 724
 725     closedir (DIRHANDLE);
 726
 727     return sort @filenames;
 728 }
 729
 730
 731 sub __wildcard_to_regex
 732 {
 733     my $wildcard = shift;
 734
 735     $wildcard =~ s,([^?*a-zA-Z0-9]),\\$1,g; # Escape punctuation.
 736     $wildcard =~ s,\*,.*,g; # Turn * into .*
 737     $wildcard =~ s,\?,.,g;  # Turn ? into .
 738     $wildcard = "^$wildcard\$"; # Bracket it.
 739
 740     return $wildcard;
 741 }
 742
 743
 744 ###########################################################################
 745 # FTPSERVER CLASS
 746 ###########################################################################
 747
 748 {
 749     my %_attr_data = ( # DEFAULT
 750         _localAddr  => 'localhost',
 751         _localPort  => 8021,
 752         _reuseAddr  => 1,
 753         _rootDir    => Cwd::getcwd(),
 754     );
 755
 756     sub _default_for
 757     {
 758         my ($self, $attr) = @_;
 759         $_attr_data{$attr};
 760     }
 761
 762     sub _standard_keys
 763     {
 764         keys %_attr_data;
 765     }
 766 }
 767
 768
 769 sub new {
 770     my ($caller, %args) = @_;
 771     my $caller_is_obj = ref($caller);
 772     my $class = $caller_is_obj || $caller;
 773     my $self = bless {}, $class;
 774     foreach my $attrname ($self->_standard_keys()) {
 775         my ($argname) = ($attrname =~ /^_(.*)/);
 776         if (exists $args{$argname}) {
 777             $self->{$attrname} = $args{$argname};
 778         } elsif ($caller_is_obj) {
 779             $self->{$attrname} = $caller->{$attrname};
 780         } else {
 781             $self->{$attrname} = $self->_default_for($attrname);
 782         }
 783     }
 784     return $self;
 785 }
 786
 787
 788 sub run
 789 {
 790     my ($self, $synch_callback) = @_;
 791     my $initialized = 0;
 792
 793     # turn buffering off on STDERR
 794     select((select(STDERR), $|=1)[0]);
 795
 796     # initialize command table
 797     my $command_table = {};
 798     foreach (keys %_commands) {
 799         my $subname = "_${_}_command";
 800         $command_table->{$_} = \&$subname;
 801     }
 802
 803     my $old_ils = $/;
 804     $/ = "\r\n";
 805
 806     # create server socket
 807     "0" =~ /(0)/; # Perl 5.7 / IO::Socket::INET bug workaround.
 808     my $server_sock = IO::Socket::INET->new (LocalHost => $self->{_localAddr},
 809                                              LocalPort => $self->{_localPort},
 810                                              Listen => 1,
 811                                              Reuse => $self->{_reuseAddr},
 812                                              Proto => 'tcp',
 813                                              Type => SOCK_STREAM) or die "bind: $!";
 814
 815     if (!$initialized) {
 816         $synch_callback->();
 817         $initialized = 1;
 818     }
 819
 820     $SIG{CHLD} = sub { wait };
 821
 822     # the accept loop
 823     while (my $client_addr = accept (my $socket, $server_sock))
 824     {
 825         # turn buffering off on $socket
 826         select((select($socket), $|=1)[0]);
 827
 828         # find out who connected
 829         my ($client_port, $client_ip) = sockaddr_in ($client_addr);
 830         my $client_ipnum = inet_ntoa ($client_ip);
 831
 832         # print who connected
 833         print STDERR "got a connection from: $client_ipnum\n" if $log;
 834
 835         # fork off a process to handle this connection.
 836         my $pid = fork();
 837         unless (defined $pid) {
 838             warn "fork: $!";
 839             sleep 5; # Back off in case system is overloaded.
 840             next;
 841         }
 842
 843         if ($pid == 0) { # Child process.
 844
 845             # install signals
 846             $SIG{URG}  = sub {
 847                 $GOT_SIGURG  = 1;
 848             };
 849
 850             $SIG{PIPE} = sub {
 851                 print STDERR "Client closed connection abruptly.\n";
 852                 exit;
 853             };
 854
 855             $SIG{ALRM} = sub {
 856                 print STDERR "Connection idle timeout expired. Closing server.\n";
 857                 exit;
 858             };
 859
 860             #$SIG{CHLD} = 'IGNORE';
 861
 862
 863             print STDERR "in child\n" if $log;
 864
 865             my $conn = {
 866                 'socket'       => $socket,
 867                 'state'        => $_connection_states{NEWCONN},
 868                 'dir'          => '/',
 869                 'restart'      => 0,
 870                 'idle_timeout' => 60, # 1 minute timeout
 871                 'rootdir'      => $self->{_rootDir},
 872             };
 873
 874             print {$conn->{socket}} "220 GNU Wget Testing FTP Server ready.\r\n";
 875
 876             # command handling loop
 877             for (;;) {
 878                 print STDERR "waiting for request\n" if $log;
 879
 880                 last unless defined (my $req = <$socket>);
 881
 882                 # Remove trailing CRLF.
 883                 $req =~ s/[\n\r]+$//;
 884
 885                 print STDERR "received request $req\n" if $log;
 886
 887                 # Get the command.
 888                 # See also RFC 2640 section 3.1.
 889                 unless ($req =~ m/^([A-Z]{3,4})\s?(.*)/i) {
 890                     # badly formed command
 891                     exit 0;
 892                 }
 893
 894                 # The following strange 'eval' is necessary to work around a
 895                 # very odd bug in Perl 5.6.0. The following assignment to
 896                 # $cmd will fail in some cases unless you use $1 in some sort
 897                 # of an expression beforehand.
 898                 # - RWMJ 2002-07-05.
 899                 eval '$1 eq $1';
 900
 901                 my ($cmd, $rest) = (uc $1, $2);
 902
 903                 # Got a command which matches in the table?
 904                 unless (exists $command_table->{$cmd}) {
 905                     print {$conn->{socket}} "500 Unrecognized command.\r\n";
 906                     next;
 907                 }
 908
 909                 # Command requires user to be authenticated?
 910                 unless ($_commands{$cmd} | $conn->{state}) {
 911                     print {$conn->{socket}} "530 Not logged in.\r\n";
 912                     next;
 913                 }
 914
 915                 # Handle the QUIT command specially.
 916                 if ($cmd eq "QUIT") {
 917                     print {$conn->{socket}} "221 Goodbye. Service closing connection.\r\n";
 918                     last;
 919                 }
 920
 921                 # Run the command.
 922                 &{$command_table->{$cmd}} ($conn, $cmd, $rest);
 923             }
 924         } else { # Father
 925             close $socket;
 926         }
 927     }
 928
 929     $/ = $old_ils;
 930 }
 931
 932 1;
 933
 934 # vim: et ts=4 sw=4
 935