tests/ftpserver.pl

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