2
0

serverhelp.pm 8.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280
  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. if(open(my $logfilefh, ">>", "$logfile")) {
  80. print $logfilefh $now;
  81. print $logfilefh @_;
  82. close($logfilefh);
  83. }
  84. }
  85. #***************************************************************************
  86. # Return server characterization factors given a server id string.
  87. #
  88. sub serverfactors {
  89. my $server = $_[0];
  90. my $proto;
  91. my $ipvnum;
  92. my $idnum;
  93. if($server =~
  94. /^((ftp|http|imap|pop3|smtp|http-pipe)s?)(\d*)(-ipv6|)$/) {
  95. $proto = $1;
  96. $idnum = ($3 && ($3 > 1)) ? $3 : 1;
  97. $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
  98. }
  99. elsif($server =~
  100. /^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
  101. $proto = $1;
  102. $idnum = ($2 && ($2 > 1)) ? $2 : 1;
  103. $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
  104. }
  105. else {
  106. die "invalid server id: '$server'"
  107. }
  108. return($proto, $ipvnum, $idnum);
  109. }
  110. #***************************************************************************
  111. # Return server name string formatted for presentation purposes
  112. #
  113. sub servername_str {
  114. my ($proto, $ipver, $idnum) = @_;
  115. $proto = uc($proto) if($proto);
  116. die "unsupported protocol: '$proto'" unless($proto &&
  117. ($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))$/));
  118. $ipver = (not $ipver) ? 'ipv4' : lc($ipver);
  119. die "unsupported IP version: '$ipver'" unless($ipver &&
  120. ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
  121. $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
  122. $idnum = 1 if(not $idnum);
  123. die "unsupported ID number: '$idnum'" unless($idnum &&
  124. ($idnum =~ /^(\d+)$/));
  125. $idnum = '' if($idnum <= 1);
  126. return "${proto}${idnum}${ipver}";
  127. }
  128. #***************************************************************************
  129. # Return server name string formatted for identification purposes
  130. #
  131. sub servername_id {
  132. my ($proto, $ipver, $idnum) = @_;
  133. return lc(servername_str($proto, $ipver, $idnum));
  134. }
  135. #***************************************************************************
  136. # Return server name string formatted for file name purposes
  137. #
  138. sub servername_canon {
  139. my ($proto, $ipver, $idnum) = @_;
  140. my $string = lc(servername_str($proto, $ipver, $idnum));
  141. $string =~ tr/-/_/;
  142. $string =~ s/\//_v/;
  143. return $string;
  144. }
  145. #***************************************************************************
  146. # Return file name for server pid file.
  147. #
  148. sub server_pidfilename {
  149. my ($piddir, $proto, $ipver, $idnum) = @_;
  150. my $trailer = '_server.pid';
  151. return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  152. }
  153. #***************************************************************************
  154. # Return file name for server port file.
  155. #
  156. sub server_portfilename {
  157. my ($piddir, $proto, $ipver, $idnum) = @_;
  158. my $trailer = '_server.port';
  159. return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  160. }
  161. #***************************************************************************
  162. # Return file name for server log file.
  163. #
  164. sub server_logfilename {
  165. my ($logdir, $proto, $ipver, $idnum) = @_;
  166. my $trailer = '_server.log';
  167. $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
  168. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  169. }
  170. #***************************************************************************
  171. # Return file name for server commands file.
  172. #
  173. sub server_cmdfilename {
  174. my ($logdir, $proto, $ipver, $idnum) = @_;
  175. my $trailer = '_server.cmd';
  176. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  177. }
  178. #***************************************************************************
  179. # Return file name for server input file.
  180. #
  181. sub server_inputfilename {
  182. my ($logdir, $proto, $ipver, $idnum) = @_;
  183. my $trailer = '_server.input';
  184. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  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. # Return file name for main or primary sockfilter pid file.
  196. #
  197. sub mainsockf_pidfilename {
  198. my ($piddir, $proto, $ipver, $idnum) = @_;
  199. die "unsupported protocol: '$proto'" unless($proto &&
  200. (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
  201. my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
  202. return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  203. }
  204. #***************************************************************************
  205. # Return file name for main or primary sockfilter log file.
  206. #
  207. sub mainsockf_logfilename {
  208. my ($logdir, $proto, $ipver, $idnum) = @_;
  209. die "unsupported protocol: '$proto'" unless($proto &&
  210. (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
  211. my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
  212. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  213. }
  214. #***************************************************************************
  215. # Return file name for data or secondary sockfilter pid file.
  216. #
  217. sub datasockf_pidfilename {
  218. my ($piddir, $proto, $ipver, $idnum) = @_;
  219. die "unsupported protocol: '$proto'" unless($proto &&
  220. (lc($proto) =~ /^ftps?$/));
  221. my $trailer = '_sockdata.pid';
  222. return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  223. }
  224. #***************************************************************************
  225. # Return file name for data or secondary sockfilter log file.
  226. #
  227. sub datasockf_logfilename {
  228. my ($logdir, $proto, $ipver, $idnum) = @_;
  229. die "unsupported protocol: '$proto'" unless($proto &&
  230. (lc($proto) =~ /^ftps?$/));
  231. my $trailer = '_sockdata.log';
  232. return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
  233. }
  234. #***************************************************************************
  235. # End of library
  236. 1;