tests/ftpserver.pl

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