| #!/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; |
| } |