tests/ftpserver.pl

   1 #!/usr/bin/env perl
   2 #***************************************************************************
   3 #                                  _   _ ____  _
   4 #  Project                     ___| | | |  _ \| |
   5 #                             / __| | | | |_) | |
   6 #                            | (__| |_| |  _ <| |___
   7 #                             \___|\___/|_| \_\_____|
   8 #
   9 # Copyright (C) 1998 - 2013, 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 ###########################################################################
  23
  24 # This is a server designed for the curl test suite.
  25 #
  26 # In December 2009 we started remaking the server to support more protocols
  27 # that are similar in spirit. Like POP3, IMAP and SMTP in addition to the FTP
  28 # it already supported since a long time. Note that it still only supports one
  29 # protocol per invoke. You need to start multiple servers to support multiple
  30 # protocols simultaneously.
  31 #
  32 # It is meant to exercise curl, it is not meant to be a fully working
  33 # or even very standard compliant server.
  34 #
  35 # You may optionally specify port on the command line, otherwise it'll
  36 # default to port 8921.
  37 #
  38 # All socket/network/TCP related stuff is done by the 'sockfilt' program.
  39 #
  40
  41 BEGIN {
  42     push(@INC, $ENV{'srcdir'}) if(defined $ENV{'srcdir'});
  43     push(@INC, ".");
  44     # sub second timestamping needs Time::HiRes
  45     eval {
  46         no warnings "all";
  47         require Time::HiRes;
  48         import  Time::HiRes qw( gettimeofday );
  49     }
  50 }
  51
  52 use strict;
  53 use warnings;
  54 use IPC::Open2;
  55
  56 require "getpart.pm";
  57 require "ftp.pm";
  58 require "directories.pm";
  59
  60 use serverhelp qw(
  61     servername_str
  62     server_pidfilename
  63     server_logfilename
  64     mainsockf_pidfilename
  65     mainsockf_logfilename
  66     datasockf_pidfilename
  67     datasockf_logfilename
  68     );
  69
  70 #**********************************************************************
  71 # global vars...
  72 #
  73 my $verbose = 0;    # set to 1 for debugging
  74 my $idstr = "";     # server instance string
  75 my $idnum = 1;      # server instance number
  76 my $ipvnum = 4;     # server IPv number (4 or 6)
  77 my $proto = 'ftp';  # default server protocol
  78 my $srcdir;         # directory where ftpserver.pl is located
  79 my $srvrname;       # server name for presentation purposes
  80
  81 my $path   = '.';
  82 my $logdir = $path .'/log';
  83
  84 #**********************************************************************
  85 # global vars used for server address and primary listener port
  86 #
  87 my $port = 8921;               # default primary listener port
  88 my $listenaddr = '127.0.0.1';  # default address for listener port
  89
  90 #**********************************************************************
  91 # global vars used for file names
  92 #
  93 my $pidfile;            # server pid file name
  94 my $logfile;            # server log file name
  95 my $mainsockf_pidfile;  # pid file for primary connection sockfilt process
  96 my $mainsockf_logfile;  # log file for primary connection sockfilt process
  97 my $datasockf_pidfile;  # pid file for secondary connection sockfilt process
  98 my $datasockf_logfile;  # log file for secondary connection sockfilt process
  99
 100 #**********************************************************************
 101 # global vars used for server logs advisor read lock handling
 102 #
 103 my $SERVERLOGS_LOCK = 'log/serverlogs.lock';
 104 my $serverlogslocked = 0;
 105
 106 #**********************************************************************
 107 # global vars used for child processes PID tracking
 108 #
 109 my $sfpid;        # PID for primary connection sockfilt process
 110 my $slavepid;     # PID for secondary connection sockfilt process
 111
 112 #**********************************************************************
 113 # global typeglob filehandle vars to read/write from/to sockfilters
 114 #
 115 local *SFREAD;    # used to read from primary connection
 116 local *SFWRITE;   # used to write to primary connection
 117 local *DREAD;     # used to read from secondary connection
 118 local *DWRITE;    # used to write to secondary connection
 119
 120 my $sockfilt_timeout = 5;  # default timeout for sockfilter eXsysreads
 121
 122 #**********************************************************************
 123 # global vars which depend on server protocol selection
 124 #
 125 my %commandfunc;  # protocol command specific function callbacks
 126 my %displaytext;  # text returned to client before callback runs
 127
 128 #**********************************************************************
 129 # global vars customized for each test from the server commands file
 130 #
 131 my $ctrldelay;     # set if server should throttle ctrl stream
 132 my $datadelay;     # set if server should throttle data stream
 133 my $retrweirdo;    # set if ftp server should use RETRWEIRDO
 134 my $retrnosize;    # set if ftp server should use RETRNOSIZE
 135 my $pasvbadip;     # set if ftp server should use PASVBADIP
 136 my $nosave;        # set if ftp server should not save uploaded data
 137 my $nodataconn;    # set if ftp srvr doesn't establish or accepts data channel
 138 my $nodataconn425; # set if ftp srvr doesn't establish data ch and replies 425
 139 my $nodataconn421; # set if ftp srvr doesn't establish data ch and replies 421
 140 my $nodataconn150; # set if ftp srvr doesn't establish data ch and replies 150
 141 my $support_capa;  # set if server supports capability command
 142 my $support_auth;  # set if server supports authentication command
 143 my %customreply;   #
 144 my %customcount;   #
 145 my %delayreply;    #
 146
 147 #**********************************************************************
 148 # global variables for to test ftp wildcardmatching or other test that
 149 # need flexible LIST responses.. and corresponding files.
 150 # $ftptargetdir is keeping the fake "name" of LIST directory.
 151 #
 152 my $ftplistparserstate;
 153 my $ftptargetdir;
 154
 155 #**********************************************************************
 156 # global variables used when running a ftp server to keep state info
 157 # relative to the secondary or data sockfilt process. Values of these
 158 # variables should only be modified using datasockf_state() sub, given
 159 # that they are closely related and relationship is a bit awkward.
 160 #
 161 my $datasockf_state = 'STOPPED'; # see datasockf_state() sub
 162 my $datasockf_mode = 'none';     # ['none','active','passive']
 163 my $datasockf_runs = 'no';       # ['no','yes']
 164 my $datasockf_conn = 'no';       # ['no','yes']
 165
 166 #**********************************************************************
 167 # global vars used for signal handling
 168 #
 169 my $got_exit_signal = 0; # set if program should finish execution ASAP
 170 my $exit_signal;         # first signal handled in exit_signal_handler
 171
 172 #**********************************************************************
 173 # exit_signal_handler will be triggered to indicate that the program
 174 # should finish its execution in a controlled way as soon as possible.
 175 # For now, program will also terminate from within this handler.
 176 #
 177 sub exit_signal_handler {
 178     my $signame = shift;
 179     # For now, simply mimic old behavior.
 180     killsockfilters($proto, $ipvnum, $idnum, $verbose);
 181     unlink($pidfile);
 182     if($serverlogslocked) {
 183         $serverlogslocked = 0;
 184         clear_advisor_read_lock($SERVERLOGS_LOCK);
 185     }
 186     exit;
 187 }
 188
 189 #**********************************************************************
 190 # logmsg is general message logging subroutine for our test servers.
 191 #
 192 sub logmsg {
 193     my $now;
 194     # sub second timestamping needs Time::HiRes
 195     if($Time::HiRes::VERSION) {
 196         my ($seconds, $usec) = gettimeofday();
 197         my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
 198             localtime($seconds);
 199         $now = sprintf("%02d:%02d:%02d.%06d ", $hour, $min, $sec, $usec);
 200     }
 201     else {
 202         my $seconds = time();
 203         my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
 204             localtime($seconds);
 205         $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec);
 206     }
 207     if(open(LOGFILEFH, ">>$logfile")) {
 208         print LOGFILEFH $now;
 209         print LOGFILEFH @_;
 210         close(LOGFILEFH);
 211     }
 212 }
 213
 214 sub ftpmsg {
 215   # append to the server.input file
 216   open(INPUT, ">>log/server$idstr.input") ||
 217     logmsg "failed to open log/server$idstr.input\n";
 218
 219   print INPUT @_;
 220   close(INPUT);
 221
 222   # use this, open->print->close system only to make the file
 223   # open as little as possible, to make the test suite run
 224   # better on windows/cygwin
 225 }
 226
 227 #**********************************************************************
 228 # eXsysread is a wrapper around perl's sysread() function. This will
 229 # repeat the call to sysread() until it has actually read the complete
 230 # number of requested bytes or an unrecoverable condition occurs.
 231 # On success returns a positive value, the number of bytes requested.
 232 # On failure or timeout returns zero.
 233 #
 234 sub eXsysread {
 235     my $FH      = shift;
 236     my $scalar  = shift;
 237     my $nbytes  = shift;
 238     my $timeout = shift; # A zero timeout disables eXsysread() time limit
 239     #
 240     my $time_limited = 0;
 241     my $timeout_rest = 0;
 242     my $start_time = 0;
 243     my $nread  = 0;
 244     my $rc;
 245
 246     $$scalar = "";
 247
 248     if((not defined $nbytes) || ($nbytes < 1)) {
 249         logmsg "Error: eXsysread() failure: " .
 250                "length argument must be positive\n";
 251         return 0;
 252     }
 253     if((not defined $timeout) || ($timeout < 0)) {
 254         logmsg "Error: eXsysread() failure: " .
 255                "timeout argument must be zero or positive\n";
 256         return 0;
 257     }
 258     if($timeout > 0) {
 259         # caller sets eXsysread() time limit
 260         $time_limited = 1;
 261         $timeout_rest = $timeout;
 262         $start_time = int(time());
 263     }
 264
 265     while($nread < $nbytes) {
 266         if($time_limited) {
 267             eval {
 268                 local $SIG{ALRM} = sub { die "alarm\n"; };
 269                 alarm $timeout_rest;
 270                 $rc = sysread($FH, $$scalar, $nbytes - $nread, $nread);
 271                 alarm 0;
 272             };
 273             $timeout_rest = $timeout - (int(time()) - $start_time);
 274             if($timeout_rest < 1) {
 275                 logmsg "Error: eXsysread() failure: timed out\n";
 276                 return 0;
 277             }
 278         }
 279         else {
 280             $rc = sysread($FH, $$scalar, $nbytes - $nread, $nread);
 281         }
 282         if($got_exit_signal) {
 283             logmsg "Error: eXsysread() failure: signalled to die\n";
 284             return 0;
 285         }
 286         if(not defined $rc) {
 287             if($!{EINTR}) {
 288                 logmsg "Warning: retrying sysread() interrupted system call\n";
 289                 next;
 290             }
 291             if($!{EAGAIN}) {
 292                 logmsg "Warning: retrying sysread() due to EAGAIN\n";
 293                 next;
 294             }
 295             if($!{EWOULDBLOCK}) {
 296                 logmsg "Warning: retrying sysread() due to EWOULDBLOCK\n";
 297                 next;
 298             }
 299             logmsg "Error: sysread() failure: $!\n";
 300             return 0;
 301         }
 302         if($rc < 0) {
 303             logmsg "Error: sysread() failure: returned negative value $rc\n";
 304             return 0;
 305         }
 306         if($rc == 0) {
 307             logmsg "Error: sysread() failure: read zero bytes\n";
 308             return 0;
 309         }
 310         $nread += $rc;
 311     }
 312     return $nread;
 313 }
 314
 315 #**********************************************************************
 316 # read_mainsockf attempts to read the given amount of output from the
 317 # sockfilter which is in use for the main or primary connection. This
 318 # reads untranslated sockfilt lingo which may hold data read from the
 319 # main or primary socket. On success returns 1, otherwise zero.
 320 #
 321 sub read_mainsockf {
 322     my $scalar  = shift;
 323     my $nbytes  = shift;
 324     my $timeout = shift; # Optional argument, if zero blocks indefinitively
 325     my $FH = \*SFREAD;
 326
 327     if(not defined $timeout) {
 328         $timeout = $sockfilt_timeout + ($nbytes >> 12);
 329     }
 330     if(eXsysread($FH, $scalar, $nbytes, $timeout) != $nbytes) {
 331         my ($fcaller, $lcaller) = (caller)[1,2];
 332         logmsg "Error: read_mainsockf() failure at $fcaller " .
 333                "line $lcaller. Due to eXsysread() failure\n";
 334         return 0;
 335     }
 336     return 1;
 337 }
 338
 339 #**********************************************************************
 340 # read_datasockf attempts to read the given amount of output from the
 341 # sockfilter which is in use for the data or secondary connection. This
 342 # reads untranslated sockfilt lingo which may hold data read from the
 343 # data or secondary socket. On success returns 1, otherwise zero.
 344 #
 345 sub read_datasockf {
 346     my $scalar = shift;
 347     my $nbytes = shift;
 348     my $timeout = shift; # Optional argument, if zero blocks indefinitively
 349     my $FH = \*DREAD;
 350
 351     if(not defined $timeout) {
 352         $timeout = $sockfilt_timeout + ($nbytes >> 12);
 353     }
 354     if(eXsysread($FH, $scalar, $nbytes, $timeout) != $nbytes) {
 355         my ($fcaller, $lcaller) = (caller)[1,2];
 356         logmsg "Error: read_datasockf() failure at $fcaller " .
 357                "line $lcaller. Due to eXsysread() failure\n";
 358         return 0;
 359     }
 360     return 1;
 361 }
 362
 363 sub sysread_or_die {
 364     my $FH     = shift;
 365     my $scalar = shift;
 366     my $length = shift;
 367     my $fcaller;
 368     my $lcaller;
 369     my $result;
 370
 371     $result = sysread($$FH, $$scalar, $length);
 372
 373     if(not defined $result) {
 374         ($fcaller, $lcaller) = (caller)[1,2];
 375         logmsg "Failed to read input\n";
 376         logmsg "Error: $srvrname server, sysread error: $!\n";
 377         logmsg "Exited from sysread_or_die() at $fcaller " .
 378                "line $lcaller. $srvrname server, sysread error: $!\n";
 379         killsockfilters($proto, $ipvnum, $idnum, $verbose);
 380         unlink($pidfile);
 381         if($serverlogslocked) {
 382             $serverlogslocked = 0;
 383             clear_advisor_read_lock($SERVERLOGS_LOCK);
 384         }
 385         exit;
 386     }
 387     elsif($result == 0) {
 388         ($fcaller, $lcaller) = (caller)[1,2];
 389         logmsg "Failed to read input\n";
 390         logmsg "Error: $srvrname server, read zero\n";
 391         logmsg "Exited from sysread_or_die() at $fcaller " .
 392                "line $lcaller. $srvrname server, read zero\n";
 393         killsockfilters($proto, $ipvnum, $idnum, $verbose);
 394         unlink($pidfile);
 395         if($serverlogslocked) {
 396             $serverlogslocked = 0;
 397             clear_advisor_read_lock($SERVERLOGS_LOCK);
 398         }
 399         exit;
 400     }
 401
 402     return $result;
 403 }
 404
 405 sub startsf {
 406     my $mainsockfcmd = "./server/sockfilt " .
 407         "--ipv$ipvnum --port $port " .
 408         "--pidfile \"$mainsockf_pidfile\" " .
 409         "--logfile \"$mainsockf_logfile\"";
 410     $sfpid = open2(*SFREAD, *SFWRITE, $mainsockfcmd);
 411
 412     print STDERR "$mainsockfcmd\n" if($verbose);
 413
 414     print SFWRITE "PING\n";
 415     my $pong;
 416     sysread_or_die(\*SFREAD, \$pong, 5);
 417
 418     if($pong !~ /^PONG/) {
 419         logmsg "Failed sockfilt command: $mainsockfcmd\n";
 420         killsockfilters($proto, $ipvnum, $idnum, $verbose);
 421         unlink($pidfile);
 422         if($serverlogslocked) {
 423             $serverlogslocked = 0;
 424             clear_advisor_read_lock($SERVERLOGS_LOCK);
 425         }
 426         die "Failed to start sockfilt!";
 427     }
 428 }
 429
 430
 431 sub sockfilt {
 432     my $l;
 433     foreach $l (@_) {
 434         printf SFWRITE "DATA\n%04x\n", length($l);
 435         print SFWRITE $l;
 436     }
 437 }
 438
 439
 440 sub sockfiltsecondary {
 441     my $l;
 442     foreach $l (@_) {
 443         printf DWRITE "DATA\n%04x\n", length($l);
 444         print DWRITE $l;
 445     }
 446 }
 447
 448
 449 # Send data to the client on the control stream, which happens to be plain
 450 # stdout.
 451
 452 sub sendcontrol {
 453     if(!$ctrldelay) {
 454         # spit it all out at once
 455         sockfilt @_;
 456     }
 457     else {
 458         my $a = join("", @_);
 459         my @a = split("", $a);
 460
 461         for(@a) {
 462             sockfilt $_;
 463             select(undef, undef, undef, 0.01);
 464         }
 465     }
 466     my $log;
 467     foreach $log (@_) {
 468         my $l = $log;
 469         $l =~ s/\r/[CR]/g;
 470         $l =~ s/\n/[LF]/g;
 471         logmsg "> \"$l\"\n";
 472     }
 473 }
 474
 475 #**********************************************************************
 476 # Send data to the FTP client on the data stream when data connection
 477 # is actually established. Given that this sub should only be called
 478 # when a data connection is supposed to be established, calling this
 479 # without a data connection is an indication of weak logic somewhere.
 480 #
 481 sub senddata {
 482     my $l;
 483     if($datasockf_conn eq 'no') {
 484         logmsg "WARNING: Detected data sending attempt without DATA channel\n";
 485         foreach $l (@_) {
 486             logmsg "WARNING: Data swallowed: $l\n"
 487         }
 488         return;
 489     }
 490     foreach $l (@_) {
 491       if(!$datadelay) {
 492         # spit it all out at once
 493         sockfiltsecondary $l;
 494       }
 495       else {
 496           # pause between each byte
 497           for (split(//,$l)) {
 498               sockfiltsecondary $_;
 499               select(undef, undef, undef, 0.01);
 500           }
 501       }
 502     }
 503 }
 504
 505 #**********************************************************************
 506 # protocolsetup initializes the 'displaytext' and 'commandfunc' hashes
 507 # for the given protocol. References to protocol command callbacks are
 508 # stored in 'commandfunc' hash, and text which will be returned to the
 509 # client before the command callback runs is stored in 'displaytext'.
 510 #
 511 sub protocolsetup {
 512     my $proto = $_[0];
 513
 514     if($proto eq 'ftp') {
 515         %commandfunc = (
 516             'PORT' => \&PORT_ftp,
 517             'EPRT' => \&PORT_ftp,
 518             'LIST' => \&LIST_ftp,
 519             'NLST' => \&NLST_ftp,
 520             'PASV' => \&PASV_ftp,
 521             'CWD'  => \&CWD_ftp,
 522             'PWD'  => \&PWD_ftp,
 523             'EPSV' => \&PASV_ftp,
 524             'RETR' => \&RETR_ftp,
 525             'SIZE' => \&SIZE_ftp,
 526             'REST' => \&REST_ftp,
 527             'STOR' => \&STOR_ftp,
 528             'APPE' => \&STOR_ftp, # append looks like upload
 529             'MDTM' => \&MDTM_ftp,
 530         );
 531         %displaytext = (
 532             'USER' => '331 We are happy you popped in!',
 533             'PASS' => '230 Welcome you silly person',
 534             'PORT' => '200 You said PORT - I say FINE',
 535             'TYPE' => '200 I modify TYPE as you wanted',
 536             'LIST' => '150 here comes a directory',
 537             'NLST' => '150 here comes a directory',
 538             'CWD'  => '250 CWD command successful.',
 539             'SYST' => '215 UNIX Type: L8', # just fake something
 540             'QUIT' => '221 bye bye baby', # just reply something
 541             'MKD'  => '257 Created your requested directory',
 542             'REST' => '350 Yeah yeah we set it there for you',
 543             'DELE' => '200 OK OK OK whatever you say',
 544             'RNFR' => '350 Received your order. Please provide more',
 545             'RNTO' => '250 Ok, thanks. File renaming completed.',
 546             'NOOP' => '200 Yes, I\'m very good at doing nothing.',
 547             'PBSZ' => '500 PBSZ not implemented',
 548             'PROT' => '500 PROT not implemented',
 549             'welcome' => join("",
 550             '220-        _   _ ____  _     '."\r\n",
 551             '220-    ___| | | |  _ \| |    '."\r\n",
 552             '220-   / __| | | | |_) | |    '."\r\n",
 553             '220-  | (__| |_| |  _ <| |___ '."\r\n",
 554             '220    \___|\___/|_| \_\_____|'."\r\n")
 555         );
 556     }
 557     elsif($proto eq 'pop3') {
 558         %commandfunc = (
 559             'CAPA' => \&CAPA_pop3,
 560             'AUTH' => \&AUTH_pop3,
 561             'RETR' => \&RETR_pop3,
 562             'LIST' => \&LIST_pop3,
 563         );
 564         %displaytext = (
 565             'USER' => '+OK We are happy you popped in!',
 566             'PASS' => '+OK Access granted',
 567             'QUIT' => '+OK byebye',
 568             'welcome' => join("",
 569             '        _   _ ____  _     '."\r\n",
 570             '    ___| | | |  _ \| |    '."\r\n",
 571             '   / __| | | | |_) | |    '."\r\n",
 572             '  | (__| |_| |  _ <| |___ '."\r\n",
 573             '   \___|\___/|_| \_\_____|'."\r\n",
 574             '+OK cURL POP3 server ready to serve'."\r\n")
 575         );
 576     }
 577     elsif($proto eq 'imap') {
 578         %commandfunc = (
 579             'APPEND' => \&APPEND_imap,
 580             'CAPABILITY' => \&CAPABILITY_imap,
 581             'EXAMINE' => \&EXAMINE_imap,
 582             'FETCH'  => \&FETCH_imap,
 583             'LIST'   => \&LIST_imap,
 584             'LOGOUT'   => \&LOGOUT_imap,
 585             'SELECT' => \&SELECT_imap,
 586             'STATUS'  => \&STATUS_imap,
 587             'STORE'  => \&STORE_imap
 588         );
 589         %displaytext = (
 590             'LOGIN'  => ' OK LOGIN completed',
 591             'welcome' => join("",
 592             '        _   _ ____  _     '."\r\n",
 593             '    ___| | | |  _ \| |    '."\r\n",
 594             '   / __| | | | |_) | |    '."\r\n",
 595             '  | (__| |_| |  _ <| |___ '."\r\n",
 596             '   \___|\___/|_| \_\_____|'."\r\n",
 597             '* OK cURL IMAP server ready to serve'."\r\n")
 598         );
 599     }
 600     elsif($proto eq 'smtp') {
 601         %commandfunc = (
 602             'DATA' => \&DATA_smtp,
 603             'RCPT' => \&RCPT_smtp,
 604         );
 605         %displaytext = (
 606             'EHLO' => "250-SIZE\r\n250 Welcome visitor, stay a while staaaaaay forever",
 607             'MAIL' => '200 Note taken',
 608             'RCPT' => '200 Receivers accepted',
 609             'QUIT' => '200 byebye',
 610             'welcome' => join("",
 611             '220-        _   _ ____  _     '."\r\n",
 612             '220-    ___| | | |  _ \| |    '."\r\n",
 613             '220-   / __| | | | |_) | |    '."\r\n",
 614             '220-  | (__| |_| |  _ <| |___ '."\r\n",
 615             '220    \___|\___/|_| \_\_____|'."\r\n")
 616         );
 617     }
 618 }
 619
 620 sub close_dataconn {
 621     my ($closed)=@_; # non-zero if already disconnected
 622
 623     my $datapid = processexists($datasockf_pidfile);
 624
 625     logmsg "=====> Closing $datasockf_mode DATA connection...\n";
 626
 627     if(!$closed) {
 628         if($datapid > 0) {
 629             logmsg "Server disconnects $datasockf_mode DATA connection\n";
 630             print DWRITE "DISC\n";
 631             my $i;
 632             sysread DREAD, $i, 5;
 633         }
 634         else {
 635             logmsg "Server finds $datasockf_mode DATA connection already ".
 636                    "disconnected\n";
 637         }
 638     }
 639     else {
 640         logmsg "Server knows $datasockf_mode DATA connection is already ".
 641                "disconnected\n";
 642     }
 643
 644     if($datapid > 0) {
 645         print DWRITE "QUIT\n";
 646         waitpid($datapid, 0);
 647         unlink($datasockf_pidfile) if(-f $datasockf_pidfile);
 648         logmsg "DATA sockfilt for $datasockf_mode data channel quits ".
 649                "(pid $datapid)\n";
 650     }
 651     else {
 652         logmsg "DATA sockfilt for $datasockf_mode data channel already ".
 653                "dead\n";
 654     }
 655
 656     logmsg "=====> Closed $datasockf_mode DATA connection\n";
 657
 658     datasockf_state('STOPPED');
 659 }
 660
 661 ################
 662 ################ SMTP commands
 663 ################
 664
 665 # what set by "RCPT"
 666 my $smtp_rcpt;
 667
 668 sub DATA_smtp {
 669     my $testno;
 670
 671     if($smtp_rcpt =~ /^TO:(.*)/) {
 672         $testno = $1;
 673     }
 674     else {
 675         return; # failure
 676     }
 677
 678     if($testno eq "<verifiedserver>") {
 679         sendcontrol "554 WE ROOLZ: $$\r\n";
 680         return 0; # don't wait for data now
 681     }
 682     else {
 683         $testno =~ s/^([^0-9]*)([0-9]+).*/$2/;
 684         sendcontrol "354 Show me the mail\r\n";
 685     }
 686
 687     logmsg "===> rcpt $testno was $smtp_rcpt\n";
 688
 689     my $filename = "log/upload.$testno";
 690
 691     logmsg "Store test number $testno in $filename\n";
 692
 693     open(FILE, ">$filename") ||
 694         return 0; # failed to open output
 695
 696     my $line;
 697     my $ulsize=0;
 698     my $disc=0;
 699     my $raw;
 700     while (5 == (sysread \*SFREAD, $line, 5)) {
 701         if($line eq "DATA\n") {
 702             my $i;
 703             my $eob;
 704             sysread \*SFREAD, $i, 5;
 705
 706             my $size = 0;
 707             if($i =~ /^([0-9a-fA-F]{4})\n/) {
 708                 $size = hex($1);
 709             }
 710
 711             read_mainsockf(\$line, $size);
 712
 713             $ulsize += $size;
 714             print FILE $line if(!$nosave);
 715
 716             $raw .= $line;
 717             if($raw =~ /\x0d\x0a\x2e\x0d\x0a/) {
 718                 # end of data marker!
 719                 $eob = 1;
 720             }
 721             logmsg "> Appending $size bytes to file\n";
 722             if($eob) {
 723                 logmsg "Found SMTP EOB marker\n";
 724                 last;
 725             }
 726         }
 727         elsif($line eq "DISC\n") {
 728             # disconnect!
 729             $disc=1;
 730             last;
 731         }
 732         else {
 733             logmsg "No support for: $line";
 734             last;
 735         }
 736     }
 737     if($nosave) {
 738         print FILE "$ulsize bytes would've been stored here\n";
 739     }
 740     close(FILE);
 741     sendcontrol "250 OK, data received!\r\n";
 742     logmsg "received $ulsize bytes upload\n";
 743
 744 }
 745
 746 sub RCPT_smtp {
 747     my ($args) = @_;
 748
 749     $smtp_rcpt = $args;
 750 }
 751
 752 ################
 753 ################ IMAP commands
 754 ################
 755
 756 # global to allow the command functions to read it
 757 my $cmdid;
 758
 759 # what was picked by SELECT
 760 my $selected;
 761
 762 # Any IMAP parameter can come in escaped and in double quotes.
 763 # This function is dumb (so far) and just removes the quotes if present.
 764 sub fix_imap_params {
 765     foreach (@_) {
 766         $_ = $1 if /^"(.*)"$/;
 767     }
 768 }
 769
 770 sub CAPABILITY_imap {
 771     my ($testno) = @_;
 772     my $data;
 773
 774     if(!$support_capa) {
 775         sendcontrol "$cmdid BAD Command\r\n";
 776     }
 777     else {
 778         $data = "* CAPABILITY IMAP4";
 779         if($support_auth) {
 780             $data .= " AUTH=UNKNOWN";
 781         }
 782         $data .= " pingpong test server\r\n";
 783
 784         sendcontrol $data;
 785         sendcontrol "$cmdid OK CAPABILITY completed\r\n";
 786     }
 787
 788     return 0;
 789 }
 790
 791 sub SELECT_imap {
 792     my ($testno) = @_;
 793     fix_imap_params($testno);
 794
 795     logmsg "SELECT_imap got test $testno\n";
 796
 797     # Example from RFC 3501, 6.3.1. SELECT Command
 798     sendcontrol "* 172 EXISTS\r\n";
 799     sendcontrol "* 1 RECENT\r\n";
 800     sendcontrol "* OK [UNSEEN 12] Message 12 is first unseen\r\n";
 801     sendcontrol "* OK [UIDVALIDITY 3857529045] UIDs valid\r\n";
 802     sendcontrol "* OK [UIDNEXT 4392] Predicted next UID\r\n";
 803     sendcontrol "* FLAGS (\\Answered \\Flagged \\Deleted \\Seen \\Draft)\r\n";
 804     sendcontrol "* OK [PERMANENTFLAGS (\\Deleted \\Seen \\*)] Limited\r\n";
 805     sendcontrol "$cmdid OK [READ-WRITE] SELECT completed\r\n";
 806
 807     $selected = $testno;
 808
 809     return 0;
 810 }
 811
 812 sub FETCH_imap {
 813     my ($args) = @_;
 814     my ($uid, $how) = split(/ /, $args, 2);
 815     my @data;
 816     my $size;
 817     fix_imap_params($uid, $how);
 818
 819     logmsg "FETCH_imap got $args\n";
 820
 821     if($selected eq "verifiedserver") {
 822         # this is the secret command that verifies that this actually is
 823         # the curl test server
 824         my $response = "WE ROOLZ: $$\r\n";
 825         if($verbose) {
 826             print STDERR "FTPD: We returned proof we are the test server\n";
 827         }
 828         $data[0] = $response;
 829         logmsg "return proof we are we\n";
 830     }
 831     else {
 832         logmsg "retrieve a mail\n";
 833
 834         my $testno = $selected;
 835         $testno =~ s/^([^0-9]*)//;
 836         my $testpart = "";
 837         if ($testno > 10000) {
 838             $testpart = $testno % 10000;
 839             $testno = int($testno / 10000);
 840         }
 841
 842         # send mail content
 843         loadtest("$srcdir/data/test$testno");
 844
 845         @data = getpart("reply", "data$testpart");
 846     }
 847
 848     for (@data) {
 849         $size += length($_);
 850     }
 851
 852     sendcontrol "* $uid FETCH ($how {$size}\r\n";
 853
 854     for my $d (@data) {
 855         sendcontrol $d;
 856     }
 857
 858     sendcontrol ")\r\n";
 859     sendcontrol "$cmdid OK FETCH completed\r\n";
 860
 861     return 0;
 862 }
 863
 864 sub APPEND_imap {
 865     my ($args) = @_;
 866
 867     logmsg "APPEND_imap got $args\r\n";
 868
 869     $args =~ /^([^ ]+) [^{]*\{(\d+)\}$/;
 870     my ($folder, $size) = ($1, $2);
 871     fix_imap_params($folder);
 872
 873     sendcontrol "+ Ready for literal data\r\n";
 874
 875     my $testno = $folder;
 876     my $filename = "log/upload.$testno";
 877
 878     logmsg "Store test number $testno in $filename\n";
 879
 880     open(FILE, ">$filename") ||
 881         return 0; # failed to open output
 882
 883     my $received = 0;
 884     my $line;
 885     while(5 == (sysread \*SFREAD, $line, 5)) {
 886         if($line eq "DATA\n") {
 887             sysread \*SFREAD, $line, 5;
 888
 889             my $chunksize = 0;
 890             if($line =~ /^([0-9a-fA-F]{4})\n/) {
 891                 $chunksize = hex($1);
 892             }
 893
 894             read_mainsockf(\$line, $chunksize);
 895
 896             my $left = $size - $received;
 897             my $datasize = ($left > $chunksize) ? $chunksize : $left;
 898
 899             if($datasize > 0) {
 900                 logmsg "> Appending $datasize bytes to file\n";
 901                 print FILE substr($line, 0, $datasize) if(!$nosave);
 902                 $line = substr($line, $datasize);
 903
 904                 $received += $datasize;
 905                 if($received == $size) {
 906                     logmsg "Received all data, waiting for final CRLF.\n";
 907                 }
 908             }
 909
 910             if($received == $size && $line eq "\r\n") {
 911                 last;
 912             }
 913         }
 914         elsif($line eq "DISC\n") {
 915             logmsg "Unexpected disconnect!\n";
 916             last;
 917         }
 918         else {
 919             logmsg "No support for: $line";
 920             last;
 921         }
 922     }
 923
 924     if($nosave) {
 925         print FILE "$size bytes would've been stored here\n";
 926     }
 927     close(FILE);
 928
 929     logmsg "received $size bytes upload\n";
 930
 931     sendcontrol "$cmdid OK APPEND completed\r\n";
 932
 933     return 0;
 934 }
 935
 936 sub STORE_imap {
 937     my ($args) = @_;
 938     my ($uid, $what) = split(/ /, $args, 2);
 939     fix_imap_params($uid);
 940
 941     logmsg "STORE_imap got $args\n";
 942
 943     sendcontrol "* $uid FETCH (FLAGS (\\Seen \\Deleted))\r\n";
 944     sendcontrol "$cmdid OK STORE completed\r\n";
 945
 946     return 0;
 947 }
 948
 949 sub LIST_imap {
 950     my ($args) = @_;
 951     my ($reference, $mailbox) = split(/ /, $args, 2);
 952     my @data;
 953     fix_imap_params($reference, $mailbox);
 954
 955     logmsg "LIST_imap got $args\n";
 956
 957     if ($reference eq "verifiedserver") {
 958          # this is the secret command that verifies that this actually is
 959          # the curl test server
 960          @data = ("* LIST () \"/\" \"WE ROOLZ: $$\"\r\n");
 961          if($verbose) {
 962              print STDERR "FTPD: We returned proof we are the test server\n";
 963          }
 964          logmsg "return proof we are we\n";
 965     }
 966     else {
 967         my $testno = $reference;
 968         $testno =~ s/^([^0-9]*)//;
 969         my $testpart = "";
 970         if ($testno > 10000) {
 971             $testpart = $testno % 10000;
 972             $testno = int($testno / 10000);
 973         }
 974
 975         loadtest("$srcdir/data/test$testno");
 976
 977         @data = getpart("reply", "data$testpart");
 978     }
 979
 980     for my $d (@data) {
 981         sendcontrol $d;
 982     }
 983
 984     sendcontrol "$cmdid OK LIST Completed\r\n";
 985
 986     return 0;
 987 }
 988
 989 sub EXAMINE_imap {
 990     my ($testno) = @_;
 991     fix_imap_params($testno);
 992
 993     logmsg "EXAMINE_imap got test $testno\n";
 994
 995     # Example from RFC 3501, 6.3.2. EXAMINE Command
 996     sendcontrol "* 17 EXISTS\r\n";
 997     sendcontrol "* 2 RECENT\r\n";
 998     sendcontrol "* OK [UNSEEN 8] Message 8 is first unseen\r\n";
 999     sendcontrol "* OK [UIDVALIDITY 3857529045] UIDs valid\r\n";
1000     sendcontrol "* OK [UIDNEXT 4392] Predicted next UID\r\n";
1001     sendcontrol "* FLAGS (\\Answered \\Flagged \\Deleted \\Seen \\Draft)\r\n";
1002     sendcontrol "* OK [PERMANENTFLAGS ()] No permanent flags permitted\r\n";
1003     sendcontrol "$cmdid OK [READ-ONLY] EXAMINE completed\r\n";
1004
1005     return 0;
1006 }
1007
1008 sub STATUS_imap {
1009     my ($testno) = @_;
1010     fix_imap_params($testno);
1011
1012     logmsg "STATUS_imap got test $testno\n";
1013
1014     $testno =~ s/[^0-9]//g;
1015     my $testpart = "";
1016     if ($testno > 10000) {
1017         $testpart = $testno % 10000;
1018         $testno = int($testno / 10000);
1019     }
1020
1021     loadtest("$srcdir/data/test$testno");
1022
1023     my @data = getpart("reply", "data$testpart");
1024
1025     for my $d (@data) {
1026         sendcontrol $d;
1027     }
1028
1029     sendcontrol "$cmdid OK STATUS completed\r\n";
1030
1031     return 0;
1032 }
1033
1034 sub LOGOUT_imap {
1035     sendcontrol "* BYE cURL IMAP server signing off\r\n";
1036     sendcontrol "$cmdid OK LOGOUT completed\r\n";
1037
1038     return 0;
1039 }
1040
1041 ################
1042 ################ POP3 commands
1043 ################
1044
1045 sub CAPA_pop3 {
1046     my ($testno) = @_;
1047     my @data = ();
1048
1049     if(!$support_capa) {
1050         push @data, "-ERR Unsupported command: 'CAPA'\r\n";
1051     }
1052     else {
1053         push @data, "+OK List of capabilities follows\r\n";
1054         push @data, "USER\r\n";
1055         if($support_auth) {
1056             push @data, "SASL UNKNOWN\r\n";
1057         }
1058         push @data, "IMPLEMENTATION POP3 pingpong test server\r\n";
1059         push @data, ".\r\n";
1060     }
1061
1062     for my $d (@data) {
1063         sendcontrol $d;
1064     }
1065
1066     return 0;
1067 }
1068
1069 sub AUTH_pop3 {
1070     my ($testno) = @_;
1071     my @data = ();
1072
1073     if(!$support_auth) {
1074         push @data, "-ERR Unsupported command: 'AUTH'\r\n";
1075     }
1076     else {
1077         push @data, "+OK List of supported mechanisms follows\r\n";
1078         push @data, "UNKNOWN\r\n";
1079         push @data, ".\r\n";
1080     }
1081
1082     for my $d (@data) {
1083         sendcontrol $d;
1084     }
1085
1086     return 0;
1087 }
1088
1089 sub RETR_pop3 {
1090      my ($testno) = @_;
1091      my @data;
1092
1093      if($testno =~ /^verifiedserver$/) {
1094          # this is the secret command that verifies that this actually is
1095          # the curl test server
1096          my $response = "WE ROOLZ: $$\r\n";
1097          if($verbose) {
1098              print STDERR "FTPD: We returned proof we are the test server\n";
1099          }
1100          $data[0] = $response;
1101          logmsg "return proof we are we\n";
1102      }
1103      else {
1104          logmsg "retrieve a mail\n";
1105
1106          $testno =~ s/^([^0-9]*)//;
1107          my $testpart = "";
1108          if ($testno > 10000) {
1109              $testpart = $testno % 10000;
1110              $testno = int($testno / 10000);
1111          }
1112
1113          # send mail content
1114          loadtest("$srcdir/data/test$testno");
1115
1116          @data = getpart("reply", "data$testpart");
1117      }
1118
1119      sendcontrol "+OK Mail transfer starts\r\n";
1120
1121      for my $d (@data) {
1122          sendcontrol $d;
1123      }
1124
1125      # end with the magic 3-byte end of mail marker, assumes that the
1126      # mail body ends with a CRLF!
1127      sendcontrol ".\r\n";
1128
1129      return 0;
1130 }
1131
1132 sub LIST_pop3 {
1133
1134 # this is a built-in fake-message list
1135 my @pop3list=(
1136 "1 100\r\n",
1137 "2 4294967400\r\n",     # > 4 GB
1138 "4 200\r\n", # Note that message 3 is a simulated "deleted" message
1139 );
1140
1141      logmsg "retrieve a message list\n";
1142
1143      sendcontrol "+OK Listing starts\r\n";
1144
1145      for my $d (@pop3list) {
1146          sendcontrol $d;
1147      }
1148
1149      # end with the magic 3-byte end of listing marker
1150      sendcontrol ".\r\n";
1151
1152      return 0;
1153 }
1154
1155 ################
1156 ################ FTP commands
1157 ################
1158 my $rest=0;
1159 sub REST_ftp {
1160     $rest = $_[0];
1161     logmsg "Set REST position to $rest\n"
1162 }
1163
1164 sub switch_directory_goto {
1165   my $target_dir = $_;
1166
1167   if(!$ftptargetdir) {
1168     $ftptargetdir = "/";
1169   }
1170
1171   if($target_dir eq "") {
1172     $ftptargetdir = "/";
1173   }
1174   elsif($target_dir eq "..") {
1175     if($ftptargetdir eq "/") {
1176       $ftptargetdir = "/";
1177     }
1178     else {
1179       $ftptargetdir =~ s/[[:alnum:]]+\/$//;
1180     }
1181   }
1182   else {
1183     $ftptargetdir .= $target_dir . "/";
1184   }
1185 }
1186
1187 sub switch_directory {
1188     my $target_dir = $_[0];
1189
1190     if($target_dir eq "/") {
1191         $ftptargetdir = "/";
1192     }
1193     else {
1194         my @dirs = split("/", $target_dir);
1195         for(@dirs) {
1196           switch_directory_goto($_);
1197         }
1198     }
1199 }
1200
1201 sub CWD_ftp {
1202   my ($folder, $fullcommand) = $_[0];
1203   switch_directory($folder);
1204   if($ftptargetdir =~ /^\/fully_simulated/) {
1205     $ftplistparserstate = "enabled";
1206   }
1207   else {
1208     undef $ftplistparserstate;
1209   }
1210 }
1211
1212 sub PWD_ftp {
1213     my $mydir;
1214     $mydir = $ftptargetdir ? $ftptargetdir : "/";
1215
1216     if($mydir ne "/") {
1217         $mydir =~ s/\/$//;
1218     }
1219     sendcontrol "257 \"$mydir\" is current directory\r\n";
1220 }
1221
1222 sub LIST_ftp {
1223   #  print "150 ASCII data connection for /bin/ls (193.15.23.1,59196) (0 bytes)\r\n";
1224
1225 # this is a built-in fake-dir ;-)
1226 my @ftpdir=("total 20\r\n",
1227 "drwxr-xr-x   8 98       98           512 Oct 22 13:06 .\r\n",
1228 "drwxr-xr-x   8 98       98           512 Oct 22 13:06 ..\r\n",
1229 "drwxr-xr-x   2 98       98           512 May  2  1996 .NeXT\r\n",
1230 "-r--r--r--   1 0        1             35 Jul 16  1996 README\r\n",
1231 "lrwxrwxrwx   1 0        1              7 Dec  9  1999 bin -> usr/bin\r\n",
1232 "dr-xr-xr-x   2 0        1            512 Oct  1  1997 dev\r\n",
1233 "drwxrwxrwx   2 98       98           512 May 29 16:04 download.html\r\n",
1234 "dr-xr-xr-x   2 0        1            512 Nov 30  1995 etc\r\n",
1235 "drwxrwxrwx   2 98       1            512 Oct 30 14:33 pub\r\n",
1236 "dr-xr-xr-x   5 0        1            512 Oct  1  1997 usr\r\n");
1237
1238     if($datasockf_conn eq 'no') {
1239         if($nodataconn425) {
1240             sendcontrol "150 Opening data connection\r\n";
1241             sendcontrol "425 Can't open data connection\r\n";
1242         }
1243         elsif($nodataconn421) {
1244             sendcontrol "150 Opening data connection\r\n";
1245             sendcontrol "421 Connection timed out\r\n";
1246         }
1247         elsif($nodataconn150) {
1248             sendcontrol "150 Opening data connection\r\n";
1249             # client shall timeout
1250         }
1251         else {
1252             # client shall timeout
1253         }
1254         return 0;
1255     }
1256
1257     if($ftplistparserstate) {
1258       @ftpdir = ftp_contentlist($ftptargetdir);
1259     }
1260
1261     logmsg "pass LIST data on data connection\n";
1262     for(@ftpdir) {
1263         senddata $_;
1264     }
1265     close_dataconn(0);
1266     sendcontrol "226 ASCII transfer complete\r\n";
1267     return 0;
1268 }
1269
1270 sub NLST_ftp {
1271     my @ftpdir=("file", "with space", "fake", "..", " ..", "funny", "README");
1272
1273     if($datasockf_conn eq 'no') {
1274         if($nodataconn425) {
1275             sendcontrol "150 Opening data connection\r\n";
1276             sendcontrol "425 Can't open data connection\r\n";
1277         }
1278         elsif($nodataconn421) {
1279             sendcontrol "150 Opening data connection\r\n";
1280             sendcontrol "421 Connection timed out\r\n";
1281         }
1282         elsif($nodataconn150) {
1283             sendcontrol "150 Opening data connection\r\n";
1284             # client shall timeout
1285         }
1286         else {
1287             # client shall timeout
1288         }
1289         return 0;
1290     }
1291
1292     logmsg "pass NLST data on data connection\n";
1293     for(@ftpdir) {
1294         senddata "$_\r\n";
1295     }
1296     close_dataconn(0);
1297     sendcontrol "226 ASCII transfer complete\r\n";
1298     return 0;
1299 }
1300
1301 sub MDTM_ftp {
1302     my $testno = $_[0];
1303     my $testpart = "";
1304     if ($testno > 10000) {
1305         $testpart = $testno % 10000;
1306         $testno = int($testno / 10000);
1307     }
1308
1309     loadtest("$srcdir/data/test$testno");
1310
1311     my @data = getpart("reply", "mdtm");
1312
1313     my $reply = $data[0];
1314     chomp $reply if($reply);
1315
1316     if($reply && ($reply =~ /^[+-]?\d+$/) && ($reply < 0)) {
1317         sendcontrol "550 $testno: no such file.\r\n";
1318     }
1319     elsif($reply) {
1320         sendcontrol "$reply\r\n";
1321     }
1322     else {
1323         sendcontrol "500 MDTM: no such command.\r\n";
1324     }
1325     return 0;
1326 }
1327
1328 sub SIZE_ftp {
1329     my $testno = $_[0];
1330     if($ftplistparserstate) {
1331         my $size = wildcard_filesize($ftptargetdir, $testno);
1332         if($size == -1) {
1333             sendcontrol "550 $testno: No such file or directory.\r\n";
1334         }
1335         else {
1336             sendcontrol "213 $size\r\n";
1337         }
1338         return 0;
1339     }
1340
1341     if($testno =~ /^verifiedserver$/) {
1342         my $response = "WE ROOLZ: $$\r\n";
1343         my $size = length($response);
1344         sendcontrol "213 $size\r\n";
1345         return 0;
1346     }
1347
1348     if($testno =~ /(\d+)\/?$/) {
1349         $testno = $1;
1350     }
1351     else {
1352         print STDERR "SIZE_ftp: invalid test number: $testno\n";
1353         return 1;
1354     }
1355
1356     my $testpart = "";
1357     if($testno > 10000) {
1358         $testpart = $testno % 10000;
1359         $testno = int($testno / 10000);
1360     }
1361
1362     loadtest("$srcdir/data/test$testno");
1363
1364     my @data = getpart("reply", "size");
1365
1366     my $size = $data[0];
1367
1368     if($size) {
1369         if($size > -1) {
1370             sendcontrol "213 $size\r\n";
1371         }
1372         else {
1373             sendcontrol "550 $testno: No such file or directory.\r\n";
1374         }
1375     }
1376     else {
1377         $size=0;
1378         @data = getpart("reply", "data$testpart");
1379         for(@data) {
1380             $size += length($_);
1381         }
1382         if($size) {
1383             sendcontrol "213 $size\r\n";
1384         }
1385         else {
1386             sendcontrol "550 $testno: No such file or directory.\r\n";
1387         }
1388     }
1389     return 0;
1390 }
1391
1392 sub RETR_ftp {
1393     my ($testno) = @_;
1394
1395     if($datasockf_conn eq 'no') {
1396         if($nodataconn425) {
1397             sendcontrol "150 Opening data connection\r\n";
1398             sendcontrol "425 Can't open data connection\r\n";
1399         }
1400         elsif($nodataconn421) {
1401             sendcontrol "150 Opening data connection\r\n";
1402             sendcontrol "421 Connection timed out\r\n";
1403         }
1404         elsif($nodataconn150) {
1405             sendcontrol "150 Opening data connection\r\n";
1406             # client shall timeout
1407         }
1408         else {
1409             # client shall timeout
1410         }
1411         return 0;
1412     }
1413
1414     if($ftplistparserstate) {
1415         my @content = wildcard_getfile($ftptargetdir, $testno);
1416         if($content[0] == -1) {
1417             #file not found
1418         }
1419         else {
1420             my $size = length $content[1];
1421             sendcontrol "150 Binary data connection for $testno ($size bytes).\r\n",
1422             senddata $content[1];
1423             close_dataconn(0);
1424             sendcontrol "226 File transfer complete\r\n";
1425         }
1426         return 0;
1427     }
1428
1429     if($testno =~ /^verifiedserver$/) {
1430         # this is the secret command that verifies that this actually is
1431         # the curl test server
1432         my $response = "WE ROOLZ: $$\r\n";
1433         my $len = length($response);
1434         sendcontrol "150 Binary junk ($len bytes).\r\n";
1435         senddata "WE ROOLZ: $$\r\n";
1436         close_dataconn(0);
1437         sendcontrol "226 File transfer complete\r\n";
1438         if($verbose) {
1439             print STDERR "FTPD: We returned proof we are the test server\n";
1440         }
1441         return 0;
1442     }
1443
1444     $testno =~ s/^([^0-9]*)//;
1445     my $testpart = "";
1446     if ($testno > 10000) {
1447         $testpart = $testno % 10000;
1448         $testno = int($testno / 10000);
1449     }
1450
1451     loadtest("$srcdir/data/test$testno");
1452
1453     my @data = getpart("reply", "data$testpart");
1454
1455     my $size=0;
1456     for(@data) {
1457         $size += length($_);
1458     }
1459
1460     my %hash = getpartattr("reply", "data$testpart");
1461
1462     if($size || $hash{'sendzero'}) {
1463
1464         if($rest) {
1465             # move read pointer forward
1466             $size -= $rest;
1467             logmsg "REST $rest was removed from size, makes $size left\n";
1468             $rest = 0; # reset REST offset again
1469         }
1470         if($retrweirdo) {
1471             sendcontrol "150 Binary data connection for $testno () ($size bytes).\r\n",
1472             "226 File transfer complete\r\n";
1473
1474             for(@data) {
1475                 my $send = $_;
1476                 senddata $send;
1477             }
1478             close_dataconn(0);
1479             $retrweirdo=0; # switch off the weirdo again!
1480         }
1481         else {
1482             my $sz = "($size bytes)";
1483             if($retrnosize) {
1484                 $sz = "size?";
1485             }
1486
1487             sendcontrol "150 Binary data connection for $testno () $sz.\r\n";
1488
1489             for(@data) {
1490                 my $send = $_;
1491                 senddata $send;
1492             }
1493             close_dataconn(0);
1494             sendcontrol "226 File transfer complete\r\n";
1495         }
1496     }
1497     else {
1498         sendcontrol "550 $testno: No such file or directory.\r\n";
1499     }
1500     return 0;
1501 }
1502
1503 sub STOR_ftp {
1504     my $testno=$_[0];
1505
1506     my $filename = "log/upload.$testno";
1507
1508     if($datasockf_conn eq 'no') {
1509         if($nodataconn425) {
1510             sendcontrol "150 Opening data connection\r\n";
1511             sendcontrol "425 Can't open data connection\r\n";
1512         }
1513         elsif($nodataconn421) {
1514             sendcontrol "150 Opening data connection\r\n";
1515             sendcontrol "421 Connection timed out\r\n";
1516         }
1517         elsif($nodataconn150) {
1518             sendcontrol "150 Opening data connection\r\n";
1519             # client shall timeout
1520         }
1521         else {
1522             # client shall timeout
1523         }
1524         return 0;
1525     }
1526
1527     logmsg "STOR test number $testno in $filename\n";
1528
1529     sendcontrol "125 Gimme gimme gimme!\r\n";
1530
1531     open(FILE, ">$filename") ||
1532         return 0; # failed to open output
1533
1534     my $line;
1535     my $ulsize=0;
1536     my $disc=0;
1537     while (5 == (sysread DREAD, $line, 5)) {
1538         if($line eq "DATA\n") {
1539             my $i;
1540             sysread DREAD, $i, 5;
1541
1542             my $size = 0;
1543             if($i =~ /^([0-9a-fA-F]{4})\n/) {
1544                 $size = hex($1);
1545             }
1546
1547             read_datasockf(\$line, $size);
1548
1549             #print STDERR "  GOT: $size bytes\n";
1550
1551             $ulsize += $size;
1552             print FILE $line if(!$nosave);
1553             logmsg "> Appending $size bytes to file\n";
1554         }
1555         elsif($line eq "DISC\n") {
1556             # disconnect!
1557             $disc=1;
1558             last;
1559         }
1560         else {
1561             logmsg "No support for: $line";
1562             last;
1563         }
1564     }
1565     if($nosave) {
1566         print FILE "$ulsize bytes would've been stored here\n";
1567     }
1568     close(FILE);
1569     close_dataconn($disc);
1570     logmsg "received $ulsize bytes upload\n";
1571     sendcontrol "226 File transfer complete\r\n";
1572     return 0;
1573 }
1574
1575 sub PASV_ftp {
1576     my ($arg, $cmd)=@_;
1577     my $pasvport;
1578     my $bindonly = ($nodataconn) ? '--bindonly' : '';
1579
1580     # kill previous data connection sockfilt when alive
1581     if($datasockf_runs eq 'yes') {
1582         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
1583         logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
1584     }
1585     datasockf_state('STOPPED');
1586
1587     logmsg "====> Passive DATA channel requested by client\n";
1588
1589     logmsg "DATA sockfilt for passive data channel starting...\n";
1590
1591     # We fire up a new sockfilt to do the data transfer for us.
1592     my $datasockfcmd = "./server/sockfilt " .
1593         "--ipv$ipvnum $bindonly --port 0 " .
1594         "--pidfile \"$datasockf_pidfile\" " .
1595         "--logfile \"$datasockf_logfile\"";
1596     $slavepid = open2(\*DREAD, \*DWRITE, $datasockfcmd);
1597
1598     if($nodataconn) {
1599         datasockf_state('PASSIVE_NODATACONN');
1600     }
1601     else {
1602         datasockf_state('PASSIVE');
1603     }
1604
1605     print STDERR "$datasockfcmd\n" if($verbose);
1606
1607     print DWRITE "PING\n";
1608     my $pong;
1609     sysread_or_die(\*DREAD, \$pong, 5);
1610
1611     if($pong =~ /^FAIL/) {
1612         logmsg "DATA sockfilt said: FAIL\n";
1613         logmsg "DATA sockfilt for passive data channel failed\n";
1614         logmsg "DATA sockfilt not running\n";
1615         datasockf_state('STOPPED');
1616         sendcontrol "500 no free ports!\r\n";
1617         return;
1618     }
1619     elsif($pong !~ /^PONG/) {
1620         logmsg "DATA sockfilt unexpected response: $pong\n";
1621         logmsg "DATA sockfilt for passive data channel failed\n";
1622         logmsg "DATA sockfilt killed now\n";
1623         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
1624         logmsg "DATA sockfilt not running\n";
1625         datasockf_state('STOPPED');
1626         sendcontrol "500 no free ports!\r\n";
1627         return;
1628     }
1629
1630     logmsg "DATA sockfilt for passive data channel started (pid $slavepid)\n";
1631
1632     # Find out on what port we listen on or have bound
1633     my $i;
1634     print DWRITE "PORT\n";
1635
1636     # READ the response code
1637     sysread_or_die(\*DREAD, \$i, 5);
1638
1639     # READ the response size
1640     sysread_or_die(\*DREAD, \$i, 5);
1641
1642     my $size = 0;
1643     if($i =~ /^([0-9a-fA-F]{4})\n/) {
1644         $size = hex($1);
1645     }
1646
1647     # READ the response data
1648     read_datasockf(\$i, $size);
1649
1650     # The data is in the format
1651     # IPvX/NNN
1652
1653     if($i =~ /IPv(\d)\/(\d+)/) {
1654         # FIX: deal with IP protocol version
1655         $pasvport = $2;
1656     }
1657
1658     if(!$pasvport) {
1659         logmsg "DATA sockfilt unknown listener port\n";
1660         logmsg "DATA sockfilt for passive data channel failed\n";
1661         logmsg "DATA sockfilt killed now\n";
1662         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
1663         logmsg "DATA sockfilt not running\n";
1664         datasockf_state('STOPPED');
1665         sendcontrol "500 no free ports!\r\n";
1666         return;
1667     }
1668
1669     if($nodataconn) {
1670         my $str = nodataconn_str();
1671         logmsg "DATA sockfilt for passive data channel ($str) bound on port ".
1672                "$pasvport\n";
1673     }
1674     else {
1675         logmsg "DATA sockfilt for passive data channel listens on port ".
1676                "$pasvport\n";
1677     }
1678
1679     if($cmd ne "EPSV") {
1680         # PASV reply
1681         my $p=$listenaddr;
1682         $p =~ s/\./,/g;
1683         if($pasvbadip) {
1684             $p="1,2,3,4";
1685         }
1686         sendcontrol sprintf("227 Entering Passive Mode ($p,%d,%d)\n",
1687                             int($pasvport/256), int($pasvport%256));
1688     }
1689     else {
1690         # EPSV reply
1691         sendcontrol sprintf("229 Entering Passive Mode (|||%d|)\n", $pasvport);
1692     }
1693
1694     logmsg "Client has been notified that DATA conn ".
1695            "will be accepted on port $pasvport\n";
1696
1697     if($nodataconn) {
1698         my $str = nodataconn_str();
1699         logmsg "====> Client fooled ($str)\n";
1700         return;
1701     }
1702
1703     eval {
1704         local $SIG{ALRM} = sub { die "alarm\n" };
1705
1706         # assume swift operations unless explicitly slow
1707         alarm ($datadelay?20:10);
1708
1709         # Wait for 'CNCT'
1710         my $input;
1711
1712         # FIX: Monitor ctrl conn for disconnect
1713
1714         while(sysread(DREAD, $input, 5)) {
1715
1716             if($input !~ /^CNCT/) {
1717                 # we wait for a connected client
1718                 logmsg "Odd, we got $input from client\n";
1719                 next;
1720             }
1721             logmsg "Client connects to port $pasvport\n";
1722             last;
1723         }
1724         alarm 0;
1725     };
1726     if ($@) {
1727         # timed out
1728         logmsg "$srvrname server timed out awaiting data connection ".
1729             "on port $pasvport\n";
1730         logmsg "accept failed or connection not even attempted\n";
1731         logmsg "DATA sockfilt killed now\n";
1732         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
1733         logmsg "DATA sockfilt not running\n";
1734         datasockf_state('STOPPED');
1735         return;
1736     }
1737     else {
1738         logmsg "====> Client established passive DATA connection ".
1739                "on port $pasvport\n";
1740     }
1741
1742     return;
1743 }
1744
1745 #
1746 # Support both PORT and EPRT here.
1747 #
1748
1749 sub PORT_ftp {
1750     my ($arg, $cmd) = @_;
1751     my $port;
1752     my $addr;
1753
1754     # kill previous data connection sockfilt when alive
1755     if($datasockf_runs eq 'yes') {
1756         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
1757         logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
1758     }
1759     datasockf_state('STOPPED');
1760
1761     logmsg "====> Active DATA channel requested by client\n";
1762
1763     # We always ignore the given IP and use localhost.
1764
1765     if($cmd eq "PORT") {
1766         if($arg !~ /(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/) {
1767             logmsg "DATA sockfilt for active data channel not started ".
1768                    "(bad PORT-line: $arg)\n";
1769             sendcontrol "500 silly you, go away\r\n";
1770             return;
1771         }
1772         $port = ($5<<8)+$6;
1773         $addr = "$1.$2.$3.$4";
1774     }
1775     # EPRT |2|::1|49706|
1776     elsif($cmd eq "EPRT") {
1777         if($arg !~ /(\d+)\|([^\|]+)\|(\d+)/) {
1778             logmsg "DATA sockfilt for active data channel not started ".
1779                    "(bad EPRT-line: $arg)\n";
1780             sendcontrol "500 silly you, go away\r\n";
1781             return;
1782         }
1783         sendcontrol "200 Thanks for dropping by. We contact you later\r\n";
1784         $port = $3;
1785         $addr = $2;
1786     }
1787     else {
1788         logmsg "DATA sockfilt for active data channel not started ".
1789                "(invalid command: $cmd)\n";
1790         sendcontrol "500 we don't like $cmd now\r\n";
1791         return;
1792     }
1793
1794     if(!$port || $port > 65535) {
1795         logmsg "DATA sockfilt for active data channel not started ".
1796                "(illegal PORT number: $port)\n";
1797         return;
1798     }
1799
1800     if($nodataconn) {
1801         my $str = nodataconn_str();
1802         logmsg "DATA sockfilt for active data channel not started ($str)\n";
1803         datasockf_state('ACTIVE_NODATACONN');
1804         logmsg "====> Active DATA channel not established\n";
1805         return;
1806     }
1807
1808     logmsg "DATA sockfilt for active data channel starting...\n";
1809
1810     # We fire up a new sockfilt to do the data transfer for us.
1811     my $datasockfcmd = "./server/sockfilt " .
1812         "--ipv$ipvnum --connect $port --addr \"$addr\" " .
1813         "--pidfile \"$datasockf_pidfile\" " .
1814         "--logfile \"$datasockf_logfile\"";
1815     $slavepid = open2(\*DREAD, \*DWRITE, $datasockfcmd);
1816
1817     datasockf_state('ACTIVE');
1818
1819     print STDERR "$datasockfcmd\n" if($verbose);
1820
1821     print DWRITE "PING\n";
1822     my $pong;
1823     sysread_or_die(\*DREAD, \$pong, 5);
1824
1825     if($pong =~ /^FAIL/) {
1826         logmsg "DATA sockfilt said: FAIL\n";
1827         logmsg "DATA sockfilt for active data channel failed\n";
1828         logmsg "DATA sockfilt not running\n";
1829         datasockf_state('STOPPED');
1830         # client shall timeout awaiting connection from server
1831         return;
1832     }
1833     elsif($pong !~ /^PONG/) {
1834         logmsg "DATA sockfilt unexpected response: $pong\n";
1835         logmsg "DATA sockfilt for active data channel failed\n";
1836         logmsg "DATA sockfilt killed now\n";
1837         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
1838         logmsg "DATA sockfilt not running\n";
1839         datasockf_state('STOPPED');
1840         # client shall timeout awaiting connection from server
1841         return;
1842     }
1843
1844     logmsg "DATA sockfilt for active data channel started (pid $slavepid)\n";
1845
1846     logmsg "====> Active DATA channel connected to client port $port\n";
1847
1848     return;
1849 }
1850
1851 #**********************************************************************
1852 # datasockf_state is used to change variables that keep state info
1853 # relative to the FTP secondary or data sockfilt process as soon as
1854 # one of the five possible stable states is reached. Variables that
1855 # are modified by this sub may be checked independently but should
1856 # not be changed except by calling this sub.
1857 #
1858 sub datasockf_state {
1859     my $state = $_[0];
1860
1861   if($state eq 'STOPPED') {
1862     # Data sockfilter initial state, not running,
1863     # not connected and not used.
1864     $datasockf_state = $state;
1865     $datasockf_mode = 'none';
1866     $datasockf_runs = 'no';
1867     $datasockf_conn = 'no';
1868   }
1869   elsif($state eq 'PASSIVE') {
1870     # Data sockfilter accepted connection from client.
1871     $datasockf_state = $state;
1872     $datasockf_mode = 'passive';
1873     $datasockf_runs = 'yes';
1874     $datasockf_conn = 'yes';
1875   }
1876   elsif($state eq 'ACTIVE') {
1877     # Data sockfilter has connected to client.
1878     $datasockf_state = $state;
1879     $datasockf_mode = 'active';
1880     $datasockf_runs = 'yes';
1881     $datasockf_conn = 'yes';
1882   }
1883   elsif($state eq 'PASSIVE_NODATACONN') {
1884     # Data sockfilter bound port without listening,
1885     # client won't be able to establish data connection.
1886     $datasockf_state = $state;
1887     $datasockf_mode = 'passive';
1888     $datasockf_runs = 'yes';
1889     $datasockf_conn = 'no';
1890   }
1891   elsif($state eq 'ACTIVE_NODATACONN') {
1892     # Data sockfilter does not even run,
1893     # client awaits data connection from server in vain.
1894     $datasockf_state = $state;
1895     $datasockf_mode = 'active';
1896     $datasockf_runs = 'no';
1897     $datasockf_conn = 'no';
1898   }
1899   else {
1900       die "Internal error. Unknown datasockf state: $state!";
1901   }
1902 }
1903
1904 #**********************************************************************
1905 # nodataconn_str returns string of efective nodataconn command. Notice
1906 # that $nodataconn may be set alone or in addition to a $nodataconnXXX.
1907 #
1908 sub nodataconn_str {
1909     my $str;
1910     # order matters
1911     $str = 'NODATACONN' if($nodataconn);
1912     $str = 'NODATACONN425' if($nodataconn425);
1913     $str = 'NODATACONN421' if($nodataconn421);
1914     $str = 'NODATACONN150' if($nodataconn150);
1915     return "$str";
1916 }
1917
1918 #**********************************************************************
1919 # customize configures test server operation for each curl test, reading
1920 # configuration commands/parameters from server commands file each time
1921 # a new client control connection is established with the test server.
1922 # On success returns 1, otherwise zero.
1923 #
1924 sub customize {
1925     $ctrldelay = 0;     # default is no throttling of the ctrl stream
1926     $datadelay = 0;     # default is no throttling of the data stream
1927     $retrweirdo = 0;    # default is no use of RETRWEIRDO
1928     $retrnosize = 0;    # default is no use of RETRNOSIZE
1929     $pasvbadip = 0;     # default is no use of PASVBADIP
1930     $nosave = 0;        # default is to actually save uploaded data to file
1931     $nodataconn = 0;    # default is to establish or accept data channel
1932     $nodataconn425 = 0; # default is to not send 425 without data channel
1933     $nodataconn421 = 0; # default is to not send 421 without data channel
1934     $nodataconn150 = 0; # default is to not send 150 without data channel
1935     $support_capa = 0;  # default is to not support capability command
1936     $support_auth = 0;  # default is to not support authentication command
1937     %customreply = ();  #
1938     %customcount = ();  #
1939     %delayreply = ();   #
1940
1941     open(CUSTOM, "<log/ftpserver.cmd") ||
1942         return 1;
1943
1944     logmsg "FTPD: Getting commands from log/ftpserver.cmd\n";
1945
1946     while(<CUSTOM>) {
1947         if($_ =~ /REPLY ([A-Za-z0-9+\/=]+) (.*)/) {
1948             $customreply{$1}=eval "qq{$2}";
1949             logmsg "FTPD: set custom reply for $1\n";
1950         }
1951         elsif($_ =~ /COUNT ([A-Z]+) (.*)/) {
1952             # we blank the customreply for this command when having
1953             # been used this number of times
1954             $customcount{$1}=$2;
1955             logmsg "FTPD: blank custom reply for $1 after $2 uses\n";
1956         }
1957         elsif($_ =~ /DELAY ([A-Z]+) (\d*)/) {
1958             $delayreply{$1}=$2;
1959             logmsg "FTPD: delay reply for $1 with $2 seconds\n";
1960         }
1961         elsif($_ =~ /SLOWDOWN/) {
1962             $ctrldelay=1;
1963             $datadelay=1;
1964             logmsg "FTPD: send response with 0.01 sec delay between each byte\n";
1965         }
1966         elsif($_ =~ /RETRWEIRDO/) {
1967             logmsg "FTPD: instructed to use RETRWEIRDO\n";
1968             $retrweirdo=1;
1969         }
1970         elsif($_ =~ /RETRNOSIZE/) {
1971             logmsg "FTPD: instructed to use RETRNOSIZE\n";
1972             $retrnosize=1;
1973         }
1974         elsif($_ =~ /PASVBADIP/) {
1975             logmsg "FTPD: instructed to use PASVBADIP\n";
1976             $pasvbadip=1;
1977         }
1978         elsif($_ =~ /NODATACONN425/) {
1979             # applies to both active and passive FTP modes
1980             logmsg "FTPD: instructed to use NODATACONN425\n";
1981             $nodataconn425=1;
1982             $nodataconn=1;
1983         }
1984         elsif($_ =~ /NODATACONN421/) {
1985             # applies to both active and passive FTP modes
1986             logmsg "FTPD: instructed to use NODATACONN421\n";
1987             $nodataconn421=1;
1988             $nodataconn=1;
1989         }
1990         elsif($_ =~ /NODATACONN150/) {
1991             # applies to both active and passive FTP modes
1992             logmsg "FTPD: instructed to use NODATACONN150\n";
1993             $nodataconn150=1;
1994             $nodataconn=1;
1995         }
1996         elsif($_ =~ /NODATACONN/) {
1997             # applies to both active and passive FTP modes
1998             logmsg "FTPD: instructed to use NODATACONN\n";
1999             $nodataconn=1;
2000         }
2001         elsif($_ =~ /SUPPORTCAPA/) {
2002             logmsg "FTPD: instructed to support CAPABILITY command\n";
2003             $support_capa=1;
2004         }
2005         elsif($_ =~ /SUPPORTAUTH/) {
2006             logmsg "FTPD: instructed to support AUTHENTICATION command\n";
2007             $support_auth=1;
2008         }
2009         elsif($_ =~ /NOSAVE/) {
2010             # don't actually store the file we upload - to be used when
2011             # uploading insanely huge amounts
2012             $nosave = 1;
2013             logmsg "FTPD: NOSAVE prevents saving of uploaded data\n";
2014         }
2015     }
2016     close(CUSTOM);
2017 }
2018
2019 #----------------------------------------------------------------------
2020 #----------------------------------------------------------------------
2021 #---------------------------  END OF SUBS  ----------------------------
2022 #----------------------------------------------------------------------
2023 #----------------------------------------------------------------------
2024
2025 #**********************************************************************
2026 # Parse command line options
2027 #
2028 # Options:
2029 #
2030 # --verbose   # verbose
2031 # --srcdir    # source directory
2032 # --id        # server instance number
2033 # --proto     # server protocol
2034 # --pidfile   # server pid file
2035 # --logfile   # server log file
2036 # --ipv4      # server IP version 4
2037 # --ipv6      # server IP version 6
2038 # --port      # server listener port
2039 # --addr      # server address for listener port binding
2040 #
2041 while(@ARGV) {
2042     if($ARGV[0] eq '--verbose') {
2043         $verbose = 1;
2044     }
2045     elsif($ARGV[0] eq '--srcdir') {
2046         if($ARGV[1]) {
2047             $srcdir = $ARGV[1];
2048             shift @ARGV;
2049         }
2050     }
2051     elsif($ARGV[0] eq '--id') {
2052         if($ARGV[1] && ($ARGV[1] =~ /^(\d+)$/)) {
2053             $idnum = $1 if($1 > 0);
2054             shift @ARGV;
2055         }
2056     }
2057     elsif($ARGV[0] eq '--proto') {
2058         if($ARGV[1] && ($ARGV[1] =~ /^(ftp|imap|pop3|smtp)$/)) {
2059             $proto = $1;
2060             shift @ARGV;
2061         }
2062         else {
2063             die "unsupported protocol $ARGV[1]";
2064         }
2065     }
2066     elsif($ARGV[0] eq '--pidfile') {
2067         if($ARGV[1]) {
2068             $pidfile = $ARGV[1];
2069             shift @ARGV;
2070         }
2071     }
2072     elsif($ARGV[0] eq '--logfile') {
2073         if($ARGV[1]) {
2074             $logfile = $ARGV[1];
2075             shift @ARGV;
2076         }
2077     }
2078     elsif($ARGV[0] eq '--ipv4') {
2079         $ipvnum = 4;
2080         $listenaddr = '127.0.0.1' if($listenaddr eq '::1');
2081     }
2082     elsif($ARGV[0] eq '--ipv6') {
2083         $ipvnum = 6;
2084         $listenaddr = '::1' if($listenaddr eq '127.0.0.1');
2085     }
2086     elsif($ARGV[0] eq '--port') {
2087         if($ARGV[1] && ($ARGV[1] =~ /^(\d+)$/)) {
2088             $port = $1 if($1 > 1024);
2089             shift @ARGV;
2090         }
2091     }
2092     elsif($ARGV[0] eq '--addr') {
2093         if($ARGV[1]) {
2094             my $tmpstr = $ARGV[1];
2095             if($tmpstr =~ /^(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)$/) {
2096                 $listenaddr = "$1.$2.$3.$4" if($ipvnum == 4);
2097             }
2098             elsif($ipvnum == 6) {
2099                 $listenaddr = $tmpstr;
2100                 $listenaddr =~ s/^\[(.*)\]$/$1/;
2101             }
2102             shift @ARGV;
2103         }
2104     }
2105     else {
2106         print STDERR "\nWarning: ftpserver.pl unknown parameter: $ARGV[0]\n";
2107     }
2108     shift @ARGV;
2109 }
2110
2111 #***************************************************************************
2112 # Initialize command line option dependant variables
2113 #
2114
2115 if(!$srcdir) {
2116     $srcdir = $ENV{'srcdir'} || '.';
2117 }
2118 if(!$pidfile) {
2119     $pidfile = "$path/". server_pidfilename($proto, $ipvnum, $idnum);
2120 }
2121 if(!$logfile) {
2122     $logfile = server_logfilename($logdir, $proto, $ipvnum, $idnum);
2123 }
2124
2125 $mainsockf_pidfile = "$path/".
2126     mainsockf_pidfilename($proto, $ipvnum, $idnum);
2127 $mainsockf_logfile =
2128     mainsockf_logfilename($logdir, $proto, $ipvnum, $idnum);
2129
2130 if($proto eq 'ftp') {
2131     $datasockf_pidfile = "$path/".
2132         datasockf_pidfilename($proto, $ipvnum, $idnum);
2133     $datasockf_logfile =
2134         datasockf_logfilename($logdir, $proto, $ipvnum, $idnum);
2135 }
2136
2137 $srvrname = servername_str($proto, $ipvnum, $idnum);
2138
2139 $idstr = "$idnum" if($idnum > 1);
2140
2141 protocolsetup($proto);
2142
2143 $SIG{INT} = \&exit_signal_handler;
2144 $SIG{TERM} = \&exit_signal_handler;
2145
2146 startsf();
2147
2148 logmsg sprintf("%s server listens on port IPv${ipvnum}/${port}\n", uc($proto));
2149
2150 open(PID, ">$pidfile");
2151 print PID $$."\n";
2152 close(PID);
2153
2154 logmsg("logged pid $$ in $pidfile\n");
2155
2156
2157 while(1) {
2158
2159     # kill previous data connection sockfilt when alive
2160     if($datasockf_runs eq 'yes') {
2161         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
2162         logmsg "DATA sockfilt for $datasockf_mode data channel killed now\n";
2163     }
2164     datasockf_state('STOPPED');
2165
2166     #
2167     # We read 'sockfilt' commands.
2168     #
2169     my $input;
2170
2171     logmsg "Awaiting input\n";
2172     sysread_or_die(\*SFREAD, \$input, 5);
2173
2174     if($input !~ /^CNCT/) {
2175         # we wait for a connected client
2176         logmsg "MAIN sockfilt said: $input";
2177         next;
2178     }
2179     logmsg "====> Client connect\n";
2180
2181     set_advisor_read_lock($SERVERLOGS_LOCK);
2182     $serverlogslocked = 1;
2183
2184     # flush data:
2185     $| = 1;
2186
2187     &customize(); # read test control instructions
2188
2189     my $welcome = $customreply{"welcome"};
2190     if(!$welcome) {
2191         $welcome = $displaytext{"welcome"};
2192     }
2193     else {
2194         # clear it after use
2195         $customreply{"welcome"}="";
2196         if($welcome !~ /\r\n\z/) {
2197             $welcome .= "\r\n";
2198         }
2199     }
2200     sendcontrol $welcome;
2201
2202     #remove global variables from last connection
2203     if($ftplistparserstate) {
2204       undef $ftplistparserstate;
2205     }
2206     if($ftptargetdir) {
2207       undef $ftptargetdir;
2208     }
2209
2210     if($verbose) {
2211         print STDERR "OUT: $welcome";
2212     }
2213
2214     my $full = "";
2215
2216     while(1) {
2217         my $i;
2218
2219         # Now we expect to read DATA\n[hex size]\n[prot], where the [prot]
2220         # part only is FTP lingo.
2221
2222         # COMMAND
2223         sysread_or_die(\*SFREAD, \$i, 5);
2224
2225         if($i !~ /^DATA/) {
2226             logmsg "MAIN sockfilt said $i";
2227             if($i =~ /^DISC/) {
2228                 # disconnect
2229                 last;
2230             }
2231             next;
2232         }
2233
2234         # SIZE of data
2235         sysread_or_die(\*SFREAD, \$i, 5);
2236
2237         my $size = 0;
2238         if($i =~ /^([0-9a-fA-F]{4})\n/) {
2239             $size = hex($1);
2240         }
2241
2242         # data
2243         read_mainsockf(\$input, $size);
2244
2245         ftpmsg $input;
2246
2247         $full .= $input;
2248
2249         # Loop until command completion
2250         next unless($full =~ /\r\n$/);
2251
2252         # Remove trailing CRLF.
2253         $full =~ s/[\n\r]+$//;
2254
2255         my $FTPCMD;
2256         my $FTPARG;
2257         if($proto eq "imap") {
2258             # IMAP is different with its identifier first on the command line
2259             unless(($full =~ /^([^ ]+) ([^ ]+) (.*)/) ||
2260                    ($full =~ /^([^ ]+) ([^ ]+)/)) {
2261                 sendcontrol "$1 '$full': command not understood.\r\n";
2262                 last;
2263             }
2264             $cmdid=$1; # set the global variable
2265             $FTPCMD=$2;
2266             $FTPARG=$3;
2267         }
2268         elsif($full =~ /^([A-Z]{3,4})(\s(.*))?$/i) {
2269             $FTPCMD=$1;
2270             $FTPARG=$3;
2271         }
2272         elsif(($proto eq "smtp") && ($full =~ /^[A-Z0-9+\/]{0,512}={0,2}$/i)) {
2273             # SMTP long "commands" are base64 authentication data.
2274             $FTPCMD=$full;
2275             $FTPARG="";
2276         }
2277         else {
2278             sendcontrol "500 '$full': command not understood.\r\n";
2279             last;
2280         }
2281
2282         logmsg "< \"$full\"\n";
2283
2284         if($verbose) {
2285             print STDERR "IN: $full\n";
2286         }
2287
2288         $full = "";
2289
2290         my $delay = $delayreply{$FTPCMD};
2291         if($delay) {
2292             # just go sleep this many seconds!
2293             logmsg("Sleep for $delay seconds\n");
2294             my $twentieths = $delay * 20;
2295             while($twentieths--) {
2296                 select(undef, undef, undef, 0.05) unless($got_exit_signal);
2297             }
2298         }
2299
2300         my $text;
2301         $text = $customreply{$FTPCMD};
2302         my $fake = $text;
2303
2304         if($text && ($text ne "")) {
2305             if($customcount{$FTPCMD} && (!--$customcount{$FTPCMD})) {
2306                 # used enough number of times, now blank the customreply
2307                 $customreply{$FTPCMD}="";
2308             }
2309         }
2310         else {
2311             $text = $displaytext{$FTPCMD};
2312         }
2313         my $check;
2314         if($text && ($text ne "")) {
2315             if($cmdid && ($cmdid ne "")) {
2316                 sendcontrol "$cmdid$text\r\n";
2317             }
2318             else {
2319                 sendcontrol "$text\r\n";
2320             }
2321         }
2322         else {
2323             $check=1; # no response yet
2324         }
2325
2326         unless($fake && ($fake ne "")) {
2327             # only perform this if we're not faking a reply
2328             my $func = $commandfunc{$FTPCMD};
2329             if($func) {
2330                 &$func($FTPARG, $FTPCMD);
2331                 $check=0; # taken care of
2332             }
2333         }
2334
2335         if($check) {
2336             logmsg "$FTPCMD wasn't handled!\n";
2337             if($proto eq 'pop3') {
2338                 sendcontrol "-ERR $FTPCMD is not dealt with!\r\n";
2339             }
2340             elsif($proto eq 'imap') {
2341                 sendcontrol "$cmdid BAD $FTPCMD is not dealt with!\r\n";
2342             }
2343             else {
2344                 sendcontrol "500 $FTPCMD is not dealt with!\r\n";
2345             }
2346         }
2347
2348     } # while(1)
2349     logmsg "====> Client disconnected\n";
2350
2351     if($serverlogslocked) {
2352         $serverlogslocked = 0;
2353         clear_advisor_read_lock($SERVERLOGS_LOCK);
2354     }
2355 }
2356
2357 killsockfilters($proto, $ipvnum, $idnum, $verbose);
2358 unlink($pidfile);
2359 if($serverlogslocked) {
2360     $serverlogslocked = 0;
2361     clear_advisor_read_lock($SERVERLOGS_LOCK);
2362 }
2363
2364 exit;