tests/serverhelp.pm

   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         mainsockf_pidfilename
  49         mainsockf_logfilename
  50         datasockf_pidfilename
  51         datasockf_logfilename
  52     );
  53
  54     # sub second timestamping needs Time::HiRes
  55     eval {
  56         no warnings "all";
  57         require Time::HiRes;
  58         import  Time::HiRes qw( gettimeofday );
  59     }
  60 }
  61
  62
  63 our $logfile;  # server log file name, for logmsg
  64
  65 #***************************************************************************
  66 # Just for convenience, test harness uses 'https' and 'httptls' literals as
  67 # values for 'proto' variable in order to differentiate different servers.
  68 # 'https' literal is used for stunnel based https test servers, and 'httptls'
  69 # is used for non-stunnel https test servers.
  70
  71 #**********************************************************************
  72 # logmsg is general message logging subroutine for our test servers.
  73 #
  74 sub logmsg {
  75     my $now;
  76     # sub second timestamping needs Time::HiRes
  77     if($Time::HiRes::VERSION) {
  78         my ($seconds, $usec) = gettimeofday();
  79         my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  80             localtime($seconds);
  81         $now = sprintf("%02d:%02d:%02d.%06d ", $hour, $min, $sec, $usec);
  82     }
  83     else {
  84         my $seconds = time();
  85         my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  86             localtime($seconds);
  87         $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec);
  88     }
  89     if(open(my $logfilefh, ">>", "$logfile")) {
  90         print $logfilefh $now;
  91         print $logfilefh @_;
  92         close($logfilefh);
  93     }
  94 }
  95
  96
  97 #***************************************************************************
  98 # Return server characterization factors given a server id string.
  99 #
 100 sub serverfactors {
 101     my $server = $_[0];
 102     my $proto;
 103     my $ipvnum;
 104     my $idnum;
 105
 106     if($server =~
 107         /^((ftp|http|imap|pop3|smtp|http-pipe)s?)(\d*)(-ipv6|)$/) {
 108         $proto  = $1;
 109         $idnum  = ($3 && ($3 > 1)) ? $3 : 1;
 110         $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
 111     }
 112     elsif($server =~
 113         /^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
 114         $proto  = $1;
 115         $idnum  = ($2 && ($2 > 1)) ? $2 : 1;
 116         $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
 117     }
 118     else {
 119         die "invalid server id: '$server'"
 120     }
 121     return($proto, $ipvnum, $idnum);
 122 }
 123
 124
 125 #***************************************************************************
 126 # Return server name string formatted for presentation purposes
 127 #
 128 sub servername_str {
 129     my ($proto, $ipver, $idnum) = @_;
 130
 131     $proto = uc($proto) if($proto);
 132     die "unsupported protocol: '$proto'" unless($proto &&
 133         ($proto =~ /^(((FTP|HTTP|HTTP\/2|HTTP\/3|IMAP|POP3|GOPHER|SMTP|HTTP-PIPE)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|HTTPTLS|DICT|SMB|SMBS|TELNET|MQTT))$/));
 134
 135     $ipver = (not $ipver) ? 'ipv4' : lc($ipver);
 136     die "unsupported IP version: '$ipver'" unless($ipver &&
 137         ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
 138     $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
 139
 140     $idnum = 1 if(not $idnum);
 141     die "unsupported ID number: '$idnum'" unless($idnum &&
 142         ($idnum =~ /^(\d+)$/));
 143     $idnum = '' if($idnum <= 1);
 144
 145     return "${proto}${idnum}${ipver}";
 146 }
 147
 148
 149 #***************************************************************************
 150 # Return server name string formatted for identification purposes
 151 #
 152 sub servername_id {
 153     my ($proto, $ipver, $idnum) = @_;
 154     return lc(servername_str($proto, $ipver, $idnum));
 155 }
 156
 157
 158 #***************************************************************************
 159 # Return server name string formatted for file name purposes
 160 #
 161 sub servername_canon {
 162     my ($proto, $ipver, $idnum) = @_;
 163     my $string = lc(servername_str($proto, $ipver, $idnum));
 164     $string =~ tr/-/_/;
 165     $string =~ s/\//_v/;
 166     return $string;
 167 }
 168
 169
 170 #***************************************************************************
 171 # Return file name for server pid file.
 172 #
 173 sub server_pidfilename {
 174     my ($piddir, $proto, $ipver, $idnum) = @_;
 175     my $trailer = '_server.pid';
 176     return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 177 }
 178
 179 #***************************************************************************
 180 # Return file name for server port file.
 181 #
 182 sub server_portfilename {
 183     my ($piddir, $proto, $ipver, $idnum) = @_;
 184     my $trailer = '_server.port';
 185     return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 186 }
 187
 188
 189 #***************************************************************************
 190 # Return file name for server log file.
 191 #
 192 sub server_logfilename {
 193     my ($logdir, $proto, $ipver, $idnum) = @_;
 194     my $trailer = '_server.log';
 195     $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
 196     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 197 }
 198
 199
 200 #***************************************************************************
 201 # Return file name for server commands file.
 202 #
 203 sub server_cmdfilename {
 204     my ($logdir, $proto, $ipver, $idnum) = @_;
 205     my $trailer = '_server.cmd';
 206     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 207 }
 208
 209
 210 #***************************************************************************
 211 # Return file name for server input file.
 212 #
 213 sub server_inputfilename {
 214     my ($logdir, $proto, $ipver, $idnum) = @_;
 215     my $trailer = '_server.input';
 216     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 217 }
 218
 219
 220 #***************************************************************************
 221 # Return file name for server output file.
 222 #
 223 sub server_outputfilename {
 224     my ($logdir, $proto, $ipver, $idnum) = @_;
 225     my $trailer = '_server.output';
 226     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 227 }
 228
 229
 230 #***************************************************************************
 231 # Return file name for main or primary sockfilter pid file.
 232 #
 233 sub mainsockf_pidfilename {
 234     my ($piddir, $proto, $ipver, $idnum) = @_;
 235     die "unsupported protocol: '$proto'" unless($proto &&
 236         (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
 237     my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
 238     return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 239 }
 240
 241
 242 #***************************************************************************
 243 # Return file name for main or primary sockfilter log file.
 244 #
 245 sub mainsockf_logfilename {
 246     my ($logdir, $proto, $ipver, $idnum) = @_;
 247     die "unsupported protocol: '$proto'" unless($proto &&
 248         (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
 249     my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
 250     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 251 }
 252
 253
 254 #***************************************************************************
 255 # Return file name for data or secondary sockfilter pid file.
 256 #
 257 sub datasockf_pidfilename {
 258     my ($piddir, $proto, $ipver, $idnum) = @_;
 259     die "unsupported protocol: '$proto'" unless($proto &&
 260         (lc($proto) =~ /^ftps?$/));
 261     my $trailer = '_sockdata.pid';
 262     return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 263 }
 264
 265
 266 #***************************************************************************
 267 # Return file name for data or secondary sockfilter log file.
 268 #
 269 sub datasockf_logfilename {
 270     my ($logdir, $proto, $ipver, $idnum) = @_;
 271     die "unsupported protocol: '$proto'" unless($proto &&
 272         (lc($proto) =~ /^ftps?$/));
 273     my $trailer = '_sockdata.log';
 274     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 275 }
 276
 277
 278 #***************************************************************************
 279 # End of library
 280 1;