1#!/usr/bin/env perl 2#*************************************************************************** 3# _ _ ____ _ 4# Project ___| | | | _ \| | 5# / __| | | | |_) | | 6# | (__| |_| | _ <| |___ 7# \___|\___/|_| \_\_____| 8# 9# Copyright (C) Daniel Fandrich, et al. 10# 11# This software is licensed as described in the file COPYING, which 12# you should have received as part of this distribution. The terms 13# are also available at https://curl.se/docs/copyright.html. 14# 15# You may opt to use, copy, modify, merge, publish, distribute and/or sell 16# copies of the Software, and permit persons to whom the Software is 17# furnished to do so, under the terms of the COPYING file. 18# 19# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY 20# KIND, either express or implied. 21# 22# SPDX-License-Identifier: curl 23# 24########################################################################### 25 26# This script is intended for developers to test some internals of the 27# runtests.pl harness. Don't try to use this unless you know what you're 28# doing! 29 30# An example command-line that starts a test http server for test 11 and waits 31# for the user before stopping it: 32# ./devtest.pl --verbose serverfortest https echo "Started https" protoport https preprocess 11 pause echo Stopping stopservers echo Done 33# curl can connect to the server while it's running like this: 34# curl -vkL https://localhost:<protoport>/11 35 36use strict; 37use warnings; 38use 5.006; 39 40BEGIN { 41 # Define srcdir to the location of the tests source directory. This is 42 # usually set by the Makefile, but for out-of-tree builds with direct 43 # invocation of runtests.pl, it may not be set. 44 if(!defined $ENV{'srcdir'}) { 45 use File::Basename; 46 $ENV{'srcdir'} = dirname(__FILE__); 47 } 48 push(@INC, $ENV{'srcdir'}); 49} 50 51use globalconfig; 52use servers qw( 53 initserverconfig 54 protoport 55 serverfortest 56 stopservers 57); 58use runner qw( 59 readtestkeywords 60 singletest_preprocess 61); 62use testutil qw( 63 setlogfunc 64); 65use getpart; 66 67 68####################################################################### 69# logmsg is our general message logging subroutine. 70# This function is currently required to be here by servers.pm 71# This is copied from runtests.pl 72# 73my $uname_release = `uname -r`; 74my $is_wsl = $uname_release =~ /Microsoft$/; 75sub logmsg { 76 for(@_) { 77 my $line = $_; 78 if ($is_wsl) { 79 # use \r\n for WSL shell 80 $line =~ s/\r?\n$/\r\n/g; 81 } 82 print "$line"; 83 } 84} 85 86####################################################################### 87# Parse and store the protocols in curl's Protocols: line 88# This is copied from runtests.pl 89# 90sub parseprotocols { 91 my ($line)=@_; 92 93 @protocols = split(' ', lc($line)); 94 95 # Generate a "proto-ipv6" version of each protocol to match the 96 # IPv6 <server> name and a "proto-unix" to match the variant which 97 # uses Unix domain sockets. This works even if support isn't 98 # compiled in because the <features> test will fail. 99 push @protocols, map(("$_-ipv6", "$_-unix"), @protocols); 100 101 # 'http-proxy' is used in test cases to do CONNECT through 102 push @protocols, 'http-proxy'; 103 104 # 'none' is used in test cases to mean no server 105 push @protocols, 'none'; 106} 107 108 109####################################################################### 110# Initialize @protocols from the curl binary under test 111# 112sub init_protocols { 113 for (`$CURL -V 2>/dev/null`) { 114 if(m/^Protocols: (.*)$/) { 115 parseprotocols($1); 116 } 117 } 118} 119 120 121####################################################################### 122# Initialize the test harness to run tests 123# 124sub init_tests { 125 setlogfunc(\&logmsg); 126 init_protocols(); 127 initserverconfig(); 128} 129 130####################################################################### 131# Main test loop 132 133init_tests(); 134 135#*************************************************************************** 136# Parse command-line options and commands 137# 138while(@ARGV) { 139 if($ARGV[0] eq "-h") { 140 print "Usage: devtest.pl [--verbose] [command [arg]...]\n"; 141 print "command is one of:\n"; 142 print " echo X\n"; 143 print " pause\n"; 144 print " preprocess\n"; 145 print " protocols *|X[,Y...]\n"; 146 print " protoport X\n"; 147 print " serverfortest X[,Y...]\n"; 148 print " stopservers\n"; 149 print " sleep N\n"; 150 exit 0; 151 } 152 elsif($ARGV[0] eq "--verbose") { 153 $verbose = 1; 154 } 155 elsif($ARGV[0] eq "sleep") { 156 shift @ARGV; 157 sleep $ARGV[0]; 158 } 159 elsif($ARGV[0] eq "echo") { 160 shift @ARGV; 161 print $ARGV[0] . "\n"; 162 } 163 elsif($ARGV[0] eq "pause") { 164 print "Press Enter to continue: "; 165 readline STDIN; 166 } 167 elsif($ARGV[0] eq "protocols") { 168 shift @ARGV; 169 if($ARGV[0] eq "*") { 170 init_protocols(); 171 } 172 else { 173 @protocols = split(",", $ARGV[0]); 174 } 175 print "Set " . scalar @protocols . " protocols\n"; 176 } 177 elsif($ARGV[0] eq "preprocess") { 178 shift @ARGV; 179 loadtest("${TESTDIR}/test${ARGV[0]}"); 180 readtestkeywords(); 181 singletest_preprocess($ARGV[0]); 182 } 183 elsif($ARGV[0] eq "protoport") { 184 shift @ARGV; 185 my $port = protoport($ARGV[0]); 186 print "protoport: $port\n"; 187 } 188 elsif($ARGV[0] eq "serverfortest") { 189 shift @ARGV; 190 my ($why, $e) = serverfortest(split(/,/, $ARGV[0])); 191 print "serverfortest: $e $why\n"; 192 } 193 elsif($ARGV[0] eq "stopservers") { 194 my $err = stopservers(); 195 print "stopservers: $err\n"; 196 } 197 else { 198 print "Error: Unknown command: $ARGV[0]\n"; 199 print "Continuing anyway\n"; 200 } 201 shift @ARGV; 202} 203