ftpserver.pl

#!/usr/bin/env perl
#***************************************************************************
#                                  _   _ ____  _
#  Project                     ___| | | |  _ \| |
#                             / __| | | | |_) | |
#                            | (__| |_| |  _ <| |___
#                             \___|\___/|_| \_\_____|
#
# Copyright (C) 1998 - 2009, Daniel Stenberg, <daniel@haxx.se>, et al.
#
# This software is licensed as described in the file COPYING, which
# you should have received as part of this distribution. The terms
# are also available at http://curl.haxx.se/docs/copyright.html.
#
# You may opt to use, copy, modify, merge, publish, distribute and/or sell
# copies of the Software, and permit persons to whom the Software is
# furnished to do so, under the terms of the COPYING file.
#
# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
# KIND, either express or implied.
#
# $Id$
###########################################################################

# This is a server designed for the curl test suite.
#
# In December 2009 we started remaking the server to support more protocols
# that are similar in spirit. Like POP3, IMAP and SMTP in addition to the
# FTP it already supported since a long time.
#
# It is meant to exercise curl, it is not meant to be a fully working
# or even very standard compliant server.
#
# You may optionally specify port on the command line, otherwise it'll
# default to port 8921.
#
# All socket/network/TCP related stuff is done by the 'sockfilt' program.
#

use strict;
use IPC::Open2;

require "getpart.pm";
require "ftp.pm";

#BEGIN {
#    if($] > 5.006) {
#        use Time::HiRes qw( gettimeofday );
#    }
#}

my $ftpdnum="";

my $logfilename = 'log/logfile.log'; # Override this for each test server

#######################################################################
# getlogfilename returns a log file name depending on given arguments.
#
sub getlogfilename {
    my ($proto, $ipversion, $ssl, $instance, $sockfilter) = @_;
    my $filename;

    # For now, simply mimic old behavior.
    $filename = "log/ftpd$ftpdnum.log";

    return $filename;
}

#######################################################################
# logmsg is general message logging subroutine for our test servers.
#
sub logmsg {
    my $now;
#   if($] > 5.006) {
#       my ($seconds, $usec) = gettimeofday();
#       my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
#           localtime($seconds);
#       $now = sprintf("%02d:%02d:%02d.%06d ", $hour, $min, $sec, $usec);
#   }
#   else {
        my $seconds = time();
        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
            localtime($seconds);
        $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec);
#   }
    if(open(LOGFILEFH, ">>$logfilename")) {
        print LOGFILEFH $now;
        print LOGFILEFH @_;
        close(LOGFILEFH);
    }
}

sub ftpmsg {
  # append to the server.input file
  open(INPUT, ">>log/server$ftpdnum.input") ||
    logmsg "failed to open log/server$ftpdnum.input\n";

  print INPUT @_;
  close(INPUT);

  # use this, open->print->close system only to make the file
  # open as little as possible, to make the test suite run
  # better on windows/cygwin
}

my $verbose=0; # set to 1 for debugging
my $pasvbadip=0;
my $retrweirdo=0;
my $retrnosize=0;
my $srcdir=".";
my $nosave=0;
my $controldelay=0; # set to 1 to delay the control connect data sending to
 # test that curl deals with that nicely
my $slavepid; # for the DATA connection sockfilt slave process
my $ipv6;
my $ext; # append to log/pid file names
my $grok_eprt;
my $port = 8921; # just a default
my $listenaddr = "127.0.0.1"; # just a default
my $pidfile = ".ftpd.pid"; # a default, use --pidfile

my $SERVERLOGS_LOCK="log/serverlogs.lock"; # server logs advisor read lock
my $serverlogslocked=0;

my $proto="ftp";

do {
    if($ARGV[0] eq "-v") {
        $verbose=1;
    }
    elsif($ARGV[0] eq "-s") {
        $srcdir=$ARGV[1];
        shift @ARGV;
    }
    elsif($ARGV[0] eq "--id") {
        $ftpdnum=$ARGV[1];
        shift @ARGV;
    }
    elsif($ARGV[0] eq "--proto") {
        # ftp pop3 imap smtp
        $proto=$ARGV[1];
        shift @ARGV;
    }
    elsif($ARGV[0] eq "--pidfile") {
        $pidfile=$ARGV[1];
        shift @ARGV;
    }
    elsif($ARGV[0] eq "--ipv6") {
        $ipv6="--ipv6";
        $ext="ipv6";
        $grok_eprt = 1;
    }
    elsif($ARGV[0] eq "--port") {
        $port = $ARGV[1];
        shift @ARGV;
    }
    elsif($ARGV[0] eq "--addr") {
        $listenaddr = $ARGV[1];
        $listenaddr =~ s/^\[(.*)\]$/$1/;
        shift @ARGV;
    }
} while(shift @ARGV);

# a dedicated protocol has been selected, check that it's a fine one
if($proto !~ /^(ftp|imap|pop3|smtp)\z/) {
    die "unsupported protocol selected";
}

sub catch_zap {
    my $signame = shift;
    ftpkillslaves($verbose);
    unlink($pidfile);
    if($serverlogslocked) {
        $serverlogslocked = 0;
        clear_advisor_read_lock($SERVERLOGS_LOCK);
    }
    exit;
}
$SIG{INT} = \&catch_zap;
$SIG{TERM} = \&catch_zap;

my $sfpid;

local(*SFREAD, *SFWRITE);

sub sysread_or_die {
    my $FH     = shift;
    my $scalar = shift;
    my $length = shift;
    my $fcaller;
    my $lcaller;
    my $result;

    $result = sysread($$FH, $$scalar, $length);

    if(not defined $result) {
        ($fcaller, $lcaller) = (caller)[1,2];
        logmsg "Failed to read input\n";
        logmsg "Error: ftp$ftpdnum$ext sysread error: $!\n";
        killpid($verbose, $sfpid);