devtest: add a new script for testing the test harness

This is currently useful for starting a test server on its own without
an associated test, which can be used for interactive curl testing or
for validating parts of the test harness itself. More commands can be
added to perform additional functions in the future.

Ref: #10818
Closes #11008

2 files changed, 194 insertions, 1 deletions

diff --git a/tests/Makefile.am b/tests/Makefile.am
index 676e5ccda..ae6b5ca33 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -27,7 +27,7 @@ PDFPAGES = testcurl.pdf runtests.pdf
 MANDISTPAGES = runtests.1.dist testcurl.1.dist
 
 EXTRA_DIST = appveyor.pm azure.pm badsymbols.pl check-deprecated.pl CMakeLists.txt \
- dictserver.py directories.pm disable-scan.pl error-codes.pl extern-scan.pl FILEFORMAT.md \
+ devtest.pl dictserver.py directories.pm disable-scan.pl error-codes.pl extern-scan.pl FILEFORMAT.md \
  processhelp.pm ftpserver.pl getpart.pm globalconfig.pm http-server.pl http2-server.pl \
  http3-server.pl manpage-scan.pl manpage-syntax.pl markdown-uppercase.pl mem-include-scan.pl \
  memanalyze.pl negtelnetserver.py nroff-scan.pl option-check.pl options-scan.pl \
diff --git a/tests/devtest.pl b/tests/devtest.pl
new file mode 100755
index 000000000..1535423c2
--- /dev/null
+++ b/tests/devtest.pl
@@ -0,0 +1,193 @@
+#!/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 harneess. 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;
+use runner qw(
+    readtestkeywords
+    singletest_preprocess
+);
+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 {
+    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;
+}