CMakeLua/Utilities/cmcurl-7.19.0/tests/ftpserver.pl

   1 #!/usr/bin/env perl
   2 #***************************************************************************
   3 #                                  _   _ ____  _
   4 #  Project                     ___| | | |  _ \| |
   5 #                             / __| | | | |_) | |
   6 #                            | (__| |_| |  _ <| |___
   7 #                             \___|\___/|_| \_\_____|
   8 #
   9 # Copyright (C) 1998 - 2008, Daniel Stenberg, <daniel@haxx.se>, et al.
  10 #
  11 # This software is licensed as described in the file COPYING, which
  12 # you should have received as part of this distribution. The terms
  13 # are also available at http://curl.haxx.se/docs/copyright.html.
  14 #
  15 # You may opt to use, copy, modify, merge, publish, distribute and/or sell
  16 # copies of the Software, and permit persons to whom the Software is
  17 # furnished to do so, under the terms of the COPYING file.
  18 #
  19 # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
  20 # KIND, either express or implied.
  21 #
  22 # $Id: ftpserver.pl,v 1.1.1.1 2008-09-23 16:32:06 hoffman Exp $
  23 ###########################################################################
  24
  25 # This is the FTP server designed for the curl test suite.
  26 #
  27 # It is meant to exercise curl, it is not meant to be a fully working
  28 # or even very standard compliant server.
  29 #
  30 # You may optionally specify port on the command line, otherwise it'll
  31 # default to port 8921.
  32 #
  33 # All socket/network/TCP related stuff is done by the 'sockfilt' program.
  34 #
  35
  36 use strict;
  37 use IPC::Open2;
  38 #use Time::HiRes qw( gettimeofday ); # not available in perl 5.6
  39
  40 require "getpart.pm";
  41 require "ftp.pm";
  42
  43
  44 my $ftpdnum="";
  45
  46 # open and close each time to allow removal at any time
  47 sub logmsg {
  48  # if later than perl 5.6 is used
  49  #   my ($seconds, $microseconds) = gettimeofday;
  50     my $seconds = time();
  51     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  52         localtime($seconds);
  53     open(FTPLOG, ">>log/ftpd$ftpdnum.log");
  54     printf FTPLOG ("%02d:%02d:%02d ", $hour, $min, $sec);
  55     print FTPLOG @_;
  56     close(FTPLOG);
  57 }
  58
  59 sub ftpmsg {
  60   # append to the server.input file
  61   open(INPUT, ">>log/server$ftpdnum.input") ||
  62     logmsg "failed to open log/server$ftpdnum.input\n";
  63
  64   print INPUT @_;
  65   close(INPUT);
  66
  67   # use this, open->print->close system only to make the file
  68   # open as little as possible, to make the test suite run
  69   # better on windows/cygwin
  70 }
  71
  72 my $verbose=0; # set to 1 for debugging
  73 my $pasvbadip=0;
  74 my $retrweirdo=0;
  75 my $retrnosize=0;
  76 my $srcdir=".";
  77 my $nosave=0;
  78 my $controldelay=0; # set to 1 to delay the control connect data sending to
  79  # test that curl deals with that nicely
  80 my $slavepid; # for the DATA connection sockfilt slave process
  81 my $ipv6;
  82 my $ext; # append to log/pid file names
  83 my $grok_eprt;
  84 my $port = 8921; # just a default
  85 my $listenaddr = "127.0.0.1"; # just a default
  86 my $pidfile = ".ftpd.pid"; # a default, use --pidfile
  87
  88 my $SERVERLOGS_LOCK="log/serverlogs.lock"; # server logs advisor read lock
  89
  90 do {
  91     if($ARGV[0] eq "-v") {
  92         $verbose=1;
  93     }
  94     elsif($ARGV[0] eq "-s") {
  95         $srcdir=$ARGV[1];
  96         shift @ARGV;
  97     }
  98     elsif($ARGV[0] eq "--id") {
  99         $ftpdnum=$ARGV[1];
 100         shift @ARGV;
 101     }
 102     elsif($ARGV[0] eq "--pidfile") {
 103         $pidfile=$ARGV[1];
 104         shift @ARGV;
 105     }
 106     elsif($ARGV[0] eq "--ipv6") {
 107         $ipv6="--ipv6";
 108         $ext="ipv6";
 109         $grok_eprt = 1;
 110     }
 111     elsif($ARGV[0] eq "--port") {
 112         $port = $ARGV[1];
 113         shift @ARGV;
 114     }
 115     elsif($ARGV[0] eq "--addr") {
 116         $listenaddr = $ARGV[1];
 117         $listenaddr =~ s/^\[(.*)\]$/\1/;
 118         shift @ARGV;
 119     }
 120 } while(shift @ARGV);
 121
 122 sub catch_zap {
 123     my $signame = shift;
 124     print STDERR "ftpserver.pl received SIG$signame, exiting\n";
 125     ftpkillslaves(1);
 126     clear_advisor_read_lock($SERVERLOGS_LOCK);
 127     die "Somebody sent me a SIG$signame";
 128 }
 129 $SIG{INT} = \&catch_zap;
 130 $SIG{KILL} = \&catch_zap;
 131
 132 my $sfpid;
 133
 134 local(*SFREAD, *SFWRITE);
 135
 136 sub sysread_or_die {
 137     my $FH     = shift;
 138     my $scalar = shift;
 139     my $length = shift;
 140     my $fcaller;
 141     my $lcaller;
 142     my $result;
 143
 144     $result = sysread($$FH, $$scalar, $length);
 145
 146     if(not defined $result) {
 147         ($fcaller, $lcaller) = (caller)[1,2];
 148         logmsg "Failed to read input\n";
 149         logmsg "Error: ftp$ftpdnum$ext sysread error: $!\n";
 150         kill(9, $sfpid);
 151         waitpid($sfpid, 0);
 152         clear_advisor_read_lock($SERVERLOGS_LOCK);
 153         die "Died in sysread_or_die() at $fcaller " .
 154             "line $lcaller. ftp$ftpdnum$ext sysread error: $!\n";
 155     }
 156     elsif($result == 0) {
 157         ($fcaller, $lcaller) = (caller)[1,2];
 158         logmsg "Failed to read input\n";
 159         logmsg "Error: ftp$ftpdnum$ext read zero\n";
 160         kill(9, $sfpid);
 161         waitpid($sfpid, 0);
 162         clear_advisor_read_lock($SERVERLOGS_LOCK);
 163         die "Died in sysread_or_die() at $fcaller " .
 164             "line $lcaller. ftp$ftpdnum$ext read zero\n";
 165     }
 166
 167     return $result;
 168 }
 169
 170 sub startsf {
 171     my $cmd="./server/sockfilt --port $port --logfile log/sockctrl$ftpdnum$ext.log --pidfile .sockfilt$ftpdnum$ext.pid $ipv6";
 172     $sfpid = open2(*SFREAD, *SFWRITE, $cmd);
 173
 174     print STDERR "$cmd\n" if($verbose);
 175
 176     print SFWRITE "PING\n";
 177     my $pong;
 178     sysread SFREAD, $pong, 5;
 179
 180     if($pong !~ /^PONG/) {
 181         logmsg "Failed sockfilt command: $cmd\n";
 182         kill(9, $sfpid);
 183         waitpid($sfpid, 0);
 184         clear_advisor_read_lock($SERVERLOGS_LOCK);
 185         die "Failed to start sockfilt!";
 186     }
 187 }
 188
 189 # remove the file here so that if startsf() fails, it is very noticeable
 190 unlink($pidfile);
 191
 192 startsf();
 193
 194 logmsg sprintf("FTP server listens on port IPv%d/$port\n", $ipv6?6:4);
 195 open(PID, ">$pidfile");
 196 print PID $$."\n";
 197 close(PID);
 198
 199 logmsg("logged pid $$ in $pidfile\n");
 200
 201 sub sockfilt {
 202     my $l;
 203     foreach $l (@_) {
 204         printf SFWRITE "DATA\n%04x\n", length($l);
 205         print SFWRITE $l;
 206     }
 207 }
 208
 209
 210 # Send data to the client on the control stream, which happens to be plain
 211 # stdout.
 212
 213 sub sendcontrol {
 214     if(!$controldelay) {
 215         # spit it all out at once
 216         sockfilt @_;
 217     }
 218     else {
 219         my $a = join("", @_);
 220         my @a = split("", $a);
 221
 222         for(@a) {
 223             sockfilt $_;
 224             select(undef, undef, undef, 0.01);
 225         }
 226     }
 227     my $log;
 228     foreach $log (@_) {
 229         my $l = $log;
 230         $l =~ s/[\r\n]//g;
 231         logmsg "> \"$l\"\n";
 232     }
 233 }
 234
 235 # Send data to the client on the data stream
 236
 237 sub senddata {
 238     my $l;
 239     foreach $l (@_) {
 240         printf DWRITE "DATA\n%04x\n", length($l);
 241         print DWRITE $l;
 242     }
 243 }
 244
 245 # this text is shown before the function specified below is run
 246 my %displaytext = ('USER' => '331 We are happy you popped in!',
 247                    'PASS' => '230 Welcome you silly person',
 248                    'PORT' => '200 You said PORT - I say FINE',
 249                    'TYPE' => '200 I modify TYPE as you wanted',
 250                    'LIST' => '150 here comes a directory',
 251                    'NLST' => '150 here comes a directory',
 252                    'CWD'  => '250 CWD command successful.',
 253                    'SYST' => '215 UNIX Type: L8', # just fake something
 254                    'QUIT' => '221 bye bye baby', # just reply something
 255                    'PWD'  => '257 "/nowhere/anywhere" is current directory',
 256                    'MKD'  => '257 Created your requested directory',
 257                    'REST' => '350 Yeah yeah we set it there for you',
 258                    'DELE' => '200 OK OK OK whatever you say',
 259                    'RNFR' => '350 Received your order. Please provide more',
 260                    'RNTO' => '250 Ok, thanks. File renaming completed.',
 261                    'NOOP' => '200 Yes, I\'m very good at doing nothing.',
 262                    'PBSZ' => '500 PBSZ not implemented',
 263                    'PROT' => '500 PROT not implemented',
 264                    );
 265
 266 # callback functions for certain commands
 267 my %commandfunc = ( 'PORT' => \&PORT_command,
 268                     'EPRT' => \&PORT_command,
 269                     'LIST' => \&LIST_command,
 270                     'NLST' => \&NLST_command,
 271                     'PASV' => \&PASV_command,
 272                     'EPSV' => \&PASV_command,
 273                     'RETR' => \&RETR_command,
 274                     'SIZE' => \&SIZE_command,
 275                     'REST' => \&REST_command,
 276                     'STOR' => \&STOR_command,
 277                     'APPE' => \&STOR_command, # append looks like upload
 278                     'MDTM' => \&MDTM_command,
 279                     );
 280
 281
 282 sub close_dataconn {
 283     my ($closed)=@_; # non-zero if already disconnected
 284
 285     if(!$closed) {
 286         logmsg "* disconnect data connection\n";
 287         print DWRITE "DISC\n";
 288         my $i;
 289         sysread DREAD, $i, 5;
 290     }
 291     else {
 292         logmsg "data connection already disconnected\n";
 293     }
 294     logmsg "=====> Closed data connection\n";
 295
 296     logmsg "* quit sockfilt for data (pid $slavepid)\n";
 297     print DWRITE "QUIT\n";
 298     waitpid $slavepid, 0;
 299     $slavepid=0;
 300 }
 301
 302 my $rest=0;
 303 sub REST_command {
 304     $rest = $_[0];
 305     logmsg "Set REST position to $rest\n"
 306 }
 307
 308 sub LIST_command {
 309   #  print "150 ASCII data connection for /bin/ls (193.15.23.1,59196) (0 bytes)\r\n";
 310
 311 # this is a built-in fake-dir ;-)
 312 my @ftpdir=("total 20\r\n",
 313 "drwxr-xr-x   8 98       98           512 Oct 22 13:06 .\r\n",
 314 "drwxr-xr-x   8 98       98           512 Oct 22 13:06 ..\r\n",
 315 "drwxr-xr-x   2 98       98           512 May  2  1996 .NeXT\r\n",
 316 "-r--r--r--   1 0        1             35 Jul 16  1996 README\r\n",
 317 "lrwxrwxrwx   1 0        1              7 Dec  9  1999 bin -> usr/bin\r\n",
 318 "dr-xr-xr-x   2 0        1            512 Oct  1  1997 dev\r\n",
 319 "drwxrwxrwx   2 98       98           512 May 29 16:04 download.html\r\n",
 320 "dr-xr-xr-x   2 0        1            512 Nov 30  1995 etc\r\n",
 321 "drwxrwxrwx   2 98       1            512 Oct 30 14:33 pub\r\n",
 322 "dr-xr-xr-x   5 0        1            512 Oct  1  1997 usr\r\n");
 323
 324     logmsg "pass LIST data on data connection\n";
 325     for(@ftpdir) {
 326         senddata $_;
 327     }
 328     close_dataconn(0);
 329     sendcontrol "226 ASCII transfer complete\r\n";
 330     return 0;
 331 }
 332
 333 sub NLST_command {
 334     my @ftpdir=("file", "with space", "fake", "..", " ..", "funny", "README");
 335     logmsg "pass NLST data on data connection\n";
 336     for(@ftpdir) {
 337         senddata "$_\r\n";
 338     }
 339     close_dataconn(0);
 340     sendcontrol "226 ASCII transfer complete\r\n";
 341     return 0;
 342 }
 343
 344 sub MDTM_command {
 345     my $testno = $_[0];
 346     my $testpart = "";
 347     if ($testno > 10000) {
 348         $testpart = $testno % 10000;
 349         $testno = int($testno / 10000);
 350     }
 351
 352     loadtest("$srcdir/data/test$testno");
 353
 354     my @data = getpart("reply", "mdtm");
 355
 356     my $reply = $data[0];
 357     chomp $reply;
 358
 359     if($reply <0) {
 360         sendcontrol "550 $testno: no such file.\r\n";
 361     }
 362     elsif($reply) {
 363         sendcontrol "$reply\r\n";
 364     }
 365     else {
 366         sendcontrol "500 MDTM: no such command.\r\n";
 367     }
 368     return 0;
 369 }
 370
 371 sub SIZE_command {
 372     my $testno = $_[0];
 373     my $testpart = "";
 374     if ($testno > 10000) {
 375         $testpart = $testno % 10000;
 376         $testno = int($testno / 10000);
 377     }
 378
 379     loadtest("$srcdir/data/test$testno");
 380
 381     if($testno eq "verifiedserver") {
 382         my $response = "WE ROOLZ: $$\r\n";
 383         my $size = length($response);
 384         sendcontrol "213 $size\r\n";
 385         return 0;
 386     }
 387
 388     my @data = getpart("reply", "size");
 389
 390     my $size = $data[0];
 391
 392     if($size) {
 393         if($size > -1) {
 394             sendcontrol "213 $size\r\n";
 395         }
 396         else {
 397             sendcontrol "550 $testno: No such file or directory.\r\n";
 398         }
 399     }
 400     else {
 401         $size=0;
 402         @data = getpart("reply", "data$testpart");
 403         for(@data) {
 404             $size += length($_);
 405         }
 406         if($size) {
 407             sendcontrol "213 $size\r\n";
 408         }
 409         else {
 410             sendcontrol "550 $testno: No such file or directory.\r\n";
 411         }
 412     }
 413     return 0;
 414 }
 415
 416 sub RETR_command {
 417     my ($testno) = @_;
 418
 419     if($testno =~ /^verifiedserver$/) {
 420         # this is the secret command that verifies that this actually is
 421         # the curl test server
 422         my $response = "WE ROOLZ: $$\r\n";
 423         my $len = length($response);
 424         sendcontrol "150 Binary junk ($len bytes).\r\n";
 425         senddata "WE ROOLZ: $$\r\n";
 426         close_dataconn(0);
 427         sendcontrol "226 File transfer complete\r\n";
 428         if($verbose) {
 429             print STDERR "FTPD: We returned proof we are the test server\n";
 430         }
 431         return 0;
 432     }
 433
 434     $testno =~ s/^([^0-9]*)//;
 435     my $testpart = "";
 436     if ($testno > 10000) {
 437         $testpart = $testno % 10000;
 438         $testno = int($testno / 10000);
 439     }
 440
 441     loadtest("$srcdir/data/test$testno");
 442
 443     my @data = getpart("reply", "data$testpart");
 444
 445     my $size=0;
 446     for(@data) {
 447         $size += length($_);
 448     }
 449
 450     my %hash = getpartattr("reply", "data$testpart");
 451
 452     if($size || $hash{'sendzero'}) {
 453
 454         if($rest) {
 455             # move read pointer forward
 456             $size -= $rest;
 457             logmsg "REST $rest was removed from size, makes $size left\n";
 458             $rest = 0; # reset REST offset again
 459         }
 460         if($retrweirdo) {
 461             sendcontrol "150 Binary data connection for $testno () ($size bytes).\r\n",
 462             "226 File transfer complete\r\n";
 463
 464             for(@data) {
 465                 my $send = $_;
 466                 senddata $send;
 467             }
 468             close_dataconn(0);
 469             $retrweirdo=0; # switch off the weirdo again!
 470         }
 471         else {
 472             my $sz = "($size bytes)";
 473             if($retrnosize) {
 474                 $sz = "size?";
 475             }
 476
 477             sendcontrol "150 Binary data connection for $testno () $sz.\r\n";
 478
 479             for(@data) {
 480                 my $send = $_;
 481                 senddata $send;
 482             }
 483             close_dataconn(0);
 484             sendcontrol "226 File transfer complete\r\n";
 485         }
 486     }
 487     else {
 488         sendcontrol "550 $testno: No such file or directory.\r\n";
 489     }
 490     return 0;
 491 }
 492
 493 sub STOR_command {
 494     my $testno=$_[0];
 495
 496     my $filename = "log/upload.$testno";
 497
 498     logmsg "STOR test number $testno in $filename\n";
 499
 500     sendcontrol "125 Gimme gimme gimme!\r\n";
 501
 502     open(FILE, ">$filename") ||
 503         return 0; # failed to open output
 504
 505     my $line;
 506     my $ulsize=0;
 507     my $disc=0;
 508     while (5 == (sysread DREAD, $line, 5)) {
 509         if($line eq "DATA\n") {
 510             my $i;
 511             sysread DREAD, $i, 5;
 512
 513             #print STDERR "  GOT: $i";
 514
 515             my $size = hex($i);
 516             sysread DREAD, $line, $size;
 517
 518             #print STDERR "  GOT: $size bytes\n";
 519
 520             $ulsize += $size;
 521             print FILE $line if(!$nosave);
 522             logmsg "> Appending $size bytes to file\n";
 523         }
 524         elsif($line eq "DISC\n") {
 525             # disconnect!
 526             $disc=1;
 527             last;
 528         }
 529         else {
 530             logmsg "No support for: $line";
 531             last;
 532         }
 533     }
 534     if($nosave) {
 535         print FILE "$ulsize bytes would've been stored here\n";
 536     }
 537     close(FILE);
 538     close_dataconn($disc);
 539     logmsg "received $ulsize bytes upload\n";
 540     sendcontrol "226 File transfer complete\r\n";
 541     return 0;
 542 }
 543
 544 sub PASV_command {
 545     my ($arg, $cmd)=@_;
 546     my $pasvport;
 547     my $pidf=".sockdata$ftpdnum$ext.pid";
 548
 549     my $prev = checkserver($pidf);
 550     if($prev > 0) {
 551         print "kill existing server: $prev\n" if($verbose);
 552         kill(9, $prev);
 553         waitpid($prev, 0);
 554     }
 555
 556     # We fire up a new sockfilt to do the data transfer for us.
 557     $slavepid = open2(\*DREAD, \*DWRITE,
 558                       "./server/sockfilt --port 0 --logfile log/sockdata$ftpdnum$ext.log --pidfile $pidf $ipv6");
 559
 560     print DWRITE "PING\n";
 561     my $pong;
 562
 563     sysread_or_die(\*DREAD, \$pong, 5);
 564
 565     if($pong !~ /^PONG/) {
 566         kill(9, $slavepid);
 567         waitpid($slavepid, 0);
 568         sendcontrol "500 no free ports!\r\n";
 569         logmsg "failed to run sockfilt for data connection\n";
 570         return 0;
 571     }
 572
 573     logmsg "Run sockfilt for data on pid $slavepid\n";
 574
 575     # Find out what port we listen on
 576     my $i;
 577     print DWRITE "PORT\n";
 578
 579     # READ the response code
 580     sysread_or_die(\*DREAD, \$i, 5);
 581
 582     # READ the response size
 583     sysread_or_die(\*DREAD, \$i, 5);
 584
 585     my $size = hex($i);
 586
 587     # READ the response data
 588     sysread_or_die(\*DREAD, \$i, $size);
 589
 590     # The data is in the format
 591     # IPvX/NNN
 592
 593     if($i =~ /IPv(\d)\/(\d+)/) {
 594         # FIX: deal with IP protocol version
 595         $pasvport = $2;
 596     }
 597
 598     if($cmd ne "EPSV") {
 599         # PASV reply
 600         my $p=$listenaddr;
 601         $p =~ s/\./,/g;
 602         if($pasvbadip) {
 603             $p="1,2,3,4";
 604         }
 605         sendcontrol sprintf("227 Entering Passive Mode ($p,%d,%d)\n",
 606                             ($pasvport/256), ($pasvport%256));
 607     }
 608     else {
 609         # EPSV reply
 610         sendcontrol sprintf("229 Entering Passive Mode (|||%d|)\n", $pasvport);
 611     }
 612
 613     eval {
 614         local $SIG{ALRM} = sub { die "alarm\n" };
 615
 616         # assume swift operations unless explicitly slow
 617         alarm ($controldelay?20:10);
 618
 619         # Wait for 'CNCT'
 620         my $input;
 621
 622         while(sysread(DREAD, $input, 5)) {
 623
 624             if($input !~ /^CNCT/) {
 625                 # we wait for a connected client
 626                 logmsg "Odd, we got $input from client\n";
 627                 next;
 628             }
 629             logmsg "====> Client DATA connect\n";
 630             last;
 631         }
 632         alarm 0;
 633     };
 634     if ($@) {
 635         # timed out
 636
 637         print DWRITE "QUIT\n";
 638         waitpid $slavepid, 0;
 639         logmsg "accept failed\n";
 640         $slavepid=0;
 641         return;
 642     }
 643     else {
 644         logmsg "data connection setup on port $pasvport\n";
 645     }
 646
 647     return;
 648 }
 649
 650 # Support both PORT and EPRT here. Consider LPRT too.
 651
 652 sub PORT_command {
 653     my ($arg, $cmd) = @_;
 654     my $port;
 655     my $addr;
 656
 657     # We always ignore the given IP and use localhost.
 658
 659     if($cmd eq "PORT") {
 660         if($arg !~ /(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/) {
 661             logmsg "bad PORT-line: $arg\n";
 662             sendcontrol "500 silly you, go away\r\n";
 663             return 0;
 664         }
 665         $port = ($5<<8)+$6;
 666         $addr = "$1.$2.$3.$4";
 667     }
 668     # EPRT |2|::1|49706|
 669     elsif(($cmd eq "EPRT") && ($grok_eprt)) {
 670         if($arg !~ /(\d+)\|([^\|]+)\|(\d+)/) {
 671             sendcontrol "500 silly you, go away\r\n";
 672             return 0;
 673         }
 674         sendcontrol "200 Thanks for dropping by. We contact you later\r\n";
 675         $port = $3;
 676         $addr = $2;
 677     }
 678     else {
 679         sendcontrol "500 we don't like $cmd now\r\n";
 680         return 0;
 681     }
 682
 683     if(!$port || $port > 65535) {
 684         print STDERR "very illegal PORT number: $port\n";
 685         return 1;
 686     }
 687
 688     # We fire up a new sockfilt to do the data transfer for us.
 689     # FIX: make it use IPv6 if need be
 690     my $filtcmd="./server/sockfilt --connect $port --addr $addr --logfile log/sockdata$ftpdnum$ext.log --pidfile .sockdata$ftpdnum$ext.pid $ipv6";
 691     $slavepid = open2(\*DREAD, \*DWRITE, $filtcmd);
 692
 693     print STDERR "$filtcmd\n" if($verbose);
 694
 695     print DWRITE "PING\n";
 696     my $pong;
 697     sysread DREAD, $pong, 5;
 698
 699     if($pong !~ /^PONG/) {
 700         logmsg "Failed sockfilt for data connection\n";
 701         kill(9, $slavepid);
 702         waitpid($slavepid, 0);
 703     }
 704
 705     logmsg "====> Client DATA connect to port $port\n";
 706
 707     return;
 708 }
 709
 710 my %customreply;
 711 my %customcount;
 712 my %delayreply;
 713 sub customize {
 714     $nosave = 0; # default is to save as normal
 715     $controldelay = 0; # default is no delaying the responses
 716     $retrweirdo = 0;
 717     $retrnosize = 0;
 718     $pasvbadip = 0;
 719     $nosave = 0;
 720     %customreply = ();
 721     %customcount = ();
 722     %delayreply = ();
 723
 724     open(CUSTOM, "<log/ftpserver.cmd") ||
 725         return 1;
 726
 727     logmsg "FTPD: Getting commands from log/ftpserver.cmd\n";
 728
 729     while(<CUSTOM>) {
 730         if($_ =~ /REPLY ([A-Z]+) (.*)/) {
 731             $customreply{$1}=eval "qq{$2}";
 732             logmsg "FTPD: set custom reply for $1\n";
 733         }
 734         if($_ =~ /COUNT ([A-Z]+) (.*)/) {
 735             # we blank the customreply for this command when having
 736             # been used this number of times
 737             $customcount{$1}=$2;
 738             logmsg "FTPD: blank custom reply for $1 after $2 uses\n";
 739         }
 740         elsif($_ =~ /DELAY ([A-Z]+) (\d*)/) {
 741             $delayreply{$1}=$2;
 742             logmsg "FTPD: delay reply for $1 with $2 seconds\n";
 743         }
 744         elsif($_ =~ /SLOWDOWN/) {
 745             $controldelay=1;
 746             logmsg "FTPD: send response with 0.1 sec delay between each byte\n";
 747         }
 748         elsif($_ =~ /RETRWEIRDO/) {
 749             logmsg "FTPD: instructed to use RETRWEIRDO\n";
 750             $retrweirdo=1;
 751         }
 752         elsif($_ =~ /RETRNOSIZE/) {
 753             logmsg "FTPD: instructed to use RETRNOSIZE\n";
 754             $retrnosize=1;
 755         }
 756         elsif($_ =~ /PASVBADIP/) {
 757             logmsg "FTPD: instructed to use PASVBADIP\n";
 758             $pasvbadip=1;
 759         }
 760         elsif($_ =~ /NOSAVE/) {
 761             # don't actually store the file we upload - to be used when
 762             # uploading insanely huge amounts
 763             $nosave = 1;
 764             logmsg "FTPD: NOSAVE prevents saving of uploaded data\n";
 765         }
 766     }
 767     close(CUSTOM);
 768 }
 769
 770 my @welcome=(
 771             '220-        _   _ ____  _     '."\r\n",
 772             '220-    ___| | | |  _ \| |    '."\r\n",
 773             '220-   / __| | | | |_) | |    '."\r\n",
 774             '220-  | (__| |_| |  _ <| |___ '."\r\n",
 775             '220    \___|\___/|_| \_\_____|'."\r\n");
 776
 777
 778 while(1) {
 779     #
 780     # We read 'sockfilt' commands.
 781     #
 782     my $input;
 783
 784     logmsg "Awaiting input\n";
 785     sysread_or_die(\*SFREAD, \$input, 5);
 786
 787     if($input !~ /^CNCT/) {
 788         # we wait for a connected client
 789         logmsg "sockfilt said: $input";
 790         next;
 791     }
 792     logmsg "====> Client connect\n";
 793
 794     set_advisor_read_lock($SERVERLOGS_LOCK);
 795
 796     # flush data:
 797     $| = 1;
 798
 799     kill(9, $slavepid) if($slavepid);
 800     waitpid($slavepid, 0) if($slavepid);
 801     $slavepid=0;
 802
 803     &customize(); # read test control instructions
 804
 805     sendcontrol @welcome;
 806     if($verbose) {
 807         for(@welcome) {
 808             print STDERR "OUT: $_";
 809         }
 810     }
 811
 812     while(1) {
 813         my $i;
 814
 815         # Now we expect to read DATA\n[hex size]\n[prot], where the [prot]
 816         # part only is FTP lingo.
 817
 818         # COMMAND
 819         sysread_or_die(\*SFREAD, \$i, 5);
 820
 821         if($i !~ /^DATA/) {
 822             logmsg "sockfilt said $i";
 823             if($i =~ /^DISC/) {
 824                 # disconnect
 825                 last;
 826             }
 827             next;
 828         }
 829
 830         # SIZE of data
 831         sysread_or_die(\*SFREAD, \$i, 5);
 832
 833         my $size = hex($i);
 834
 835         # data
 836         sysread SFREAD, $_, $size;
 837
 838         ftpmsg $_;
 839
 840         # Remove trailing CRLF.
 841         s/[\n\r]+$//;
 842
 843         unless (m/^([A-Z]{3,4})\s?(.*)/i) {
 844             sendcontrol "500 '$_': command not understood.\r\n";
 845             last;
 846         }
 847         my $FTPCMD=$1;
 848         my $FTPARG=$2;
 849         my $full=$_;
 850
 851         logmsg "< \"$full\"\n";
 852
 853         if($verbose) {
 854             print STDERR "IN: $full\n";
 855         }
 856
 857         my $delay = $delayreply{$FTPCMD};
 858         if($delay) {
 859             # just go sleep this many seconds!
 860             logmsg("Sleep for $delay seconds\n");
 861             sleep($delay);
 862         }
 863
 864         my $text;
 865         $text = $customreply{$FTPCMD};
 866         my $fake = $text;
 867         if($text eq "") {
 868             $text = $displaytext{$FTPCMD};
 869         }
 870         else {
 871             if($customcount{$FTPCMD} && (!--$customcount{$FTPCMD})) {
 872                 # used enough number of times, now blank the customreply
 873                 $customreply{$FTPCMD}="";
 874             }
 875         }
 876         my $check;
 877         if($text) {
 878             sendcontrol "$text\r\n";
 879         }
 880         else {
 881             $check=1; # no response yet
 882         }
 883
 884         if($fake eq "") {
 885             # only perform this if we're not faking a reply
 886             my $func = $commandfunc{$FTPCMD};
 887             if($func) {
 888                 &$func($FTPARG, $FTPCMD);
 889                 $check=0; # taken care of
 890             }
 891         }
 892
 893         if($check) {
 894             logmsg "$FTPCMD wasn't handled!\n";
 895             sendcontrol "500 $FTPCMD is not dealt with!\r\n";
 896         }
 897
 898     } # while(1)
 899     logmsg "====> Client disconnected\n";
 900
 901     clear_advisor_read_lock($SERVERLOGS_LOCK);
 902 }
 903
 904 print SFWRITE "QUIT\n";
 905 waitpid $sfpid, 0;
 906
 907 clear_advisor_read_lock($SERVERLOGS_LOCK);
 908
 909 exit;