1: #***************************************************************************
2: # _ _ ____ _
3: # Project ___| | | | _ \| |
4: # / __| | | | |_) | |
5: # | (__| |_| | _ <| |___
6: # \___|\___/|_| \_\_____|
7: #
8: # Copyright (C) 1998 - 2020, 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_portfilename
55: server_logfilename
56: server_cmdfilename
57: server_inputfilename
58: server_outputfilename
59: mainsockf_pidfilename
60: mainsockf_logfilename
61: datasockf_pidfilename
62: datasockf_logfilename
63: );
64:
65:
66: #***************************************************************************
67: # Just for convenience, test harness uses 'https' and 'httptls' literals as
68: # values for 'proto' variable in order to differentiate different servers.
69: # 'https' literal is used for stunnel based https test servers, and 'httptls'
70: # is used for non-stunnel https test servers.
71:
72:
73: #***************************************************************************
74: # Return server characterization factors given a server id string.
75: #
76: sub serverfactors {
77: my $server = $_[0];
78: my $proto;
79: my $ipvnum;
80: my $idnum;
81:
82: if($server =~
83: /^((ftp|http|imap|pop3|smtp|http-pipe)s?)(\d*)(-ipv6|)$/) {
84: $proto = $1;
85: $idnum = ($3 && ($3 > 1)) ? $3 : 1;
86: $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
87: }
88: elsif($server =~
89: /^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
90: $proto = $1;
91: $idnum = ($2 && ($2 > 1)) ? $2 : 1;
92: $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
93: }
94: else {
95: die "invalid server id: '$server'"
96: }
97: return($proto, $ipvnum, $idnum);
98: }
99:
100:
101: #***************************************************************************
102: # Return server name string formatted for presentation purposes
103: #
104: sub servername_str {
105: my ($proto, $ipver, $idnum) = @_;
106:
107: $proto = uc($proto) if($proto);
108: die "unsupported protocol: '$proto'" unless($proto &&
109: ($proto =~ /^(((FTP|HTTP|HTTP\/2|IMAP|POP3|SMTP|HTTP-PIPE)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|GOPHER|HTTPTLS|DICT|SMB|SMBS|TELNET|MQTT))$/));
110:
111: $ipver = (not $ipver) ? 'ipv4' : lc($ipver);
112: die "unsupported IP version: '$ipver'" unless($ipver &&
113: ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
114: $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
115:
116: $idnum = 1 if(not $idnum);
117: die "unsupported ID number: '$idnum'" unless($idnum &&
118: ($idnum =~ /^(\d+)$/));
119: $idnum = '' unless($idnum > 1);
120:
121: return "${proto}${idnum}${ipver}";
122: }
123:
124:
125: #***************************************************************************
126: # Return server name string formatted for identification purposes
127: #
128: sub servername_id {
129: my ($proto, $ipver, $idnum) = @_;
130: return lc(servername_str($proto, $ipver, $idnum));
131: }
132:
133:
134: #***************************************************************************
135: # Return server name string formatted for file name purposes
136: #
137: sub servername_canon {
138: my ($proto, $ipver, $idnum) = @_;
139: my $string = lc(servername_str($proto, $ipver, $idnum));
140: $string =~ tr/-/_/;
141: $string =~ s/\//_v/;
142: return $string;
143: }
144:
145:
146: #***************************************************************************
147: # Return file name for server pid file.
148: #
149: sub server_pidfilename {
150: my ($proto, $ipver, $idnum) = @_;
151: my $trailer = '_server.pid';
152: return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
153: }
154:
155: #***************************************************************************
156: # Return file name for server port file.
157: #
158: sub server_portfilename {
159: my ($proto, $ipver, $idnum) = @_;
160: my $trailer = '_server.port';
161: return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
162: }
163:
164:
165: #***************************************************************************
166: # Return file name for server log file.
167: #
168: sub server_logfilename {
169: my ($logdir, $proto, $ipver, $idnum) = @_;
170: my $trailer = '_server.log';
171: $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
172: return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
173: }
174:
175:
176: #***************************************************************************
177: # Return file name for server commands file.
178: #
179: sub server_cmdfilename {
180: my ($logdir, $proto, $ipver, $idnum) = @_;
181: my $trailer = '_server.cmd';
182: return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
183: }
184:
185:
186: #***************************************************************************
187: # Return file name for server input file.
188: #
189: sub server_inputfilename {
190: my ($logdir, $proto, $ipver, $idnum) = @_;
191: my $trailer = '_server.input';
192: return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
193: }
194:
195:
196: #***************************************************************************
197: # Return file name for server output file.
198: #
199: sub server_outputfilename {
200: my ($logdir, $proto, $ipver, $idnum) = @_;
201: my $trailer = '_server.output';
202: return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
203: }
204:
205:
206: #***************************************************************************
207: # Return file name for main or primary sockfilter pid file.
208: #
209: sub mainsockf_pidfilename {
210: my ($proto, $ipver, $idnum) = @_;
211: die "unsupported protocol: '$proto'" unless($proto &&
212: (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
213: my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
214: return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
215: }
216:
217:
218: #***************************************************************************
219: # Return file name for main or primary sockfilter log file.
220: #
221: sub mainsockf_logfilename {
222: my ($logdir, $proto, $ipver, $idnum) = @_;
223: die "unsupported protocol: '$proto'" unless($proto &&
224: (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
225: my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
226: return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
227: }
228:
229:
230: #***************************************************************************
231: # Return file name for data or secondary sockfilter pid file.
232: #
233: sub datasockf_pidfilename {
234: my ($proto, $ipver, $idnum) = @_;
235: die "unsupported protocol: '$proto'" unless($proto &&
236: (lc($proto) =~ /^ftps?$/));
237: my $trailer = '_sockdata.pid';
238: return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
239: }
240:
241:
242: #***************************************************************************
243: # Return file name for data or secondary sockfilter log file.
244: #
245: sub datasockf_logfilename {
246: my ($logdir, $proto, $ipver, $idnum) = @_;
247: die "unsupported protocol: '$proto'" unless($proto &&
248: (lc($proto) =~ /^ftps?$/));
249: my $trailer = '_sockdata.log';
250: return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
251: }
252:
253:
254: #***************************************************************************
255: # End of library
256: 1;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to serverhelp.pm CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [ELWIX - Embedded LightWeight unIX -] / embedaddon / curl / tests