runtests.pl

harvest是一个下载html网页得机器人

}

#######################################################################
# start the ftps server (or rather, tunnel) if needed
#
sub runftpsserver {
    my $verbose = $_[0];
    my $STATUS;
    my $RUNNING;
    my $pid=checkserver($FTPSPIDFILE );

    if(!$stunnel) {
        return 0;
    }

    if($pid > 0) {
        # 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";
    }
    sleep(1);

    $pid=checkserver($FTPSPIDFILE );

    return $pid;
}

#######################################################################
# Remove all files in the specified directory
#
sub cleardir {
    my $dir = $_[0];
    my $count;
    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";
        }
    }
    return $result;
}

#######################################################################
# display information about curl and the host the test suite runs on
#
sub checkcurl {

    unlink($memdump); # remove this if there was one left

    my $curl;
    my $libcurl;
    my @version=`$CURL -V 2>/dev/null`;
    for(@version) {
        chomp;

        if($_ =~ /^curl/) {
            $curl = $_;

            $curl =~ s/^(.*)(libcurl.*)/$1/g;
            $libcurl = $2;

           if ($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;
            }
        }
    }

    my $hostname=`hostname`;
    my $hosttype=`uname -a`;

    print "********* System characteristics ******** \n",
    "* $curl\n",
    "* $libcurl\n",
    "* 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/%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];

    my @what;
    my $why;
    my $serverproblem;

    # 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");
    }

    printf("test %03d...", $testnum);
    
    for(@what) {
        my $f = $_;
        $f =~ s/\s//g;

        if($f eq "SSL") {
            if($ssl_version) {
                next;
            }
        }
        elsif($f eq "netrc_debug") {
            if($curl_debug) {
                next;
            }
        }

        $why = "lacks $f";
        $serverproblem = 15; # set it here
        last;
    }

    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 SSL-capable server";
        }
        else {
            $why = "unfulfilled requirements";
        }
        $skipped++;
        $skipped{$why}++;
        $teststat[$testnum]=$why; # store reason for this test case
        
        print "SKIPPED\n";
        if(!$short) {
            print "* Test $testnum: $why\n";
        }

        return -1;
    }

    # 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

        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");

    if(!$short) {
        my $name = $testname[0];
        $name =~ s/\n//g;
        print "[$name]\n";
    }

    if($listonly) {
        return 0; # look successful
    }

    my @codepieces = getpart("client", "tool");

    my $tool="";
    if(@codepieces) {
        $tool = $codepieces[0];
        chomp $tool;
    }

    # 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

    # substitute variables in the command line
    subVariables \$cmd;

    if($curl_debug) {
        unlink($memdump);
    }

    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;
        close OUTFILE;
    }

    my %cmdhash = getpartattr("client", "command");

    my $out="";

    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";
    }
    else {
        $cmdargs = " $cmd"; # $cmd is the command line for the test file
        $CURLOUT = $STDOUT; # sends received data to stdout
    }

    my @stdintest = getpart("client", "stdin");

    if(@stdintest) {
        my $stdinfile="$LOGDIR/stdin-for-$testnum";
        writearray($stdinfile, \@stdintest);

        $cmdargs .= " <$stdinfile";
    }
    if($valgrind) {
        $cmdargs .= " 3>log/valgrind$testnum";
    }
    my $CMDLINE;

    if(!$tool) {
        $CMDLINE="$CURL";
    }
    else {
        $CMDLINE="$LIBDIR/$tool";
        $DBGCURL=$CMDLINE;
    }

    $CMDLINE .= "$cmdargs >>$STDOUT 2>>$STDERR";

    if($verbose) {
        print "$CMDLINE\n"; 
   }

    print CMDLOG "$CMDLINE\n";

    my $res;
    # run the command line we built
    if($gdbthis) {
        open(GDBCMD, ">log/gdbcmd");
        print GDBCMD "set args $cmdargs\n";
        print GDBCMD "show args\n";
        close(GDBCMD);
        system("gdb --directory libtest $DBGCURL -x log/gdbcmd");
        $res =0; # makes it always continue after a debugged run
    }
    else {
        $res = system("$CMDLINE");
        my $signal_num  = $res & 127;
        my $dumped_core = $res & 128;

        if(!$anyway && ($signal_num || $dumped_core)) {
            $res = 1000;
        }
        else {
            $res /= 256;
        }
    }

    # remove the special FTP command file after each test!
    unlink($FTPDCMD);

    my $e;
    for $e (@envs) {
        $ENV{$e}=""; # clean up
    }

    my @err = getpart("verify", "errorcode");
    my $errorcode = $err[0];

    if($errorcode || $res) {
        if($errorcode == $res) {
            $errorcode =~ s/\n//;
            if($verbose) {
                print " received errorcode $errorcode OK";
            }
            elsif(!$short) {
                print " error OK";
            }
        }
        else {
            if(!$short) {
                print "curl returned $res, ".(0+$errorcode)." was expected\n";
            }
            print " error FAILED\n";
            return 1;
        }
    }

    if (@validstdout) {
        # verify redirected stdout
        my @actual = loadarray($STDOUT);

        $res = compare("stdout", \@actual, \@validstdout);
        if($res) {
            return 1;
        }