serverhelp.pm (10183B)
1 #*************************************************************************** 2 # _ _ ____ _ 3 # Project ___| | | | _ \| | 4 # / __| | | | |_) | | 5 # | (__| |_| | _ <| |___ 6 # \___|\___/|_| \_\_____| 7 # 8 # Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al. 9 # 10 # This software is licensed as described in the file COPYING, which 11 # you should have received as part of this distribution. The terms 12 # are also available at https://curl.se/docs/copyright.html. 13 # 14 # You may opt to use, copy, modify, merge, publish, distribute and/or sell 15 # copies of the Software, and permit persons to whom the Software is 16 # furnished to do so, under the terms of the COPYING file. 17 # 18 # This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY 19 # KIND, either express or implied. 20 # 21 # SPDX-License-Identifier: curl 22 # 23 #*************************************************************************** 24 25 # This perl module contains functions useful in writing test servers. 26 27 package serverhelp; 28 29 use strict; 30 use warnings; 31 32 BEGIN { 33 use base qw(Exporter); 34 35 our @EXPORT_OK = qw( 36 logmsg 37 $logfile 38 serverfactors 39 servername_id 40 servername_str 41 servername_canon 42 server_pidfilename 43 server_portfilename 44 server_logfilename 45 server_cmdfilename 46 server_inputfilename 47 server_outputfilename 48 server_exe 49 server_exe_args 50 mainsockf_pidfilename 51 mainsockf_logfilename 52 datasockf_pidfilename 53 datasockf_logfilename 54 ); 55 56 # sub second timestamping needs Time::HiRes 57 eval { 58 no warnings "all"; 59 require Time::HiRes; 60 import Time::HiRes qw( gettimeofday ); 61 } 62 } 63 64 use globalconfig; 65 use pathhelp qw( 66 exe_ext 67 ); 68 use testutil qw( 69 exerunner 70 ); 71 72 our $logfile; # server log file name, for logmsg 73 74 #*************************************************************************** 75 # Just for convenience, test harness uses 'https' and 'httptls' literals as 76 # values for 'proto' variable in order to differentiate different servers. 77 # 'https' literal is used for stunnel based https test servers, and 'httptls' 78 # is used for non-stunnel https test servers. 79 80 #********************************************************************** 81 # logmsg is general message logging subroutine for our test servers. 82 # 83 sub logmsg { 84 my $now; 85 # sub second timestamping needs Time::HiRes 86 if($Time::HiRes::VERSION) { 87 my ($seconds, $usec) = gettimeofday(); 88 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = 89 localtime($seconds); 90 $now = sprintf("%02d:%02d:%02d.%06d ", $hour, $min, $sec, $usec); 91 } 92 else { 93 my $seconds = time(); 94 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = 95 localtime($seconds); 96 $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec); 97 } 98 # we see warnings on Windows run that $logfile is used uninitialized 99 # TODO: not found yet where this comes from 100 $logfile = "serverhelp_uninitialized.log" if(!$logfile); 101 if(open(my $logfilefh, ">>", "$logfile")) { 102 print $logfilefh $now; 103 print $logfilefh @_; 104 close($logfilefh); 105 } 106 } 107 108 109 #*************************************************************************** 110 # Return server characterization factors given a server id string. 111 # 112 sub serverfactors { 113 my $server = $_[0]; 114 my $proto; 115 my $ipvnum; 116 my $idnum; 117 118 if($server =~ 119 /^((ftp|http|imap|pop3|smtp)s?)(\d*)(-ipv6|)$/) { 120 $proto = $1; 121 $idnum = ($3 && ($3 > 1)) ? $3 : 1; 122 $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4; 123 } 124 elsif($server =~ 125 /^(dns|tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) { 126 $proto = $1; 127 $idnum = ($2 && ($2 > 1)) ? $2 : 1; 128 $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4; 129 } 130 else { 131 die "invalid server id: '$server'" 132 } 133 return($proto, $ipvnum, $idnum); 134 } 135 136 137 #*************************************************************************** 138 # Return server name string formatted for presentation purposes 139 # 140 sub servername_str { 141 my ($proto, $ipver, $idnum) = @_; 142 143 $proto = uc($proto) if($proto); 144 die "unsupported protocol: '$proto'" unless($proto && 145 ($proto =~ /^(((DNS|FTP|HTTP|HTTP\/2|HTTP\/3|IMAP|POP3|GOPHER|SMTP|HTTPS-MTLS)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|HTTPTLS|DICT|SMB|SMBS|TELNET|MQTT))$/)); 146 147 $ipver = (not $ipver) ? 'ipv4' : lc($ipver); 148 die "unsupported IP version: '$ipver'" unless($ipver && 149 ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/)); 150 $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : ''); 151 152 $idnum = 1 if(not $idnum); 153 die "unsupported ID number: '$idnum'" unless($idnum && 154 ($idnum =~ /^(\d+)$/)); 155 $idnum = '' if($idnum <= 1); 156 157 return "${proto}${idnum}${ipver}"; 158 } 159 160 161 #*************************************************************************** 162 # Return server name string formatted for identification purposes 163 # 164 sub servername_id { 165 my ($proto, $ipver, $idnum) = @_; 166 return lc(servername_str($proto, $ipver, $idnum)); 167 } 168 169 170 #*************************************************************************** 171 # Return server name string formatted for file name purposes 172 # 173 sub servername_canon { 174 my ($proto, $ipver, $idnum) = @_; 175 my $string = lc(servername_str($proto, $ipver, $idnum)); 176 $string =~ tr/-/_/; 177 $string =~ s/\//_v/; 178 return $string; 179 } 180 181 182 #*************************************************************************** 183 # Return file name for server pid file. 184 # 185 sub server_pidfilename { 186 my ($piddir, $proto, $ipver, $idnum) = @_; 187 my $trailer = '_server.pid'; 188 return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 189 } 190 191 #*************************************************************************** 192 # Return file name for server port file. 193 # 194 sub server_portfilename { 195 my ($piddir, $proto, $ipver, $idnum) = @_; 196 my $trailer = '_server.port'; 197 return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 198 } 199 200 201 #*************************************************************************** 202 # Return file name for server log file. 203 # 204 sub server_logfilename { 205 my ($logdir, $proto, $ipver, $idnum) = @_; 206 my $trailer = '_server.log'; 207 $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/); 208 return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 209 } 210 211 212 #*************************************************************************** 213 # Return file name for server commands file. 214 # 215 sub server_cmdfilename { 216 my ($logdir, $proto, $ipver, $idnum) = @_; 217 my $trailer = '_server.cmd'; 218 return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 219 } 220 221 222 #*************************************************************************** 223 # Return file name for server input file. 224 # 225 sub server_inputfilename { 226 my ($logdir, $proto, $ipver, $idnum) = @_; 227 my $trailer = '_server.input'; 228 return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 229 } 230 231 232 #*************************************************************************** 233 # Return file name for server output file. 234 # 235 sub server_outputfilename { 236 my ($logdir, $proto, $ipver, $idnum) = @_; 237 my $trailer = '_server.output'; 238 return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 239 } 240 241 242 #*************************************************************************** 243 # Return filename for a server executable 244 # 245 sub server_exe { 246 my ($name, $ext) = @_; 247 if(!defined $ext) { 248 $ext = 'SRV'; 249 } 250 return exerunner() . $SRVDIR . "servers" . exe_ext($ext) . " $name"; 251 } 252 253 254 #*************************************************************************** 255 # Return filename for a server executable as an argument list 256 # 257 sub server_exe_args { 258 my ($name, $ext) = @_; 259 if(!defined $ext) { 260 $ext = 'SRV'; 261 } 262 my @cmd = ($SRVDIR . "servers" . exe_ext($ext), $name); 263 if($ENV{'CURL_TEST_EXE_RUNNER'}) { 264 unshift @cmd, $ENV{'CURL_TEST_EXE_RUNNER'}; 265 } 266 return @cmd; 267 } 268 269 270 #*************************************************************************** 271 # Return file name for main or primary sockfilter pid file. 272 # 273 sub mainsockf_pidfilename { 274 my ($piddir, $proto, $ipver, $idnum) = @_; 275 die "unsupported protocol: '$proto'" unless($proto && 276 (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/)); 277 my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid'; 278 return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 279 } 280 281 282 #*************************************************************************** 283 # Return file name for main or primary sockfilter log file. 284 # 285 sub mainsockf_logfilename { 286 my ($logdir, $proto, $ipver, $idnum) = @_; 287 die "unsupported protocol: '$proto'" unless($proto && 288 (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/)); 289 my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log'; 290 return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 291 } 292 293 294 #*************************************************************************** 295 # Return file name for data or secondary sockfilter pid file. 296 # 297 sub datasockf_pidfilename { 298 my ($piddir, $proto, $ipver, $idnum) = @_; 299 die "unsupported protocol: '$proto'" unless($proto && 300 (lc($proto) =~ /^ftps?$/)); 301 my $trailer = '_sockdata.pid'; 302 return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 303 } 304 305 306 #*************************************************************************** 307 # Return file name for data or secondary sockfilter log file. 308 # 309 sub datasockf_logfilename { 310 my ($logdir, $proto, $ipver, $idnum) = @_; 311 die "unsupported protocol: '$proto'" unless($proto && 312 (lc($proto) =~ /^ftps?$/)); 313 my $trailer = '_sockdata.log'; 314 return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer"; 315 } 316 317 318 #*************************************************************************** 319 # End of library 320 1;