tests/serverhelp.pm

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