mirror of
https://github.com/curl/curl.git
synced 2024-11-27 05:50:21 +08:00
2fbbddbe85
Introduced in the initial gopher commits, there was added logic to do GOPHER test serving in the pingpong server but as it resembles HTTP much more than FTP or SMTP, the gopher testing has been moved over to instead use the sws (HTTP) server. This change simply removes unused code.
238 lines
7.3 KiB
Perl
238 lines
7.3 KiB
Perl
#***************************************************************************
|
|
# _ _ ____ _
|
|
# Project ___| | | | _ \| |
|
|
# / __| | | | |_) | |
|
|
# | (__| |_| | _ <| |___
|
|
# \___|\___/|_| \_\_____|
|
|
#
|
|
# Copyright (C) 1998 - 2010, 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
|
|
);
|
|
|
|
|
|
#***************************************************************************
|
|
# 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)(\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))$/));
|
|
|
|
$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;
|
|
|