Home | History | Annotate | Download | only in tests
      1 #!/usr/bin/env perl
      2 #***************************************************************************
      3 #                                  _   _ ____  _
      4 #  Project                     ___| | | |  _ \| |
      5 #                             / __| | | | |_) | |
      6 #                            | (__| |_| |  _ <| |___
      7 #                             \___|\___/|_| \_\_____|
      8 #
      9 # Copyright (C) 1998 - 2018, Daniel Stenberg, <daniel (at] 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 (at] 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 (at] 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 (substr($command, 0, 5) eq "FETCH"){
   1564         my $func = $commandfunc{"FETCH"};
   1565         if($func) {
   1566             &$func($args, $command);
   1567         }
   1568     }
   1569     elsif (($command ne "COPY") &&
   1570            ($command ne "STORE") && ($command ne "SEARCH")) {
   1571         sendcontrol "$cmdid BAD Command Argument\r\n";
   1572     }
   1573     else {
   1574         my @data = getreplydata($selected);
   1575 
   1576         for my $d (@data) {
   1577             sendcontrol $d;
   1578         }
   1579 
   1580         sendcontrol "$cmdid OK $command completed\r\n";
   1581     }
   1582 
   1583     return 0;
   1584 }
   1585 
   1586 sub NOOP_imap {
   1587     my ($args) = @_;
   1588     my @data = (
   1589         "* 22 EXPUNGE\r\n",
   1590         "* 23 EXISTS\r\n",
   1591         "* 3 RECENT\r\n",
   1592         "* 14 FETCH (FLAGS (\\Seen \\Deleted))\r\n",
   1593     );
   1594 
   1595     if ($args) {
   1596         sendcontrol "$cmdid BAD Command Argument\r\n";
   1597     }
   1598     else {
   1599         for my $d (@data) {
   1600             sendcontrol $d;
   1601         }
   1602 
   1603         sendcontrol "$cmdid OK NOOP completed\r\n";
   1604     }
   1605 
   1606     return 0;
   1607 }
   1608 
   1609 sub LOGOUT_imap {
   1610     sendcontrol "* BYE curl IMAP server signing off\r\n";
   1611     sendcontrol "$cmdid OK LOGOUT completed\r\n";
   1612 
   1613     return 0;
   1614 }
   1615 
   1616 ################
   1617 ################ POP3 commands
   1618 ################
   1619 
   1620 # Who is attempting to log in
   1621 my $username;
   1622 
   1623 sub CAPA_pop3 {
   1624     my @list = ();
   1625     my $mechs;
   1626 
   1627     # Calculate the capability list based on the specified capabilities
   1628     # (except APOP) and any authentication mechanisms
   1629     for my $c (@capabilities) {
   1630         push @list, "$c\r\n" unless $c eq "APOP";
   1631     }
   1632 
   1633     for my $am (@auth_mechs) {
   1634         if(!$mechs) {
   1635             $mechs = "$am";
   1636         }
   1637         else {
   1638             $mechs .= " $am";
   1639         }
   1640     }
   1641 
   1642     if($mechs) {
   1643         push @list, "SASL $mechs\r\n";
   1644     }
   1645 
   1646     if(!@list) {
   1647         sendcontrol "-ERR Unrecognized command\r\n";
   1648     }
   1649     else {
   1650         my @data = ();
   1651 
   1652         # Calculate the CAPA response
   1653         push @data, "+OK List of capabilities follows\r\n";
   1654 
   1655         for my $l (@list) {
   1656             push @data, "$l\r\n";
   1657         }
   1658 
   1659         push @data, "IMPLEMENTATION POP3 pingpong test server\r\n";
   1660 
   1661         # Send the CAPA response
   1662         for my $d (@data) {
   1663             sendcontrol $d;
   1664         }
   1665 
   1666         # End with the magic 3-byte end of listing marker
   1667         sendcontrol ".\r\n";
   1668     }
   1669 
   1670     return 0;
   1671 }
   1672 
   1673 sub APOP_pop3 {
   1674     my ($args) = @_;
   1675     my ($user, $secret) = split(/ /, $args, 2);
   1676 
   1677     if (!grep /^APOP$/, @capabilities) {
   1678         sendcontrol "-ERR Unrecognized command\r\n";
   1679     }
   1680     elsif (($user eq "") || ($secret eq "")) {
   1681         sendcontrol "-ERR Protocol error\r\n";
   1682     }
   1683     else {
   1684         my $digest = Digest::MD5::md5_hex($POP3_TIMESTAMP, $TEXT_PASSWORD);
   1685 
   1686         if ($secret ne $digest) {
   1687             sendcontrol "-ERR Login failure\r\n";
   1688         }
   1689         else {
   1690             sendcontrol "+OK Login successful\r\n";
   1691         }
   1692     }
   1693 
   1694     return 0;
   1695 }
   1696 
   1697 sub AUTH_pop3 {
   1698     if(!@auth_mechs) {
   1699         sendcontrol "-ERR Unrecognized command\r\n";
   1700     }
   1701     else {
   1702         my @data = ();
   1703 
   1704         # Calculate the AUTH response
   1705         push @data, "+OK List of supported mechanisms follows\r\n";
   1706 
   1707         for my $am (@auth_mechs) {
   1708             push @data, "$am\r\n";
   1709         }
   1710 
   1711         # Send the AUTH response
   1712         for my $d (@data) {
   1713             sendcontrol $d;
   1714         }
   1715 
   1716         # End with the magic 3-byte end of listing marker
   1717         sendcontrol ".\r\n";
   1718     }
   1719 
   1720     return 0;
   1721 }
   1722 
   1723 sub USER_pop3 {
   1724     my ($user) = @_;
   1725 
   1726     logmsg "USER_pop3 got $user\n";
   1727 
   1728     if (!$user) {
   1729         sendcontrol "-ERR Protocol error\r\n";
   1730     }
   1731     else {
   1732         $username = $user;
   1733 
   1734         sendcontrol "+OK\r\n";
   1735     }
   1736 
   1737     return 0;
   1738 }
   1739 
   1740 sub PASS_pop3 {
   1741     my ($password) = @_;
   1742 
   1743     logmsg "PASS_pop3 got $password\n";
   1744 
   1745     sendcontrol "+OK Login successful\r\n";
   1746 
   1747     return 0;
   1748 }
   1749 
   1750 sub RETR_pop3 {
   1751     my ($msgid) = @_;
   1752     my @data;
   1753 
   1754     if($msgid =~ /^verifiedserver$/) {
   1755         # this is the secret command that verifies that this actually is
   1756         # the curl test server
   1757         my $response = "WE ROOLZ: $$\r\n";
   1758         if($verbose) {
   1759             print STDERR "FTPD: We returned proof we are the test server\n";
   1760         }
   1761         $data[0] = $response;
   1762         logmsg "return proof we are we\n";
   1763     }
   1764     else {
   1765         # send mail content
   1766         logmsg "retrieve a mail\n";
   1767 
   1768         @data = getreplydata($msgid);
   1769     }
   1770 
   1771     sendcontrol "+OK Mail transfer starts\r\n";
   1772 
   1773     for my $d (@data) {
   1774         sendcontrol $d;
   1775     }
   1776 
   1777     # end with the magic 3-byte end of mail marker, assumes that the
   1778     # mail body ends with a CRLF!
   1779     sendcontrol ".\r\n";
   1780 
   1781     return 0;
   1782 }
   1783 
   1784 sub LIST_pop3 {
   1785     # This is a built-in fake-message list
   1786     my @data = (
   1787         "1 100\r\n",
   1788         "2 4294967400\r\n",	# > 4 GB
   1789         "3 200\r\n",
   1790     );
   1791 
   1792     logmsg "retrieve a message list\n";
   1793 
   1794     sendcontrol "+OK Listing starts\r\n";
   1795 
   1796     for my $d (@data) {
   1797         sendcontrol $d;
   1798     }
   1799 
   1800     # End with the magic 3-byte end of listing marker
   1801     sendcontrol ".\r\n";
   1802 
   1803     return 0;
   1804 }
   1805 
   1806 sub DELE_pop3 {
   1807     my ($msgid) = @_;
   1808 
   1809     logmsg "DELE_pop3 got $msgid\n";
   1810 
   1811     if (!$msgid) {
   1812         sendcontrol "-ERR Protocol error\r\n";
   1813     }
   1814     else {
   1815         push (@deleted, $msgid);
   1816 
   1817         sendcontrol "+OK\r\n";
   1818     }
   1819 
   1820     return 0;
   1821 }
   1822 
   1823 sub STAT_pop3 {
   1824     my ($args) = @_;
   1825 
   1826     if ($args) {
   1827         sendcontrol "-ERR Protocol error\r\n";
   1828     }
   1829     else {
   1830         # Send statistics for the built-in fake message list as
   1831         # detailed in the LIST_pop3 function above
   1832         sendcontrol "+OK 3 4294967800\r\n";
   1833     }
   1834 
   1835     return 0;
   1836 }
   1837 
   1838 sub NOOP_pop3 {
   1839     my ($args) = @_;
   1840 
   1841     if ($args) {
   1842         sendcontrol "-ERR Protocol error\r\n";
   1843     }
   1844     else {
   1845         sendcontrol "+OK\r\n";
   1846     }
   1847 
   1848     return 0;
   1849 }
   1850 
   1851 sub UIDL_pop3 {
   1852     # This is a built-in fake-message UID list
   1853     my @data = (
   1854         "1 1\r\n",
   1855         "2 2\r\n",
   1856         "3 4\r\n", # Note that UID 3 is a simulated "deleted" message
   1857     );
   1858 
   1859     if (!grep /^UIDL$/, @capabilities) {
   1860         sendcontrol "-ERR Unrecognized command\r\n";
   1861     }
   1862     else {
   1863         logmsg "retrieve a message UID list\n";
   1864 
   1865         sendcontrol "+OK Listing starts\r\n";
   1866 
   1867         for my $d (@data) {
   1868             sendcontrol $d;
   1869         }
   1870 
   1871         # End with the magic 3-byte end of listing marker
   1872         sendcontrol ".\r\n";
   1873     }
   1874 
   1875     return 0;
   1876 }
   1877 
   1878 sub TOP_pop3 {
   1879     my ($args) = @_;
   1880     my ($msgid, $lines) = split(/ /, $args, 2);
   1881 
   1882     logmsg "TOP_pop3 got $args\n";
   1883 
   1884     if (!grep /^TOP$/, @capabilities) {
   1885         sendcontrol "-ERR Unrecognized command\r\n";
   1886     }
   1887     elsif (($msgid eq "") || ($lines eq "")) {
   1888         sendcontrol "-ERR Protocol error\r\n";
   1889     }
   1890     else {
   1891         if ($lines == "0") {
   1892             logmsg "retrieve header of mail\n";
   1893         }
   1894         else {
   1895             logmsg "retrieve top $lines lines of mail\n";
   1896         }
   1897 
   1898         my @data = getreplydata($msgid);
   1899 
   1900         sendcontrol "+OK Mail transfer starts\r\n";
   1901 
   1902         # Send mail content
   1903         for my $d (@data) {
   1904             sendcontrol $d;
   1905         }
   1906 
   1907         # End with the magic 3-byte end of mail marker, assumes that the
   1908         # mail body ends with a CRLF!
   1909         sendcontrol ".\r\n";
   1910     }
   1911 
   1912     return 0;
   1913 }
   1914 
   1915 sub RSET_pop3 {
   1916     my ($args) = @_;
   1917 
   1918     if ($args) {
   1919         sendcontrol "-ERR Protocol error\r\n";
   1920     }
   1921     else {
   1922         if (@deleted) {
   1923             logmsg "resetting @deleted message(s)\n";
   1924 
   1925             @deleted = ();
   1926         }
   1927 
   1928         sendcontrol "+OK\r\n";
   1929     }
   1930 
   1931     return 0;
   1932 }
   1933 
   1934 sub QUIT_pop3 {
   1935     if(@deleted) {
   1936         logmsg "deleting @deleted message(s)\n";
   1937 
   1938         @deleted = ();
   1939     }
   1940 
   1941     sendcontrol "+OK curl POP3 server signing off\r\n";
   1942 
   1943     return 0;
   1944 }
   1945 
   1946 ################
   1947 ################ FTP commands
   1948 ################
   1949 my $rest=0;
   1950 sub REST_ftp {
   1951     $rest = $_[0];
   1952     logmsg "Set REST position to $rest\n"
   1953 }
   1954 
   1955 sub switch_directory_goto {
   1956   my $target_dir = $_;
   1957 
   1958   if(!$ftptargetdir) {
   1959     $ftptargetdir = "/";
   1960   }
   1961 
   1962   if($target_dir eq "") {
   1963     $ftptargetdir = "/";
   1964   }
   1965   elsif($target_dir eq "..") {
   1966     if($ftptargetdir eq "/") {
   1967       $ftptargetdir = "/";
   1968     }
   1969     else {
   1970       $ftptargetdir =~ s/[[:alnum:]]+\/$//;
   1971     }
   1972   }
   1973   else {
   1974     $ftptargetdir .= $target_dir . "/";
   1975   }
   1976 }
   1977 
   1978 sub switch_directory {
   1979     my $target_dir = $_[0];
   1980 
   1981     if($target_dir =~ /^test-(\d+)/) {
   1982         $cwd_testno = $1;
   1983     }
   1984     elsif($target_dir eq "/") {
   1985         $ftptargetdir = "/";
   1986     }
   1987     else {
   1988         my @dirs = split("/", $target_dir);
   1989         for(@dirs) {
   1990           switch_directory_goto($_);
   1991         }
   1992     }
   1993 }
   1994 
   1995 sub CWD_ftp {
   1996   my ($folder, $fullcommand) = $_[0];
   1997   switch_directory($folder);
   1998   if($ftptargetdir =~ /^\/fully_simulated/) {
   1999     $ftplistparserstate = "enabled";
   2000   }
   2001   else {
   2002     undef $ftplistparserstate;
   2003   }
   2004 }
   2005 
   2006 sub PWD_ftp {
   2007     my $mydir;
   2008     $mydir = $ftptargetdir ? $ftptargetdir : "/";
   2009 
   2010     if($mydir ne "/") {
   2011         $mydir =~ s/\/$//;
   2012     }
   2013     sendcontrol "257 \"$mydir\" is current directory\r\n";
   2014 }
   2015 
   2016 sub LIST_ftp {
   2017     #  print "150 ASCII data connection for /bin/ls (193.15.23.1,59196) (0 bytes)\r\n";
   2018 
   2019 # this is a built-in fake-dir ;-)
   2020 my @ftpdir=("total 20\r\n",
   2021 "drwxr-xr-x   8 98       98           512 Oct 22 13:06 .\r\n",
   2022 "drwxr-xr-x   8 98       98           512 Oct 22 13:06 ..\r\n",
   2023 "drwxr-xr-x   2 98       98           512 May  2  1996 .NeXT\r\n",
   2024 "-r--r--r--   1 0        1             35 Jul 16  1996 README\r\n",
   2025 "lrwxrwxrwx   1 0        1              7 Dec  9  1999 bin -> usr/bin\r\n",
   2026 "dr-xr-xr-x   2 0        1            512 Oct  1  1997 dev\r\n",
   2027 "drwxrwxrwx   2 98       98           512 May 29 16:04 download.html\r\n",
   2028 "dr-xr-xr-x   2 0        1            512 Nov 30  1995 etc\r\n",
   2029 "drwxrwxrwx   2 98       1            512 Oct 30 14:33 pub\r\n",
   2030 "dr-xr-xr-x   5 0        1            512 Oct  1  1997 usr\r\n");
   2031 
   2032     if($datasockf_conn eq 'no') {
   2033         if($nodataconn425) {
   2034             sendcontrol "150 Opening data connection\r\n";
   2035             sendcontrol "425 Can't open data connection\r\n";
   2036         }
   2037         elsif($nodataconn421) {
   2038             sendcontrol "150 Opening data connection\r\n";
   2039             sendcontrol "421 Connection timed out\r\n";
   2040         }
   2041         elsif($nodataconn150) {
   2042             sendcontrol "150 Opening data connection\r\n";
   2043             # client shall timeout
   2044         }
   2045         else {
   2046             # client shall timeout
   2047         }
   2048         return 0;
   2049     }
   2050 
   2051     if($ftplistparserstate) {
   2052       @ftpdir = ftp_contentlist($ftptargetdir);
   2053     }
   2054 
   2055     logmsg "pass LIST data on data connection\n";
   2056 
   2057     if($cwd_testno) {
   2058         loadtest("$srcdir/data/test$cwd_testno");
   2059 
   2060         my @data = getpart("reply", "data");
   2061         for(@data) {
   2062             my $send = $_;
   2063             # convert all \n to \r\n for ASCII transfer
   2064             $send =~ s/\r\n/\n/g;
   2065             $send =~ s/\n/\r\n/g;
   2066             logmsg "send $send as data\n";
   2067             senddata $send;
   2068         }
   2069         $cwd_testno = 0; # forget it again
   2070     }
   2071     else {
   2072         # old hard-coded style
   2073         for(@ftpdir) {
   2074             senddata $_;
   2075         }
   2076     }
   2077     close_dataconn(0);
   2078     sendcontrol "226 ASCII transfer complete\r\n";
   2079     return 0;
   2080 }
   2081 
   2082 sub NLST_ftp {
   2083     my @ftpdir=("file", "with space", "fake", "..", " ..", "funny", "README");
   2084 
   2085     if($datasockf_conn eq 'no') {
   2086         if($nodataconn425) {
   2087             sendcontrol "150 Opening data connection\r\n";
   2088             sendcontrol "425 Can't open data connection\r\n";
   2089         }
   2090         elsif($nodataconn421) {
   2091             sendcontrol "150 Opening data connection\r\n";
   2092             sendcontrol "421 Connection timed out\r\n";
   2093         }
   2094         elsif($nodataconn150) {
   2095             sendcontrol "150 Opening data connection\r\n";
   2096             # client shall timeout
   2097         }
   2098         else {
   2099             # client shall timeout
   2100         }
   2101         return 0;
   2102     }
   2103 
   2104     logmsg "pass NLST data on data connection\n";
   2105     for(@ftpdir) {
   2106         senddata "$_\r\n";
   2107     }
   2108     close_dataconn(0);
   2109     sendcontrol "226 ASCII transfer complete\r\n";
   2110     return 0;
   2111 }
   2112 
   2113 sub MDTM_ftp {
   2114     my $testno = $_[0];
   2115     my $testpart = "";
   2116     if ($testno > 10000) {
   2117         $testpart = $testno % 10000;
   2118         $testno = int($testno / 10000);
   2119     }
   2120 
   2121     loadtest("$srcdir/data/test$testno");
   2122 
   2123     my @data = getpart("reply", "mdtm");
   2124 
   2125     my $reply = $data[0];
   2126     chomp $reply if($reply);
   2127 
   2128     if($reply && ($reply =~ /^[+-]?\d+$/) && ($reply < 0)) {
   2129         sendcontrol "550 $testno: no such file.\r\n";
   2130     }
   2131     elsif($reply) {
   2132         sendcontrol "$reply\r\n";
   2133     }
   2134     else {
   2135         sendcontrol "500 MDTM: no such command.\r\n";
   2136     }
   2137     return 0;
   2138 }
   2139 
   2140 sub SIZE_ftp {
   2141     my $testno = $_[0];
   2142     if($ftplistparserstate) {
   2143         my $size = wildcard_filesize($ftptargetdir, $testno);
   2144         if($size == -1) {
   2145             sendcontrol "550 $testno: No such file or directory.\r\n";
   2146         }
   2147         else {
   2148             sendcontrol "213 $size\r\n";
   2149         }
   2150         return 0;
   2151     }
   2152 
   2153     if($testno =~ /^verifiedserver$/) {
   2154         my $response = "WE ROOLZ: $$\r\n";
   2155         my $size = length($response);
   2156         sendcontrol "213 $size\r\n";
   2157         return 0;
   2158     }
   2159 
   2160     if($testno =~ /(\d+)\/?$/) {
   2161         $testno = $1;
   2162     }
   2163     else {
   2164         print STDERR "SIZE_ftp: invalid test number: $testno\n";
   2165         return 1;
   2166     }
   2167 
   2168     my $testpart = "";
   2169     if($testno > 10000) {
   2170         $testpart = $testno % 10000;
   2171         $testno = int($testno / 10000);
   2172     }
   2173 
   2174     loadtest("$srcdir/data/test$testno");
   2175 
   2176     my @data = getpart("reply", "size");
   2177 
   2178     my $size = $data[0];
   2179 
   2180     if($size) {
   2181         if($size > -1) {
   2182             sendcontrol "213 $size\r\n";
   2183         }
   2184         else {
   2185             sendcontrol "550 $testno: No such file or directory.\r\n";
   2186         }
   2187     }
   2188     else {
   2189         $size=0;
   2190         @data = getpart("reply", "data$testpart");
   2191         for(@data) {
   2192             $size += length($_);
   2193         }
   2194         if($size) {
   2195             sendcontrol "213 $size\r\n";
   2196         }
   2197         else {
   2198             sendcontrol "550 $testno: No such file or directory.\r\n";
   2199         }
   2200     }
   2201     return 0;
   2202 }
   2203 
   2204 sub RETR_ftp {
   2205     my ($testno) = @_;
   2206 
   2207     if($datasockf_conn eq 'no') {
   2208         if($nodataconn425) {
   2209             sendcontrol "150 Opening data connection\r\n";
   2210             sendcontrol "425 Can't open data connection\r\n";
   2211         }
   2212         elsif($nodataconn421) {
   2213             sendcontrol "150 Opening data connection\r\n";
   2214             sendcontrol "421 Connection timed out\r\n";
   2215         }
   2216         elsif($nodataconn150) {
   2217             sendcontrol "150 Opening data connection\r\n";
   2218             # client shall timeout
   2219         }
   2220         else {
   2221             # client shall timeout
   2222         }
   2223         return 0;
   2224     }
   2225 
   2226     if($ftplistparserstate) {
   2227         my @content = wildcard_getfile($ftptargetdir, $testno);
   2228         if($content[0] == -1) {
   2229             #file not found
   2230         }
   2231         else {
   2232             my $size = length $content[1];
   2233             sendcontrol "150 Binary data connection for $testno ($size bytes).\r\n",
   2234             senddata $content[1];
   2235             close_dataconn(0);
   2236             sendcontrol "226 File transfer complete\r\n";
   2237         }
   2238         return 0;
   2239     }
   2240 
   2241     if($testno =~ /^verifiedserver$/) {
   2242         # this is the secret command that verifies that this actually is
   2243         # the curl test server
   2244         my $response = "WE ROOLZ: $$\r\n";
   2245         my $len = length($response);
   2246         sendcontrol "150 Binary junk ($len bytes).\r\n";
   2247         senddata "WE ROOLZ: $$\r\n";
   2248         close_dataconn(0);
   2249         sendcontrol "226 File transfer complete\r\n";
   2250         if($verbose) {
   2251             print STDERR "FTPD: We returned proof we are the test server\n";
   2252         }
   2253         return 0;
   2254     }
   2255 
   2256     $testno =~ s/^([^0-9]*)//;
   2257     my $testpart = "";
   2258     if ($testno > 10000) {
   2259         $testpart = $testno % 10000;
   2260         $testno = int($testno / 10000);
   2261     }
   2262 
   2263     loadtest("$srcdir/data/test$testno");
   2264 
   2265     my @data = getpart("reply", "data$testpart");
   2266 
   2267     my $size=0;
   2268     for(@data) {
   2269         $size += length($_);
   2270     }
   2271 
   2272     my %hash = getpartattr("reply", "data$testpart");
   2273 
   2274     if($size || $hash{'sendzero'}) {
   2275 
   2276         if($rest) {
   2277             # move read pointer forward
   2278             $size -= $rest;
   2279             logmsg "REST $rest was removed from size, makes $size left\n";
   2280             $rest = 0; # reset REST offset again
   2281         }
   2282         if($retrweirdo) {
   2283             sendcontrol "150 Binary data connection for $testno () ($size bytes).\r\n",
   2284             "226 File transfer complete\r\n";
   2285 
   2286             for(@data) {
   2287                 my $send = $_;
   2288                 senddata $send;
   2289             }
   2290             close_dataconn(0);
   2291             $retrweirdo=0; # switch off the weirdo again!
   2292         }
   2293         else {
   2294             my $sz = "($size bytes)";
   2295             if($retrnosize) {
   2296                 $sz = "size?";
   2297             }
   2298 
   2299             sendcontrol "150 Binary data connection for $testno () $sz.\r\n";
   2300 
   2301             for(@data) {
   2302                 my $send = $_;
   2303                 senddata $send;
   2304             }
   2305             close_dataconn(0);
   2306             sendcontrol "226 File transfer complete\r\n";
   2307         }
   2308     }
   2309     else {
   2310         sendcontrol "550 $testno: No such file or directory.\r\n";
   2311     }
   2312     return 0;
   2313 }
   2314 
   2315 sub STOR_ftp {
   2316     my $testno=$_[0];
   2317 
   2318     my $filename = "log/upload.$testno";
   2319 
   2320     if($datasockf_conn eq 'no') {
   2321         if($nodataconn425) {
   2322             sendcontrol "150 Opening data connection\r\n";
   2323             sendcontrol "425 Can't open data connection\r\n";
   2324         }
   2325         elsif($nodataconn421) {
   2326             sendcontrol "150 Opening data connection\r\n";
   2327             sendcontrol "421 Connection timed out\r\n";
   2328         }
   2329         elsif($nodataconn150) {
   2330             sendcontrol "150 Opening data connection\r\n";
   2331             # client shall timeout
   2332         }
   2333         else {
   2334             # client shall timeout
   2335         }
   2336         return 0;
   2337     }
   2338 
   2339     logmsg "STOR test number $testno in $filename\n";
   2340 
   2341     sendcontrol "125 Gimme gimme gimme!\r\n";
   2342 
   2343     open(FILE, ">$filename") ||
   2344         return 0; # failed to open output
   2345 
   2346     my $line;
   2347     my $ulsize=0;
   2348     my $disc=0;
   2349     while (5 == (sysread DREAD, $line, 5)) {
   2350         if($line eq "DATA\n") {
   2351             my $i;
   2352             sysread DREAD, $i, 5;
   2353 
   2354             my $size = 0;
   2355             if($i =~ /^([0-9a-fA-F]{4})\n/) {
   2356                 $size = hex($1);
   2357             }
   2358 
   2359             read_datasockf(\$line, $size);
   2360 
   2361             #print STDERR "  GOT: $size bytes\n";
   2362 
   2363             $ulsize += $size;
   2364             print FILE $line if(!$nosave);
   2365             logmsg "> Appending $size bytes to file\n";
   2366         }
   2367         elsif($line eq "DISC\n") {
   2368             # disconnect!
   2369             $disc=1;
   2370             last;
   2371         }
   2372         else {
   2373             logmsg "No support for: $line";
   2374             last;
   2375         }
   2376     }
   2377     if($nosave) {
   2378         print FILE "$ulsize bytes would've been stored here\n";
   2379     }
   2380     close(FILE);
   2381     close_dataconn($disc);
   2382     logmsg "received $ulsize bytes upload\n";
   2383     sendcontrol "226 File transfer complete\r\n";
   2384     return 0;
   2385 }
   2386 
   2387 sub PASV_ftp {
   2388     my ($arg, $cmd)=@_;
   2389     my $pasvport;
   2390     my $bindonly = ($nodataconn) ? '--bindonly' : '';
   2391 
   2392     # kill previous data connection sockfilt when alive
   2393     if($datasockf_runs eq 'yes') {
   2394         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
   2395         logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
   2396     }
   2397     datasockf_state('STOPPED');
   2398 
   2399     logmsg "====> Passive DATA channel requested by client\n";
   2400 
   2401     logmsg "DATA sockfilt for passive data channel starting...\n";
   2402 
   2403     # We fire up a new sockfilt to do the data transfer for us.
   2404     my $datasockfcmd = "./server/sockfilt " .
   2405         "--ipv$ipvnum $bindonly --port 0 " .
   2406         "--pidfile \"$datasockf_pidfile\" " .
   2407         "--logfile \"$datasockf_logfile\"";
   2408     $slavepid = open2(\*DREAD, \*DWRITE, $datasockfcmd);
   2409 
   2410     if($nodataconn) {
   2411         datasockf_state('PASSIVE_NODATACONN');
   2412     }
   2413     else {
   2414         datasockf_state('PASSIVE');
   2415     }
   2416 
   2417     print STDERR "$datasockfcmd\n" if($verbose);
   2418 
   2419     print DWRITE "PING\n";
   2420     my $pong;
   2421     sysread_or_die(\*DREAD, \$pong, 5);
   2422 
   2423     if($pong =~ /^FAIL/) {
   2424         logmsg "DATA sockfilt said: FAIL\n";
   2425         logmsg "DATA sockfilt for passive data channel failed\n";
   2426         logmsg "DATA sockfilt not running\n";
   2427         datasockf_state('STOPPED');
   2428         sendcontrol "500 no free ports!\r\n";
   2429         return;
   2430     }
   2431     elsif($pong !~ /^PONG/) {
   2432         logmsg "DATA sockfilt unexpected response: $pong\n";
   2433         logmsg "DATA sockfilt for passive data channel failed\n";
   2434         logmsg "DATA sockfilt killed now\n";
   2435         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
   2436         logmsg "DATA sockfilt not running\n";
   2437         datasockf_state('STOPPED');
   2438         sendcontrol "500 no free ports!\r\n";
   2439         return;
   2440     }
   2441 
   2442     logmsg "DATA sockfilt for passive data channel started (pid $slavepid)\n";
   2443 
   2444     # Find out on what port we listen on or have bound
   2445     my $i;
   2446     print DWRITE "PORT\n";
   2447 
   2448     # READ the response code
   2449     sysread_or_die(\*DREAD, \$i, 5);
   2450 
   2451     # READ the response size
   2452     sysread_or_die(\*DREAD, \$i, 5);
   2453 
   2454     my $size = 0;
   2455     if($i =~ /^([0-9a-fA-F]{4})\n/) {
   2456         $size = hex($1);
   2457     }
   2458 
   2459     # READ the response data
   2460     read_datasockf(\$i, $size);
   2461 
   2462     # The data is in the format
   2463     # IPvX/NNN
   2464 
   2465     if($i =~ /IPv(\d)\/(\d+)/) {
   2466         # FIX: deal with IP protocol version
   2467         $pasvport = $2;
   2468     }
   2469 
   2470     if(!$pasvport) {
   2471         logmsg "DATA sockfilt unknown listener port\n";
   2472         logmsg "DATA sockfilt for passive data channel failed\n";
   2473         logmsg "DATA sockfilt killed now\n";
   2474         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
   2475         logmsg "DATA sockfilt not running\n";
   2476         datasockf_state('STOPPED');
   2477         sendcontrol "500 no free ports!\r\n";
   2478         return;
   2479     }
   2480 
   2481     if($nodataconn) {
   2482         my $str = nodataconn_str();
   2483         logmsg "DATA sockfilt for passive data channel ($str) bound on port ".
   2484                "$pasvport\n";
   2485     }
   2486     else {
   2487         logmsg "DATA sockfilt for passive data channel listens on port ".
   2488                "$pasvport\n";
   2489     }
   2490 
   2491     if($cmd ne "EPSV") {
   2492         # PASV reply
   2493         my $p=$listenaddr;
   2494         $p =~ s/\./,/g;
   2495         if($pasvbadip) {
   2496             $p="1,2,3,4";
   2497         }
   2498         sendcontrol sprintf("227 Entering Passive Mode ($p,%d,%d)\n",
   2499                             int($pasvport/256), int($pasvport%256));
   2500     }
   2501     else {
   2502         # EPSV reply
   2503         sendcontrol sprintf("229 Entering Passive Mode (|||%d|)\n", $pasvport);
   2504     }
   2505 
   2506     logmsg "Client has been notified that DATA conn ".
   2507            "will be accepted on port $pasvport\n";
   2508 
   2509     if($nodataconn) {
   2510         my $str = nodataconn_str();
   2511         logmsg "====> Client fooled ($str)\n";
   2512         return;
   2513     }
   2514 
   2515     eval {
   2516         local $SIG{ALRM} = sub { die "alarm\n" };
   2517 
   2518         # assume swift operations unless explicitly slow
   2519         alarm ($datadelay?20:10);
   2520 
   2521         # Wait for 'CNCT'
   2522         my $input;
   2523 
   2524         # FIX: Monitor ctrl conn for disconnect
   2525 
   2526         while(sysread(DREAD, $input, 5)) {
   2527 
   2528             if($input !~ /^CNCT/) {
   2529                 # we wait for a connected client
   2530                 logmsg "Odd, we got $input from client\n";
   2531                 next;
   2532             }
   2533             logmsg "Client connects to port $pasvport\n";
   2534             last;
   2535         }
   2536         alarm 0;
   2537     };
   2538     if ($@) {
   2539         # timed out
   2540         logmsg "$srvrname server timed out awaiting data connection ".
   2541             "on port $pasvport\n";
   2542         logmsg "accept failed or connection not even attempted\n";
   2543         logmsg "DATA sockfilt killed now\n";
   2544         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
   2545         logmsg "DATA sockfilt not running\n";
   2546         datasockf_state('STOPPED');
   2547         return;
   2548     }
   2549     else {
   2550         logmsg "====> Client established passive DATA connection ".
   2551                "on port $pasvport\n";
   2552     }
   2553 
   2554     return;
   2555 }
   2556 
   2557 #
   2558 # Support both PORT and EPRT here.
   2559 #
   2560 
   2561 sub PORT_ftp {
   2562     my ($arg, $cmd) = @_;
   2563     my $port;
   2564     my $addr;
   2565 
   2566     # kill previous data connection sockfilt when alive
   2567     if($datasockf_runs eq 'yes') {
   2568         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
   2569         logmsg "DATA sockfilt for $datasockf_mode data channel killed\n";
   2570     }
   2571     datasockf_state('STOPPED');
   2572 
   2573     logmsg "====> Active DATA channel requested by client\n";
   2574 
   2575     # We always ignore the given IP and use localhost.
   2576 
   2577     if($cmd eq "PORT") {
   2578         if($arg !~ /(\d+),(\d+),(\d+),(\d+),(\d+),(\d+)/) {
   2579             logmsg "DATA sockfilt for active data channel not started ".
   2580                    "(bad PORT-line: $arg)\n";
   2581             sendcontrol "500 silly you, go away\r\n";
   2582             return;
   2583         }
   2584         $port = ($5<<8)+$6;
   2585         $addr = "$1.$2.$3.$4";
   2586     }
   2587     # EPRT |2|::1|49706|
   2588     elsif($cmd eq "EPRT") {
   2589         if($arg !~ /(\d+)\|([^\|]+)\|(\d+)/) {
   2590             logmsg "DATA sockfilt for active data channel not started ".
   2591                    "(bad EPRT-line: $arg)\n";
   2592             sendcontrol "500 silly you, go away\r\n";
   2593             return;
   2594         }
   2595         sendcontrol "200 Thanks for dropping by. We contact you later\r\n";
   2596         $port = $3;
   2597         $addr = $2;
   2598     }
   2599     else {
   2600         logmsg "DATA sockfilt for active data channel not started ".
   2601                "(invalid command: $cmd)\n";
   2602         sendcontrol "500 we don't like $cmd now\r\n";
   2603         return;
   2604     }
   2605 
   2606     if(!$port || $port > 65535) {
   2607         logmsg "DATA sockfilt for active data channel not started ".
   2608                "(illegal PORT number: $port)\n";
   2609         return;
   2610     }
   2611 
   2612     if($nodataconn) {
   2613         my $str = nodataconn_str();
   2614         logmsg "DATA sockfilt for active data channel not started ($str)\n";
   2615         datasockf_state('ACTIVE_NODATACONN');
   2616         logmsg "====> Active DATA channel not established\n";
   2617         return;
   2618     }
   2619 
   2620     logmsg "DATA sockfilt for active data channel starting...\n";
   2621 
   2622     # We fire up a new sockfilt to do the data transfer for us.
   2623     my $datasockfcmd = "./server/sockfilt " .
   2624         "--ipv$ipvnum --connect $port --addr \"$addr\" " .
   2625         "--pidfile \"$datasockf_pidfile\" " .
   2626         "--logfile \"$datasockf_logfile\"";
   2627     $slavepid = open2(\*DREAD, \*DWRITE, $datasockfcmd);
   2628 
   2629     datasockf_state('ACTIVE');
   2630 
   2631     print STDERR "$datasockfcmd\n" if($verbose);
   2632 
   2633     print DWRITE "PING\n";
   2634     my $pong;
   2635     sysread_or_die(\*DREAD, \$pong, 5);
   2636 
   2637     if($pong =~ /^FAIL/) {
   2638         logmsg "DATA sockfilt said: FAIL\n";
   2639         logmsg "DATA sockfilt for active data channel failed\n";
   2640         logmsg "DATA sockfilt not running\n";
   2641         datasockf_state('STOPPED');
   2642         # client shall timeout awaiting connection from server
   2643         return;
   2644     }
   2645     elsif($pong !~ /^PONG/) {
   2646         logmsg "DATA sockfilt unexpected response: $pong\n";
   2647         logmsg "DATA sockfilt for active data channel failed\n";
   2648         logmsg "DATA sockfilt killed now\n";
   2649         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
   2650         logmsg "DATA sockfilt not running\n";
   2651         datasockf_state('STOPPED');
   2652         # client shall timeout awaiting connection from server
   2653         return;
   2654     }
   2655 
   2656     logmsg "DATA sockfilt for active data channel started (pid $slavepid)\n";
   2657 
   2658     logmsg "====> Active DATA channel connected to client port $port\n";
   2659 
   2660     return;
   2661 }
   2662 
   2663 #**********************************************************************
   2664 # datasockf_state is used to change variables that keep state info
   2665 # relative to the FTP secondary or data sockfilt process as soon as
   2666 # one of the five possible stable states is reached. Variables that
   2667 # are modified by this sub may be checked independently but should
   2668 # not be changed except by calling this sub.
   2669 #
   2670 sub datasockf_state {
   2671     my $state = $_[0];
   2672 
   2673   if($state eq 'STOPPED') {
   2674     # Data sockfilter initial state, not running,
   2675     # not connected and not used.
   2676     $datasockf_state = $state;
   2677     $datasockf_mode = 'none';
   2678     $datasockf_runs = 'no';
   2679     $datasockf_conn = 'no';
   2680   }
   2681   elsif($state eq 'PASSIVE') {
   2682     # Data sockfilter accepted connection from client.
   2683     $datasockf_state = $state;
   2684     $datasockf_mode = 'passive';
   2685     $datasockf_runs = 'yes';
   2686     $datasockf_conn = 'yes';
   2687   }
   2688   elsif($state eq 'ACTIVE') {
   2689     # Data sockfilter has connected to client.
   2690     $datasockf_state = $state;
   2691     $datasockf_mode = 'active';
   2692     $datasockf_runs = 'yes';
   2693     $datasockf_conn = 'yes';
   2694   }
   2695   elsif($state eq 'PASSIVE_NODATACONN') {
   2696     # Data sockfilter bound port without listening,
   2697     # client won't be able to establish data connection.
   2698     $datasockf_state = $state;
   2699     $datasockf_mode = 'passive';
   2700     $datasockf_runs = 'yes';
   2701     $datasockf_conn = 'no';
   2702   }
   2703   elsif($state eq 'ACTIVE_NODATACONN') {
   2704     # Data sockfilter does not even run,
   2705     # client awaits data connection from server in vain.
   2706     $datasockf_state = $state;
   2707     $datasockf_mode = 'active';
   2708     $datasockf_runs = 'no';
   2709     $datasockf_conn = 'no';
   2710   }
   2711   else {
   2712       die "Internal error. Unknown datasockf state: $state!";
   2713   }
   2714 }
   2715 
   2716 #**********************************************************************
   2717 # nodataconn_str returns string of effective nodataconn command. Notice
   2718 # that $nodataconn may be set alone or in addition to a $nodataconnXXX.
   2719 #
   2720 sub nodataconn_str {
   2721     my $str;
   2722     # order matters
   2723     $str = 'NODATACONN' if($nodataconn);
   2724     $str = 'NODATACONN425' if($nodataconn425);
   2725     $str = 'NODATACONN421' if($nodataconn421);
   2726     $str = 'NODATACONN150' if($nodataconn150);
   2727     return "$str";
   2728 }
   2729 
   2730 #**********************************************************************
   2731 # customize configures test server operation for each curl test, reading
   2732 # configuration commands/parameters from server commands file each time
   2733 # a new client control connection is established with the test server.
   2734 # On success returns 1, otherwise zero.
   2735 #
   2736 sub customize {
   2737     $ctrldelay = 0;     # default is no throttling of the ctrl stream
   2738     $datadelay = 0;     # default is no throttling of the data stream
   2739     $retrweirdo = 0;    # default is no use of RETRWEIRDO
   2740     $retrnosize = 0;    # default is no use of RETRNOSIZE
   2741     $pasvbadip = 0;     # default is no use of PASVBADIP
   2742     $nosave = 0;        # default is to actually save uploaded data to file
   2743     $nodataconn = 0;    # default is to establish or accept data channel
   2744     $nodataconn425 = 0; # default is to not send 425 without data channel
   2745     $nodataconn421 = 0; # default is to not send 421 without data channel
   2746     $nodataconn150 = 0; # default is to not send 150 without data channel
   2747     @capabilities = (); # default is to not support capability commands
   2748     @auth_mechs = ();   # default is to not support authentication commands
   2749     %fulltextreply = ();#
   2750     %commandreply = (); #
   2751     %customcount = ();  #
   2752     %delayreply = ();   #
   2753 
   2754     open(CUSTOM, "<log/ftpserver.cmd") ||
   2755         return 1;
   2756 
   2757     logmsg "FTPD: Getting commands from log/ftpserver.cmd\n";
   2758 
   2759     while(<CUSTOM>) {
   2760         if($_ =~ /REPLY \"([A-Z]+ [A-Za-z0-9+-\/=\*. ]+)\" (.*)/) {
   2761             $fulltextreply{$1}=eval "qq{$2}";
   2762             logmsg "FTPD: set custom reply for $1\n";
   2763         }
   2764         elsif($_ =~ /REPLY(LF|) ([A-Za-z0-9+\/=\*]*) (.*)/) {
   2765             $commandreply{$2}=eval "qq{$3}";
   2766             if($1 ne "LF") {
   2767                 $commandreply{$2}.="\r\n";
   2768             }
   2769             else {
   2770                 $commandreply{$2}.="\n";
   2771             }
   2772             if($2 eq "") {
   2773                 logmsg "FTPD: set custom reply for empty command\n";
   2774             }
   2775             else {
   2776                 logmsg "FTPD: set custom reply for $2 command\n";
   2777             }
   2778         }
   2779         elsif($_ =~ /COUNT ([A-Z]+) (.*)/) {
   2780             # we blank the custom reply for this command when having
   2781             # been used this number of times
   2782             $customcount{$1}=$2;
   2783             logmsg "FTPD: blank custom reply for $1 command after $2 uses\n";
   2784         }
   2785         elsif($_ =~ /DELAY ([A-Z]+) (\d*)/) {
   2786             $delayreply{$1}=$2;
   2787             logmsg "FTPD: delay reply for $1 with $2 seconds\n";
   2788         }
   2789         elsif($_ =~ /SLOWDOWN/) {
   2790             $ctrldelay=1;
   2791             $datadelay=1;
   2792             logmsg "FTPD: send response with 0.01 sec delay between each byte\n";
   2793         }
   2794         elsif($_ =~ /RETRWEIRDO/) {
   2795             logmsg "FTPD: instructed to use RETRWEIRDO\n";
   2796             $retrweirdo=1;
   2797         }
   2798         elsif($_ =~ /RETRNOSIZE/) {
   2799             logmsg "FTPD: instructed to use RETRNOSIZE\n";
   2800             $retrnosize=1;
   2801         }
   2802         elsif($_ =~ /PASVBADIP/) {
   2803             logmsg "FTPD: instructed to use PASVBADIP\n";
   2804             $pasvbadip=1;
   2805         }
   2806         elsif($_ =~ /NODATACONN425/) {
   2807             # applies to both active and passive FTP modes
   2808             logmsg "FTPD: instructed to use NODATACONN425\n";
   2809             $nodataconn425=1;
   2810             $nodataconn=1;
   2811         }
   2812         elsif($_ =~ /NODATACONN421/) {
   2813             # applies to both active and passive FTP modes
   2814             logmsg "FTPD: instructed to use NODATACONN421\n";
   2815             $nodataconn421=1;
   2816             $nodataconn=1;
   2817         }
   2818         elsif($_ =~ /NODATACONN150/) {
   2819             # applies to both active and passive FTP modes
   2820             logmsg "FTPD: instructed to use NODATACONN150\n";
   2821             $nodataconn150=1;
   2822             $nodataconn=1;
   2823         }
   2824         elsif($_ =~ /NODATACONN/) {
   2825             # applies to both active and passive FTP modes
   2826             logmsg "FTPD: instructed to use NODATACONN\n";
   2827             $nodataconn=1;
   2828         }
   2829         elsif($_ =~ /CAPA (.*)/) {
   2830             logmsg "FTPD: instructed to support CAPABILITY command\n";
   2831             @capabilities = split(/ (?!(?:[^" ]|[^"] [^"])+")/, $1);
   2832             foreach (@capabilities) {
   2833                 $_ = $1 if /^"(.*)"$/;
   2834             }
   2835         }
   2836         elsif($_ =~ /AUTH (.*)/) {
   2837             logmsg "FTPD: instructed to support AUTHENTICATION command\n";
   2838             @auth_mechs = split(/ /, $1);
   2839         }
   2840         elsif($_ =~ /NOSAVE/) {
   2841             # don't actually store the file we upload - to be used when
   2842             # uploading insanely huge amounts
   2843             $nosave = 1;
   2844             logmsg "FTPD: NOSAVE prevents saving of uploaded data\n";
   2845         }
   2846     }
   2847     close(CUSTOM);
   2848 }
   2849 
   2850 #----------------------------------------------------------------------
   2851 #----------------------------------------------------------------------
   2852 #---------------------------  END OF SUBS  ----------------------------
   2853 #----------------------------------------------------------------------
   2854 #----------------------------------------------------------------------
   2855 
   2856 #**********************************************************************
   2857 # Parse command line options
   2858 #
   2859 # Options:
   2860 #
   2861 # --verbose   # verbose
   2862 # --srcdir    # source directory
   2863 # --id        # server instance number
   2864 # --proto     # server protocol
   2865 # --pidfile   # server pid file
   2866 # --logfile   # server log file
   2867 # --ipv4      # server IP version 4
   2868 # --ipv6      # server IP version 6
   2869 # --port      # server listener port
   2870 # --addr      # server address for listener port binding
   2871 #
   2872 while(@ARGV) {
   2873     if($ARGV[0] eq '--verbose') {
   2874         $verbose = 1;
   2875     }
   2876     elsif($ARGV[0] eq '--srcdir') {
   2877         if($ARGV[1]) {
   2878             $srcdir = $ARGV[1];
   2879             shift @ARGV;
   2880         }
   2881     }
   2882     elsif($ARGV[0] eq '--id') {
   2883         if($ARGV[1] && ($ARGV[1] =~ /^(\d+)$/)) {
   2884             $idnum = $1 if($1 > 0);
   2885             shift @ARGV;
   2886         }
   2887     }
   2888     elsif($ARGV[0] eq '--proto') {
   2889         if($ARGV[1] && ($ARGV[1] =~ /^(ftp|imap|pop3|smtp)$/)) {
   2890             $proto = $1;
   2891             shift @ARGV;
   2892         }
   2893         else {
   2894             die "unsupported protocol $ARGV[1]";
   2895         }
   2896     }
   2897     elsif($ARGV[0] eq '--pidfile') {
   2898         if($ARGV[1]) {
   2899             $pidfile = $ARGV[1];
   2900             shift @ARGV;
   2901         }
   2902     }
   2903     elsif($ARGV[0] eq '--logfile') {
   2904         if($ARGV[1]) {
   2905             $logfile = $ARGV[1];
   2906             shift @ARGV;
   2907         }
   2908     }
   2909     elsif($ARGV[0] eq '--ipv4') {
   2910         $ipvnum = 4;
   2911         $listenaddr = '127.0.0.1' if($listenaddr eq '::1');
   2912     }
   2913     elsif($ARGV[0] eq '--ipv6') {
   2914         $ipvnum = 6;
   2915         $listenaddr = '::1' if($listenaddr eq '127.0.0.1');
   2916     }
   2917     elsif($ARGV[0] eq '--port') {
   2918         if($ARGV[1] && ($ARGV[1] =~ /^(\d+)$/)) {
   2919             $port = $1 if($1 > 1024);
   2920             shift @ARGV;
   2921         }
   2922     }
   2923     elsif($ARGV[0] eq '--addr') {
   2924         if($ARGV[1]) {
   2925             my $tmpstr = $ARGV[1];
   2926             if($tmpstr =~ /^(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)\.(\d\d?\d?)$/) {
   2927                 $listenaddr = "$1.$2.$3.$4" if($ipvnum == 4);
   2928             }
   2929             elsif($ipvnum == 6) {
   2930                 $listenaddr = $tmpstr;
   2931                 $listenaddr =~ s/^\[(.*)\]$/$1/;
   2932             }
   2933             shift @ARGV;
   2934         }
   2935     }
   2936     else {
   2937         print STDERR "\nWarning: ftpserver.pl unknown parameter: $ARGV[0]\n";
   2938     }
   2939     shift @ARGV;
   2940 }
   2941 
   2942 #***************************************************************************
   2943 # Initialize command line option dependent variables
   2944 #
   2945 
   2946 if(!$srcdir) {
   2947     $srcdir = $ENV{'srcdir'} || '.';
   2948 }
   2949 if(!$pidfile) {
   2950     $pidfile = "$path/". server_pidfilename($proto, $ipvnum, $idnum);
   2951 }
   2952 if(!$logfile) {
   2953     $logfile = server_logfilename($logdir, $proto, $ipvnum, $idnum);
   2954 }
   2955 
   2956 $mainsockf_pidfile = "$path/".
   2957     mainsockf_pidfilename($proto, $ipvnum, $idnum);
   2958 $mainsockf_logfile =
   2959     mainsockf_logfilename($logdir, $proto, $ipvnum, $idnum);
   2960 
   2961 if($proto eq 'ftp') {
   2962     $datasockf_pidfile = "$path/".
   2963         datasockf_pidfilename($proto, $ipvnum, $idnum);
   2964     $datasockf_logfile =
   2965         datasockf_logfilename($logdir, $proto, $ipvnum, $idnum);
   2966 }
   2967 
   2968 $srvrname = servername_str($proto, $ipvnum, $idnum);
   2969 
   2970 $idstr = "$idnum" if($idnum > 1);
   2971 
   2972 protocolsetup($proto);
   2973 
   2974 $SIG{INT} = \&exit_signal_handler;
   2975 $SIG{TERM} = \&exit_signal_handler;
   2976 
   2977 startsf();
   2978 
   2979 logmsg sprintf("%s server listens on port IPv${ipvnum}/${port}\n", uc($proto));
   2980 
   2981 open(PID, ">$pidfile");
   2982 print PID $$."\n";
   2983 close(PID);
   2984 
   2985 logmsg("logged pid $$ in $pidfile\n");
   2986 
   2987 
   2988 while(1) {
   2989 
   2990     # kill previous data connection sockfilt when alive
   2991     if($datasockf_runs eq 'yes') {
   2992         killsockfilters($proto, $ipvnum, $idnum, $verbose, 'data');
   2993         logmsg "DATA sockfilt for $datasockf_mode data channel killed now\n";
   2994     }
   2995     datasockf_state('STOPPED');
   2996 
   2997     #
   2998     # We read 'sockfilt' commands.
   2999     #
   3000     my $input;
   3001 
   3002     logmsg "Awaiting input\n";
   3003     sysread_or_die(\*SFREAD, \$input, 5);
   3004 
   3005     if($input !~ /^CNCT/) {
   3006         # we wait for a connected client
   3007         logmsg "MAIN sockfilt said: $input";
   3008         next;
   3009     }
   3010     logmsg "====> Client connect\n";
   3011 
   3012     set_advisor_read_lock($SERVERLOGS_LOCK);
   3013     $serverlogslocked = 1;
   3014 
   3015     # flush data:
   3016     $| = 1;
   3017 
   3018     &customize(); # read test control instructions
   3019 
   3020     my $welcome = $commandreply{"welcome"};
   3021     if(!$welcome) {
   3022         $welcome = $displaytext{"welcome"};
   3023     }
   3024     else {
   3025         # clear it after use
   3026         $commandreply{"welcome"}="";
   3027         if($welcome !~ /\r\n\z/) {
   3028             $welcome .= "\r\n";
   3029         }
   3030     }
   3031     sendcontrol $welcome;
   3032 
   3033     #remove global variables from last connection
   3034     if($ftplistparserstate) {
   3035       undef $ftplistparserstate;
   3036     }
   3037     if($ftptargetdir) {
   3038       $ftptargetdir = "";
   3039     }
   3040 
   3041     if($verbose) {
   3042         print STDERR "OUT: $welcome";
   3043     }
   3044 
   3045     my $full = "";
   3046 
   3047     while(1) {
   3048         my $i;
   3049 
   3050         # Now we expect to read DATA\n[hex size]\n[prot], where the [prot]
   3051         # part only is FTP lingo.
   3052 
   3053         # COMMAND
   3054         sysread_or_die(\*SFREAD, \$i, 5);
   3055 
   3056         if($i !~ /^DATA/) {
   3057             logmsg "MAIN sockfilt said $i";
   3058             if($i =~ /^DISC/) {
   3059                 # disconnect
   3060                 last;
   3061             }
   3062             next;
   3063         }
   3064 
   3065         # SIZE of data
   3066         sysread_or_die(\*SFREAD, \$i, 5);
   3067 
   3068         my $size = 0;
   3069         if($i =~ /^([0-9a-fA-F]{4})\n/) {
   3070             $size = hex($1);
   3071         }
   3072 
   3073         # data
   3074         read_mainsockf(\$input, $size);
   3075 
   3076         ftpmsg $input;
   3077 
   3078         $full .= $input;
   3079 
   3080         # Loop until command completion
   3081         next unless($full =~ /\r\n$/);
   3082 
   3083         # Remove trailing CRLF.
   3084         $full =~ s/[\n\r]+$//;
   3085 
   3086         my $FTPCMD;
   3087         my $FTPARG;
   3088         if($proto eq "imap") {
   3089             # IMAP is different with its identifier first on the command line
   3090             if(($full =~ /^([^ ]+) ([^ ]+) (.*)/) ||
   3091                ($full =~ /^([^ ]+) ([^ ]+)/)) {
   3092                 $cmdid=$1; # set the global variable
   3093                 $FTPCMD=$2;
   3094                 $FTPARG=$3;
   3095             }
   3096             # IMAP authentication cancellation
   3097             elsif($full =~ /^\*$/) {
   3098                 # Command id has already been set
   3099                 $FTPCMD="*";
   3100                 $FTPARG="";
   3101             }
   3102             # IMAP long "commands" are base64 authentication data
   3103             elsif($full =~ /^[A-Z0-9+\/]*={0,2}$/i) {
   3104                 # Command id has already been set
   3105                 $FTPCMD=$full;
   3106                 $FTPARG="";
   3107             }
   3108             else {
   3109                 sendcontrol "$full BAD Command\r\n";
   3110                 last;
   3111             }
   3112         }
   3113         elsif($full =~ /^([A-Z]{3,4})(\s(.*))?$/i) {
   3114             $FTPCMD=$1;
   3115             $FTPARG=$3;
   3116         }
   3117         elsif($proto eq "pop3") {
   3118             # POP3 authentication cancellation
   3119             if($full =~ /^\*$/) {
   3120                 $FTPCMD="*";
   3121                 $FTPARG="";
   3122             }
   3123             # POP3 long "commands" are base64 authentication data
   3124             elsif($full =~ /^[A-Z0-9+\/]*={0,2}$/i) {
   3125                 $FTPCMD=$full;
   3126                 $FTPARG="";
   3127             }
   3128             else {
   3129                 sendcontrol "-ERR Unrecognized command\r\n";
   3130                 last;
   3131             }
   3132         }
   3133         elsif($proto eq "smtp") {
   3134             # SMTP authentication cancellation
   3135             if($full =~ /^\*$/) {
   3136                 $FTPCMD="*";
   3137                 $FTPARG="";
   3138             }
   3139             # SMTP long "commands" are base64 authentication data
   3140             elsif($full =~ /^[A-Z0-9+\/]{0,512}={0,2}$/i) {
   3141                 $FTPCMD=$full;
   3142                 $FTPARG="";
   3143             }
   3144             else {
   3145                 sendcontrol "500 Unrecognized command\r\n";
   3146                 last;
   3147             }
   3148         }
   3149         else {
   3150             sendcontrol "500 Unrecognized command\r\n";
   3151             last;
   3152         }
   3153 
   3154         logmsg "< \"$full\"\n";
   3155 
   3156         if($verbose) {
   3157             print STDERR "IN: $full\n";
   3158         }
   3159 
   3160         $full = "";
   3161 
   3162         my $delay = $delayreply{$FTPCMD};
   3163         if($delay) {
   3164             # just go sleep this many seconds!
   3165             logmsg("Sleep for $delay seconds\n");
   3166             my $twentieths = $delay * 20;
   3167             while($twentieths--) {
   3168                 select(undef, undef, undef, 0.05) unless($got_exit_signal);
   3169             }
   3170         }
   3171 
   3172         my $check = 1; # no response yet
   3173 
   3174         # See if there is a custom reply for the full text
   3175         my $fulltext = $FTPARG ? $FTPCMD . " " . $FTPARG : $FTPCMD;
   3176         my $text = $fulltextreply{$fulltext};
   3177         if($text && ($text ne "")) {
   3178             sendcontrol "$text\r\n";
   3179             $check = 0;
   3180         }
   3181         else {
   3182             # See if there is a custom reply for the command
   3183             $text = $commandreply{$FTPCMD};
   3184             if($text && ($text ne "")) {
   3185                 if($customcount{$FTPCMD} && (!--$customcount{$FTPCMD})) {
   3186                     # used enough times so blank the custom command reply
   3187                     $commandreply{$FTPCMD}="";
   3188                 }
   3189 
   3190                 sendcontrol $text;
   3191                 $check = 0;
   3192             }
   3193             else {
   3194                 # See if there is any display text for the command
   3195                 $text = $displaytext{$FTPCMD};
   3196                 if($text && ($text ne "")) {
   3197                     if($proto eq 'imap') {
   3198                         sendcontrol "$cmdid $text\r\n";
   3199                     }
   3200                     else {
   3201                         sendcontrol "$text\r\n";
   3202                     }
   3203 
   3204                     $check = 0;
   3205                 }
   3206 
   3207                 # only perform this if we're not faking a reply
   3208                 my $func = $commandfunc{uc($FTPCMD)};
   3209                 if($func) {
   3210                     &$func($FTPARG, $FTPCMD);
   3211                     $check = 0;
   3212                 }
   3213             }
   3214         }
   3215 
   3216         if($check) {
   3217             logmsg "$FTPCMD wasn't handled!\n";
   3218             if($proto eq 'pop3') {
   3219                 sendcontrol "-ERR $FTPCMD is not dealt with!\r\n";
   3220             }
   3221             elsif($proto eq 'imap') {
   3222                 sendcontrol "$cmdid BAD $FTPCMD is not dealt with!\r\n";
   3223             }
   3224             else {
   3225                 sendcontrol "500 $FTPCMD is not dealt with!\r\n";
   3226             }
   3227         }
   3228 
   3229     } # while(1)
   3230     logmsg "====> Client disconnected\n";
   3231 
   3232     if($serverlogslocked) {
   3233         $serverlogslocked = 0;
   3234         clear_advisor_read_lock($SERVERLOGS_LOCK);
   3235     }
   3236 }
   3237 
   3238 killsockfilters($proto, $ipvnum, $idnum, $verbose);
   3239 unlink($pidfile);
   3240 if($serverlogslocked) {
   3241     $serverlogslocked = 0;
   3242     clear_advisor_read_lock($SERVERLOGS_LOCK);
   3243 }
   3244 
   3245 exit;
   3246