serverhelp.pm 9.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283
  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. # This perl module contains functions useful in writing test servers.
  25. package serverhelp;
  26. use strict;
  27. use warnings;
  28. BEGIN {
  29. use base qw(Exporter);
  30. our @EXPORT_OK = qw(
  31. logmsg
  32. $logfile
  33. serverfactors
  34. servername_id
  35. servername_str
  36. servername_canon
  37. server_pidfilename
  38. server_portfilename
  39. server_logfilename
  40. server_cmdfilename
  41. server_inputfilename
  42. server_outputfilename
  43. mainsockf_pidfilename
  44. mainsockf_logfilename
  45. datasockf_pidfilename
  46. datasockf_logfilename
  47. );
  48. # sub second timestamping needs Time::HiRes
  49. eval {
  50. no warnings "all";
  51. require Time::HiRes;
  52. import Time::HiRes qw( gettimeofday );
  53. }
  54. }
  55. our $logfile; # server log file name, for logmsg
  56. #***************************************************************************
  57. # Just for convenience, test harness uses 'https' and 'httptls' literals as
  58. # values for 'proto' variable in order to differentiate different servers.
  59. # 'https' literal is used for stunnel based https test servers, and 'httptls'
  60. # is used for non-stunnel https test servers.
  61. #**********************************************************************
  62. # logmsg is general message logging subroutine for our test servers.
  63. #
  64. sub logmsg {
  65. my $now;
  66. # sub second timestamping needs Time::HiRes
  67. if($Time::HiRes::VERSION) {
  68. my ($seconds, $usec) = gettimeofday();
  69. my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  70. localtime($seconds);
  71. $now = sprintf("%02d:%02d:%02d.%06d ", $hour, $min, $sec, $usec);
  72. }
  73. else {
  74. my $seconds = time();
  75. my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  76. localtime($seconds);
  77. $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec);
  78. }
  79. # we see warnings on Windows run that $logfile is used uninitialized
  80. # TODO: not found yet where this comes from
  81. $logfile = "serverhelp_uninitialized.log" if(!$logfile);
  82. if(open(my $logfilefh, ">>", "$logfile")) {
  83. print $logfilefh $now;
  84. print $logfilefh @_;
  85. close($logfilefh);
  86. }
  87. }
  88. #***************************************************************************
  89. # Return server characterization factors given a server id string.
  90. #
  91. sub serverfactors {
  92. my $server = $_[0];
  93. my $proto;
  94. my $ipvnum;
  95. my $idnum;
  96. if($server =~
  97. /^((ftp|http|imap|pop3|smtp|http-pipe)s?)(\d*)(-ipv6|)$/) {
  98. $proto = $1;
  99. $idnum = ($3 && ($3 > 1)) ? $3 : 1;
  100. $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
  101. }
  102. elsif($server =~
  103. /^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
  104. $proto = $1;
  105. $idnum = ($2 && ($2 > 1)) ? $2 : 1;
  106. $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
  107. }
  108. else {
  109. die "invalid server id: '$server'"
  110. }
  111. return($proto, $ipvnum, $idnum);
  112. }
  113. #***************************************************************************
  114. # Return server name string formatted for presentation purposes
  115. #
  116. sub servername_str {
  117. my ($proto, $ipver, $idnum) = @_;
  118. $proto = uc($proto) if($proto);
  119. die "unsupported protocol: '$proto'" unless($proto &&
  120. ($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))$/));
  121. $ipver = (not $ipver) ? 'ipv4' : lc($ipver);
  122. die "unsupported IP version: '$ipver'" unless($ipver &&
  123. ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
  124. $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
  125. $idnum = 1 if(not $idnum);
  126. die "unsupported ID number: '$idnum'" unless($idnum &&
  127. ($idnum =~ /^(\d+)$/));
  128. $idnum = '' if($idnum <= 1);
  129. return "${proto}${idnum}${ipver}";
  130. }
  131. #***************************************************************************
  132. # Return server name string formatted for identification purposes
  133. #
  134. sub servername_id {
  135. my ($proto, $ipver, $idnum) = @_;
  136. return lc(servername_str($proto, $ipver, $idnum));
  137. }
  138. #***************************************************************************
  139. # Return server name string formatted for file name purposes
  140. #
  141. sub servername_canon {
  142. my ($proto, $ipver, $idnum) = @_;
  143. my $string = lc(servername_str($proto, $ipver, $idnum));
  144. $string =~ tr/-/_/;
  145. $string =~ s/\//_v/;
  146. return $string;
  147. }
  148. #***************************************************************************
  149. # Return file name for server pid file.
  150. #
  151. sub server_pidfilename {
  152. my ($piddir, $proto, $ipver, $idnum) = @_;
  153. my $trailer = '_server.pid';
  154. return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  155. }
  156. #***************************************************************************
  157. # Return file name for server port file.
  158. #
  159. sub server_portfilename {
  160. my ($piddir, $proto, $ipver, $idnum) = @_;
  161. my $trailer = '_server.port';
  162. return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  163. }
  164. #***************************************************************************
  165. # Return file name for server log file.
  166. #
  167. sub server_logfilename {
  168. my ($logdir, $proto, $ipver, $idnum) = @_;
  169. my $trailer = '_server.log';
  170. $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
  171. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  172. }
  173. #***************************************************************************
  174. # Return file name for server commands file.
  175. #
  176. sub server_cmdfilename {
  177. my ($logdir, $proto, $ipver, $idnum) = @_;
  178. my $trailer = '_server.cmd';
  179. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  180. }
  181. #***************************************************************************
  182. # Return file name for server input file.
  183. #
  184. sub server_inputfilename {
  185. my ($logdir, $proto, $ipver, $idnum) = @_;
  186. my $trailer = '_server.input';
  187. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  188. }
  189. #***************************************************************************
  190. # Return file name for server output file.
  191. #
  192. sub server_outputfilename {
  193. my ($logdir, $proto, $ipver, $idnum) = @_;
  194. my $trailer = '_server.output';
  195. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  196. }
  197. #***************************************************************************
  198. # Return file name for main or primary sockfilter pid file.
  199. #
  200. sub mainsockf_pidfilename {
  201. my ($piddir, $proto, $ipver, $idnum) = @_;
  202. die "unsupported protocol: '$proto'" unless($proto &&
  203. (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
  204. my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
  205. return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  206. }
  207. #***************************************************************************
  208. # Return file name for main or primary sockfilter log file.
  209. #
  210. sub mainsockf_logfilename {
  211. my ($logdir, $proto, $ipver, $idnum) = @_;
  212. die "unsupported protocol: '$proto'" unless($proto &&
  213. (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
  214. my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
  215. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  216. }
  217. #***************************************************************************
  218. # Return file name for data or secondary sockfilter pid file.
  219. #
  220. sub datasockf_pidfilename {
  221. my ($piddir, $proto, $ipver, $idnum) = @_;
  222. die "unsupported protocol: '$proto'" unless($proto &&
  223. (lc($proto) =~ /^ftps?$/));
  224. my $trailer = '_sockdata.pid';
  225. return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  226. }
  227. #***************************************************************************
  228. # Return file name for data or secondary sockfilter log file.
  229. #
  230. sub datasockf_logfilename {
  231. my ($logdir, $proto, $ipver, $idnum) = @_;
  232. die "unsupported protocol: '$proto'" unless($proto &&
  233. (lc($proto) =~ /^ftps?$/));
  234. my $trailer = '_sockdata.log';
  235. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  236. }
  237. #***************************************************************************
  238. # End of library
  239. 1;