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