quickjs-tart

devtest.pl (5892B)

---

 #!/usr/bin/env perl
 #***************************************************************************
 #                                  _   _ ____  _
 #  Project                     ___| | | |  _ \| |
 #                             / __| | | | |_) | |
 #                            | (__| |_| |  _ <| |___
 #                             \___|\___/|_| \_\_____|
 #
 # Copyright (C) Daniel Fandrich, 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 https://curl.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.
 #
 # SPDX-License-Identifier: curl
 #
 ###########################################################################
 
 # This script is intended for developers to test some internals of the
 # runtests.pl harness. Don't try to use this unless you know what you're
 # doing!
 
 # An example command-line that starts a test http server for test 11 and waits
 # for the user before stopping it:
 #   ./devtest.pl --verbose serverfortest https echo "Started https" protoport https preprocess 11 pause echo Stopping stopservers echo Done
 # curl can connect to the server while it's running like this:
 #   curl -vkL https://localhost:<protoport>/11
 
 use strict;
 use warnings;
 use 5.006;
 
 BEGIN {
     # Define srcdir to the location of the tests source directory. This is
     # usually set by the Makefile, but for out-of-tree builds with direct
     # invocation of runtests.pl, it may not be set.
     if(!defined $ENV{'srcdir'}) {
         use File::Basename;
         $ENV{'srcdir'} = dirname(__FILE__);
     }
     push(@INC, $ENV{'srcdir'});
 }
 
 use globalconfig;
 use servers qw(
     initserverconfig
     protoport
     serverfortest
     stopservers
 );
 use runner qw(
     readtestkeywords
     singletest_preprocess
 );
 use testutil qw(
     setlogfunc
 );
 use getpart;
 
 
 #######################################################################
 # logmsg is our general message logging subroutine.
 # This function is currently required to be here by servers.pm
 # This is copied from runtests.pl
 #
 my $uname_release = `uname -r`;
 my $is_wsl = $uname_release =~ /Microsoft$/;
 sub logmsg {
     for(@_) {
         my $line = $_;
         if($is_wsl) {
             # use \r\n for WSL shell
             $line =~ s/\r?\n$/\r\n/g;
         }
         print "$line";
     }
 }
 
 #######################################################################
 # Parse and store the protocols in curl's Protocols: line
 # This is copied from runtests.pl
 #
 sub parseprotocols {
     my ($line)=@_;
 
     @protocols = split(' ', lc($line));
 
     # Generate a "proto-ipv6" version of each protocol to match the
     # IPv6 <server> name and a "proto-unix" to match the variant which
     # uses Unix domain sockets. This works even if support isn't
     # compiled in because the <features> test will fail.
     push @protocols, map(("$_-ipv6", "$_-unix"), @protocols);
 
     # 'http-proxy' is used in test cases to do CONNECT through
     push @protocols, 'http-proxy';
 
     # 'none' is used in test cases to mean no server
     push @protocols, 'none';
 }
 
 
 #######################################################################
 # Initialize @protocols from the curl binary under test
 #
 sub init_protocols {
     for (`$CURL -V 2>$dev_null`) {
         if(m/^Protocols: (.*)$/) {
             parseprotocols($1);
         }
     }
 }
 
 
 #######################################################################
 # Initialize the test harness to run tests
 #
 sub init_tests {
     setlogfunc(\&logmsg);
     init_protocols();
     initserverconfig();
 }
 
 #######################################################################
 # Main test loop
 
 init_tests();
 
 #***************************************************************************
 # Parse command-line options and commands
 #
 while(@ARGV) {
     if($ARGV[0] eq "-h") {
         print "Usage: devtest.pl [--verbose] [command [arg]...]\n";
         print "command is one of:\n";
         print "  echo X\n";
         print "  pause\n";
         print "  preprocess\n";
         print "  protocols *|X[,Y...]\n";
         print "  protoport X\n";
         print "  serverfortest X[,Y...]\n";
         print "  stopservers\n";
         print "  sleep N\n";
         exit 0;
     }
     elsif($ARGV[0] eq "--verbose") {
         $verbose = 1;
     }
     elsif($ARGV[0] eq "sleep") {
         shift @ARGV;
         sleep $ARGV[0];
     }
     elsif($ARGV[0] eq "echo") {
         shift @ARGV;
         print $ARGV[0] . "\n";
     }
     elsif($ARGV[0] eq "pause") {
         print "Press Enter to continue: ";
         readline STDIN;
     }
     elsif($ARGV[0] eq "protocols") {
         shift @ARGV;
         if($ARGV[0] eq "*") {
             init_protocols();
         }
         else {
             @protocols = split(",", $ARGV[0]);
         }
         print "Set " . scalar @protocols . " protocols\n";
     }
     elsif($ARGV[0] eq "preprocess") {
         shift @ARGV;
         loadtest("${TESTDIR}/test${ARGV[0]}");
         readtestkeywords();
         singletest_preprocess($ARGV[0]);
     }
     elsif($ARGV[0] eq "protoport") {
         shift @ARGV;
         my $port = protoport($ARGV[0]);
         print "protoport: $port\n";
     }
     elsif($ARGV[0] eq "serverfortest") {
         shift @ARGV;
         my ($why, $e) = serverfortest(split(/,/, $ARGV[0]));
         print "serverfortest: $e $why\n";
     }
     elsif($ARGV[0] eq "stopservers") {
         my $err = stopservers();
         print "stopservers: $err\n";
     }
     else {
         print "Error: Unknown command: $ARGV[0]\n";
         print "Continuing anyway\n";
     }
     shift @ARGV;
 }