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

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