QRScanner/mobile/jni/thirdparty/curl/tests/serverhelp.pm

   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
  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 # 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 #
  75 sub 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 #
 103 sub 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)$/));
 113     $ipver = ($ipver =~ /6$/) ? '-IPv6' : '';
 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 #
 127 sub 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 #
 136 sub 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 #
 147 sub 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 #
 157 sub 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 #
 168 sub 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 #
 178 sub 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 #
 188 sub 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 #
 198 sub 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 #
 210 sub 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 #
 222 sub 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 #
 234 sub 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
 245 1;
 246