Skip to content
Snippets Groups Projects
runtests.pl 42.3 KiB
Newer Older
  • Learn to ignore specific revisions
  • Daniel Stenberg's avatar
    Daniel Stenberg committed
    #!/usr/bin/env perl
    
    #***************************************************************************
    #                                  _   _ ____  _
    #  Project                     ___| | | |  _ \| |
    #                             / __| | | | |_) | |
    #                            | (__| |_| |  _ <| |___
    
    #                             \___|\___/|_| \_\_____|
    #
    # Copyright (C) 1998 - 2004, 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$
    
    ###########################################################################
    
    # These should be the only variables that might be needed to get edited:
    
    
    require "getpart.pm"; # array functions
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    my $HOSTIP="127.0.0.1";
    
    my $HOSTPORT=8999; # bad name, but this is the HTTP server port
    
    my $HTTPSPORT=8433; # this is the HTTPS server port
    
    my $FTPPORT=8921;  # this is the FTP server port
    
    my $FTPSPORT=8821;  # this is the FTPS server port
    
    my $CURL="../src/curl"; # what curl executable to run on the tests
    
    my $DBGCURL=$CURL; #"../src/.libs/curl";  # alternative for debugging
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    my $LOGDIR="log";
    
    my $LIBDIR="./libtest";
    
    my $SERVERIN="$LOGDIR/server.input"; # what curl sent the server
    
    my $CURLLOG="$LOGDIR/curl.log"; # all command lines run
    
    my $FTPDCMD="$LOGDIR/ftpserver.cmd"; # copy ftp server instructions here
    
    
    # Normally, all test cases should be run, but at times it is handy to
    # simply run a particular one:
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    my $TESTCASES="all";
    
    
    # To run specific test cases, set them like:
    # $TESTCASES="1 2 3 7 8";
    
    #######################################################################
    # No variables below this point should need to be modified
    #
    
    
    my $HTTPSPIDFILE=".https.pid";
    
    my $FTPPIDFILE=".ftp.pid";
    my $FTPSPIDFILE=".ftps.pid";
    
    # invoke perl like this:
    my $perl="perl -I$srcdir";
    
    
    # this gets set if curl is compiled with debugging:
    my $curl_debug=0;
    
    # name of the file that the memory debugging creates:
    my $memdump="memdump";
    
    # the path to the script that analyzes the memory debug output file:
    
    my $memanalyze="./memanalyze.pl";
    
    my $stunnel = checkcmd("stunnel");
    my $valgrind = checkcmd("valgrind");
    
    my $ssl_version; # set if libcurl is built with SSL support
    
    my $large_file;  # set if libcurl is built with large file support
    
    my $skipped=0;  # number of tests skipped; reported in main loop
    
    my %skipped;    # skipped{reason}=counter, reasons for skip
    my @teststat;   # teststat[testnum]=reason, reasons for skip
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    #######################################################################
    # variables the command line options may set
    #
    
    my $short;
    my $verbose;
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    my $anyway;
    
    my $gdbthis;      # run test case with gdb debugger
    my $keepoutfiles; # keep stdout and stderr files after tests
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    my $listonly;     # only list the tests
    
    
    my $pwd;          # current working directory
    
    
    my %run;	  # running server
    
    
    # torture test variables
    my $torture;
    my $tortnum;
    my $tortalloc;
    
    
    # enable memory debugging if curl is compiled with it
    $ENV{'CURL_MEMDEBUG'} = 1;
    
    ##########################################################################
    # Clear all possible '*_proxy' environment variables for various protocols
    # to prevent them to interfere with our testing!
    
    my $protocol;
    foreach $protocol (('ftp', 'http', 'ftps', 'https', 'gopher', 'no')) {
        my $proxy = "${protocol}_proxy";
        # clear lowercase version
        $ENV{$proxy}=undef;
        # clear uppercase version
        $ENV{uc($proxy)}=undef;
    }
    
    
    #######################################################################
    # Check for a command in the PATH.
    #
    sub checkcmd {
        my ($cmd)=@_;
        my @paths=("/usr/sbin", "/usr/local/sbin", "/sbin", "/usr/bin",
                   "/usr/local/bin", split(":", $ENV{'PATH'}));
        for(@paths) {
            if( -x "$_/$cmd") {
                return "$_/$cmd";
            }
        }
    }
    
    
    #######################################################################
    
    # Return the pid of the server as found in the given pid file
    
        my $PIDFILE = $_[0];
    
    #######################################################################
    # Memory allocation test and failure torture testing.
    #
    sub torture {
        # start all test servers (http, https, ftp, ftps)
        &startservers(("http", "https", "ftp", "ftps"));
        my $c;
    
        my @test=('http://%HOSTIP:%HOSTPORT/1',
                  'ftp://%HOSTIP:%FTPPORT/');
        
        # loop over the different tests commands
        for(@test) {
    
            my $cmdargs = "$_";
    
            print "We want test $c\n";
    
            my $redir=">log/torture.stdout 2>log/torture.stderr";
    
            subVariables(\$cmdargs);
    
            my $testcmd = "$CURL $cmdargs $redir";
    
            # First get URL from test server, ignore the output/result
            system($testcmd);
    
            # Set up gdb-stuff if desired
            if($gdbthis) {
                open(GDBCMD, ">log/gdbcmd");
                print GDBCMD "set args $cmdargs\n";
                print GDBCMD "show args\n";
                close(GDBCMD);
                $testcmd = "gdb $CURL -x log/gdbcmd";
            }
    
            print "Torture test $c:\n";
            print " CMD: $testcmd\n" if($verbose);
    
            
            # memanalyze -v is our friend, get the number of allocations made
            my $count;
    
            my @out = `$memanalyze -v $memdump`;
    
            for(@out) {
                if(/^Allocations: (\d+)/) {
                    $count = $1;
                    last;
                }
            }
            if(!$count) {
                # hm, no allocations in this fetch, ignore and get next
    
                print "BEEEP, no allocs found for test $c!!!\n";
    
                next;
            }
            print " $count allocations to excersize\n";
    
            for ( 1 .. $count ) {
                my $limit = $_;
                my $fail;
    
                if($tortalloc && ($tortalloc != $limit)) {
                    next;
                }
    
    
                print "Alloc no: $limit\r" if(!$gdbthis);
    
                
                # make the memory allocation function number $limit return failure
                $ENV{'CURL_MEMLIMIT'} = $limit;
    
                # remove memdump first to be sure we get a new nice and clean one
    
                unlink($memdump);
                
                print "**> Alloc number $limit is now set to fail <**\n" if($gdbthis);
    
    
                my $ret = system($testcmd);
    
                # verify that it returns a proper error code, doesn't leak memory
                # and doesn't core dump
                if($ret & 255) {
                    print " system() returned $ret\n";
                    $fail=1;
                }
                else {
                    my @memdata=`$memanalyze $memdump`;
                    my $leak=0;
                    for(@memdata) {
                        if($_ ne "") {
                            # well it could be other memory problems as well, but
                            # we call it leak for short here
                            $leak=1;
                        }
                    }
                    if($leak) {
                        print "** MEMORY FAILURE\n";
                        print @memdata;
    
                        print `$memanalyze -l $memdump`;
    
                        $fail = 1;
                    }
                }
                if($fail) {
                    print " Failed on alloc number $limit in test $c.\n",
                    " invoke with -t$c,$limit to repeat this single case.\n";
                    stopservers();
                    exit 1;
                }
            }
    
            print "\n torture test $c did GOOD\n";
    
    
            # all is well, now test a different kind of URL
        }
    
        stopservers();
        exit; # for now, we stop after these tests
    
    #######################################################################
    
    # stop the given test server
    
    sub stopserver {
    
        # check for pidfile
    
        if ( -f $pid ) {
            my $PIDFILE = $pid;
            $pid = serverpid($PIDFILE);
    
            unlink $PIDFILE; # server is killed
    
        }
        elsif($pid <= 0) {
            return; # this is not a good pid
        }
    
        my $res = kill (9, $pid); # die!
    
        if($res && $verbose) {
            print "RUN: Test server pid $pid signalled to die\n";
        }
        elsif($verbose) {
            print "RUN: Test server pid $pid didn't exist\n";
    
    #######################################################################
    
    # check the given test server if it is still alive
    
    sub checkserver {
        my ($pidfile)=@_;
    
        # check for pidfile
    
        if ( -f $pidfile ) {
    
            $pid=serverpid($pidfile);
            if ($pid ne "" && kill(0, $pid)) {
                return $pid;
    
                return -$pid; # negative means dead process
    
    }
    
    #######################################################################
    # start the http server, or if it already runs, verify that it is our
    # test server on the test-port!
    #
    sub runhttpserver {
        my $verbose = $_[0];
        my $RUNNING;
    
        $pid = checkserver ($HTTPPIDFILE);
    
    
        # verify if our/any server is running on this port
    
        my $cmd = "$CURL -o log/verifiedserver --silent -i $HOSTIP:$HOSTPORT/verifiedserver 2>/dev/null";
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
        print "CMD; $cmd\n" if ($verbose);
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    
    
        print "RUN: curl command returned $res\n" if ($verbose);
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    
    
        open(FILE, "<log/verifiedserver");
        my @file=<FILE>;
        close(FILE);
        $data=$file[0]; # first line
    
        if ( $data =~ /WE ROOLZ: (\d+)/ ) {
            $pid = 0+$1;
    
            print "RUN: Unknown HTTP server is running on port $HOSTPORT\n";
    
            my $res = kill (9, $pid); # die!
            if(!$res) {
    
                print "RUN: Failed to kill test HTTP server, do it manually and",
    
        my $dir=$ENV{'srcdir'};
        if($dir) {
            $flag .= "-d \"$dir\" ";
        }
    
        $cmd="$perl $srcdir/httpserver.pl $flag $HOSTPORT &";
    
        system($cmd);
        if($verbose) {
            print "CMD: $cmd\n";
    
            # verify that our server is up and running:
            my $data=`$CURL --silent -i $HOSTIP:$HOSTPORT/verifiedserver 2>/dev/null`;
    
    
            if ( $data =~ /WE ROOLZ: (\d+)/ ) {
                $pid = 0+$1;
    
                if($verbose) {
                    print STDERR "RUN: Retrying HTTP server existence in 3 sec\n";
                }
                sleep(3);
    
        }
        if(!$verified) {
            print STDERR "RUN: failed to start our HTTP server\n";
    
        }
    
        if($verbose) {
            print "RUN: HTTP server is now verified to be our server\n";
        }
    
    
    #######################################################################
    # start the https server (or rather, tunnel) if needed
    #
    sub runhttpsserver {
    
        my $verbose = $_[0];
        my $STATUS;
        my $RUNNING;
    
            # kill previous stunnel!
            if($verbose) {
    
                print "RUN: kills off running stunnel at $pid\n";
    
            stopserver($HTTPSPIDFILE);
    
    
        my $flag=$debugprotocol?"-v ":"";
    
        my $cmd="$perl $srcdir/httpsserver.pl $flag -s \"$stunnel\" -d $srcdir -r $HOSTPORT $HTTPSPORT &";
    
        if($verbose) {
    
            print "CMD: $cmd\n";
    
    
        for(1 .. 10) {
            $pid=checkserver($HTTPSPIDFILE);
    
            if($pid <= 0) {
                if($verbose) {
                    print STDERR "RUN: waiting 3 sec for HTTPS server\n";
                }
                sleep(3);
            }
            else {
                last;
            }
        }
    
    }
    
    #######################################################################
    # start the ftp server if needed
    #
    sub runftpserver {
        my $verbose = $_[0];
        my $STATUS;
        my $RUNNING;
        # check for pidfile
        my $pid = checkserver ($FTPPIDFILE );
    
        if ($pid <= 0) {
    
            print "RUN: Check port $FTPPORT for our own FTP server\n"
                if ($verbose);
    
            my $time=time();
            # check if this is our server running on this port:
            my $data=`$CURL -m4 --silent -i ftp://$HOSTIP:$FTPPORT/verifiedserver 2>/dev/null`;
    
            # if this took more than 2 secs, we assume it "hung" on a weird server
            my $took = time()-$time;
            
            if ( $data =~ /WE ROOLZ: (\d+)/ ) {
                # this is our test server with a known pid!
    
            }
            else {
                if($data || ($took > 2)) {
                    # this is not a known server
                    print "RUN: Unknown server on our favourite port: $FTPPORT\n";
    
    
        if($pid > 0) {
            print "RUN: Killing a previous server using pid $pid\n" if($verbose);
            my $res = kill (9, $pid); # die!
            if(!$res) {
                print "RUN: Failed to kill our FTP test server, do it manually and",
                " restart the tests.\n";
    
            sleep(1);
        }
        
        # now (re-)start our server:
        my $flag=$debugprotocol?"-v ":"";
    
        my $cmd="$perl $srcdir/ftpserver.pl $flag $FTPPORT &";
        if($verbose) {
            print "CMD: $cmd\n";
        }
        system($cmd);
    
            # verify that our server is up and running:
    
            my $data=`$CURL --silent -i ftp://$HOSTIP:$FTPPORT/verifiedserver 2>/dev/null`;
    
            if ( $data =~ /WE ROOLZ: (\d+)/ ) {
                $pid = 0+$1;
                $verified = 1;
                last;
            }
            else {
    
                if($verbose) {
    
                    print STDERR "RUN: Retrying FTP server existence in 3 sec\n";
    
            warn "RUN: failed to start our FTP server\n";
            return -2;
    
        }
    
        if($verbose) {
            print "RUN: FTP server is now verified to be our server\n";
        }
    
    
    }
    
    #######################################################################
    # start the ftps server (or rather, tunnel) if needed
    #
    sub runftpsserver {
        my $verbose = $_[0];
        my $STATUS;
        my $RUNNING;
    
    
            # kill previous stunnel!
            if($verbose) {
    
                print "kills off running stunnel at $pid\n";
    
            }
            stopserver($FTPSPIDFILE);
        }
    
        my $flag=$debugprotocol?"-v ":"";
    
        my $cmd="$perl $srcdir/ftpsserver.pl $flag -s \"$stunnel\" -d $srcdir -r $FTPPORT $FTPSPORT &";
    
        system($cmd);
        if($verbose) {
    
            print "CMD: $cmd\n";
    
        for(1 .. 10) {
    
            $pid=checkserver($FTPSPIDFILE );
    
            if($pid <= 0) {
                if($verbose) {
                    print STDERR "RUN: waiting 3 sec for FTPS server\n";
                }
                sleep(3);
            }
            else {
                last;
            }
        }
    
    #######################################################################
    # Remove all files in the specified directory
    #
    sub cleardir {
        my $dir = $_[0];
        my $count;
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
        my $file;
    
    
        # Get all files
        opendir(DIR, $dir) ||
            return 0; # can't open dir
        while($file = readdir(DIR)) {
            if($file !~ /^\./) {
                unlink("$dir/$file");
                $count++;
            }
        }
        closedir DIR;
        return $count;
    }
    
    #######################################################################
    # filter out the specified pattern from the given input file and store the
    # results in the given output file
    #
    
    sub filteroff {
        my $infile=$_[0];
        my $filter=$_[1];
        my $ofile=$_[2];
    
        open(IN, "<$infile")
            || return 1;
    
        open(OUT, ">$ofile")
            || return 1;
    
        # print "FILTER: off $filter from $infile to $ofile\n";
    
        while(<IN>) {
            $_ =~ s/$filter//;
            print OUT $_;
        }
        close(IN);
        close(OUT);    
        return 0;
    }
    
    
    #######################################################################
    # compare test results with the expected output, we might filter off
    # some pattern that is allowed to differ, output test results
    #
    
    
    sub compare {
    
        # filter off patterns _before_ this comparison!
    
        my ($subject, $firstref, $secondref)=@_;
    
        my $result = compareparts($firstref, $secondref);
    
        if($result) {
            if(!$short) {
                print "\n $subject FAILED:\n";
                print showdiff($firstref, $secondref);
            }
            else {
                print "FAILED\n";
            }
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
        }
    
        return $result;
    
    #######################################################################
    # display information about curl and the host the test suite runs on
    #
    
    
        unlink($memdump); # remove this if there was one left
    
    
            if($_ =~ /^curl/) {
                $curl = $_;
                $curl =~ s/^(.*)(libcurl.*)/$1/g;
                $libcurl = $2;
    
                if($curl =~ /mingw32/) {
                    # This is a windows minw32 build, we need to translate the
                    # given path to the "actual" windows path.
    
                    my @m = `mount`;
                    my $matchlen;
                    my $bestmatch;
                    my $mount;
    
    # example mount output:
    # C:\DOCUME~1\Temp on /tmp type user (binmode,noumount)
    # c:\ActiveState\perl on /perl type user (binmode)
    # C:\msys\1.0\bin on /usr/bin type user (binmode,cygexec,noumount)
    # C:\msys\1.0\bin on /bin type user (binmode,cygexec,noumount)
    
                    foreach $mount (@m) {
                        if( $mount =~ /(.*) on ([^ ]*) type /) {
                            my ($mingw, $real)=($2, $1);
                            if($pwd =~ /^$mingw/) {
                                # the path we got from pwd starts with the path
                                # we found on this line in the mount output
    
                                my $len = length($real);
                                if($len > $matchlen) {
                                    # we remember the match that is the longest
                                    $matchlen = $len;
                                    $bestmatch = $real;
                                }
                            }
                        }
                    }
                    if(!$matchlen) {
                        print "Serious error, can't find our \"real\" path!\n";
                    }
                    else {
                        # now prepend the prefix from the mount command to build
                        # our "actual path"
                        $pwd = "$bestmatch$pwd";
                    }
                    $pwd =~ s#\\#/#g;
                }
                elsif ($curl =~ /win32/)
                {
    
                   # Native Windows builds don't understand the
                   # output of cygwin's pwd.  It will be
                   # something like /cygdrive/c/<some path>.
                   #
                   # Use the cygpath utility to convert the
                   # working directory to a Windows friendly
                   # path.  The -m option converts to use drive
                   # letter:, but it uses / instead \.  Forward
                   # slashes (/) are easier for us.  We don't
                   # have to escape them to get them to curl
                   # through a shell.
                   chomp($pwd = `cygpath -m $pwd`);
               }
    
            }
            elsif($_ =~ /^Protocols: (.*)/i) {
                # these are the supported protocols, we don't use this knowledge
                # at this point
            }
            elsif($_ =~ /^Features: (.*)/i) {
                my $feat = $1;
                if($feat =~ /debug/i) {
                    # debug is a listed "feature", use that knowledge
                    $curl_debug = 1;
                    # set the NETRC debug env
                    $ENV{'CURL_DEBUG_NETRC'} = 'log/netrc';
                }
                if($feat =~ /SSL/i) {
                    # ssl enabled
                    $ssl_version=1;
                }
    
                if($feat =~ /Largefile/i) {
                    # large file support
                    $large_file=1;
                }
    
        my $hostname=`hostname`;
        my $hosttype=`uname -a`;
    
    
        print "********* System characteristics ******** \n",
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
        "* Host: $hostname",
        "* System: $hosttype";
    
        printf("* Server SSL:       %s\n", $stunnel?"ON":"OFF");
    
        printf("* libcurl SSL:      %s\n", $ssl_version?"ON":"OFF");
    
        printf("* libcurl debug:    %s\n", $curl_debug?"ON":"OFF");
    
        printf("* valgrind:         %s\n", $valgrind?"ON":"OFF");
    
        print "***************************************** \n";
    
    #######################################################################
    # substitute the variable stuff into either a joined up file or 
    # a command, in either case passed by reference
    #
    sub subVariables {
      my ($thing) = @_;
      $$thing =~ s/%HOSTIP/$HOSTIP/g;
      $$thing =~ s/%HOSTPORT/$HOSTPORT/g;
    
      $$thing =~ s/%HTTPPORT/$HOSTPORT/g;
    
      $$thing =~ s/%HTTPSPORT/$HTTPSPORT/g;
      $$thing =~ s/%FTPPORT/$FTPPORT/g;
      $$thing =~ s/%FTPSPORT/$FTPSPORT/g;
      $$thing =~ s/%SRCDIR/$srcdir/g;
      $$thing =~ s/%PWD/$pwd/g;
    }
    
    
    #######################################################################
    # Run a single specified test case
    #
    
    
    sub singletest {
    
        my $testnum=$_[0];
    
    
        # load the test case file definition
        if(loadtest("${TESTDIR}/test${testnum}")) {
            if($verbose) {
                # this is not a test
    
                print "RUN: $testnum doesn't look like a test case!\n";
    
            $serverproblem = 100;
        }
        else {
            @what = getpart("client", "features");
    
        for(@what) {
            my $f = $_;
            $f =~ s/\s//g;
    
            if($f eq "SSL") {
                if($ssl_version) {
                    next;
                }
            }
            elsif($f eq "netrc_debug") {
    
            elsif($f eq "large_file") {
                if($large_file) {
                    next;
                }
            }
    
        if(!$serverproblem) {
            $serverproblem = serverfortest($testnum);
        }
    
    
        if($serverproblem) {
            # there's a problem with the server, don't run
            # this particular server, but count it as "skipped"
    
            if($serverproblem == 2) {
                $why = "server problems";
            }
            elsif($serverproblem == 100) {
                $why = "no test";
            }
            elsif($serverproblem == 99) {
                $why = "bad test";
    
            elsif($serverproblem == 15) {
                # set above, a lacking prereq
            }
            elsif($serverproblem == 1) {
    
                $why = "no HTTPS server";
            }
            elsif($serverproblem == 3) {
                $why = "no FTPS server";
    
            $skipped++;
            $skipped{$why}++;
            $teststat[$testnum]=$why; # store reason for this test case
            
            print "SKIPPED\n";
            if(!$short) {
                print "* Test $testnum: $why\n";
            }
    
    
        # extract the reply data
        my @reply = getpart("reply", "data");
        my @replycheck = getpart("reply", "datacheck");
    
        if (@replycheck) {
    
            # we use this file instead to check the final output against
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
    
            my %hash = getpartattr("reply", "datacheck");
            if($hash{'nonewline'}) {
                # Yes, we must cut off the final newline from the final line
                # of the datacheck
                chomp($replycheck[$#replycheck]);
            }
        
    
            @reply=@replycheck;
    
        }
    
        # curl command to run
    
        my @curlcmd= getpart("client", "command");
    
        # this is the valid protocol blurb curl should generate
        my @protocol= getpart("verify", "protocol");
    
        # redirected stdout/stderr to these files
        $STDOUT="$LOGDIR/stdout$testnum";
        $STDERR="$LOGDIR/stderr$testnum";
    
        # if this section exists, we verify that the stdout contained this:
        my @validstdout = getpart("verify", "stdout");
    
        # if this section exists, we verify upload
        my @upload = getpart("verify", "upload");
    
        # if this section exists, it is FTP server instructions:
        my @ftpservercmd = getpart("server", "instruction");
    
        my $CURLOUT="$LOGDIR/curl$testnum.out"; # curl output if not stdout
    
        # name of the test
    
        my @testname= getpart("client", "name");
    
            my $name = $testname[0];
            $name =~ s/\n//g;
            print "[$name]\n";
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
        if($listonly) {
            return 0; # look successful
        }
    
    
        my @codepieces = getpart("client", "tool");
    
        my $tool="";
        if(@codepieces) {
            $tool = $codepieces[0];
            chomp $tool;
        }
    
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
        # remove previous server output logfile
        unlink($SERVERIN);
    
        if(@ftpservercmd) {
            # write the instructions to file
            writearray($FTPDCMD, \@ftpservercmd);
        }
    
    
        my (@setenv)= getpart("client", "setenv");
        my @envs;
    
        my $s;
        for $s (@setenv) {
            chomp $s; # cut off the newline
    
            subVariables \$s;
    
            if($s =~ /([^=]*)=(.*)/) {
                my ($var, $content)=($1, $2);
                $ENV{$var}=$content;
                # remember which, so that we can clear them afterwards!
                push @envs, $var;
            }
        }
    
    
        # get the command line options to use
    
        my ($cmd, @blaha)= getpart("client", "command");
    
    
        # make some nice replace operations
    
        $cmd =~ s/\n//g; # no newlines please
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
        # substitute variables in the command line
    
        my @inputfile=getpart("client", "file");
        if(@inputfile) {
            # we need to generate a file before this test is invoked
            my %hash = getpartattr("client", "file");
    
            my $filename=$hash{'name'};
    
            if(!$filename) {
                print "ERROR: section client=>file has no name attribute!\n";
                exit;
            }
    
            my $fileContent = join('', @inputfile);
            subVariables \$fileContent;
    #        print "DEBUG: writing file " . $filename . "\n";
            open OUTFILE, ">$filename";
    
            binmode OUTFILE; # for crapage systems, use binary       
            print OUTFILE $fileContent;
    
        my %cmdhash = getpartattr("client", "command");
    
    
    Daniel Stenberg's avatar
    Daniel Stenberg committed
        if($cmdhash{'option'} !~ /no-output/) {
            #We may slap on --output!
    
            if (!@validstdout) {
    
                $out=" --output $CURLOUT ";
    
        my $cmdargs;
        if(!$tool) {
            # run curl, add -v for debug information output
    
            $cmdargs ="$out --include -v $cmd";