Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

247 lines (202 sloc) 7.836 kb
#***************************************************************************
# _ _ ____ _
# Project ___| | | | _ \| |
# / __| | | | |_) | |
# | (__| |_| | _ <| |___
# \___|\___/|_| \_\_____|
#
# Copyright (C) 1998 - 2011, Daniel Stenberg, <daniel@haxx.se>, et al.
#
# This software is licensed as described in the file COPYING, which
# you should have received as part of this distribution. The terms
# are also available at http://curl.haxx.se/docs/copyright.html.
#
# You may opt to use, copy, modify, merge, publish, distribute and/or sell
# copies of the Software, and permit persons to whom the Software is
# furnished to do so, under the terms of the COPYING file.
#
# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
# KIND, either express or implied.
#
#***************************************************************************
package serverhelp;
use strict;
use warnings;
use Exporter;
#***************************************************************************
# Global symbols allowed without explicit package name
#
use vars qw(
@ISA
@EXPORT_OK
);
#***************************************************************************
# Inherit Exporter's capabilities
#
@ISA = qw(Exporter);
#***************************************************************************
# Global symbols this module will export upon request
#
@EXPORT_OK = qw(
serverfactors
servername_id
servername_str
servername_canon
server_pidfilename
server_logfilename
server_cmdfilename
server_inputfilename
server_outputfilename
mainsockf_pidfilename
mainsockf_logfilename
datasockf_pidfilename
datasockf_logfilename
);
#***************************************************************************
# Just for convenience, test harness uses 'https' and 'httptls' literals as
# values for 'proto' variable in order to differentiate different servers.
# 'https' literal is used for stunnel based https test servers, and 'httptls'
# is used for non-stunnel https test servers.
#***************************************************************************
# Return server characterization factors given a server id string.
#
sub serverfactors {
my $server = $_[0];
my $proto;
my $ipvnum;
my $idnum;
if($server =~
/^((ftp|http|imap|pop3|smtp)s?)(\d*)(-ipv6|)$/) {
$proto = $1;
$idnum = ($3 && ($3 > 1)) ? $3 : 1;
$ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
}
elsif($server =~
/^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
$proto = $1;
$idnum = ($2 && ($2 > 1)) ? $2 : 1;
$ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
}
else {
die "invalid server id: '$server'"
}
return($proto, $ipvnum, $idnum);
}
#***************************************************************************
# Return server name string formatted for presentation purposes
#
sub servername_str {
my ($proto, $ipver, $idnum) = @_;
$proto = uc($proto) if($proto);
die "unsupported protocol: '$proto'" unless($proto &&
($proto =~ /^(((FTP|HTTP|IMAP|POP3|SMTP)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|GOPHER|HTTPTLS))$/));
$ipver = (not $ipver) ? 'ipv4' : lc($ipver);
die "unsupported IP version: '$ipver'" unless($ipver &&
($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6)$/));
$ipver = ($ipver =~ /6$/) ? '-IPv6' : '';
$idnum = 1 if(not $idnum);
die "unsupported ID number: '$idnum'" unless($idnum &&
($idnum =~ /^(\d+)$/));
$idnum = '' unless($idnum > 1);
return "${proto}${idnum}${ipver}";
}
#***************************************************************************
# Return server name string formatted for identification purposes
#
sub servername_id {
my ($proto, $ipver, $idnum) = @_;
return lc(servername_str($proto, $ipver, $idnum));
}
#***************************************************************************
# Return server name string formatted for file name purposes
#
sub servername_canon {
my ($proto, $ipver, $idnum) = @_;
my $string = lc(servername_str($proto, $ipver, $idnum));
$string =~ tr/-/_/;
return $string;
}
#***************************************************************************
# Return file name for server pid file.
#
sub server_pidfilename {
my ($proto, $ipver, $idnum) = @_;
my $trailer = '_server.pid';
return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# Return file name for server log file.
#
sub server_logfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
my $trailer = '_server.log';
$trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# Return file name for server commands file.
#
sub server_cmdfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
my $trailer = '_server.cmd';
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# Return file name for server input file.
#
sub server_inputfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
my $trailer = '_server.input';
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# Return file name for server output file.
#
sub server_outputfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
my $trailer = '_server.output';
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# Return file name for main or primary sockfilter pid file.
#
sub mainsockf_pidfilename {
my ($proto, $ipver, $idnum) = @_;
die "unsupported protocol: '$proto'" unless($proto &&
(lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# Return file name for main or primary sockfilter log file.
#
sub mainsockf_logfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
die "unsupported protocol: '$proto'" unless($proto &&
(lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# Return file name for data or secondary sockfilter pid file.
#
sub datasockf_pidfilename {
my ($proto, $ipver, $idnum) = @_;
die "unsupported protocol: '$proto'" unless($proto &&
(lc($proto) =~ /^ftps?$/));
my $trailer = '_sockdata.pid';
return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# Return file name for data or secondary sockfilter log file.
#
sub datasockf_logfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
die "unsupported protocol: '$proto'" unless($proto &&
(lc($proto) =~ /^ftps?$/));
my $trailer = '_sockdata.log';
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
#***************************************************************************
# End of library
1;
Jump to Line
Something went wrong with that request. Please try again.