tests/ftpserver.pl

   1 #!/usr/bin/env perl
   2 #***************************************************************************
   3 #                                  _   _ ____  _
   4 #  Project                     ___| | | |  _ \| |
   5 #                             / __| | | | |_) | |
   6 #                            | (__| |_| |  _ <| |___
   7 #                             \___|\___/|_| \_\_____|
   8 #
   9 # Copyright (C) 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 https://curl.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 # SPDX-License-Identifier: curl
  23 #
  24 ###########################################################################
  25
  26 # This is a server designed for the curl test suite.
  27 #
  28 # In December 2009 we started remaking the server to support more protocols
  29 # that are similar in spirit. Like POP3, IMAP and SMTP in addition to the FTP
  30 # it already supported since a long time. Note that it still only supports one
  31 # protocol per invoke. You need to start multiple servers to support multiple
  32 # protocols simultaneously.
  33 #
  34 # It is meant to exercise curl, it is not meant to be a fully working
  35 # or even very standard compliant server.
  36 #
  37 # You may optionally specify port on the command line, otherwise it'll
  38 # default to port 8921.
  39 #
  40 # All socket/network/TCP related stuff is done by the 'sockfilt' program.
  41 #
  42
  43 use strict;
  44 use warnings;
  45
  46 BEGIN {
  47     push(@INC, $ENV{'srcdir'}) if(defined $ENV{'srcdir'});
  48     push(@INC, ".");
  49 }
  50
  51 use IPC::Open2;
  52 use Digest::MD5;
  53 use File::Basename;
  54
  55 use directories;
  56
  57 use getpart qw(
  58     getpartattr
  59     getpart
  60     loadtest
  61     );
  62
  63 use processhelp;
  64
  65 use serverhelp qw(
  66     logmsg
  67     $logfile
  68     servername_str
  69     server_pidfilename
  70     server_logfilename
  71     mainsockf_pidfilename
  72     mainsockf_logfilename
  73     datasockf_pidfilename
  74     datasockf_logfilename
  75     );
  76
  77 use pathhelp qw(
  78     exe_ext
  79     );
  80
  81 use globalconfig qw(
  82     $SERVERCMD
  83     $LOCKDIR
  84     );
  85
  86 #**********************************************************************
  87 # global vars...
  88 #
  89 my $verbose = 0;    # set to 1 for debugging
  90 my $idstr = "";     # server instance string
  91 my $idnum = 1;      # server instance number
  92 my $ipvnum = 4;     # server IPv number (4 or 6)
  93 my $proto = 'ftp';  # default server protocol
  94 my $srcdir;         # directory where ftpserver.pl is located
  95 my $srvrname;       # server name for presentation purposes
  96 my $cwd_testno;     # test case numbers extracted from CWD command
  97 my $testno = 0;     # test case number (read from server.cmd)
  98 my $path   = '.';
  99 my $logdir = $path .'/log';
 100 my $piddir;
 101
 102 #**********************************************************************
 103 # global vars used for server address and primary listener port
 104 #
 105 my $port = 8921;               # default primary listener port
 106 my $listenaddr = '127.0.0.1';  # default address for listener port
 107
 108 #**********************************************************************
 109 # global vars used for file names
 110 #
 111 my $PORTFILE="ftpserver.port"; # server port file name
 112 my $portfile;           # server port file path
 113 my $pidfile;            # server pid file name
 114 my $mainsockf_pidfile;  # pid file for primary connection sockfilt process
 115 my $mainsockf_logfile;  # log file for primary connection sockfilt process
 116 my $datasockf_pidfile;  # pid file for secondary connection sockfilt process
 117 my $datasockf_logfile;  # log file for secondary connection sockfilt process
 118
 119 #**********************************************************************
 120 # global vars used for server logs advisor read lock handling
 121 #
 122 my $serverlogs_lockfile;
 123 my $serverlogslocked = 0;
 124
 125 #**********************************************************************
 126 # global vars used for child processes PID tracking
 127 #
 128 my $sfpid;        # PID for primary connection sockfilt process
 129 my $slavepid;     # PID for secondary connection sockfilt process
 130
 131 #**********************************************************************
 132 # global typeglob filehandle vars to read/write from/to sockfilters
 133 #
 134 local *SFREAD;    # used to read from primary connection
 135 local *SFWRITE;   # used to write to primary connection
 136 local *DREAD;     # used to read from secondary connection
 137 local *DWRITE;    # used to write to secondary connection
 138
 139 my $sockfilt_timeout = 5;  # default timeout for sockfilter eXsysreads
 140
 141 #**********************************************************************
 142 # global vars which depend on server protocol selection
 143 #
 144 my %commandfunc;   # protocol command specific function callbacks
 145 my %displaytext;   # text returned to client before callback runs
 146
 147 #**********************************************************************
 148 # global vars customized for each test from the server commands file
 149 #
 150 my $ctrldelay;     # set if server should throttle ctrl stream
 151 my $datadelay;     # set if server should throttle data stream
 152 my $retrweirdo;    # set if ftp server should use RETRWEIRDO
 153 my $retrnosize;    # set if ftp server should use RETRNOSIZE
 154 my $retrsize;      # set if ftp server should use RETRSIZE
 155 my $pasvbadip;     # set if ftp server should use PASVBADIP
 156 my $nosave;        # set if ftp server should not save uploaded data
 157 my $nodataconn;    # set if ftp srvr doesn't establish or accepts data channel
 158 my $nodataconn425; # set if ftp srvr doesn't establish data ch and replies 425
 159 my $nodataconn421; # set if ftp srvr doesn't establish data ch and replies 421
 160 my $nodataconn150; # set if ftp srvr doesn't establish data ch and replies 150
 161 my $storeresp;
 162 my $postfetch;
 163 my @capabilities;  # set if server supports capability commands
 164 my @auth_mechs;    # set if server supports authentication commands
 165 my %fulltextreply; #
 166 my %commandreply;  #
 167 my %customcount;   #
 168 my %delayreply;    #
 169
 170 #**********************************************************************
 171 # global variables for to test ftp wildcardmatching or other test that
 172 # need flexible LIST responses.. and corresponding files.
 173 # $ftptargetdir is keeping the fake "name" of LIST directory.
 174 #
 175 my $ftplistparserstate;
 176 my $ftptargetdir="";
 177
 178 #**********************************************************************
 179 # global variables used when running a ftp server to keep state info
 180 # relative to the secondary or data sockfilt process. Values of these
 181 # variables should only be modified using datasockf_state() sub, given
 182 # that they are closely related and relationship is a bit awkward.
 183 #
 184 my $datasockf_state = 'STOPPED'; # see datasockf_state() sub
 185 my $datasockf_mode = 'none';     # ['none','active','passive']
 186 my $datasockf_runs = 'no';       # ['no','yes']
 187 my $datasockf_conn = 'no';       # ['no','yes']
 188
 189 #**********************************************************************
 190 # global vars used for signal handling
 191 #
 192 my $got_exit_signal = 0; # set if program should finish execution ASAP
 193 my $exit_signal;         # first signal handled in exit_signal_handler
 194
 195 #**********************************************************************
 196 # Mail related definitions
 197 #
 198 my $TEXT_PASSWORD = "secret";
 199 my $POP3_TIMESTAMP = "<1972.987654321\@curl>";
 200
 201 #**********************************************************************
 202 # exit_signal_handler will be triggered to indicate that the program
 203 # should finish its execution in a controlled way as soon as possible.
 204 # For now, program will also terminate from within this handler.
 205 #
 206 sub exit_signal_handler {
 207     my $signame = shift;
 208     # For now, simply mimic old behavior.
 209     killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
 210     unlink($pidfile);
 211     unlink($portfile);
 212     if($serverlogslocked) {
 213         $serverlogslocked = 0;
 214         clear_advisor_read_lock($serverlogs_lockfile);
 215     }
 216     exit;
 217 }
 218
 219 sub ftpmsg {
 220   # append to the server.input file
 221   open(my $input, ">>", "$logdir/server$idstr.input") ||
 222     logmsg "failed to open $logdir/server$idstr.input\n";
 223
 224   print $input @_;
 225   close($input);
 226
 227   # use this, open->print->close system only to make the file
 228   # open as little as possible, to make the test suite run
 229   # better on windows/cygwin
 230 }
 231
 232 #**********************************************************************
 233 # eXsysread is a wrapper around perl's sysread() function. This will
 234 # repeat the call to sysread() until it has actually read the complete
 235 # number of requested bytes or an unrecoverable condition occurs.
 236 # On success returns a positive value, the number of bytes requested.
 237 # On failure or timeout returns zero.
 238 #
 239 sub eXsysread {
 240     my $FH      = shift;
 241     my $scalar  = shift;
 242     my $nbytes  = shift;
 243     my $timeout = shift; # A zero timeout disables eXsysread() time limit
 244     #
 245     my $time_limited = 0;
 246     my $timeout_rest = 0;
 247     my $start_time = 0;
 248     my $nread  = 0;
 249     my $rc;
 250
 251     $$scalar = "";
 252
 253     if((not defined $nbytes) || ($nbytes < 1)) {
 254         logmsg "Error: eXsysread() failure: " .
 255                "length argument must be positive\n";
 256         return 0;
 257     }
 258     if((not defined $timeout) || ($timeout < 0)) {
 259         logmsg "Error: eXsysread() failure: " .
 260                "timeout argument must be zero or positive\n";
 261         return 0;
 262     }
 263     if($timeout > 0) {
 264         # caller sets eXsysread() time limit
 265         $time_limited = 1;
 266         $timeout_rest = $timeout;
 267         $start_time = int(time());
 268     }
 269
 270     while($nread < $nbytes) {
 271         if($time_limited) {
 272             eval {
 273                 local $SIG{ALRM} = sub { die "alarm\n"; };
 274                 alarm $timeout_rest;
 275                 $rc = sysread($FH, $$scalar, $nbytes - $nread, $nread);
 276                 alarm 0;
 277             };
 278             $timeout_rest = $timeout - (int(time()) - $start_time);
 279             if($timeout_rest < 1) {
 280                 logmsg "Error: eXsysread() failure: timed out\n";
 281                 return 0;
 282             }
 283         }
 284         else {
 285             $rc = sysread($FH, $$scalar, $nbytes - $nread, $nread);
 286         }
 287         if($got_exit_signal) {
 288             logmsg "Error: eXsysread() failure: signalled to die\n";
 289             return 0;
 290         }
 291         if(not defined $rc) {
 292             if($!{EINTR}) {
 293                 logmsg "Warning: retrying sysread() interrupted system call\n";
 294                 next;
 295             }
 296             if($!{EAGAIN}) {
 297                 logmsg "Warning: retrying sysread() due to EAGAIN\n";
 298                 next;
 299             }
 300             if($!{EWOULDBLOCK}) {
 301                 logmsg "Warning: retrying sysread() due to EWOULDBLOCK\n";
 302                 next;
 303             }
 304             logmsg "Error: sysread() failure: $!\n";
 305             return 0;
 306         }
 307         if($rc < 0) {
 308             logmsg "Error: sysread() failure: returned negative value $rc\n";
 309             return 0;
 310         }
 311         if($rc == 0) {
 312             logmsg "Error: sysread() failure: read zero bytes\n";
 313             return 0;
 314         }
 315         $nread += $rc;
 316     }
 317     return $nread;
 318 }
 319
 320 #**********************************************************************
 321 # read_mainsockf attempts to read the given amount of output from the
 322 # sockfilter which is in use for the main or primary connection. This
 323 # reads untranslated sockfilt lingo which may hold data read from the
 324 # main or primary socket. On success returns 1, otherwise zero.
 325 #
 326 sub read_mainsockf {
 327     my $scalar  = shift;
 328     my $nbytes  = shift;
 329     my $timeout = shift; # Optional argument, if zero blocks indefinitely
 330     my $FH = \*SFREAD;
 331
 332     if(not defined $timeout) {
 333         $timeout = $sockfilt_timeout + ($nbytes >> 12);
 334     }
 335     if(eXsysread($FH, $scalar, $nbytes, $timeout) != $nbytes) {
 336         my ($fcaller, $lcaller) = (caller)[1,2];
 337         logmsg "Error: read_mainsockf() failure at $fcaller " .
 338                "line $lcaller. Due to eXsysread() failure\n";
 339         return 0;
 340     }
 341     return 1;
 342 }
 343
 344 #**********************************************************************
 345 # read_datasockf attempts to read the given amount of output from the
 346 # sockfilter which is in use for the data or secondary connection. This
 347 # reads untranslated sockfilt lingo which may hold data read from the
 348 # data or secondary socket. On success returns 1, otherwise zero.
 349 #
 350 sub read_datasockf {
 351     my $scalar = shift;
 352     my $nbytes = shift;
 353     my $timeout = shift; # Optional argument, if zero blocks indefinitely
 354     my $FH = \*DREAD;
 355
 356     if(not defined $timeout) {
 357         $timeout = $sockfilt_timeout + ($nbytes >> 12);
 358     }
 359     if(eXsysread($FH, $scalar, $nbytes, $timeout) != $nbytes) {
 360         my ($fcaller, $lcaller) = (caller)[1,2];
 361         logmsg "Error: read_datasockf() failure at $fcaller " .
 362                "line $lcaller. Due to eXsysread() failure\n";
 363         return 0;
 364     }
 365     return 1;
 366 }
 367
 368 sub sysread_or_die {
 369     my $FH     = shift;
 370     my $scalar = shift;
 371     my $length = shift;
 372     my $fcaller;
 373     my $lcaller;
 374     my $result;
 375
 376     $result = sysread($$FH, $$scalar, $length);
 377
 378     if(not defined $result) {
 379         ($fcaller, $lcaller) = (caller)[1,2];
 380         logmsg "Failed to read input\n";
 381         logmsg "Error: $srvrname server, sysread error: $!\n";
 382         logmsg "Exited from sysread_or_die() at $fcaller " .
 383                "line $lcaller. $srvrname server, sysread error: $!\n";
 384         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
 385         unlink($pidfile);
 386         unlink($portfile);
 387         if($serverlogslocked) {
 388             $serverlogslocked = 0;
 389             clear_advisor_read_lock($serverlogs_lockfile);
 390         }
 391         exit;
 392     }
 393     elsif($result == 0) {
 394         ($fcaller, $lcaller) = (caller)[1,2];
 395         logmsg "Failed to read input\n";
 396         logmsg "Error: $srvrname server, read zero\n";
 397         logmsg "Exited from sysread_or_die() at $fcaller " .
 398                "line $lcaller. $srvrname server, read zero\n";
 399         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
 400         unlink($pidfile);
 401         unlink($portfile);
 402         if($serverlogslocked) {
 403             $serverlogslocked = 0;
 404             clear_advisor_read_lock($serverlogs_lockfile);
 405         }
 406         exit;
 407     }
 408
 409     return $result;
 410 }
 411
 412 sub startsf {
 413     my @mainsockfcmd = ("./server/sockfilt".exe_ext('SRV'),
 414         "--ipv$ipvnum",
 415         "--port", $port,
 416         "--pidfile", $mainsockf_pidfile,
 417         "--portfile", $portfile,
 418         "--logfile", $mainsockf_logfile);
 419     $sfpid = open2(*SFREAD, *SFWRITE, @mainsockfcmd);
 420
 421     print STDERR "@mainsockfcmd\n" if($verbose);
 422
 423     print SFWRITE "PING\n";
 424     my $pong;
 425     sysread_or_die(\*SFREAD, \$pong, 5);
 426
 427     if($pong !~ /^PONG/) {
 428         logmsg "Failed sockfilt command: @mainsockfcmd\n";
 429         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
 430         unlink($pidfile);
 431         unlink($portfile);
 432         if($serverlogslocked) {
 433             $serverlogslocked = 0;
 434             clear_advisor_read_lock($serverlogs_lockfile);
 435         }
 436         die "Failed to start sockfilt!";
 437     }
 438 }
 439
 440 #**********************************************************************
 441 # Returns the given test's reply data
 442 #
 443 sub getreplydata {
 444     my ($num) = @_;
 445     my $testpart = "";
 446
 447     $num =~ s/^([^0-9]*)//;
 448     if($num > 10000) {
 449        $testpart = $num % 10000;
 450     }
 451
 452     my @data = getpart("reply", "data$testpart");
 453     if((!@data) && ($testpart ne "")) {
 454         @data = getpart("reply", "data");
 455     }
 456
 457     return @data;
 458 }
 459
 460 sub sockfilt {
 461     my $l;
 462     foreach $l (@_) {
 463         printf SFWRITE "DATA\n%04x\n", length($l);
 464         print SFWRITE $l;
 465     }
 466 }
 467
 468 sub sockfiltsecondary {
 469     my $l;
 470     foreach $l (@_) {
 471         printf DWRITE "DATA\n%04x\n", length($l);
 472         print DWRITE $l;
 473     }
 474 }
 475
 476 #**********************************************************************
 477 # Send data to the client on the control stream, which happens to be plain
 478 # stdout.
 479 #
 480 sub sendcontrol {
 481     if(!$ctrldelay) {
 482         # spit it all out at once
 483         sockfilt @_;
 484     }
 485     else {
 486         my $a = join("", @_);
 487         my @a = split("", $a);
 488
 489         for(@a) {
 490             sockfilt $_;
 491             portable_sleep(0.01);
 492         }
 493     }
 494     my $log;
 495     foreach $log (@_) {
 496         my $l = $log;
 497         $l =~ s/\r/[CR]/g;
 498         $l =~ s/\n/[LF]/g;
 499         logmsg "> \"$l\"\n";
 500     }
 501 }
 502
 503 #**********************************************************************
 504 # Send data to the FTP client on the data stream when data connection
 505 # is actually established. Given that this sub should only be called
 506 # when a data connection is supposed to be established, calling this
 507 # without a data connection is an indication of weak logic somewhere.
 508 #
 509 sub senddata {
 510     my $l;
 511     if($datasockf_conn eq 'no') {
 512         logmsg "WARNING: Detected data sending attempt without DATA channel\n";
 513         foreach $l (@_) {
 514             logmsg "WARNING: Data swallowed: $l\n"
 515         }
 516         return;
 517     }
 518
 519     foreach $l (@_) {
 520         if(!$datadelay) {
 521             # spit it all out at once
 522             sockfiltsecondary $l;
 523         }
 524         else {
 525             # pause between each byte
 526             for (split(//,$l)) {
 527                 sockfiltsecondary $_;
 528                 portable_sleep(0.01);
 529             }
 530         }
 531     }
 532 }
 533
 534 #**********************************************************************
 535 # protocolsetup initializes the 'displaytext' and 'commandfunc' hashes
 536 # for the given protocol. References to protocol command callbacks are
 537 # stored in 'commandfunc' hash, and text which will be returned to the
 538 # client before the command callback runs is stored in 'displaytext'.
 539 #
 540 sub protocolsetup {
 541     my $proto = $_[0];
 542
 543     if($proto eq 'ftp') {
 544         %commandfunc = (
 545             'PORT' => \&PORT_ftp,
 546             'EPRT' => \&PORT_ftp,
 547             'LIST' => \&LIST_ftp,
 548             'NLST' => \&NLST_ftp,
 549             'PASV' => \&PASV_ftp,
 550             'CWD'  => \&CWD_ftp,
 551             'PWD'  => \&PWD_ftp,
 552             'EPSV' => \&PASV_ftp,
 553             'RETR' => \&RETR_ftp,
 554             'SIZE' => \&SIZE_ftp,
 555             'REST' => \&REST_ftp,
 556             'STOR' => \&STOR_ftp,
 557             'APPE' => \&STOR_ftp, # append looks like upload
 558             'MDTM' => \&MDTM_ftp,
 559         );
 560         %displaytext = (
 561             'USER' => '331 We are happy you popped in!',
 562             'PASS' => '230 Welcome you silly person',
 563             'PORT' => '200 You said PORT - I say FINE',
 564             'TYPE' => '200 I modify TYPE as you wanted',
 565             'LIST' => '150 here comes a directory',
 566             'NLST' => '150 here comes a directory',
 567             'CWD'  => '250 CWD command successful.',
 568             'SYST' => '215 UNIX Type: L8', # just fake something
 569             'QUIT' => '221 bye bye baby', # just reply something
 570             'MKD'  => '257 Created your requested directory',
 571             'REST' => '350 Yeah yeah we set it there for you',
 572             'DELE' => '200 OK OK OK whatever you say',
 573             'RNFR' => '350 Received your order. Please provide more',
 574             'RNTO' => '250 Ok, thanks. File renaming completed.',
 575             'NOOP' => '200 Yes, I\'m very good at doing nothing.',
 576             'PBSZ' => '500 PBSZ not implemented',
 577             'PROT' => '500 PROT not implemented',
 578             'welcome' => join("",
 579             '220-        _   _ ____  _     '."\r\n",
 580             '220-    ___| | | |  _ \| |    '."\r\n",
 581             '220-   / __| | | | |_) | |    '."\r\n",
 582             '220-  | (__| |_| |  _ {| |___ '."\r\n",
 583             '220    \___|\___/|_| \_\_____|'."\r\n")
 584         );
 585     }
 586     elsif($proto eq 'pop3') {
 587         %commandfunc = (
 588             'APOP' => \&APOP_pop3,
 589             'AUTH' => \&AUTH_pop3,
 590             'CAPA' => \&CAPA_pop3,
 591             'DELE' => \&DELE_pop3,
 592             'LIST' => \&LIST_pop3,
 593             'NOOP' => \&NOOP_pop3,
 594             'PASS' => \&PASS_pop3,
 595             'QUIT' => \&QUIT_pop3,
 596             'RETR' => \&RETR_pop3,
 597             'RSET' => \&RSET_pop3,
 598             'STAT' => \&STAT_pop3,
 599             'TOP'  => \&TOP_pop3,
 600             'UIDL' => \&UIDL_pop3,
 601             'USER' => \&USER_pop3,
 602         );
 603         %displaytext = (
 604             'welcome' => join("",
 605             '        _   _ ____  _     '."\r\n",
 606             '    ___| | | |  _ \| |    '."\r\n",
 607             '   / __| | | | |_) | |    '."\r\n",
 608             '  | (__| |_| |  _ {| |___ '."\r\n",
 609             '   \___|\___/|_| \_\_____|'."\r\n",
 610             '+OK curl POP3 server ready to serve '."\r\n")
 611         );
 612     }
 613     elsif($proto eq 'imap') {
 614         %commandfunc = (
 615             'APPEND'     => \&APPEND_imap,
 616             'CAPABILITY' => \&CAPABILITY_imap,
 617             'CHECK'      => \&CHECK_imap,
 618             'CLOSE'      => \&CLOSE_imap,
 619             'COPY'       => \&COPY_imap,
 620             'CREATE'     => \&CREATE_imap,
 621             'DELETE'     => \&DELETE_imap,
 622             'EXAMINE'    => \&EXAMINE_imap,
 623             'EXPUNGE'    => \&EXPUNGE_imap,
 624             'FETCH'      => \&FETCH_imap,
 625             'LIST'       => \&LIST_imap,
 626             'LSUB'       => \&LSUB_imap,
 627             'LOGIN'      => \&LOGIN_imap,
 628             'LOGOUT'     => \&LOGOUT_imap,
 629             'NOOP'       => \&NOOP_imap,
 630             'RENAME'     => \&RENAME_imap,
 631             'SEARCH'     => \&SEARCH_imap,
 632             'SELECT'     => \&SELECT_imap,
 633             'STATUS'     => \&STATUS_imap,
 634             'STORE'      => \&STORE_imap,
 635             'UID'        => \&UID_imap,
 636             'IDLE'       => \&IDLE_imap,
 637         );
 638         %displaytext = (
 639             'welcome' => join("",
 640             '        _   _ ____  _     '."\r\n",
 641             '    ___| | | |  _ \| |    '."\r\n",
 642             '   / __| | | | |_) | |    '."\r\n",
 643             '  | (__| |_| |  _ {| |___ '."\r\n",
 644             '   \___|\___/|_| \_\_____|'."\r\n",
 645             '* OK curl IMAP server ready to serve'."\r\n")
 646         );
 647     }
 648     elsif($proto eq 'smtp') {
 649         %commandfunc = (
 650             'DATA' => \&DATA_smtp,
 651             'EHLO' => \&EHLO_smtp,
 652             'EXPN' => \&EXPN_smtp,
 653             'HELO' => \&HELO_smtp,
 654             'HELP' => \&HELP_smtp,
 655             'MAIL' => \&MAIL_smtp,
 656             'NOOP' => \&NOOP_smtp,
 657             'RSET' => \&RSET_smtp,
 658             'RCPT' => \&RCPT_smtp,
 659             'VRFY' => \&VRFY_smtp,
 660             'QUIT' => \&QUIT_smtp,
 661         );
 662         %displaytext = (
 663             'welcome' => join("",
 664             '220-        _   _ ____  _     '."\r\n",
 665             '220-    ___| | | |  _ \| |    '."\r\n",
 666             '220-   / __| | | | |_) | |    '."\r\n",
 667             '220-  | (__| |_| |  _ {| |___ '."\r\n",
 668             '220    \___|\___/|_| \_\_____|'."\r\n")
 669         );
 670     }
 671 }
 672
 673 # Perform the disconnecgt handshake with sockfilt on the secondary connection
 674 # (the only connection we actively disconnect).
 675 # This involves waiting for the disconnect acknowledgmeent after the DISC
 676 # command, while throwing away anything else that might come in before
 677 # that.
 678 sub disc_handshake {
 679     print DWRITE "DISC\n";
 680     my $line;
 681     my $nr;
 682     while (5 == ($nr = sysread DREAD, $line, 5)) {
 683         if($line eq "DATA\n") {
 684             # Must read the data bytes to stay in sync
 685             my $i;
 686             sysread DREAD, $i, 5;
 687
 688             my $size = 0;
 689             if($i =~ /^([0-9a-fA-F]{4})\n/) {
 690                 $size = hex($1);
 691             }
 692
 693             read_datasockf(\$line, $size);
 694
 695             logmsg "> Throwing away $size bytes on closed connection\n";
 696         }
 697         elsif($line eq "DISC\n") {
 698             logmsg "Fancy that; client wants to DISC, too\n";
 699             printf DWRITE "ACKD\n";
 700         }
 701         elsif($line eq "ACKD\n") {
 702             # Got the ack we were waiting for
 703             last;
 704         }
 705         else {
 706             logmsg "Ignoring: $line";
 707             # sockfilt should not be sending us any other commands
 708         }
 709     }
 710     if(!defined($nr)) {
 711         logmsg "Error: pipe read error ($!) while waiting for ACKD";
 712     }
 713     elsif($nr <= 0) {
 714         logmsg "Error: pipe EOF while waiting for ACKD";
 715     }
 716 }
 717
 718 sub close_dataconn {
 719     my ($closed)=@_; # non-zero if already disconnected
 720
 721     my $datapid = processexists($datasockf_pidfile);
 722
 723     logmsg "=====> Closing $datasockf_mode DATA connection...\n";
 724
 725     if(!$closed) {
 726         if($datapid > 0) {
 727             logmsg "Server disconnects $datasockf_mode DATA connection\n";
 728             disc_handshake();
 729             logmsg "Server disconnected $datasockf_mode DATA connection\n";
 730         }
 731         else {
 732             logmsg "Server finds $datasockf_mode DATA connection already ".
 733                    "disconnected\n";
 734         }
 735     }
 736     else {
 737         logmsg "Server knows $datasockf_mode DATA connection is already ".
 738                "disconnected\n";
 739     }
 740
 741     if($datapid > 0) {
 742         logmsg "DATA sockfilt for $datasockf_mode data channel quits ".
 743                "(pid $datapid)\n";
 744         print DWRITE "QUIT\n";
 745         pidwait($datapid, 0);
 746         unlink($datasockf_pidfile) if(-f $datasockf_pidfile);
 747         logmsg "DATA sockfilt for $datasockf_mode data channel quit ".
 748                "(pid $datapid)\n";
 749     }
 750     else {
 751         logmsg "DATA sockfilt for $datasockf_mode data channel already ".
 752                "dead\n";
 753     }
 754
 755     logmsg "=====> Closed $datasockf_mode DATA connection\n";
 756
 757     datasockf_state('STOPPED');
 758 }
 759
 760 ################
 761 ################ SMTP commands
 762 ################
 763
 764 # The type of server (SMTP or ESMTP)
 765 my $smtp_type;
 766
 767 # The client (which normally contains the test number)
 768 my $smtp_client;
 769
 770 sub EHLO_smtp {
 771     my ($client) = @_;
 772     my @data;
 773
 774     # TODO: Get the IP address of the client connection to use in the
 775     # EHLO response when the client doesn't specify one but for now use
 776     # 127.0.0.1
 777     if(!$client) {
 778         $client = "[127.0.0.1]";
 779     }
 780
 781     # Set the server type to ESMTP
 782     $smtp_type = "ESMTP";
 783
 784     # Calculate the EHLO response
 785     push @data, "$smtp_type pingpong test server Hello $client";
 786
 787     if((@capabilities) || (@auth_mechs)) {
 788         my $mechs;
 789
 790         for my $c (@capabilities) {
 791             push @data, $c;
 792         }
 793
 794         for my $am (@auth_mechs) {
 795             if(!$mechs) {
 796                 $mechs = "$am";
 797             }
 798             else {
 799                 $mechs .= " $am";
 800             }
 801         }
 802
 803         if($mechs) {
 804             push @data, "AUTH $mechs";
 805         }
 806     }
 807
 808     # Send the EHLO response
 809     for(my $i = 0; $i < @data; $i++) {
 810         my $d = $data[$i];
 811
 812         if($i < @data - 1) {
 813             sendcontrol "250-$d\r\n";
 814         }
 815         else {
 816             sendcontrol "250 $d\r\n";
 817         }
 818     }
 819
 820     # Store the client (as it may contain the test number)
 821     $smtp_client = $client;
 822
 823     return 0;
 824 }
 825
 826 sub HELO_smtp {
 827     my ($client) = @_;
 828
 829     # TODO: Get the IP address of the client connection to use in the HELO
 830     # response when the client doesn't specify one but for now use 127.0.0.1
 831     if(!$client) {
 832         $client = "[127.0.0.1]";
 833     }
 834
 835     # Set the server type to SMTP
 836     $smtp_type = "SMTP";
 837
 838     # Send the HELO response
 839     sendcontrol "250 $smtp_type pingpong test server Hello $client\r\n";
 840
 841     # Store the client (as it may contain the test number)
 842     $smtp_client = $client;
 843
 844     return 0;
 845 }
 846
 847 sub MAIL_smtp {
 848     my ($args) = @_;
 849
 850     logmsg "MAIL_smtp got $args\n";
 851
 852     if (!$args) {
 853         sendcontrol "501 Unrecognized parameter\r\n";
 854     }
 855     else {
 856         my $from;
 857         my $size;
 858         my $smtputf8 = grep /^SMTPUTF8$/, @capabilities;
 859         my @elements = split(/ /, $args);
 860
 861         # Get the FROM and SIZE parameters
 862         for my $e (@elements) {
 863             if($e =~ /^FROM:(.*)$/) {
 864                 $from = $1;
 865             }
 866             elsif($e =~ /^SIZE=(\d+)$/) {
 867                 $size = $1;
 868             }
 869         }
 870
 871         # this server doesn't "validate" MAIL FROM addresses
 872         if (length($from)) {
 873             my @found;
 874             my $valid = 1;
 875
 876             # Check the capabilities for SIZE and if the specified size is
 877             # greater than the message size then reject it
 878             if (@found = grep /^SIZE (\d+)$/, @capabilities) {
 879                 if ($found[0] =~ /^SIZE (\d+)$/) {
 880                     if ($size > $1) {
 881                         $valid = 0;
 882                     }
 883                 }
 884             }
 885
 886             if(!$valid) {
 887                 sendcontrol "552 Message size too large\r\n";
 888             }
 889             else {
 890                 sendcontrol "250 Sender OK\r\n";
 891             }
 892         }
 893         else {
 894             sendcontrol "501 Invalid address\r\n";
 895         }
 896     }
 897
 898     return 0;
 899 }
 900
 901 sub RCPT_smtp {
 902     my ($args) = @_;
 903
 904     logmsg "RCPT_smtp got $args\n";
 905
 906     # Get the TO parameter
 907     if($args !~ /^TO:(.*)/) {
 908         sendcontrol "501 Unrecognized parameter\r\n";
 909     }
 910     else {
 911         my $smtputf8 = grep /^SMTPUTF8$/, @capabilities;
 912         my $to = $1;
 913
 914         # Validate the to address (only a valid email address inside <> is
 915         # allowed, such as <user@example.com>)
 916         if ((!$smtputf8 && $to =~
 917               /^<([a-zA-Z0-9._%+-]+)\@(([a-zA-Z0-9-]+)\.)+([a-zA-Z]{2,4})>$/) ||
 918             ($smtputf8 && $to =~
 919               /^<([a-zA-Z0-9\x{80}-\x{ff}._%+-]+)\@(([a-zA-Z0-9\x{80}-\x{ff}-]+)\.)+([a-zA-Z]{2,4})>$/)) {
 920             sendcontrol "250 Recipient OK\r\n";
 921         }
 922         else {
 923             sendcontrol "501 Invalid address\r\n";
 924         }
 925     }
 926
 927     return 0;
 928 }
 929
 930 sub DATA_smtp {
 931     my ($args) = @_;
 932
 933     if ($args) {
 934         sendcontrol "501 Unrecognized parameter\r\n";
 935     }
 936     elsif ($smtp_client !~ /^(\d*)$/) {
 937         sendcontrol "501 Invalid arguments\r\n";
 938     }
 939     else {
 940         sendcontrol "354 Show me the mail\r\n";
 941
 942         my $testno = $smtp_client;
 943         my $filename = "$logdir/upload.$testno";
 944
 945         logmsg "Store test number $testno in $filename\n";
 946
 947         open(my $file, ">", "$filename") ||
 948             return 0; # failed to open output
 949
 950         my $line;
 951         my $ulsize=0;
 952         my $disc=0;
 953         my $raw;
 954         while (5 == (sysread \*SFREAD, $line, 5)) {
 955             if($line eq "DATA\n") {
 956                 my $i;
 957                 my $eob;
 958                 sysread \*SFREAD, $i, 5;
 959
 960                 my $size = 0;
 961                 if($i =~ /^([0-9a-fA-F]{4})\n/) {
 962                     $size = hex($1);
 963                 }
 964
 965                 read_mainsockf(\$line, $size);
 966
 967                 $ulsize += $size;
 968                 print $file $line if(!$nosave);
 969
 970                 $raw .= $line;
 971                 if($raw =~ /(?:^|\x0d\x0a)\x2e\x0d\x0a/) {
 972                     # end of data marker!
 973                     $eob = 1;
 974                 }
 975
 976                 logmsg "> Appending $size bytes to file\n";
 977
 978                 if($eob) {
 979                     logmsg "Found SMTP EOB marker\n";
 980                     last;
 981                 }
 982             }
 983             elsif($line eq "DISC\n") {
 984                 # disconnect!
 985                 $disc=1;
 986                 printf SFWRITE "ACKD\n";
 987                 last;
 988             }
 989             else {
 990                 logmsg "No support for: $line";
 991                 last;
 992             }
 993         }
 994
 995         if($nosave) {
 996             print $file "$ulsize bytes would've been stored here\n";
 997         }
 998
 999         close($file);
1000
1001         logmsg "received $ulsize bytes upload\n";
1002
1003         sendcontrol "250 OK, data received!\r\n";
1004     }
1005
1006     return 0;
1007 }
1008
1009 sub NOOP_smtp {
1010     my ($args) = @_;
1011
1012     if($args) {
1013         sendcontrol "501 Unrecognized parameter\r\n";
1014     }
1015     else {
1016         sendcontrol "250 OK\r\n";
1017     }
1018
1019     return 0;
1020 }
1021
1022 sub RSET_smtp {
1023     my ($args) = @_;
1024
1025     if($args) {
1026         sendcontrol "501 Unrecognized parameter\r\n";
1027     }
1028     else {
1029         sendcontrol "250 Resetting\r\n";
1030     }
1031
1032     return 0;
1033 }
1034
1035 sub HELP_smtp {
1036     my ($args) = @_;
1037
1038     # One argument is optional
1039     if($args) {
1040         logmsg "HELP_smtp got $args\n";
1041     }
1042
1043     if($smtp_client eq "verifiedserver") {
1044         # This is the secret command that verifies that this actually is
1045         # the curl test server
1046         sendcontrol "214 WE ROOLZ: $$\r\n";
1047
1048         if($verbose) {
1049             print STDERR "FTPD: We returned proof we are the test server\n";
1050         }
1051
1052         logmsg "return proof we are we\n";
1053     }
1054     else {
1055         sendcontrol "214-This server supports the following commands:\r\n";
1056
1057         if(@auth_mechs) {
1058             sendcontrol "214 HELO EHLO RCPT DATA RSET MAIL VRFY EXPN QUIT HELP AUTH\r\n";
1059         }
1060         else {
1061             sendcontrol "214 HELO EHLO RCPT DATA RSET MAIL VRFY EXPN QUIT HELP\r\n";
1062         }
1063     }
1064
1065     return 0;
1066 }
1067
1068 sub VRFY_smtp {
1069     my ($args) = @_;
1070     my ($username, $address) = split(/ /, $args, 2);
1071
1072     logmsg "VRFY_smtp got $args\n";
1073
1074     if($username eq "") {
1075         sendcontrol "501 Unrecognized parameter\r\n";
1076     }
1077     else {
1078         my $smtputf8 = grep /^SMTPUTF8$/, @capabilities;
1079
1080         # Validate the username (only a valid local or external username is
1081         # allowed, such as user or user@example.com)
1082         if ((!$smtputf8 && $username =~
1083             /^([a-zA-Z0-9._%+-]+)(\@(([a-zA-Z0-9-]+)\.)+([a-zA-Z]{2,4}))?$/) ||
1084             ($smtputf8 && $username =~
1085             /^([a-zA-Z0-9\x{80}-\x{ff}._%+-]+)(\@(([a-zA-Z0-9\x{80}-\x{ff}-]+)\.)+([a-zA-Z]{2,4}))?$/)) {
1086
1087             my @data = getreplydata($smtp_client);
1088
1089             if(!@data) {
1090                 if ($username !~
1091                     /^([a-zA-Z0-9._%+-]+)\@(([a-zA-Z0-9-]+)\.)+([a-zA-Z]{2,4})$/) {
1092                   push @data, "250 <$username\@example.com>\r\n"
1093                 }
1094                 else {
1095                   push @data, "250 <$username>\r\n"
1096                 }
1097             }
1098
1099             for my $d (@data) {
1100                 sendcontrol $d;
1101             }
1102         }
1103         else {
1104             sendcontrol "501 Invalid address\r\n";
1105         }
1106     }
1107
1108     return 0;
1109 }
1110
1111 sub EXPN_smtp {
1112     my ($list_name) = @_;
1113
1114     logmsg "EXPN_smtp got $list_name\n";
1115
1116     if(!$list_name) {
1117         sendcontrol "501 Unrecognized parameter\r\n";
1118     }
1119     else {
1120         my @data = getreplydata($smtp_client);
1121
1122         for my $d (@data) {
1123             sendcontrol $d;
1124         }
1125     }
1126
1127     return 0;
1128 }
1129
1130 sub QUIT_smtp {
1131     sendcontrol "221 curl $smtp_type server signing off\r\n";
1132
1133     return 0;
1134 }
1135
1136 # What was deleted by IMAP STORE / POP3 DELE commands
1137 my @deleted;
1138
1139 ################
1140 ################ IMAP commands
1141 ################
1142
1143 # global to allow the command functions to read it
1144 my $cmdid;
1145
1146 # what was picked by SELECT
1147 my $selected;
1148
1149 # Any IMAP parameter can come in escaped and in double quotes.
1150 # This function is dumb (so far) and just removes the quotes if present.
1151 sub fix_imap_params {
1152     foreach (@_) {
1153         $_ = $1 if /^"(.*)"$/;
1154     }
1155 }
1156
1157 sub CAPABILITY_imap {
1158     if((!@capabilities) && (!@auth_mechs)) {
1159         sendcontrol "$cmdid BAD Command\r\n";
1160     }
1161     else {
1162         my $data;
1163
1164         # Calculate the CAPABILITY response
1165         $data = "* CAPABILITY IMAP4";
1166
1167         for my $c (@capabilities) {
1168             $data .= " $c";
1169         }
1170
1171         for my $am (@auth_mechs) {
1172             $data .= " AUTH=$am";
1173         }
1174
1175         $data .= " pingpong test server\r\n";
1176
1177         # Send the CAPABILITY response
1178         sendcontrol $data;
1179         sendcontrol "$cmdid OK CAPABILITY completed\r\n";
1180     }
1181
1182     return 0;
1183 }
1184
1185 sub LOGIN_imap {
1186     my ($args) = @_;
1187     my ($user, $password) = split(/ /, $args, 2);
1188     fix_imap_params($user, $password);
1189
1190     logmsg "LOGIN_imap got $args\n";
1191
1192     if ($user eq "") {
1193         sendcontrol "$cmdid BAD Command Argument\r\n";
1194     }
1195     else {
1196         sendcontrol "$cmdid OK LOGIN completed\r\n";
1197     }
1198
1199     return 0;
1200 }
1201
1202 sub SELECT_imap {
1203     my ($mailbox) = @_;
1204     fix_imap_params($mailbox);
1205
1206     logmsg "SELECT_imap got test $mailbox\n";
1207
1208     if($mailbox eq "") {
1209         sendcontrol "$cmdid BAD Command Argument\r\n";
1210     }
1211     else {
1212         # Example from RFC 3501, 6.3.1. SELECT Command
1213         sendcontrol "* 172 EXISTS\r\n";
1214         sendcontrol "* 1 RECENT\r\n";
1215         sendcontrol "* OK [UNSEEN 12] Message 12 is first unseen\r\n";
1216         sendcontrol "* OK [UIDVALIDITY 3857529045] UIDs valid\r\n";
1217         sendcontrol "* OK [UIDNEXT 4392] Predicted next UID\r\n";
1218         sendcontrol "* FLAGS (\\Answered \\Flagged \\Deleted \\Seen \\Draft)\r\n";
1219         sendcontrol "* OK [PERMANENTFLAGS (\\Deleted \\Seen \\*)] Limited\r\n";
1220         sendcontrol "$cmdid OK [READ-WRITE] SELECT completed\r\n";
1221
1222         $selected = $mailbox;
1223     }
1224
1225     return 0;
1226 }
1227
1228 sub FETCH_imap {
1229     my ($args) = @_;
1230     my ($uid, $how) = split(/ /, $args, 2);
1231     fix_imap_params($uid, $how);
1232
1233     logmsg "FETCH_imap got $args\n";
1234
1235     if ($selected eq "") {
1236         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
1237     }
1238     else {
1239         my @data;
1240         my $size;
1241
1242         if($selected eq "verifiedserver") {
1243             # this is the secret command that verifies that this actually is
1244             # the curl test server
1245             my $response = "WE ROOLZ: $$\r\n";
1246             if($verbose) {
1247                 print STDERR "FTPD: We returned proof we are the test server\n";
1248             }
1249             $data[0] = $response;
1250             logmsg "return proof we are we\n";
1251         }
1252         else {
1253             # send mail content
1254             logmsg "retrieve a mail\n";
1255
1256             @data = getreplydata($selected);
1257         }
1258
1259         for (@data) {
1260             $size += length($_);
1261         }
1262
1263         sendcontrol "* $uid FETCH ($how {$size}\r\n";
1264
1265         for my $d (@data) {
1266             sendcontrol $d;
1267         }
1268
1269         # Set the custom extra header content with POSTFETCH
1270         sendcontrol "$postfetch)\r\n";
1271         sendcontrol "$cmdid OK FETCH completed\r\n";
1272     }
1273
1274     return 0;
1275 }
1276
1277 sub APPEND_imap {
1278     my ($args) = @_;
1279
1280     logmsg "APPEND_imap got $args\r\n";
1281
1282     $args =~ /^([^ ]+) [^{]*\{(\d+)\}$/;
1283     my ($mailbox, $size) = ($1, $2);
1284     fix_imap_params($mailbox);
1285
1286     if($mailbox eq "") {
1287         sendcontrol "$cmdid BAD Command Argument\r\n";
1288     }
1289     else {
1290         sendcontrol "+ Ready for literal data\r\n";
1291
1292         my $testno = $mailbox;
1293         my $filename = "$logdir/upload.$testno";
1294
1295         logmsg "Store test number $testno in $filename\n";
1296
1297         open(my $file, ">", "$filename") ||
1298             return 0; # failed to open output
1299
1300         my $received = 0;
1301         my $line;
1302         while(5 == (sysread \*SFREAD, $line, 5)) {
1303             if($line eq "DATA\n") {
1304                 sysread \*SFREAD, $line, 5;
1305
1306                 my $chunksize = 0;
1307                 if($line =~ /^([0-9a-fA-F]{4})\n/) {
1308                     $chunksize = hex($1);
1309                 }
1310
1311                 read_mainsockf(\$line, $chunksize);
1312
1313                 my $left = $size - $received;
1314                 my $datasize = ($left > $chunksize) ? $chunksize : $left;
1315
1316                 if($datasize > 0) {
1317                     logmsg "> Appending $datasize bytes to file\n";
1318                     print $file substr($line, 0, $datasize) if(!$nosave);
1319                     $line = substr($line, $datasize);
1320
1321                     $received += $datasize;
1322                     if($received == $size) {
1323                         logmsg "Received all data, waiting for final CRLF.\n";
1324                     }
1325                 }
1326
1327                 if($received == $size && $line eq "\r\n") {
1328                     last;
1329                 }
1330             }
1331             elsif($line eq "DISC\n") {
1332                 logmsg "Unexpected disconnect!\n";
1333                 printf SFWRITE "ACKD\n";
1334                 last;
1335             }
1336             else {
1337                 logmsg "No support for: $line";
1338                 last;
1339             }
1340         }
1341
1342         if($nosave) {
1343             print $file "$size bytes would've been stored here\n";
1344         }
1345
1346         close($file);
1347
1348         logmsg "received $size bytes upload\n";
1349
1350         sendcontrol "$cmdid OK APPEND completed\r\n";
1351     }
1352
1353     return 0;
1354 }
1355
1356 sub STORE_imap {
1357     my ($args) = @_;
1358     my ($uid, $what, $value) = split(/ /, $args, 3);
1359     fix_imap_params($uid);
1360
1361     logmsg "STORE_imap got $args\n";
1362
1363     if ($selected eq "") {
1364         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
1365     }
1366     elsif (($uid eq "") || ($what ne "+Flags") || ($value eq "")) {
1367         sendcontrol "$cmdid BAD Command Argument\r\n";
1368     }
1369     else {
1370         if($value eq "\\Deleted") {
1371             push(@deleted, $uid);
1372         }
1373
1374         sendcontrol "* $uid FETCH (FLAGS (\\Seen $value))\r\n";
1375         sendcontrol "$cmdid OK STORE completed\r\n";
1376     }
1377
1378     return 0;
1379 }
1380
1381 sub LIST_imap {
1382     my ($args) = @_;
1383     my ($reference, $mailbox) = split(/ /, $args, 2);
1384     fix_imap_params($reference, $mailbox);
1385
1386     logmsg "LIST_imap got $args\n";
1387
1388     if ($reference eq "") {
1389         sendcontrol "$cmdid BAD Command Argument\r\n";
1390     }
1391     elsif ($reference eq "verifiedserver") {
1392         # this is the secret command that verifies that this actually is
1393         # the curl test server
1394         sendcontrol "* LIST () \"/\" \"WE ROOLZ: $$\"\r\n";
1395         sendcontrol "$cmdid OK LIST Completed\r\n";
1396
1397         if($verbose) {
1398             print STDERR "FTPD: We returned proof we are the test server\n";
1399         }
1400
1401         logmsg "return proof we are we\n";
1402     }
1403     else {
1404         my @data = getreplydata($reference);
1405
1406         for my $d (@data) {
1407             sendcontrol $d;
1408         }
1409
1410         sendcontrol "$cmdid OK LIST Completed\r\n";
1411     }
1412
1413     return 0;
1414 }
1415
1416 sub LSUB_imap {
1417     my ($args) = @_;
1418     my ($reference, $mailbox) = split(/ /, $args, 2);
1419     fix_imap_params($reference, $mailbox);
1420
1421     logmsg "LSUB_imap got $args\n";
1422
1423     if ($reference eq "") {
1424         sendcontrol "$cmdid BAD Command Argument\r\n";
1425     }
1426     else {
1427         my @data = getreplydata($reference);
1428
1429         for my $d (@data) {
1430             sendcontrol $d;
1431         }
1432
1433         sendcontrol "$cmdid OK LSUB Completed\r\n";
1434     }
1435
1436     return 0;
1437 }
1438
1439 sub EXAMINE_imap {
1440     my ($mailbox) = @_;
1441     fix_imap_params($mailbox);
1442
1443     logmsg "EXAMINE_imap got $mailbox\n";
1444
1445     if ($mailbox eq "") {
1446         sendcontrol "$cmdid BAD Command Argument\r\n";
1447     }
1448     else {
1449         my @data = getreplydata($mailbox);
1450
1451         for my $d (@data) {
1452             sendcontrol $d;
1453         }
1454
1455         sendcontrol "$cmdid OK [READ-ONLY] EXAMINE completed\r\n";
1456     }
1457
1458     return 0;
1459 }
1460
1461 sub STATUS_imap {
1462     my ($args) = @_;
1463     my ($mailbox, $what) = split(/ /, $args, 2);
1464     fix_imap_params($mailbox);
1465
1466     logmsg "STATUS_imap got $args\n";
1467
1468     if ($mailbox eq "") {
1469         sendcontrol "$cmdid BAD Command Argument\r\n";
1470     }
1471     else {
1472         my @data = getreplydata($mailbox);
1473
1474         for my $d (@data) {
1475             sendcontrol $d;
1476         }
1477
1478         sendcontrol "$cmdid OK STATUS completed\r\n";
1479     }
1480
1481     return 0;
1482 }
1483
1484 sub SEARCH_imap {
1485     my ($what) = @_;
1486     fix_imap_params($what);
1487
1488     logmsg "SEARCH_imap got $what\n";
1489
1490     if ($selected eq "") {
1491         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
1492     }
1493     elsif ($what eq "") {
1494         sendcontrol "$cmdid BAD Command Argument\r\n";
1495     }
1496     else {
1497         my @data = getreplydata($selected);
1498
1499         for my $d (@data) {
1500             sendcontrol $d;
1501         }
1502
1503         sendcontrol "$cmdid OK SEARCH completed\r\n";
1504     }
1505
1506     return 0;
1507 }
1508
1509 sub CREATE_imap {
1510     my ($args) = @_;
1511     fix_imap_params($args);
1512
1513     logmsg "CREATE_imap got $args\n";
1514
1515     if ($args eq "") {
1516         sendcontrol "$cmdid BAD Command Argument\r\n";
1517     }
1518     else {
1519         sendcontrol "$cmdid OK CREATE completed\r\n";
1520     }
1521
1522     return 0;
1523 }
1524
1525 sub DELETE_imap {
1526     my ($args) = @_;
1527     fix_imap_params($args);
1528
1529     logmsg "DELETE_imap got $args\n";
1530
1531     if ($args eq "") {
1532         sendcontrol "$cmdid BAD Command Argument\r\n";
1533     }
1534     else {
1535         sendcontrol "$cmdid OK DELETE completed\r\n";
1536     }
1537
1538     return 0;
1539 }
1540
1541 sub RENAME_imap {
1542     my ($args) = @_;
1543     my ($from_mailbox, $to_mailbox) = split(/ /, $args, 2);
1544     fix_imap_params($from_mailbox, $to_mailbox);
1545
1546     logmsg "RENAME_imap got $args\n";
1547
1548     if (($from_mailbox eq "") || ($to_mailbox eq "")) {
1549         sendcontrol "$cmdid BAD Command Argument\r\n";
1550     }
1551     else {
1552         sendcontrol "$cmdid OK RENAME completed\r\n";
1553     }
1554
1555     return 0;
1556 }
1557
1558 sub CHECK_imap {
1559     if ($selected eq "") {
1560         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
1561     }
1562     else {
1563         sendcontrol "$cmdid OK CHECK completed\r\n";
1564     }
1565
1566     return 0;
1567 }
1568
1569 sub CLOSE_imap {
1570     if ($selected eq "") {
1571         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
1572     }
1573     elsif (!@deleted) {
1574         sendcontrol "$cmdid BAD Command Argument\r\n";
1575     }
1576     else {
1577         sendcontrol "$cmdid OK CLOSE completed\r\n";
1578
1579         @deleted = ();
1580     }
1581
1582     return 0;
1583 }
1584
1585 sub EXPUNGE_imap {
1586     if ($selected eq "") {
1587         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
1588     }
1589     else {
1590         if (!@deleted) {
1591             # Report the number of existing messages as per the SELECT
1592             # command
1593             sendcontrol "* 172 EXISTS\r\n";
1594         }
1595         else {
1596             # Report the message UIDs being deleted
1597             for my $d (@deleted) {
1598                 sendcontrol "* $d EXPUNGE\r\n";
1599             }
1600
1601             @deleted = ();
1602         }
1603
1604         sendcontrol "$cmdid OK EXPUNGE completed\r\n";
1605     }
1606
1607     return 0;
1608 }
1609
1610 sub COPY_imap {
1611     my ($args) = @_;
1612     my ($uid, $mailbox) = split(/ /, $args, 2);
1613     fix_imap_params($uid, $mailbox);
1614
1615     logmsg "COPY_imap got $args\n";
1616
1617     if (($uid eq "") || ($mailbox eq "")) {
1618         sendcontrol "$cmdid BAD Command Argument\r\n";
1619     }
1620     else {
1621         sendcontrol "$cmdid OK COPY completed\r\n";
1622     }
1623
1624     return 0;
1625 }
1626
1627 sub IDLE_imap {
1628     logmsg "IDLE received\n";
1629
1630     sendcontrol "+ entering idle mode\r\n";
1631     return 0;
1632 }
1633
1634 sub UID_imap {
1635     my ($args) = @_;
1636     my ($command) = split(/ /, $args, 1);
1637     fix_imap_params($command);
1638
1639     logmsg "UID_imap got $args\n";
1640
1641     if ($selected eq "") {
1642         sendcontrol "$cmdid BAD Command received in Invalid state\r\n";
1643     }
1644     elsif (substr($command, 0, 5) eq "FETCH"){
1645         my $func = $commandfunc{"FETCH"};
1646         if($func) {
1647             &$func($args, $command);
1648         }
1649     }
1650     elsif (($command ne "COPY") &&
1651            ($command ne "STORE") && ($command ne "SEARCH")) {
1652         sendcontrol "$cmdid BAD Command Argument\r\n";
1653     }
1654     else {
1655         my @data = getreplydata($selected);
1656
1657         for my $d (@data) {
1658             sendcontrol $d;
1659         }
1660
1661         sendcontrol "$cmdid OK $command completed\r\n";
1662     }
1663
1664     return 0;
1665 }
1666
1667 sub NOOP_imap {
1668     my ($args) = @_;
1669     my @data = (
1670         "* 22 EXPUNGE\r\n",
1671         "* 23 EXISTS\r\n",
1672         "* 3 RECENT\r\n",
1673         "* 14 FETCH (FLAGS (\\Seen \\Deleted))\r\n",
1674     );
1675
1676     if ($args) {
1677         sendcontrol "$cmdid BAD Command Argument\r\n";
1678     }
1679     else {
1680         for my $d (@data) {
1681             sendcontrol $d;
1682         }
1683
1684         sendcontrol "$cmdid OK NOOP completed\r\n";
1685     }
1686
1687     return 0;
1688 }
1689
1690 sub LOGOUT_imap {
1691     sendcontrol "* BYE curl IMAP server signing off\r\n";
1692     sendcontrol "$cmdid OK LOGOUT completed\r\n";
1693
1694     return 0;
1695 }
1696
1697 ################
1698 ################ POP3 commands
1699 ################
1700
1701 # Who is attempting to log in
1702 my $username;
1703
1704 sub CAPA_pop3 {
1705     my @list = ();
1706     my $mechs;
1707
1708     # Calculate the capability list based on the specified capabilities
1709     # (except APOP) and any authentication mechanisms
1710     for my $c (@capabilities) {
1711         push @list, "$c\r\n" unless $c eq "APOP";
1712     }
1713
1714     for my $am (@auth_mechs) {
1715         if(!$mechs) {
1716             $mechs = "$am";
1717         }
1718         else {
1719             $mechs .= " $am";
1720         }
1721     }
1722
1723     if($mechs) {
1724         push @list, "SASL $mechs\r\n";
1725     }
1726
1727     if(!@list) {
1728         sendcontrol "-ERR Unrecognized command\r\n";
1729     }
1730     else {
1731         my @data = ();
1732
1733         # Calculate the CAPA response
1734         push @data, "+OK List of capabilities follows\r\n";
1735
1736         for my $l (@list) {
1737             push @data, "$l\r\n";
1738         }
1739
1740         push @data, "IMPLEMENTATION POP3 pingpong test server\r\n";
1741
1742         # Send the CAPA response
1743         for my $d (@data) {
1744             sendcontrol $d;
1745         }
1746
1747         # End with the magic 3-byte end of listing marker
1748         sendcontrol ".\r\n";
1749     }
1750
1751     return 0;
1752 }
1753
1754 sub APOP_pop3 {
1755     my ($args) = @_;
1756     my ($user, $secret) = split(/ /, $args, 2);
1757
1758     if (!grep /^APOP$/, @capabilities) {
1759         sendcontrol "-ERR Unrecognized command\r\n";
1760     }
1761     elsif (($user eq "") || ($secret eq "")) {
1762         sendcontrol "-ERR Protocol error\r\n";
1763     }
1764     else {
1765         my $digest = Digest::MD5::md5_hex($POP3_TIMESTAMP, $TEXT_PASSWORD);
1766
1767         if ($secret ne $digest) {
1768             sendcontrol "-ERR Login failure\r\n";
1769         }
1770         else {
1771             sendcontrol "+OK Login successful\r\n";
1772         }
1773     }
1774
1775     return 0;
1776 }
1777
1778 sub AUTH_pop3 {
1779     if(!@auth_mechs) {
1780         sendcontrol "-ERR Unrecognized command\r\n";
1781     }
1782     else {
1783         my @data = ();
1784
1785         # Calculate the AUTH response
1786         push @data, "+OK List of supported mechanisms follows\r\n";
1787
1788         for my $am (@auth_mechs) {
1789             push @data, "$am\r\n";
1790         }
1791
1792         # Send the AUTH response
1793         for my $d (@data) {
1794             sendcontrol $d;
1795         }
1796
1797         # End with the magic 3-byte end of listing marker
1798         sendcontrol ".\r\n";
1799     }
1800
1801     return 0;
1802 }
1803
1804 sub USER_pop3 {
1805     my ($user) = @_;
1806
1807     logmsg "USER_pop3 got $user\n";
1808
1809     if (!$user) {
1810         sendcontrol "-ERR Protocol error\r\n";
1811     }
1812     else {
1813         $username = $user;
1814
1815         sendcontrol "+OK\r\n";
1816     }
1817
1818     return 0;
1819 }
1820
1821 sub PASS_pop3 {
1822     my ($password) = @_;
1823
1824     logmsg "PASS_pop3 got $password\n";
1825
1826     sendcontrol "+OK Login successful\r\n";
1827
1828     return 0;
1829 }
1830
1831 sub RETR_pop3 {
1832     my ($msgid) = @_;
1833     my @data;
1834
1835     if($msgid =~ /^verifiedserver$/) {
1836         # this is the secret command that verifies that this actually is
1837         # the curl test server
1838         my $response = "WE ROOLZ: $$\r\n";
1839         if($verbose) {
1840             print STDERR "FTPD: We returned proof we are the test server\n";
1841         }
1842         $data[0] = $response;
1843         logmsg "return proof we are we\n";
1844     }
1845     else {
1846         # send mail content
1847         logmsg "retrieve a mail\n";
1848
1849         @data = getreplydata($msgid);
1850     }
1851
1852     sendcontrol "+OK Mail transfer starts\r\n";
1853
1854     for my $d (@data) {
1855         sendcontrol $d;
1856     }
1857
1858     # end with the magic 3-byte end of mail marker, assumes that the
1859     # mail body ends with a CRLF!
1860     sendcontrol ".\r\n";
1861
1862     return 0;
1863 }
1864
1865 sub LIST_pop3 {
1866     # This is a built-in fake-message list
1867     my @data = (
1868         "1 100\r\n",
1869         "2 4294967400\r\n",  # > 4 GB
1870         "3 200\r\n",
1871     );
1872
1873     logmsg "retrieve a message list\n";
1874
1875     sendcontrol "+OK Listing starts\r\n";
1876
1877     for my $d (@data) {
1878         sendcontrol $d;
1879     }
1880
1881     # End with the magic 3-byte end of listing marker
1882     sendcontrol ".\r\n";
1883
1884     return 0;
1885 }
1886
1887 sub DELE_pop3 {
1888     my ($msgid) = @_;
1889
1890     logmsg "DELE_pop3 got $msgid\n";
1891
1892     if (!$msgid) {
1893         sendcontrol "-ERR Protocol error\r\n";
1894     }
1895     else {
1896         push (@deleted, $msgid);
1897
1898         sendcontrol "+OK\r\n";
1899     }
1900
1901     return 0;
1902 }
1903
1904 sub STAT_pop3 {
1905     my ($args) = @_;
1906
1907     if ($args) {
1908         sendcontrol "-ERR Protocol error\r\n";
1909     }
1910     else {
1911         # Send statistics for the built-in fake message list as
1912         # detailed in the LIST_pop3 function above
1913         sendcontrol "+OK 3 4294967800\r\n";
1914     }
1915
1916     return 0;
1917 }
1918
1919 sub NOOP_pop3 {
1920     my ($args) = @_;
1921
1922     if ($args) {
1923         sendcontrol "-ERR Protocol error\r\n";
1924     }
1925     else {
1926         sendcontrol "+OK\r\n";
1927     }
1928
1929     return 0;
1930 }
1931
1932 sub UIDL_pop3 {
1933     # This is a built-in fake-message UID list
1934     my @data = (
1935         "1 1\r\n",
1936         "2 2\r\n",
1937         "3 4\r\n", # Note that UID 3 is a simulated "deleted" message
1938     );
1939
1940     if (!grep /^UIDL$/, @capabilities) {
1941         sendcontrol "-ERR Unrecognized command\r\n";
1942     }
1943     else {
1944         logmsg "retrieve a message UID list\n";
1945
1946         sendcontrol "+OK Listing starts\r\n";
1947
1948         for my $d (@data) {
1949             sendcontrol $d;
1950         }
1951
1952         # End with the magic 3-byte end of listing marker
1953         sendcontrol ".\r\n";
1954     }
1955
1956     return 0;
1957 }
1958
1959 sub TOP_pop3 {
1960     my ($args) = @_;
1961     my ($msgid, $lines) = split(/ /, $args, 2);
1962
1963     logmsg "TOP_pop3 got $args\n";
1964
1965     if (!grep /^TOP$/, @capabilities) {
1966         sendcontrol "-ERR Unrecognized command\r\n";
1967     }
1968     elsif (($msgid eq "") || ($lines eq "")) {
1969         sendcontrol "-ERR Protocol error\r\n";
1970     }
1971     else {
1972         if ($lines == "0") {
1973             logmsg "retrieve header of mail\n";
1974         }
1975         else {
1976             logmsg "retrieve top $lines lines of mail\n";
1977         }
1978
1979         my @data = getreplydata($msgid);
1980
1981         sendcontrol "+OK Mail transfer starts\r\n";
1982
1983         # Send mail content
1984         for my $d (@data) {
1985             sendcontrol $d;
1986         }
1987
1988         # End with the magic 3-byte end of mail marker, assumes that the
1989         # mail body ends with a CRLF!
1990         sendcontrol ".\r\n";
1991     }
1992
1993     return 0;
1994 }
1995
1996 sub RSET_pop3 {
1997     my ($args) = @_;
1998
1999     if ($args) {
2000         sendcontrol "-ERR Protocol error\r\n";
2001     }
2002     else {
2003         if (@deleted) {
2004             logmsg "resetting @deleted message(s)\n";
2005
2006             @deleted = ();
2007         }
2008
2009         sendcontrol "+OK\r\n";
2010     }
2011
2012     return 0;
2013 }
2014
2015 sub QUIT_pop3 {
2016     if(@deleted) {
2017         logmsg "deleting @deleted message(s)\n";
2018
2019         @deleted = ();
2020     }
2021
2022     sendcontrol "+OK curl POP3 server signing off\r\n";
2023
2024     return 0;
2025 }
2026
2027 ################
2028 ################ FTP commands
2029 ################
2030 my $rest=0;
2031 sub REST_ftp {
2032     $rest = $_[0];
2033     logmsg "Set REST position to $rest\n"
2034 }
2035
2036 sub switch_directory_goto {
2037   my $target_dir = $_;
2038
2039   if(!$ftptargetdir) {
2040     $ftptargetdir = "/";
2041   }
2042
2043   if($target_dir eq "") {
2044     $ftptargetdir = "/";
2045   }
2046   elsif($target_dir eq "..") {
2047     if($ftptargetdir eq "/") {
2048       $ftptargetdir = "/";
2049     }
2050     else {
2051       $ftptargetdir =~ s/[[:alnum:]]+\/$//;
2052     }
2053   }
2054   else {
2055     $ftptargetdir .= $target_dir . "/";
2056   }
2057 }
2058
2059 sub switch_directory {
2060     my $target_dir = $_[0];
2061
2062     if($target_dir =~ /^test-(\d+)/) {
2063         $cwd_testno = $1;
2064     }
2065     elsif($target_dir eq "/") {
2066         $ftptargetdir = "/";
2067     }
2068     else {
2069         my @dirs = split("/", $target_dir);
2070         for(@dirs) {
2071           switch_directory_goto($_);
2072         }
2073     }
2074 }
2075
2076 sub CWD_ftp {
2077   my ($folder, $fullcommand) = $_[0];
2078   switch_directory($folder);
2079   if($ftptargetdir =~ /^\/fully_simulated/) {
2080     $ftplistparserstate = "enabled";
2081   }
2082   else {
2083     undef $ftplistparserstate;
2084   }
2085 }
2086
2087 sub PWD_ftp {
2088     my $mydir;
2089     $mydir = $ftptargetdir ? $ftptargetdir : "/";
2090
2091     if($mydir ne "/") {
2092         $mydir =~ s/\/$//;
2093     }
2094     sendcontrol "257 \"$mydir\" is current directory\r\n";
2095 }
2096
2097 sub LIST_ftp {
2098     #  print "150 ASCII data connection for /bin/ls (193.15.23.1,59196) (0 bytes)\r\n";
2099
2100 # this is a built-in fake-dir ;-)
2101 my @ftpdir=("total 20\r\n",
2102 "drwxr-xr-x   8 98       98           512 Oct 22 13:06 .\r\n",
2103 "drwxr-xr-x   8 98       98           512 Oct 22 13:06 ..\r\n",
2104 "drwxr-xr-x   2 98       98           512 May  2  1996 .NeXT\r\n",
2105 "-r--r--r--   1 0        1             35 Jul 16  1996 README\r\n",
2106 "lrwxrwxrwx   1 0        1              7 Dec  9  1999 bin -> usr/bin\r\n",
2107 "dr-xr-xr-x   2 0        1            512 Oct  1  1997 dev\r\n",
2108 "drwxrwxrwx   2 98       98           512 May 29 16:04 download.html\r\n",
2109 "dr-xr-xr-x   2 0        1            512 Nov 30  1995 etc\r\n",
2110 "drwxrwxrwx   2 98       1            512 Oct 30 14:33 pub\r\n",
2111 "dr-xr-xr-x   5 0        1            512 Oct  1  1997 usr\r\n");
2112
2113     if($datasockf_conn eq 'no') {
2114         if($nodataconn425) {
2115             sendcontrol "150 Opening data connection\r\n";
2116             sendcontrol "425 Can't open data connection\r\n";
2117         }
2118         elsif($nodataconn421) {
2119             sendcontrol "150 Opening data connection\r\n";
2120             sendcontrol "421 Connection timed out\r\n";
2121         }
2122         elsif($nodataconn150) {
2123             sendcontrol "150 Opening data connection\r\n";
2124             # client shall timeout
2125         }
2126         else {
2127             # client shall timeout
2128         }
2129         return 0;
2130     }
2131
2132     if($ftplistparserstate) {
2133       @ftpdir = ftp_contentlist($ftptargetdir);
2134     }
2135
2136     logmsg "pass LIST data on data connection\n";
2137
2138     if($cwd_testno) {
2139         loadtest("$logdir/test$cwd_testno");
2140
2141         my @data = getpart("reply", "data");
2142         for(@data) {
2143             my $send = $_;
2144             # convert all \n to \r\n for ASCII transfer
2145             $send =~ s/\r\n/\n/g;
2146             $send =~ s/\n/\r\n/g;
2147             logmsg "send $send as data\n";
2148             senddata $send;
2149         }
2150         $cwd_testno = 0; # forget it again
2151     }
2152     else {
2153         # old hard-coded style
2154         for(@ftpdir) {
2155             senddata $_;
2156         }
2157     }
2158     close_dataconn(0);
2159     sendcontrol "226 ASCII transfer complete\r\n";
2160     return 0;
2161 }
2162
2163 sub NLST_ftp {
2164     my @ftpdir=("file", "with space", "fake", "..", " ..", "funny", "README");
2165
2166     if($datasockf_conn eq 'no') {
2167         if($nodataconn425) {
2168             sendcontrol "150 Opening data connection\r\n";
2169             sendcontrol "425 Can't open data connection\r\n";
2170         }
2171         elsif($nodataconn421) {
2172             sendcontrol "150 Opening data connection\r\n";
2173             sendcontrol "421 Connection timed out\r\n";
2174         }
2175         elsif($nodataconn150) {
2176             sendcontrol "150 Opening data connection\r\n";
2177             # client shall timeout
2178         }
2179         else {
2180             # client shall timeout
2181         }
2182         return 0;
2183     }
2184
2185     logmsg "pass NLST data on data connection\n";
2186     for(@ftpdir) {
2187         senddata "$_\r\n";
2188     }
2189     close_dataconn(0);
2190     sendcontrol "226 ASCII transfer complete\r\n";
2191     return 0;
2192 }
2193
2194 sub MDTM_ftp {
2195     my $testno = $_[0];
2196     my $testpart = "";
2197     if ($testno > 10000) {
2198         $testpart = $testno % 10000;
2199         $testno = int($testno / 10000);
2200     }
2201
2202     loadtest("$logdir/test$testno");
2203
2204     my @data = getpart("reply", "mdtm");
2205
2206     my $reply = $data[0];
2207     chomp $reply if($reply);
2208
2209     if($reply && ($reply =~ /^[+-]?\d+$/) && ($reply < 0)) {
2210         sendcontrol "550 $testno: no such file.\r\n";
2211     }
2212     elsif($reply) {
2213         sendcontrol "$reply\r\n";
2214     }
2215     else {
2216         sendcontrol "500 MDTM: no such command.\r\n";
2217     }
2218     return 0;
2219 }
2220
2221 sub SIZE_ftp {
2222     my $testno = $_[0];
2223     if($ftplistparserstate) {
2224         my $size = wildcard_filesize($ftptargetdir, $testno);
2225         if($size == -1) {
2226             sendcontrol "550 $testno: No such file or directory.\r\n";
2227         }
2228         else {
2229             sendcontrol "213 $size\r\n";
2230         }
2231         return 0;
2232     }
2233
2234     if($testno =~ /^verifiedserver$/) {
2235         my $response = "WE ROOLZ: $$\r\n";
2236         my $size = length($response);
2237         sendcontrol "213 $size\r\n";
2238         return 0;
2239     }
2240
2241     if($testno =~ /(\d+)\/?$/) {
2242         $testno = $1;
2243     }
2244     else {
2245         print STDERR "SIZE_ftp: invalid test number: $testno\n";
2246         return 1;
2247     }
2248
2249     my $testpart = "";
2250     if($testno > 10000) {
2251         $testpart = $testno % 10000;
2252         $testno = int($testno / 10000);
2253     }
2254
2255     loadtest("$logdir/test$testno");
2256     my @data = getpart("reply", "size");
2257
2258     my $size = $data[0];
2259
2260     if($size) {
2261         if($size > -1) {
2262             sendcontrol "213 $size\r\n";
2263         }
2264         else {
2265             sendcontrol "550 $testno: No such file or directory.\r\n";
2266         }
2267     }
2268     else {
2269         $size=0;
2270         @data = getpart("reply", "data$testpart");
2271         for(@data) {
2272             $size += length($_);
2273         }
2274         if($size) {
2275             sendcontrol "213 $size\r\n";
2276         }
2277         else {
2278             sendcontrol "550 $testno: No such file or directory.\r\n";
2279         }
2280     }
2281     return 0;
2282 }
2283
2284 sub RETR_ftp {
2285     my ($testno) = @_;
2286
2287     if($datasockf_conn eq 'no') {
2288         if($nodataconn425) {
2289             sendcontrol "150 Opening data connection\r\n";
2290             sendcontrol "425 Can't open data connection\r\n";
2291         }
2292         elsif($nodataconn421) {
2293             sendcontrol "150 Opening data connection\r\n";
2294             sendcontrol "421 Connection timed out\r\n";
2295         }
2296         elsif($nodataconn150) {
2297             sendcontrol "150 Opening data connection\r\n";
2298             # client shall timeout
2299         }
2300         else {
2301             # client shall timeout
2302         }
2303         return 0;
2304     }
2305
2306     if($ftplistparserstate) {
2307         my @content = wildcard_getfile($ftptargetdir, $testno);
2308         if($content[0] == -1) {
2309             #file not found
2310         }
2311         else {
2312             my $size = length $content[1];
2313             sendcontrol "150 Binary data connection for $testno ($size bytes).\r\n",
2314             senddata $content[1];
2315             close_dataconn(0);
2316             sendcontrol "226 File transfer complete\r\n";
2317         }
2318         return 0;
2319     }
2320
2321     if($testno =~ /^verifiedserver$/) {
2322         # this is the secret command that verifies that this actually is
2323         # the curl test server
2324         my $response = "WE ROOLZ: $$\r\n";
2325         my $len = length($response);
2326         sendcontrol "150 Binary junk ($len bytes).\r\n";
2327         senddata "WE ROOLZ: $$\r\n";
2328         close_dataconn(0);
2329         sendcontrol "226 File transfer complete\r\n";
2330         if($verbose) {
2331             print STDERR "FTPD: We returned proof we are the test server\n";
2332         }
2333         return 0;
2334     }
2335
2336     $testno =~ s/^([^0-9]*)//;
2337     my $testpart = "";
2338     if ($testno > 10000) {
2339         $testpart = $testno % 10000;
2340         $testno = int($testno / 10000);
2341     }
2342
2343     loadtest("$logdir/test$testno");
2344
2345     my @data = getpart("reply", "data$testpart");
2346
2347     my $size=0;
2348     for(@data) {
2349         $size += length($_);
2350     }
2351
2352     my %hash = getpartattr("reply", "data$testpart");
2353
2354     if($size || $hash{'sendzero'}) {
2355
2356         if($rest) {
2357             # move read pointer forward
2358             $size -= $rest;
2359             logmsg "REST $rest was removed from size, makes $size left\n";
2360             $rest = 0; # reset REST offset again
2361         }
2362         if($retrweirdo) {
2363             sendcontrol "150 Binary data connection for $testno () ($size bytes).\r\n",
2364             "226 File transfer complete\r\n";
2365
2366             for(@data) {
2367                 my $send = $_;
2368                 senddata $send;
2369             }
2370             close_dataconn(0);
2371             $retrweirdo=0; # switch off the weirdo again!
2372         }
2373         else {
2374             my $sz = "($size bytes)";
2375             if($retrnosize) {
2376                 $sz = "size?";
2377             }
2378             elsif($retrsize > 0) {
2379                 $sz = "($retrsize bytes)";
2380             }
2381
2382             sendcontrol "150 Binary data connection for $testno () $sz.\r\n";
2383
2384             for(@data) {
2385                 my $send = $_;
2386                 senddata $send;
2387             }
2388             close_dataconn(0);
2389             sendcontrol "226 File transfer complete\r\n";
2390         }
2391     }
2392     else {
2393         sendcontrol "550 $testno: No such file or directory.\r\n";
2394     }
2395     return 0;
2396 }
2397
2398 sub STOR_ftp {
2399     my $testno=$_[0];
2400
2401     my $filename = "$logdir/upload.$testno";
2402
2403     if($datasockf_conn eq 'no') {
2404         if($nodataconn425) {
2405             sendcontrol "150 Opening data connection\r\n";
2406             sendcontrol "425 Can't open data connection\r\n";
2407         }
2408         elsif($nodataconn421) {
2409             sendcontrol "150 Opening data connection\r\n";
2410             sendcontrol "421 Connection timed out\r\n";
2411         }
2412         elsif($nodataconn150) {
2413             sendcontrol "150 Opening data connection\r\n";
2414             # client shall timeout
2415         }
2416         else {
2417             # client shall timeout
2418         }
2419         return 0;
2420     }
2421
2422     logmsg "STOR test number $testno in $filename\n";
2423
2424     sendcontrol "125 Gimme gimme gimme!\r\n";
2425
2426     open(my $file, ">", "$filename") ||
2427         return 0; # failed to open output
2428
2429     my $line;
2430     my $ulsize=0;
2431     my $disc=0;
2432     while (5 == (sysread DREAD, $line, 5)) {
2433         if($line eq "DATA\n") {
2434             my $i;
2435             sysread DREAD, $i, 5;
2436
2437             my $size = 0;
2438             if($i =~ /^([0-9a-fA-F]{4})\n/) {
2439                 $size = hex($1);
2440             }
2441
2442             read_datasockf(\$line, $size);
2443
2444             #print STDERR "  GOT: $size bytes\n";
2445
2446             $ulsize += $size;
2447             print $file $line if(!$nosave);
2448             logmsg "> Appending $size bytes to file\n";
2449         }
2450         elsif($line eq "DISC\n") {
2451             # disconnect!
2452             $disc=1;
2453             printf DWRITE "ACKD\n";
2454             last;
2455         }
2456         else {
2457             logmsg "No support for: $line";
2458             last;
2459         }
2460         if($storeresp) {
2461             # abort early
2462             last;
2463         }
2464     }
2465     if($nosave) {
2466         print $file "$ulsize bytes would've been stored here\n";
2467     }
2468     close($file);
2469     close_dataconn($disc);
2470     logmsg "received $ulsize bytes upload\n";
2471     if($storeresp) {
2472         sendcontrol "$storeresp\r\n";
2473     }
2474     else {
2475         sendcontrol "226 File transfer complete\r\n";
2476     }
2477     return 0;
2478 }
2479
2480 sub PASV_ftp {
2481     my ($arg, $cmd)=@_;
2482     my $pasvport;
2483
2484     # kill previous data connection sockfilt when alive
2485     if($datasockf_runs eq 'yes') {
2486         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
2487         logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
2488     }
2489     datasockf_state('STOPPED');
2490
2491     logmsg "====> Passive DATA channel requested by client\n";
2492
2493     logmsg "DATA sockfilt for passive data channel starting...\n";
2494
2495     # We fire up a new sockfilt to do the data transfer for us.
2496     my @datasockfcmd = ("./server/sockfilt".exe_ext('SRV'),
2497         "--ipv$ipvnum", "--port", 0,
2498         "--pidfile", $datasockf_pidfile,
2499         "--logfile",  $datasockf_logfile);
2500     if($nodataconn) {
2501         push(@datasockfcmd, '--bindonly');
2502     }
2503     $slavepid = open2(\*DREAD, \*DWRITE, @datasockfcmd);
2504
2505     if($nodataconn) {
2506         datasockf_state('PASSIVE_NODATACONN');
2507     }
2508     else {
2509         datasockf_state('PASSIVE');
2510     }
2511
2512     print STDERR "@datasockfcmd\n" if($verbose);
2513
2514     print DWRITE "PING\n";
2515     my $pong;
2516     sysread_or_die(\*DREAD, \$pong, 5);
2517
2518     if($pong =~ /^FAIL/) {
2519         logmsg "DATA sockfilt said: FAIL\n";
2520         logmsg "DATA sockfilt for passive data channel failed\n";
2521         logmsg "DATA sockfilt not running\n";
2522         datasockf_state('STOPPED');
2523         sendcontrol "500 no free ports!\r\n";
2524         return;
2525     }
2526     elsif($pong !~ /^PONG/) {
2527         logmsg "DATA sockfilt unexpected response: $pong\n";
2528         logmsg "DATA sockfilt for passive data channel failed\n";
2529         logmsg "DATA sockfilt killed now\n";
2530         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
2531         logmsg "DATA sockfilt not running\n";
2532         datasockf_state('STOPPED');
2533         sendcontrol "500 no free ports!\r\n";
2534         return;
2535     }
2536
2537     logmsg "DATA sockfilt for passive data channel started (pid $slavepid)\n";
2538
2539     # Find out on what port we listen on or have bound
2540     my $i;
2541     print DWRITE "PORT\n";
2542
2543     # READ the response code
2544     sysread_or_die(\*DREAD, \$i, 5);
2545
2546     # READ the response size
2547     sysread_or_die(\*DREAD, \$i, 5);
2548
2549     my $size = 0;
2550     if($i =~ /^([0-9a-fA-F]{4})\n/) {
2551         $size = hex($1);
2552     }
2553
2554     # READ the response data
2555     read_datasockf(\$i, $size);
2556
2557     # The data is in the format
2558     # IPvX/NNN
2559
2560     if($i =~ /IPv(\d)\/(\d+)/) {
2561         # FIX: deal with IP protocol version
2562         $pasvport = $2;
2563     }
2564
2565     if(!$pasvport) {
2566         logmsg "DATA sockfilt unknown listener port\n";
2567         logmsg "DATA sockfilt for passive data channel failed\n";
2568         logmsg "DATA sockfilt killed now\n";
2569         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
2570         logmsg "DATA sockfilt not running\n";
2571         datasockf_state('STOPPED');
2572         sendcontrol "500 no free ports!\r\n";
2573         return;
2574     }
2575
2576     if($nodataconn) {
2577         my $str = nodataconn_str();
2578         logmsg "DATA sockfilt for passive data channel ($str) bound on port ".
2579                "$pasvport\n";
2580     }
2581     else {
2582         logmsg "DATA sockfilt for passive data channel listens on port ".
2583                "$pasvport\n";
2584     }
2585
2586     if($cmd ne "EPSV") {
2587         # PASV reply
2588         my $p=$listenaddr;
2589         $p =~ s/\./,/g;
2590         if($pasvbadip) {
2591             $p="1,2,3,4";
2592         }
2593         sendcontrol sprintf("227 Entering Passive Mode ($p,%d,%d)\n",
2594                             int($pasvport/256), int($pasvport%256));
2595     }
2596     else {
2597         # EPSV reply
2598         sendcontrol sprintf("229 Entering Passive Mode (|||%d|)\n", $pasvport);
2599     }
2600
2601     logmsg "Client has been notified that DATA conn ".
2602            "will be accepted on port $pasvport\n";
2603
2604     if($nodataconn) {
2605         my $str = nodataconn_str();
2606         logmsg "====> Client fooled ($str)\n";
2607         return;
2608     }
2609
2610     eval {
2611         local $SIG{ALRM} = sub { die "alarm\n" };
2612
2613         # assume swift operations unless explicitly slow
2614         alarm ($datadelay?20:2);
2615
2616         # Wait for 'CNCT'
2617         my $input;
2618
2619         # FIX: Monitor ctrl conn for disconnect
2620
2621         while(sysread(DREAD, $input, 5)) {
2622
2623             if($input !~ /^CNCT/) {
2624                 # we wait for a connected client
2625                 logmsg "Odd, we got $input from client\n";
2626                 next;
2627             }
2628             logmsg "Client connects to port $pasvport\n";
2629             last;
2630         }
2631         alarm 0;
2632     };
2633     if ($@) {
2634         # timed out
2635         logmsg "$srvrname server timed out awaiting data connection ".
2636             "on port $pasvport\n";
2637         logmsg "accept failed or connection not even attempted\n";
2638         logmsg "DATA sockfilt killed now\n";
2639         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
2640         logmsg "DATA sockfilt not running\n";
2641         datasockf_state('STOPPED');
2642         return;
2643     }
2644     else {
2645         logmsg "====> Client established passive DATA connection ".
2646                "on port $pasvport\n";
2647     }
2648
2649     return;
2650 }
2651
2652 #
2653 # Support both PORT and EPRT here.
2654 #
2655
2656 sub PORT_ftp {
2657     my ($arg, $cmd) = @_;
2658     my $port;
2659     my $addr;
2660
2661     # kill previous data connection sockfilt when alive
2662     if($datasockf_runs eq 'yes') {
2663         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
2664         logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
2665     }
2666     datasockf_state('STOPPED');
2667
2668     logmsg "====> Active DATA channel requested by client\n";
2669
2670     # We always ignore the given IP and use localhost.
2671
2672     if($cmd eq "PORT") {
2673         if($arg !~ /(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/) {
2674             logmsg "DATA sockfilt for active data channel not started ".
2675                    "(bad PORT-line: $arg)\n";
2676             sendcontrol "500 silly you, go away\r\n";
2677             return;
2678         }
2679         $port = ($5<<8)+$6;
2680         $addr = "$1.$2.$3.$4";
2681     }
2682     # EPRT |2|::1|49706|
2683     elsif($cmd eq "EPRT") {
2684         if($arg !~ /(\d+)\|([^\|]+)\|(\d+)/) {
2685             logmsg "DATA sockfilt for active data channel not started ".
2686                    "(bad EPRT-line: $arg)\n";
2687             sendcontrol "500 silly you, go away\r\n";
2688             return;
2689         }
2690         sendcontrol "200 Thanks for dropping by. We contact you later\r\n";
2691         $port = $3;
2692         $addr = $2;
2693     }
2694     else {
2695         logmsg "DATA sockfilt for active data channel not started ".
2696                "(invalid command: $cmd)\n";
2697         sendcontrol "500 we don't like $cmd now\r\n";
2698         return;
2699     }
2700
2701     if(!$port || $port > 65535) {
2702         logmsg "DATA sockfilt for active data channel not started ".
2703                "(illegal PORT number: $port)\n";
2704         return;
2705     }
2706
2707     if($nodataconn) {
2708         my $str = nodataconn_str();
2709         logmsg "DATA sockfilt for active data channel not started ($str)\n";
2710         datasockf_state('ACTIVE_NODATACONN');
2711         logmsg "====> Active DATA channel not established\n";
2712         return;
2713     }
2714
2715     logmsg "DATA sockfilt for active data channel starting...\n";
2716
2717     # We fire up a new sockfilt to do the data transfer for us.
2718     my @datasockfcmd = ("./server/sockfilt".exe_ext('SRV'),
2719         "--ipv$ipvnum", "--connect", $port, "--addr", $addr,
2720         "--pidfile", $datasockf_pidfile,
2721         "--logfile", $datasockf_logfile);
2722     $slavepid = open2(\*DREAD, \*DWRITE, @datasockfcmd);
2723
2724     datasockf_state('ACTIVE');
2725
2726     print STDERR "@datasockfcmd\n" if($verbose);
2727
2728     print DWRITE "PING\n";
2729     my $pong;
2730     sysread_or_die(\*DREAD, \$pong, 5);
2731
2732     if($pong =~ /^FAIL/) {
2733         logmsg "DATA sockfilt said: FAIL\n";
2734         logmsg "DATA sockfilt for active data channel failed\n";
2735         logmsg "DATA sockfilt not running\n";
2736         datasockf_state('STOPPED');
2737         # client shall timeout awaiting connection from server
2738         return;
2739     }
2740     elsif($pong !~ /^PONG/) {
2741         logmsg "DATA sockfilt unexpected response: $pong\n";
2742         logmsg "DATA sockfilt for active data channel failed\n";
2743         logmsg "DATA sockfilt killed now\n";
2744         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
2745         logmsg "DATA sockfilt not running\n";
2746         datasockf_state('STOPPED');
2747         # client shall timeout awaiting connection from server
2748         return;
2749     }
2750
2751     logmsg "DATA sockfilt for active data channel started (pid $slavepid)\n";
2752
2753     logmsg "====> Active DATA channel connected to client port $port\n";
2754
2755     return;
2756 }
2757
2758 #**********************************************************************
2759 # datasockf_state is used to change variables that keep state info
2760 # relative to the FTP secondary or data sockfilt process as soon as
2761 # one of the five possible stable states is reached. Variables that
2762 # are modified by this sub may be checked independently but should
2763 # not be changed except by calling this sub.
2764 #
2765 sub datasockf_state {
2766     my $state = $_[0];
2767
2768   if($state eq 'STOPPED') {
2769     # Data sockfilter initial state, not running,
2770     # not connected and not used.
2771     $datasockf_state = $state;
2772     $datasockf_mode = 'none';
2773     $datasockf_runs = 'no';
2774     $datasockf_conn = 'no';
2775   }
2776   elsif($state eq 'PASSIVE') {
2777     # Data sockfilter accepted connection from client.
2778     $datasockf_state = $state;
2779     $datasockf_mode = 'passive';
2780     $datasockf_runs = 'yes';
2781     $datasockf_conn = 'yes';
2782   }
2783   elsif($state eq 'ACTIVE') {
2784     # Data sockfilter has connected to client.
2785     $datasockf_state = $state;
2786     $datasockf_mode = 'active';
2787     $datasockf_runs = 'yes';
2788     $datasockf_conn = 'yes';
2789   }
2790   elsif($state eq 'PASSIVE_NODATACONN') {
2791     # Data sockfilter bound port without listening,
2792     # client won't be able to establish data connection.
2793     $datasockf_state = $state;
2794     $datasockf_mode = 'passive';
2795     $datasockf_runs = 'yes';
2796     $datasockf_conn = 'no';
2797   }
2798   elsif($state eq 'ACTIVE_NODATACONN') {
2799     # Data sockfilter does not even run,
2800     # client awaits data connection from server in vain.
2801     $datasockf_state = $state;
2802     $datasockf_mode = 'active';
2803     $datasockf_runs = 'no';
2804     $datasockf_conn = 'no';
2805   }
2806   else {
2807       die "Internal error. Unknown datasockf state: $state!";
2808   }
2809 }
2810
2811 #**********************************************************************
2812 # nodataconn_str returns string of effective nodataconn command. Notice
2813 # that $nodataconn may be set alone or in addition to a $nodataconnXXX.
2814 #
2815 sub nodataconn_str {
2816     my $str;
2817     # order matters
2818     $str = 'NODATACONN' if($nodataconn);
2819     $str = 'NODATACONN425' if($nodataconn425);
2820     $str = 'NODATACONN421' if($nodataconn421);
2821     $str = 'NODATACONN150' if($nodataconn150);
2822     return "$str";
2823 }
2824
2825 #**********************************************************************
2826 # customize configures test server operation for each curl test, reading
2827 # configuration commands/parameters from server commands file each time
2828 # a new client control connection is established with the test server.
2829 # On success returns 1, otherwise zero.
2830 #
2831 sub customize {
2832     $ctrldelay = 0;     # default is no throttling of the ctrl stream
2833     $datadelay = 0;     # default is no throttling of the data stream
2834     $retrweirdo = 0;    # default is no use of RETRWEIRDO
2835     $retrnosize = 0;    # default is no use of RETRNOSIZE
2836     $retrsize = 0;      # default is no use of RETRSIZE
2837     $pasvbadip = 0;     # default is no use of PASVBADIP
2838     $nosave = 0;        # default is to actually save uploaded data to file
2839     $nodataconn = 0;    # default is to establish or accept data channel
2840     $nodataconn425 = 0; # default is to not send 425 without data channel
2841     $nodataconn421 = 0; # default is to not send 421 without data channel
2842     $nodataconn150 = 0; # default is to not send 150 without data channel
2843     $storeresp = "";    # send as ultimate STOR response
2844     $postfetch = "";    # send as header after a FETCH response
2845     @capabilities = (); # default is to not support capability commands
2846     @auth_mechs = ();   # default is to not support authentication commands
2847     %fulltextreply = ();#
2848     %commandreply = (); #
2849     %customcount = ();  #
2850     %delayreply = ();   #
2851
2852     open(my $custom, "<", "$logdir/$SERVERCMD") ||
2853         return 1;
2854
2855     logmsg "FTPD: Getting commands from $logdir/$SERVERCMD\n";
2856
2857     while(<$custom>) {
2858         if($_ =~ /REPLY \"([A-Z]+ [A-Za-z0-9+-\/=\*. ]+)\" (.*)/) {
2859             $fulltextreply{$1}=eval "qq{$2}";
2860             logmsg "FTPD: set custom reply for $1\n";
2861         }
2862         elsif($_ =~ /REPLY(LF|) ([A-Za-z0-9+\/=\*]*) (.*)/) {
2863             $commandreply{$2}=eval "qq{$3}";
2864             if($1 ne "LF") {
2865                 $commandreply{$2}.="\r\n";
2866             }
2867             else {
2868                 $commandreply{$2}.="\n";
2869             }
2870             if($2 eq "") {
2871                 logmsg "FTPD: set custom reply for empty command\n";
2872             }
2873             else {
2874                 logmsg "FTPD: set custom reply for $2 command\n";
2875             }
2876         }
2877         elsif($_ =~ /COUNT ([A-Z]+) (.*)/) {
2878             # we blank the custom reply for this command when having
2879             # been used this number of times
2880             $customcount{$1}=$2;
2881             logmsg "FTPD: blank custom reply for $1 command after $2 uses\n";
2882         }
2883         elsif($_ =~ /DELAY ([A-Z]+) (\d*)/) {
2884             $delayreply{$1}=$2;
2885             logmsg "FTPD: delay reply for $1 with $2 seconds\n";
2886         }
2887         elsif($_ =~ /POSTFETCH (.*)/) {
2888             logmsg "FTPD: read POSTFETCH header data\n";
2889             $postfetch = $1;
2890         }
2891         elsif($_ =~ /SLOWDOWN/) {
2892             $ctrldelay=1;
2893             $datadelay=1;
2894             logmsg "FTPD: send response with 0.01 sec delay between each byte\n";
2895         }
2896         elsif($_ =~ /RETRWEIRDO/) {
2897             logmsg "FTPD: instructed to use RETRWEIRDO\n";
2898             $retrweirdo=1;
2899         }
2900         elsif($_ =~ /RETRNOSIZE/) {
2901             logmsg "FTPD: instructed to use RETRNOSIZE\n";
2902             $retrnosize=1;
2903         }
2904         elsif($_ =~ /RETRSIZE (\d+)/) {
2905             $retrsize= $1;
2906             logmsg "FTPD: instructed to use RETRSIZE = $1\n";
2907         }
2908         elsif($_ =~ /PASVBADIP/) {
2909             logmsg "FTPD: instructed to use PASVBADIP\n";
2910             $pasvbadip=1;
2911         }
2912         elsif($_ =~ /NODATACONN425/) {
2913             # applies to both active and passive FTP modes
2914             logmsg "FTPD: instructed to use NODATACONN425\n";
2915             $nodataconn425=1;
2916             $nodataconn=1;
2917         }
2918         elsif($_ =~ /NODATACONN421/) {
2919             # applies to both active and passive FTP modes
2920             logmsg "FTPD: instructed to use NODATACONN421\n";
2921             $nodataconn421=1;
2922             $nodataconn=1;
2923         }
2924         elsif($_ =~ /NODATACONN150/) {
2925             # applies to both active and passive FTP modes
2926             logmsg "FTPD: instructed to use NODATACONN150\n";
2927             $nodataconn150=1;
2928             $nodataconn=1;
2929         }
2930         elsif($_ =~ /NODATACONN/) {
2931             # applies to both active and passive FTP modes
2932             logmsg "FTPD: instructed to use NODATACONN\n";
2933             $nodataconn=1;
2934         }
2935         elsif($_ =~ /^STOR (.*)/) {
2936             $storeresp=$1;
2937             logmsg "FTPD: instructed to use respond to STOR with '$storeresp'\n";
2938         }
2939         elsif($_ =~ /CAPA (.*)/) {
2940             logmsg "FTPD: instructed to support CAPABILITY command\n";
2941             @capabilities = split(/ (?!(?:[^" ]|[^"] [^"])+")/, $1);
2942             foreach (@capabilities) {
2943                 $_ = $1 if /^"(.*)"$/;
2944             }
2945         }
2946         elsif($_ =~ /AUTH (.*)/) {
2947             logmsg "FTPD: instructed to support AUTHENTICATION command\n";
2948             @auth_mechs = split(/ /, $1);
2949         }
2950         elsif($_ =~ /NOSAVE/) {
2951             # don't actually store the file we upload - to be used when
2952             # uploading insanely huge amounts
2953             $nosave = 1;
2954             logmsg "FTPD: NOSAVE prevents saving of uploaded data\n";
2955         }
2956         elsif($_ =~ /^Testnum (\d+)/){
2957             $testno = $1;
2958             logmsg "FTPD: run test case number: $testno\n";
2959         }
2960     }
2961     close($custom);
2962 }
2963
2964 #----------------------------------------------------------------------
2965 #----------------------------------------------------------------------
2966 #---------------------------  END OF SUBS  ----------------------------
2967 #----------------------------------------------------------------------
2968 #----------------------------------------------------------------------
2969
2970 #**********************************************************************
2971 # Parse command line options
2972 #
2973 # Options:
2974 #
2975 # --verbose   # verbose
2976 # --srcdir    # source directory
2977 # --id        # server instance number
2978 # --proto     # server protocol
2979 # --pidfile   # server pid file
2980 # --portfile  # server port file
2981 # --logfile   # server log file
2982 # --logdir    # server log directory
2983 # --ipv4      # server IP version 4
2984 # --ipv6      # server IP version 6
2985 # --port      # server listener port
2986 # --addr      # server address for listener port binding
2987 #
2988 while(@ARGV) {
2989     if($ARGV[0] eq '--verbose') {
2990         $verbose = 1;
2991     }
2992     elsif($ARGV[0] eq '--srcdir') {
2993         if($ARGV[1]) {
2994             $srcdir = $ARGV[1];
2995             shift @ARGV;
2996         }
2997     }
2998     elsif($ARGV[0] eq '--id') {
2999         if($ARGV[1] && ($ARGV[1] =~ /^(\d+)$/)) {
3000             $idnum = $1 if($1 > 0);
3001             shift @ARGV;
3002         }
3003     }
3004     elsif($ARGV[0] eq '--proto') {
3005         if($ARGV[1] && ($ARGV[1] =~ /^(ftp|imap|pop3|smtp)$/)) {
3006             $proto = $1;
3007             shift @ARGV;
3008         }
3009         else {
3010             die "unsupported protocol $ARGV[1]";
3011         }
3012     }
3013     elsif($ARGV[0] eq '--pidfile') {
3014         if($ARGV[1]) {
3015             $pidfile = $ARGV[1];
3016             shift @ARGV;
3017         }
3018     }
3019     elsif($ARGV[0] eq '--portfile') {
3020         if($ARGV[1]) {
3021             $portfile = $ARGV[1];
3022             shift @ARGV;
3023         }
3024     }
3025     elsif($ARGV[0] eq '--logfile') {
3026         if($ARGV[1]) {
3027             $logfile = $ARGV[1];
3028             shift @ARGV;
3029         }
3030     }
3031     elsif($ARGV[0] eq '--logdir') {
3032         if($ARGV[1]) {
3033             $logdir = $ARGV[1];
3034             shift @ARGV;
3035         }
3036     }
3037     elsif($ARGV[0] eq '--ipv4') {
3038         $ipvnum = 4;
3039         $listenaddr = '127.0.0.1' if($listenaddr eq '::1');
3040     }
3041     elsif($ARGV[0] eq '--ipv6') {
3042         $ipvnum = 6;
3043         $listenaddr = '::1' if($listenaddr eq '127.0.0.1');
3044     }
3045     elsif($ARGV[0] eq '--port') {
3046         if($ARGV[1] =~ /^(\d+)$/) {
3047             $port = $1;
3048             shift @ARGV;
3049         }
3050     }
3051     elsif($ARGV[0] eq '--addr') {
3052         if($ARGV[1]) {
3053             my $tmpstr = $ARGV[1];
3054             if($tmpstr =~ /^(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)$/) {
3055                 $listenaddr = "$1.$2.$3.$4" if($ipvnum == 4);
3056             }
3057             elsif($ipvnum == 6) {
3058                 $listenaddr = $tmpstr;
3059                 $listenaddr =~ s/^\[(.*)\]$/$1/;
3060             }
3061             shift @ARGV;
3062         }
3063     }
3064     else {
3065         print STDERR "\nWarning: ftpserver.pl unknown parameter: $ARGV[0]\n";
3066     }
3067     shift @ARGV;
3068 }
3069
3070 #***************************************************************************
3071 # Initialize command line option dependent variables
3072 #
3073
3074 if($pidfile) {
3075     # Use our pidfile directory to store the other pidfiles
3076     $piddir = dirname($pidfile);
3077 }
3078 else {
3079     # Use the current directory to store all the pidfiles
3080     $piddir = $path;
3081     $pidfile = server_pidfilename($piddir, $proto, $ipvnum, $idnum);
3082 }
3083 if(!$portfile) {
3084     $portfile = $piddir . "/" . $PORTFILE;
3085 }
3086 if(!$srcdir) {
3087     $srcdir = $ENV{'srcdir'} || '.';
3088 }
3089 if(!$logfile) {
3090     $logfile = server_logfilename($logdir, $proto, $ipvnum, $idnum);
3091 }
3092
3093 $mainsockf_pidfile = mainsockf_pidfilename($piddir, $proto, $ipvnum, $idnum);
3094 $mainsockf_logfile =
3095     mainsockf_logfilename($logdir, $proto, $ipvnum, $idnum);
3096
3097 if($proto eq 'ftp') {
3098     $datasockf_pidfile = datasockf_pidfilename($piddir, $proto, $ipvnum, $idnum);
3099     $datasockf_logfile =
3100         datasockf_logfilename($logdir, $proto, $ipvnum, $idnum);
3101 }
3102
3103 $srvrname = servername_str($proto, $ipvnum, $idnum);
3104 $serverlogs_lockfile = "$logdir/$LOCKDIR/${srvrname}.lock";
3105
3106 $idstr = "$idnum" if($idnum > 1);
3107
3108 protocolsetup($proto);
3109
3110 $SIG{INT} = \&exit_signal_handler;
3111 $SIG{TERM} = \&exit_signal_handler;
3112
3113 startsf();
3114
3115 # actual port
3116 if($portfile && !$port) {
3117     my $aport;
3118     open(my $p, "<", "$portfile");
3119     $aport = <$p>;
3120     close($p);
3121     $port = 0 + $aport;
3122 }
3123
3124 logmsg sprintf("%s server listens on port IPv${ipvnum}/${port}\n", uc($proto));
3125
3126 open(my $pid, ">", "$pidfile");
3127 print $pid $$."\n";
3128 close($pid);
3129
3130 logmsg("logged pid $$ in $pidfile\n");
3131
3132 while(1) {
3133
3134     # kill previous data connection sockfilt when alive
3135     if($datasockf_runs eq 'yes') {
3136         killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose, 'data');
3137         logmsg "DATA sockfilt for $datasockf_mode data channel killed now\n";
3138     }
3139     datasockf_state('STOPPED');
3140
3141     #
3142     # We read 'sockfilt' commands.
3143     #
3144     my $input;
3145
3146     logmsg "Awaiting input\n";
3147     sysread_or_die(\*SFREAD, \$input, 5);
3148
3149     if($input !~ /^CNCT/) {
3150         # we wait for a connected client
3151         logmsg "MAIN sockfilt said: $input";
3152         next;
3153     }
3154     logmsg "====> Client connect\n";
3155
3156     set_advisor_read_lock($serverlogs_lockfile);
3157     $serverlogslocked = 1;
3158
3159     # flush data:
3160     $| = 1;
3161
3162     &customize(); # read test control instructions
3163     loadtest("$logdir/test$testno");
3164
3165     my $welcome = $commandreply{"welcome"};
3166     if(!$welcome) {
3167         $welcome = $displaytext{"welcome"};
3168     }
3169     else {
3170         # clear it after use
3171         $commandreply{"welcome"}="";
3172         if($welcome !~ /\r\n\z/) {
3173             $welcome .= "\r\n";
3174         }
3175     }
3176     sendcontrol $welcome;
3177
3178     #remove global variables from last connection
3179     if($ftplistparserstate) {
3180       undef $ftplistparserstate;
3181     }
3182     if($ftptargetdir) {
3183       $ftptargetdir = "";
3184     }
3185
3186     if($verbose) {
3187         print STDERR "OUT: $welcome";
3188     }
3189
3190     my $full = "";
3191
3192     while(1) {
3193         my $i;
3194
3195         # Now we expect to read DATA\n[hex size]\n[prot], where the [prot]
3196         # part only is FTP lingo.
3197
3198         # COMMAND
3199         sysread_or_die(\*SFREAD, \$i, 5);
3200
3201         if($i !~ /^DATA/) {
3202             logmsg "MAIN sockfilt said $i";
3203             if($i =~ /^DISC/) {
3204                 # disconnect
3205                 printf SFWRITE "ACKD\n";
3206                 last;
3207             }
3208             next;
3209         }
3210
3211         # SIZE of data
3212         sysread_or_die(\*SFREAD, \$i, 5);
3213
3214         my $size = 0;
3215         if($i =~ /^([0-9a-fA-F]{4})\n/) {
3216             $size = hex($1);
3217         }
3218
3219         # data
3220         read_mainsockf(\$input, $size);
3221
3222         ftpmsg $input;
3223
3224         $full .= $input;
3225
3226         # Loop until command completion
3227         next unless($full =~ /\r\n$/);
3228
3229         # Remove trailing CRLF.
3230         $full =~ s/[\n\r]+$//;
3231
3232         my $FTPCMD;
3233         my $FTPARG;
3234         if($proto eq "imap") {
3235             # IMAP is different with its identifier first on the command line
3236             if(($full =~ /^([^ ]+) ([^ ]+) (.*)/) ||
3237                ($full =~ /^([^ ]+) ([^ ]+)/)) {
3238                 $cmdid=$1; # set the global variable
3239                 $FTPCMD=$2;
3240                 $FTPARG=$3;
3241             }
3242             # IMAP authentication cancellation
3243             elsif($full =~ /^\*$/) {
3244                 # Command id has already been set
3245                 $FTPCMD="*";
3246                 $FTPARG="";
3247             }
3248             # IMAP long "commands" are base64 authentication data
3249             elsif($full =~ /^[A-Z0-9+\/]*={0,2}$/i) {
3250                 # Command id has already been set
3251                 $FTPCMD=$full;
3252                 $FTPARG="";
3253             }
3254             else {
3255                 sendcontrol "$full BAD Command\r\n";
3256                 last;
3257             }
3258         }
3259         elsif($full =~ /^([A-Z]{3,4})(\s(.*))?$/i) {
3260             $FTPCMD=$1;
3261             $FTPARG=$3;
3262         }
3263         elsif($proto eq "pop3") {
3264             # POP3 authentication cancellation
3265             if($full =~ /^\*$/) {
3266                 $FTPCMD="*";
3267                 $FTPARG="";
3268             }
3269             # POP3 long "commands" are base64 authentication data
3270             elsif($full =~ /^[A-Z0-9+\/]*={0,2}$/i) {
3271                 $FTPCMD=$full;
3272                 $FTPARG="";
3273             }
3274             else {
3275                 sendcontrol "-ERR Unrecognized command\r\n";
3276                 last;
3277             }
3278         }
3279         elsif($proto eq "smtp") {
3280             # SMTP authentication cancellation
3281             if($full =~ /^\*$/) {
3282                 $FTPCMD="*";
3283                 $FTPARG="";
3284             }
3285             # SMTP long "commands" are base64 authentication data
3286             elsif($full =~ /^[A-Z0-9+\/]{0,512}={0,2}$/i) {
3287                 $FTPCMD=$full;
3288                 $FTPARG="";
3289             }
3290             else {
3291                 sendcontrol "500 Unrecognized command\r\n";
3292                 last;
3293             }
3294         }
3295         else {
3296             sendcontrol "500 Unrecognized command\r\n";
3297             last;
3298         }
3299
3300         logmsg "< \"$full\"\n";
3301
3302         if($verbose) {
3303             print STDERR "IN: $full\n";
3304         }
3305
3306         $full = "";
3307
3308         my $delay = $delayreply{$FTPCMD};
3309         if($delay) {
3310             # just go sleep this many seconds!
3311             logmsg("Sleep for $delay seconds\n");
3312             my $twentieths = $delay * 20;
3313             while($twentieths--) {
3314                 portable_sleep(0.05) unless($got_exit_signal);
3315             }
3316         }
3317
3318         my $check = 1; # no response yet
3319
3320         # See if there is a custom reply for the full text
3321         my $fulltext = $FTPARG ? $FTPCMD . " " . $FTPARG : $FTPCMD;
3322         my $text = $fulltextreply{$fulltext};
3323         if($text && ($text ne "")) {
3324             sendcontrol "$text\r\n";
3325             $check = 0;
3326         }
3327         else {
3328             # See if there is a custom reply for the command
3329             $text = $commandreply{$FTPCMD};
3330             if($text && ($text ne "")) {
3331                 if($customcount{$FTPCMD} && (!--$customcount{$FTPCMD})) {
3332                     # used enough times so blank the custom command reply
3333                     $commandreply{$FTPCMD}="";
3334                 }
3335
3336                 sendcontrol $text;
3337                 $check = 0;
3338             }
3339             else {
3340                 # See if there is any display text for the command
3341                 $text = $displaytext{$FTPCMD};
3342                 if($text && ($text ne "")) {
3343                     if($proto eq 'imap') {
3344                         sendcontrol "$cmdid $text\r\n";
3345                     }
3346                     else {
3347                         sendcontrol "$text\r\n";
3348                     }
3349
3350                     $check = 0;
3351                 }
3352
3353                 # only perform this if we're not faking a reply
3354                 my $func = $commandfunc{uc($FTPCMD)};
3355                 if($func) {
3356                     &$func($FTPARG, $FTPCMD);
3357                     $check = 0;
3358                 }
3359             }
3360         }
3361
3362         if($check) {
3363             logmsg "$FTPCMD wasn't handled!\n";
3364             if($proto eq 'pop3') {
3365                 sendcontrol "-ERR $FTPCMD is not dealt with!\r\n";
3366             }
3367             elsif($proto eq 'imap') {
3368                 sendcontrol "$cmdid BAD $FTPCMD is not dealt with!\r\n";
3369             }
3370             else {
3371                 sendcontrol "500 $FTPCMD is not dealt with!\r\n";
3372             }
3373         }
3374
3375     } # while(1)
3376     logmsg "====> Client disconnected\n";
3377
3378     if($serverlogslocked) {
3379         $serverlogslocked = 0;
3380         clear_advisor_read_lock($serverlogs_lockfile);
3381     }
3382 }
3383
3384 killsockfilters($piddir, $proto, $ipvnum, $idnum, $verbose);
3385 unlink($pidfile);
3386 if($serverlogslocked) {
3387     $serverlogslocked = 0;
3388     clear_advisor_read_lock($serverlogs_lockfile);
3389 }
3390
3391 exit;