package serverhelp;
use strict;
use warnings;
use Exporter;
use vars qw(
@ISA
@EXPORT_OK
);
@ISA = qw(Exporter);
@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
);
sub serverfactors {
my $server = $_[0];
my $proto;
my $ipvnum;
my $idnum;
if($server =~
/^((ftp|http|imap|pop3|smtp|http-pipe)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);
}
sub servername_str {
my ($proto, $ipver, $idnum) = @_;
$proto = uc($proto) if($proto);
die "unsupported protocol: '$proto'" unless($proto &&
($proto =~ /^(((FTP|HTTP|HTTP\/2|IMAP|POP3|SMTP|HTTP-PIPE)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|GOPHER|HTTPTLS|DICT|SMB|SMBS|TELNET))$/));
$ipver = (not $ipver) ? 'ipv4' : lc($ipver);
die "unsupported IP version: '$ipver'" unless($ipver &&
($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
$ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
$idnum = 1 if(not $idnum);
die "unsupported ID number: '$idnum'" unless($idnum &&
($idnum =~ /^(\d+)$/));
$idnum = '' unless($idnum > 1);
return "${proto}${idnum}${ipver}";
}
sub servername_id {
my ($proto, $ipver, $idnum) = @_;
return lc(servername_str($proto, $ipver, $idnum));
}
sub servername_canon {
my ($proto, $ipver, $idnum) = @_;
my $string = lc(servername_str($proto, $ipver, $idnum));
$string =~ tr/-/_/;
$string =~ s/\//_v/;
return $string;
}
sub server_pidfilename {
my ($proto, $ipver, $idnum) = @_;
my $trailer = '_server.pid';
return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
}
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";
}
sub server_cmdfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
my $trailer = '_server.cmd';
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
sub server_inputfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
my $trailer = '_server.input';
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
sub server_outputfilename {
my ($logdir, $proto, $ipver, $idnum) = @_;
my $trailer = '_server.output';
return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
}
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";
}
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";
}
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";
}
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";
}
1;