1#***************************************************************************
2#                                  _   _ ____  _
3#  Project                     ___| | | |  _ \| |
4#                             / __| | | | |_) | |
5#                            | (__| |_| |  _ <| |___
6#                             \___|\___/|_| \_\_____|
7#
8# Copyright (C) 1998 - 2011, 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 http://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|IMAP|POP3|SMTP|HTTP-PIPE)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|GOPHER|HTTPTLS))$/));
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    return $string;
141}
142
143
144#***************************************************************************
145# Return file name for server pid file.
146#
147sub server_pidfilename {
148    my ($proto, $ipver, $idnum) = @_;
149    my $trailer = '_server.pid';
150    return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
151}
152
153
154#***************************************************************************
155# Return file name for server log file.
156#
157sub server_logfilename {
158    my ($logdir, $proto, $ipver, $idnum) = @_;
159    my $trailer = '_server.log';
160    $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
161    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
162}
163
164
165#***************************************************************************
166# Return file name for server commands file.
167#
168sub server_cmdfilename {
169    my ($logdir, $proto, $ipver, $idnum) = @_;
170    my $trailer = '_server.cmd';
171    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
172}
173
174
175#***************************************************************************
176# Return file name for server input file.
177#
178sub server_inputfilename {
179    my ($logdir, $proto, $ipver, $idnum) = @_;
180    my $trailer = '_server.input';
181    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
182}
183
184
185#***************************************************************************
186# Return file name for server output file.
187#
188sub server_outputfilename {
189    my ($logdir, $proto, $ipver, $idnum) = @_;
190    my $trailer = '_server.output';
191    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
192}
193
194
195#***************************************************************************
196# Return file name for main or primary sockfilter pid file.
197#
198sub mainsockf_pidfilename {
199    my ($proto, $ipver, $idnum) = @_;
200    die "unsupported protocol: '$proto'" unless($proto &&
201        (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
202    my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
203    return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
204}
205
206
207#***************************************************************************
208# Return file name for main or primary sockfilter log file.
209#
210sub 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
219#***************************************************************************
220# Return file name for data or secondary sockfilter pid file.
221#
222sub datasockf_pidfilename {
223    my ($proto, $ipver, $idnum) = @_;
224    die "unsupported protocol: '$proto'" unless($proto &&
225        (lc($proto) =~ /^ftps?$/));
226    my $trailer = '_sockdata.pid';
227    return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
228}
229
230
231#***************************************************************************
232# Return file name for data or secondary sockfilter log file.
233#
234sub datasockf_logfilename {
235    my ($logdir, $proto, $ipver, $idnum) = @_;
236    die "unsupported protocol: '$proto'" unless($proto &&
237        (lc($proto) =~ /^ftps?$/));
238    my $trailer = '_sockdata.log';
239    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
240}
241
242
243#***************************************************************************
244# End of library
2451;
246
247