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     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 153 }
 154
 155
 156 #***************************************************************************
 157 # Return file name for server commands file.
 158 #
 159 sub server_cmdfilename {
 160     my ($logdir, $proto, $ipver, $idnum) = @_;
 161     my $trailer = '_server.cmd';
 162     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 163 }
 164
 165
 166 #***************************************************************************
 167 # Return file name for server input file.
 168 #
 169 sub server_inputfilename {
 170     my ($logdir, $proto, $ipver, $idnum) = @_;
 171     my $trailer = '_server.input';
 172     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 173 }
 174
 175
 176 #***************************************************************************
 177 # Return file name for server output file.
 178 #
 179 sub server_outputfilename {
 180     my ($logdir, $proto, $ipver, $idnum) = @_;
 181     my $trailer = '_server.output';
 182     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 183 }
 184
 185
 186 #***************************************************************************
 187 # Return file name for main or primary sockfilter pid file.
 188 #
 189 sub mainsockf_pidfilename {
 190     my ($proto, $ipver, $idnum) = @_;
 191     die "unsupported protocol: $proto" unless($proto &&
 192         (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
 193     my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
 194     return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
 195 }
 196
 197
 198 #***************************************************************************
 199 # Return file name for main or primary sockfilter log file.
 200 #
 201 sub mainsockf_logfilename {
 202     my ($logdir, $proto, $ipver, $idnum) = @_;
 203     die "unsupported protocol: $proto" unless($proto &&
 204         (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
 205     my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
 206     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 207 }
 208
 209
 210 #***************************************************************************
 211 # Return file name for data or secondary sockfilter pid file.
 212 #
 213 sub datasockf_pidfilename {
 214     my ($proto, $ipver, $idnum) = @_;
 215     die "unsupported protocol: $proto" unless($proto &&
 216         (lc($proto) =~ /^ftps?$/));
 217     my $trailer = '_sockdata.pid';
 218     return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
 219 }
 220
 221
 222 #***************************************************************************
 223 # Return file name for data or secondary sockfilter log file.
 224 #
 225 sub datasockf_logfilename {
 226     my ($logdir, $proto, $ipver, $idnum) = @_;
 227     die "unsupported protocol: $proto" unless($proto &&
 228         (lc($proto) =~ /^ftps?$/));
 229     my $trailer = '_sockdata.log';
 230     return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
 231 }
 232
 233
 234 #***************************************************************************
 235 # End of library
 236 1;
 237