tests/serverhelp.pm

   1 #***************************************************************************
   2 #                                  _   _ ____  _
   3 #  Project                     ___| | | |  _ \| |
   4 #                             / __| | | | |_) | |
   5 #                            | (__| |_| |  _ <| |___
   6 #                             \___|\___/|_| \_\_____|
   7 #
   8 # Copyright (C) 1998 - 2016, 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.haxx.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 #***************************************************************************
  22
  23 package serverhelp;
  24
  25 use strict;
  26 use warnings;
  27 use Exporter;
  28
  29
  30 #***************************************************************************
  31 # Global symbols allowed without explicit package name
  32 #
  33 use vars qw(
  34     @ISA
  35     @EXPORT_OK
  36     );
  37
  38
  39 #***************************************************************************
  40 # Inherit Exporter's capabilities
  41 #
  42 @ISA = qw(Exporter);
  43
  44
  45 #***************************************************************************
  46 # Global symbols this module will export upon request
  47 #
  48 @EXPORT_OK = qw(
  49     serverfactors
  50     servername_id
  51     servername_str
  52     servername_canon
  53     server_pidfilename
  54     server_logfilename
  55     server_cmdfilename
  56     server_inputfilename
  57     server_outputfilename
  58     mainsockf_pidfilename
  59     mainsockf_logfilename
  60     datasockf_pidfilename
  61     datasockf_logfilename
  62     );
  63
  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 #***************************************************************************
  73 # Return server characterization factors given a server id string.
  74 #
  75 sub serverfactors {
  76     my $server = $_[0];
  77     my $proto;
  78     my $ipvnum;
  79     my $idnum;
  80
  81     if($server =~
  82         /^((ftp|http|imap|pop3|smtp|http-pipe)s?)(\d*)(-ipv6|)$/) {
  83         $proto  = $1;
  84         $idnum  = ($3 && ($3 > 1)) ? $3 : 1;
  85         $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
  86     }
  87     elsif($server =~
  88         /^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
  89         $proto  = $1;
  90         $idnum  = ($2 && ($2 > 1)) ? $2 : 1;
  91         $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
  92     }
  93     else {
  94         die "invalid server id: '$server'"
  95     }
  96     return($proto, $ipvnum, $idnum);
  97 }
  98
  99
 100 #***************************************************************************
 101 # Return server name string formatted for presentation purposes
 102 #
 103 sub servername_str {
 104     my ($proto, $ipver, $idnum) = @_;
 105
 106     $proto = uc($proto) if($proto);
 107     die "unsupported protocol: '$proto'" unless($proto &&
 108         ($proto =~ /^(((FTP|HTTP|HTTP\/2|IMAP|POP3|SMTP|HTTP-PIPE)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|GOPHER|HTTPTLS|DICT|SMB|SMBS|TELNET))$/));
 109
 110     $ipver = (not $ipver) ? 'ipv4' : lc($ipver);
 111     die "unsupported IP version: '$ipver'" unless($ipver &&
 112         ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
 113     $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
 114
 115     $idnum = 1 if(not $idnum);
 116     die "unsupported ID number: '$idnum'" unless($idnum &&
 117         ($idnum =~ /^(\d+)$/));
 118     $idnum = '' unless($idnum > 1);
 119
 120     return "${proto}${idnum}${ipver}";
 121 }
 122
 123
 124 #***************************************************************************
 125 # Return server name string formatted for identification purposes
 126 #
 127 sub servername_id {
 128     my ($proto, $ipver, $idnum) = @_;
 129     return lc(servername_str($proto, $ipver, $idnum));
 130 }
 131
 132
 133 #***************************************************************************
 134 # Return server name string formatted for file name purposes
 135 #
 136 sub servername_canon {
 137     my ($proto, $ipver, $idnum) = @_;
 138     my $string = lc(servername_str($proto, $ipver, $idnum));
 139     $string =~ tr/-/_/;
 140     $string =~ s/\//_v/;
 141     return $string;
 142 }
 143
 144
 145 #***************************************************************************
 146 # Return file name for server pid file.
 147 #
 148 sub server_pidfilename {
 149     my ($proto, $ipver, $idnum) = @_;
 150     my $trailer = '_server.pid';
 151     return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
 152 }
 153
 154
 155 #***************************************************************************
 156 # Return file name for server log file.
 157 #
 158 sub server_logfilename {
 159     my ($logdir, $proto, $ipver, $idnum) = @_;
 160     my $trailer = '_server.log';
 161     $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
 162     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 163 }
 164
 165
 166 #***************************************************************************
 167 # Return file name for server commands file.
 168 #
 169 sub server_cmdfilename {
 170     my ($logdir, $proto, $ipver, $idnum) = @_;
 171     my $trailer = '_server.cmd';
 172     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 173 }
 174
 175
 176 #***************************************************************************
 177 # Return file name for server input file.
 178 #
 179 sub server_inputfilename {
 180     my ($logdir, $proto, $ipver, $idnum) = @_;
 181     my $trailer = '_server.input';
 182     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 183 }
 184
 185
 186 #***************************************************************************
 187 # Return file name for server output file.
 188 #
 189 sub server_outputfilename {
 190     my ($logdir, $proto, $ipver, $idnum) = @_;
 191     my $trailer = '_server.output';
 192     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 193 }
 194
 195
 196 #***************************************************************************
 197 # Return file name for main or primary sockfilter pid file.
 198 #
 199 sub mainsockf_pidfilename {
 200     my ($proto, $ipver, $idnum) = @_;
 201     die "unsupported protocol: '$proto'" unless($proto &&
 202         (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
 203     my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
 204     return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
 205 }
 206
 207
 208 #***************************************************************************
 209 # Return file name for main or primary sockfilter log file.
 210 #
 211 sub mainsockf_logfilename {
 212     my ($logdir, $proto, $ipver, $idnum) = @_;
 213     die "unsupported protocol: '$proto'" unless($proto &&
 214         (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
 215     my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
 216     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 217 }
 218
 219
 220 #***************************************************************************
 221 # Return file name for data or secondary sockfilter pid file.
 222 #
 223 sub datasockf_pidfilename {
 224     my ($proto, $ipver, $idnum) = @_;
 225     die "unsupported protocol: '$proto'" unless($proto &&
 226         (lc($proto) =~ /^ftps?$/));
 227     my $trailer = '_sockdata.pid';
 228     return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
 229 }
 230
 231
 232 #***************************************************************************
 233 # Return file name for data or secondary sockfilter log file.
 234 #
 235 sub datasockf_logfilename {
 236     my ($logdir, $proto, $ipver, $idnum) = @_;
 237     die "unsupported protocol: '$proto'" unless($proto &&
 238         (lc($proto) =~ /^ftps?$/));
 239     my $trailer = '_sockdata.log';
 240     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 241 }
 242
 243
 244 #***************************************************************************
 245 # End of library
 246 1;
 247