1 #*************************************************************************** 2 # _ _ ____ _ 3 # Project ___| | | | _ \| | 4 # / __| | | | |_) | | 5 # | (__| |_| | _ <| |___ 6 # \___|\___/|_| \_\_____| 7 # 8 # Copyright (C) 1998 - 2016, Daniel Stenberg, <daniel (at] 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
