• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
1#***************************************************************************
2#                                  _   _ ____  _
3#  Project                     ___| | | |  _ \| |
4#                             / __| | | | |_) | |
5#                            | (__| |_| |  _ <| |___
6#                             \___|\___/|_| \_\_____|
7#
8# Copyright (C) 1998 - 2016, 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
23package serverhelp;
24
25use strict;
26use warnings;
27use Exporter;
28
29
30#***************************************************************************
31# Global symbols allowed without explicit package name
32#
33use 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#
75sub 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#
103sub 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#
127sub 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#
136sub 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#
148sub 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#
158sub 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#
169sub 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#
179sub 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#
189sub 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#
199sub 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#
211sub 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#
223sub 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#
235sub 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
2461;
247