\n";
+ }
+
+ return;
+}
+# end editfile
+###############################################################################
+# start savefile
+sub savefile {
+ my $file = shift;
+ my $restart = shift;
+
+ $FORM{formdata} =~ s/\r//g;
+ if ($FORM{ace} == "1") {
+ if ($FORM{formdata} !~ /^# Do not remove or change this line as it is a safeguard for the UI editor\n/) {
+ print "
UI editor safeguard missing, changes have not been saved.
\n";
+ return;
+ }
+ $FORM{formdata} =~ s/^# Do not remove or change this line as it is a safeguard for the UI editor\n//g;
+ }
+
+ sysopen (my $OUT, $file, O_WRONLY | O_CREAT) or die "Unable to open file: $!";
+ flock ($OUT, LOCK_EX);
+ seek ($OUT, 0, 0);
+ truncate ($OUT, 0);
+ if ($FORM{formdata} !~ /\n$/) {$FORM{formdata} .= "\n"}
+ print $OUT $FORM{formdata};
+ close ($OUT);
+
+ if ($restart eq "csf") {
+ print "
Changes saved. You should restart csf.
Changes saved. You should restart lfd.
Changes saved. You should restart csf and lfd.\n";
+ print "
\n";
+ }
+ else {
+ print "
Changes saved.
\n";
+ }
+
+ return;
+}
+# end cloudflare
+###############################################################################
+# start cloudflare
+sub cloudflare {
+ my $scope = &ConfigServer::CloudFlare::getscope();
+ print "
\n";
+ print "\n";
+ print "\n";
+
+ print "
\n";
+ print "csf - CloudFlare ";
+ print "Select the user(s), then select the action below \n";
+ foreach my $user (keys %{$scope->{user}}) {print "$user \n"}
+ print " \n";
+# } else {
+# print "Select the domain(s), then select the action below \n";
+# foreach my $domain (keys %{$scope->{domain}}) {print "$domain \n"}
+# print " \n";
+# }
+ print "CF List Rules ";
+ print "CloudFlare Add \n";
+ print "CloudFlare Delete \n";
+ print "CF Temp Allow/Deny ";
+ print "
\n";
+ print "
\n";
+ print "
Note:\n
\n";
+ print "target can be one of:An IP address \n2 letter Country Code \nIP range CIDR \n \n";
+ print "Only Enterprise customers can block a Country Code, but all can allow and challenge \n";
+ print " \nIP range CIDR is limited to /16 and /24 \n";
+ print "\n";
+ &printreturn;
+ return;
+}
+# end cloudflare
+###############################################################################
+# start resize
+sub resize {
+ my $part = shift;
+ my $scroll = shift;
+ if ($part eq "top") {
+ print "
a \n";
+ print "A
\n";
+ } else {
+ print "
+EOF
+ }
+ return;
+}
+# end resize
+###############################################################################
+# start printreturn
+sub printreturn {
+ print "
\n";
+
+ return;
+}
+# end printreturn
+###############################################################################
+# start confirmmodal
+# print "
Submit \n";
+# &confirmmodal;
+sub confirmmodal {
+ print "
\n";
+ print "
\n";
+ print "
\n";
+ print "
\n";
+ print "
text \n";
+ print "\n";
+ print "\n";
+ print "
\n";
+ print "
\n";
+ print "
\n";
+ print "\n";
+ return;
+}
+# end confirmmodal
+###############################################################################
+# start csgetversion
+sub csgetversion {
+ my $product = shift;
+ my $current = shift;
+ my $upgrade = 0;
+ my $newversion;
+ if (-e "/var/lib/configserver/".$product.".txt.error") {
+ open (my $VERSION, "<", "/var/lib/configserver/".$product.".txt.error");
+ flock ($VERSION, LOCK_SH);
+ $newversion = <$VERSION>;
+ close ($VERSION);
+ chomp $newversion;
+ if ($newversion eq "") {
+ $newversion = "Failed to retrieve latest version from ConfigServer";
+ } else {
+ $newversion = "Failed to retrieve latest version from ConfigServer: $newversion";
+ }
+ }
+ elsif (-e "/var/lib/configserver/".$product.".txt") {
+ open (my $VERSION, "<", "/var/lib/configserver/".$product.".txt");
+ flock ($VERSION, LOCK_SH);
+ $newversion = <$VERSION>;
+ close ($VERSION);
+ chomp $newversion;
+ if ($newversion eq "") {
+ $newversion = "Failed to retrieve latest version from ConfigServer";
+ } else {
+ if ($newversion =~ /^[\d\.]*$/) {
+ if ($newversion > $current) {$upgrade = 1} else {$newversion = ""}
+ } else {$newversion = ""}
+ }
+ }
+ elsif (-e "/var/lib/configserver/error") {
+ open (my $VERSION, "<", "/var/lib/configserver/error");
+ flock ($VERSION, LOCK_SH);
+ $newversion = <$VERSION>;
+ close ($VERSION);
+ chomp $newversion;
+ if ($newversion eq "") {
+ $newversion = "Failed to retrieve latest version from ConfigServer";
+ } else {
+ $newversion = "Failed to retrieve latest version from ConfigServer: $newversion";
+ }
+ } else {
+ $newversion = "Failed to retrieve latest version from ConfigServer";
+ }
+ return ($upgrade, $newversion);
+}
+# end csgetversion
+###############################################################################
+# start manualversion
+sub manualversion {
+ my $current = shift;
+ my $upgrade = 0;
+ my $url = "https://$config{DOWNLOADSERVER}/csf/version.txt";
+ if ($config{URLGET} == 1) {$url = "http://$config{DOWNLOADSERVER}/csf/version.txt";}
+ my ($status, $newversion) = $urlget->urlget($url);
+ if (!$status and $newversion ne "" and $newversion =~ /^[\d\.]*$/ and $newversion > $current) {$upgrade = 1} else {$newversion = ""}
+ return ($upgrade, $newversion);
+}
+# end manualversion
+###############################################################################
+
+1;
diff --git a/src/redux/ConfigServer/GetEthDev.pm b/src/redux/ConfigServer/GetEthDev.pm
new file mode 100644
index 000000000..e9fbcd8ce
--- /dev/null
+++ b/src/redux/ConfigServer/GetEthDev.pm
@@ -0,0 +1,157 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::GetEthDev;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Carp;
+use Fcntl qw(:DEFAULT :flock);
+use IPC::Open3;
+use POSIX qw(locale_h);
+use ConfigServer::Config;
+use ConfigServer::CheckIP qw(checkip);
+use ConfigServer::Logger;
+
+use Exporter qw(import);
+our $VERSION = 1.01;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my (%ifaces, %ipv4, %ipv6, %brd);
+
+# end main
+###############################################################################
+# start new
+sub new {
+ my $class = shift;
+ my $self = {};
+ bless $self,$class;
+
+ my $status;
+ my $config = ConfigServer::Config->loadconfig();
+ my %config = $config->config();
+ my $ipv4reg = $config->ipv4reg;
+ my $ipv6reg = $config->ipv6reg;
+ $brd{"255.255.255.255"} = 1;
+ setlocale(LC_ALL, "POSIX");
+
+ if (-e $config{IP}) {
+ my ($childin, $childout);
+ my $pid = open3($childin, $childout, $childout, $config{IP}, "-oneline", "addr");
+ my @ifconfig = <$childout>;
+ waitpid ($pid, 0);
+ chomp @ifconfig;
+
+ foreach my $line (@ifconfig) {
+ if ($line =~ /^\d+:\s+([\w\.\-]+)/ ) {
+ $ifaces{$1} = 1;
+ }
+ if ($line =~ /inet.*?($ipv4reg)/) {
+ my ($ip,undef) = split(/\//,$1);
+ if (checkip(\$ip)) {
+ $ipv4{$ip} = 1;
+ }
+ }
+ if ($line =~ /brd\s+($ipv4reg)/) {
+ my ($ip,undef) = split(/\//,$1);
+ if (checkip(\$ip)) {
+ $brd{$ip} = 1;
+ }
+ }
+ if ($line =~ /inet6.*?($ipv6reg)/) {
+ my ($ip,undef) = split(/\//,$1);
+ $ip .= "/128";
+ if (checkip(\$ip)) {
+ $ipv6{$ip} = 1;
+ }
+ }
+ }
+ $status = 0;
+ }
+ elsif (-e $config{IFCONFIG}) {
+ my ($childin, $childout);
+ my $pid = open3($childin, $childout, $childout, $config{IFCONFIG});
+ my @ifconfig = <$childout>;
+ waitpid ($pid, 0);
+ chomp @ifconfig;
+
+ foreach my $line (@ifconfig) {
+ if ($line =~ /^([\w\.\-]+)/ ) {
+ $ifaces{$1} = 1;
+ }
+ if ($line =~ /inet.*?($ipv4reg)/) {
+ my ($ip,undef) = split(/\//,$1);
+ if (checkip(\$ip)) {
+ $ipv4{$ip} = 1;
+ }
+ }
+ if ($line =~ /Bcast:($ipv4reg)/) {
+ my ($ip,undef) = split(/\//,$1);
+ if (checkip(\$ip)) {
+ $brd{$ip} = 1;
+ }
+ }
+ if ($line =~ /inet6.*?($ipv6reg)/) {
+ my ($ip,undef) = split(/\//,$1);
+ $ip .= "/128";
+ if (checkip(\$ip)) {
+ $ipv6{$ip} = 1;
+ }
+ }
+ }
+ $status = 0;
+ }
+ else {
+ $status = 1;
+ }
+
+ if (-e "/var/cpanel/cpnat") {
+ open (my $NAT, "<", "/var/cpanel/cpnat");
+ flock ($NAT, LOCK_SH);
+ while (my $line = <$NAT>) {
+ chomp $line;
+ if ($line =~ /^(\#|\n|\r)/) {next}
+ my ($internal,$external) = split(/\s+/,$line);
+ if (checkip(\$internal) and checkip(\$external)) {
+ $ipv4{$external} = 1;
+ }
+ }
+ close ($NAT);
+ }
+
+ $self->{status} = $status;
+ return $self;
+}
+# end main
+###############################################################################
+# start ifaces
+sub ifaces {
+ return %ifaces;
+}
+# end ifaces
+###############################################################################
+# start ipv4
+sub ipv4 {
+ return %ipv4;
+}
+# end ipv4
+###############################################################################
+# start ipv6
+sub ipv6 {
+ return %ipv6;
+}
+# end ipv6
+###############################################################################
+# start brd
+sub brd {
+ return %brd;
+}
+# end brd
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/GetIPs.pm b/src/redux/ConfigServer/GetIPs.pm
new file mode 100644
index 000000000..0139e60bb
--- /dev/null
+++ b/src/redux/ConfigServer/GetIPs.pm
@@ -0,0 +1,82 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::GetIPs;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Carp;
+use Socket;
+use IPC::Open3;
+use ConfigServer::Config;
+
+use Exporter qw(import);
+our $VERSION = 1.03;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(getips);
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+my $ipv4reg = ConfigServer::Config->ipv4reg;
+my $ipv6reg = ConfigServer::Config->ipv6reg;
+
+# end main
+###############################################################################
+# start getips
+sub getips {
+ my $hostname = shift;
+ my @ips;
+
+ if (-e $config{HOST} and -x $config{HOST}) {
+ my $cmdpid;
+ eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die};
+ alarm(10);
+ my ($childin, $childout);
+ $cmdpid = open3($childin, $childout, $childout, $config{HOST},"-W","5",$hostname);
+ close $childin;
+ my @results = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @results;
+
+ foreach my $line (@results) {
+ if ($line =~ /($ipv4reg|$ipv6reg)/) {push @ips, $1}
+ }
+ alarm(0);
+ };
+ alarm(0);
+ if ($cmdpid =~ /\d+/ and $cmdpid > 1 and kill(0,$cmdpid)) {kill(9,$cmdpid)}
+ } else {
+ local $SIG{__DIE__} = undef;
+ eval ('use Socket6;');
+ if ($@) {
+ my @iplist;
+ my (undef, undef, undef, undef, @addrs) = gethostbyname($hostname);
+ foreach (@addrs) {push(@iplist,join(".",unpack("C4", $_)))}
+ push @ips,$_ foreach(@iplist);
+ } else {
+ eval ('
+ use Socket6;
+ my @res = getaddrinfo($hostname, undef, AF_UNSPEC, SOCK_STREAM);
+ while(scalar(@res)>=5){
+ my $saddr;
+ (undef, undef, undef, $saddr, undef, @res) = @res;
+ my ($host, undef) = getnameinfo($saddr,NI_NUMERICHOST | NI_NUMERICSERV);
+ push @ips,$host;
+
+ }
+ ');
+ }
+ }
+
+ return @ips;
+}
+# end getips
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/KillSSH.pm b/src/redux/ConfigServer/KillSSH.pm
new file mode 100644
index 000000000..e68bfad59
--- /dev/null
+++ b/src/redux/ConfigServer/KillSSH.pm
@@ -0,0 +1,94 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::KillSSH;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use ConfigServer::Logger;
+
+use Exporter qw(import);
+our $VERSION = 1.00;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+# end main
+###############################################################################
+# start iplookup
+sub find {
+ my $ip = shift;
+ my $ports = shift;
+
+ my %inodes;
+
+ if ($ports eq "" or $ip eq "") {return}
+
+ foreach my $proto ("tcp","tcp6") {
+ open (my $IN, "<", "/proc/net/$proto");
+ flock ($IN, LOCK_SH);
+ while (<$IN>) {
+ my @rec = split();
+ if ($rec[9] =~ /uid/) {next}
+
+ my ($dip,$dport) = split(/:/,$rec[2]);
+ $dport = hex($dport);
+
+ my ($sip,$sport) = split(/:/,$rec[1]);
+ $sport = hex($sport);
+
+ $dip = &hex2ip($dip);
+ $sip = &hex2ip($sip);
+
+ if ($sip eq '0.0.0.1') {next}
+ if ($dip eq $ip) {
+ foreach my $port (split(/\,/, $ports)) {
+ if ($port eq $sport) {
+ $inodes{$rec[9]} = 1;
+ }
+ }
+ }
+ }
+ close ($IN);
+ }
+
+ opendir (my $PROCDIR, "/proc");
+ while (my $pid = readdir($PROCDIR)) {
+ if ($pid !~ /^\d+$/) {next}
+ opendir (DIR, "/proc/$pid/fd") or next;
+ while (my $file = readdir (DIR)) {
+ if ($file =~ /^\./) {next}
+ my $fd = readlink("/proc/$pid/fd/$file");
+ if ($fd =~ /^socket:\[?([0-9]+)\]?$/) {
+ if ($inodes{$1} and readlink("/proc/$pid/exe") =~ /sshd/) {
+ kill (9,$pid);
+ ConfigServer::Logger::logfile("*PT_SSHDKILL*: Process PID:[$pid] killed for blocked IP:[$ip]");
+ }
+ }
+ }
+ closedir (DIR);
+ }
+ closedir ($PROCDIR);
+ return;
+}
+# end find
+###############################################################################
+## start hex2ip
+sub hex2ip {
+ my $bin = pack "C*" => map hex, $_[0] =~ /../g;
+ my @l = unpack "L*", $bin;
+ if (@l == 4) {
+ return join ':', map { sprintf "%x:%x", $_ >> 16, $_ & 0xffff } @l;
+ }
+ elsif (@l == 1) {
+ return join '.', map { $_ >> 24, ($_ >> 16 ) & 0xff, ($_ >> 8) & 0xff, $_ & 0xff } @l;
+ }
+}
+## end hex2ip
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/Logger.pm b/src/redux/ConfigServer/Logger.pm
new file mode 100644
index 000000000..250946e2a
--- /dev/null
+++ b/src/redux/ConfigServer/Logger.pm
@@ -0,0 +1,70 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::Logger;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Carp;
+use Fcntl qw(:DEFAULT :flock);
+use ConfigServer::Config;
+
+use Exporter qw(import);
+our $VERSION = 1.02;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(logfile);
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+my $hostname;
+if (-e "/proc/sys/kernel/hostname") {
+ open (my $IN, "<", "/proc/sys/kernel/hostname");
+ flock ($IN, LOCK_SH);
+ $hostname = <$IN>;
+ chomp $hostname;
+ close ($IN);
+} else {
+ $hostname = "unknown";
+}
+my $hostshort = (split(/\./,$hostname))[0];
+
+my $sys_syslog;
+if ($config{SYSLOG}) {
+ eval('use Sys::Syslog;'); ##no critic
+ unless ($@) {$sys_syslog = 1}
+}
+
+# end main
+###############################################################################
+# start logfile
+sub logfile {
+ my $line = shift;
+ my @ts = split(/\s+/,scalar localtime);
+ if ($ts[2] < 10) {$ts[2] = " ".$ts[2]}
+
+ my $logfile = "/var/log/lfd.log";
+ if ($< != 0) {$logfile = "/var/log/lfd_messenger.log"}
+
+ sysopen (my $LOGFILE, $logfile, O_WRONLY | O_APPEND | O_CREAT);
+ flock ($LOGFILE, LOCK_EX);
+ print $LOGFILE "$ts[1] $ts[2] $ts[3] $hostshort lfd[$$]: $line\n";
+ close ($LOGFILE);
+
+ if ($config{SYSLOG} and $sys_syslog) {
+ eval {
+ local $SIG{__DIE__} = undef;
+ openlog('lfd', 'ndelay,pid', 'user');
+ syslog('info', $line);
+ closelog();
+ }
+ }
+ return;
+}
+# end logfile
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/LookUpIP.pm b/src/redux/ConfigServer/LookUpIP.pm
new file mode 100644
index 000000000..c6cd6c156
--- /dev/null
+++ b/src/redux/ConfigServer/LookUpIP.pm
@@ -0,0 +1,426 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::LookUpIP;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Carp;
+use Fcntl qw(:DEFAULT :flock);
+use IPC::Open3;
+use JSON::Tiny;
+use Net::IP;
+use Socket;
+use ConfigServer::CheckIP qw(checkip);
+use ConfigServer::Config;
+use ConfigServer::URLGet;
+
+use Exporter qw(import);
+our $VERSION = 2.00;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(iplookup);
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+
+my $urlget;
+if ($config{CC_LOOKUPS} == 4) {
+ $urlget = ConfigServer::URLGet->new($config{URLGET}, "", $config{URLPROXY});
+ unless (defined $urlget) {
+ $config{URLGET} = 1;
+ $urlget = ConfigServer::URLGet->new($config{URLGET}, "", $config{URLPROXY});
+ }
+}
+
+# end main
+###############################################################################
+# start iplookup
+sub iplookup {
+ my $ip = shift;
+ my $cconly = shift;
+ my $host = "-";
+ my $iptype = checkip(\$ip);
+
+ if ($config{LF_LOOKUPS} and !$cconly) {
+ my $dnsip;
+ my $dnsrip;
+ my $dnshost;
+ my $cachehit;
+ open (my $DNS, "<", "/var/lib/csf/csf.dnscache");
+ flock ($DNS, LOCK_SH);
+ while (my $line = <$DNS>) {
+ chomp $line;
+ ($dnsip,$dnsrip,$dnshost) = split(/\|/,$line);
+ if ($ip eq $dnsip) {
+ $cachehit = 1;
+ last;
+ }
+ }
+ close ($DNS);
+ if ($cachehit) {
+ $host = $dnshost;
+ } else {
+ if (-e $config{HOST} and -x $config{HOST}) {
+ my $cmdpid;
+ eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die};
+ alarm(10);
+ my ($childin, $childout);
+ $cmdpid = open3($childin, $childout, $childout, $config{HOST},"-W","5",$ip);
+ close $childin;
+ my @results = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @results;
+ if ($results[0] =~ /(\S+)\.$/) {$host = $1}
+ alarm(0);
+ };
+ alarm(0);
+ if ($cmdpid =~ /\d+/ and $cmdpid > 1 and kill(0,$cmdpid)) {kill(9,$cmdpid)}
+ } else {
+ if ($iptype == 4) {
+ eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die};
+ alarm(10);
+ my $ipaddr = inet_aton($ip);
+ $host = gethostbyaddr($ipaddr, AF_INET);
+ alarm(0);
+ };
+ alarm(0);
+ }
+ elsif ($iptype == 6) {
+ eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die};
+ alarm(10);
+ eval('use Socket6;'); ##no critic
+ my $ipaddr = inet_pton(AF_INET6, $ip);
+ $host = gethostbyaddr($ipaddr, AF_INET6);
+ alarm(0);
+ };
+ alarm(0);
+ }
+ }
+ sysopen (DNS, "/var/lib/csf/csf.dnscache", O_WRONLY | O_APPEND | O_CREAT);
+ flock (DNS, LOCK_EX);
+ print DNS "$ip|$ip|$host\n";
+ close (DNS);
+ }
+ if ($host eq "") {$host = "-"}
+ }
+
+ if (($config{CC_LOOKUPS} and $iptype == 4) or ($config{CC_LOOKUPS} and $config{CC6_LOOKUPS} and $iptype == 6)) {
+ my @result;
+ eval {
+ local $SIG{__DIE__} = undef;
+ @result = &geo_binary($ip,$iptype);
+ };
+ my $asn = $result[4];
+ if ($result[0] eq "") {$result[0] = "-"}
+ if ($result[1] eq "") {$result[1] = "-"}
+ if ($result[2] eq "") {$result[2] = "-"}
+ if ($result[3] eq "") {$result[3] = "-"}
+ if ($result[4] eq "") {$result[4] = "-"} else {$result[4] = "[$result[4]]"}
+ if ($config{CC_LOOKUPS} == 3) {
+ if ($cconly) {return ($result[0],$asn)}
+ my $return = "$ip ($result[0]/$result[1]/$result[2]/$result[3]/$host/$result[4])";
+ if ($result[0] eq "-") {$return = "$ip ($host)"}
+ $return =~ s/'|"//g;
+ return $return;
+ }
+ elsif ($config{CC_LOOKUPS} == 2 or $config{CC_LOOKUPS} == 4) {
+ if ($cconly) {return $result[0]}
+ my $return = "$ip ($result[0]/$result[1]/$result[2]/$result[3]/$host)";
+ if ($result[0] eq "-") {$return = "$ip ($host)"}
+ $return =~ s/'|"//g;
+ return $return;
+ }
+ else {
+ if ($cconly) {return $result[0]}
+ my $return = "$ip ($result[0]/$result[1]/$host)";
+ if ($result[0] eq "-") {$return = "$ip ($host)"}
+ $return =~ s/'|"//g;
+ return $return;
+ }
+ }
+
+ if ($config{LF_LOOKUPS}) {
+ if ($host eq "-") {$host = "Unknown"}
+ my $return = "$ip ($host)";
+ $return =~ s/'//g;
+ return $return;
+ } else {
+ return $ip;
+ }
+}
+# end iplookup
+###############################################################################
+# start geo_binary
+sub geo_binary {
+ my $myip = shift;
+ my $ipv = shift;
+ my @return;
+
+ my $netip = Net::IP->new($myip);
+ my $ip = $netip->binip();
+ my $type = $netip->iptype();
+ if ($type eq "PRIVATE") {return}
+
+ if ($config{CC_LOOKUPS} == 4) {
+ my ($status, $text) = $urlget->urlget("http://api.db-ip.com/v2/free/$myip");
+ if ($status) {$text = ""}
+ if ($text ne "") {
+ my $json = JSON::Tiny::decode_json($text);
+ return ($json->{countryCode},$json->{countryName},$json->{stateProv},$json->{city});
+ } else {
+ return;
+ }
+ return;
+ }
+
+ if ($config{CC_SRC} eq "" or $config{CC_SRC} eq "1") {
+ my $file = "/var/lib/csf/Geo/GeoLite2-Country-Blocks-IPv${ipv}.csv";
+ if ($config{CC_LOOKUPS} == 2 or $config{CC_LOOKUPS} == 3) {
+ $file = "/var/lib/csf/Geo/GeoLite2-City-Blocks-IPv${ipv}.csv";
+ }
+ my $start = 0;
+ my $end = -s $file;
+ $end += 4;
+ my $cnt = 0;
+ my $last;
+ my $range;
+ my $geoid;
+ open (my $CSV, "<", $file);
+ flock ($CSV, LOCK_SH);
+ while (1) {
+ my $mid = int (($end + $start) / 2);
+ seek ($CSV, $mid, 0);
+ my $a = <$CSV>;
+ my $b = <$CSV>;
+ chomp $b;
+ ($range,$geoid,undef) = split(/\,/,$b);
+ if ($range !~ /^\d/ or $range eq $last or $range eq "") {return}
+ $last = $range;
+ my $netip = Net::IP->new($range);
+ my $lastip = $netip->last_ip();
+ $lastip = Net::IP::ip_iptobin($lastip,$ipv);
+ my $firstip = $netip->ip();
+ $firstip = Net::IP::ip_iptobin($firstip,$ipv);
+ if (Net::IP::ip_bincomp($ip,'lt',$firstip) == 1) {
+ $end = $mid;
+ }
+ elsif (Net::IP::ip_bincomp($ip,'gt',$lastip) == 1) {
+ $start = $mid;
+ } else {
+ last;
+ }
+ $cnt++;
+ if ($cnt > 200) {return}
+ }
+ close ($CSV);
+
+ if ($geoid > 0) {
+ my $file = "/var/lib/csf/Geo/GeoLite2-Country-Locations-en.csv";
+ if ($config{CC_LOOKUPS} == 2 or $config{CC_LOOKUPS} == 3) {
+ $file = "/var/lib/csf/Geo/GeoLite2-City-Locations-en.csv";
+ }
+ my $start = 0;
+ my $end = -s $file;
+ $end += 4;
+ my $cnt = 0;
+ my $last;
+ open (my $CSV, "<", $file);
+ flock ($CSV, LOCK_SH);
+ while (1) {
+ my $mid = int (($end + $start) / 2);
+ seek ($CSV, $mid, 0);
+ my $a = <$CSV>;
+ my $b = <$CSV>;
+ chomp $b;
+ my @bits = split(/\,/,$b);
+ if ($range !~ /^\d/ or $bits[0] eq $last or $bits[0] eq "") {last}
+ $last = $bits[0];
+ if ($geoid < $bits[0]) {
+ $end = $mid;
+ }
+ elsif ($geoid > $bits[0]) {
+ $start = $mid + 1;
+ } else {
+ $b =~ s/\"//g;
+ my ($geoname_id, $locale_code, $continent_code, $continent_name, $country_iso_code, $country_name, $subdivision_1_iso_code, $subdivision_1_name, $subdivision_2_iso_code, $subdivision_2_name, $city_name, $metro_code, $time_zone) = split(/\,/,$b);
+ my $region = $subdivision_2_name;
+ if ($region eq "" or $region eq $city_name) {$region = $subdivision_1_name}
+ $return[0] = $country_iso_code;
+ $return[1] = $country_name;
+ $return[2] = $region;
+ $return[3] = $city_name;
+ last;
+ }
+ $cnt++;
+ if ($cnt > 200) {return}
+ }
+ close ($CSV);
+ }
+
+ if ($config{CC_LOOKUPS} == 3) {
+ my $file = "/var/lib/csf/Geo/GeoLite2-ASN-Blocks-IPv${ipv}.csv";
+ my $start = 0;
+ my $end = -s $file;
+ $end += 4;
+ my $cnt = 0;
+ my $last;
+ my $range;
+ my $asn;
+ my $asnorg;
+ open (my $CSV, "<", $file);
+ flock ($CSV, LOCK_SH);
+ while (1) {
+ my $mid = int (($end + $start) / 2);
+ seek ($CSV, $mid, 0);
+ my $a = <$CSV>;
+ my $b = <$CSV>;
+ chomp $b;
+ ($range,$asn,$asnorg) = split(/\,/,$b,3);
+ if ($range !~ /^\d/ or $range eq $last or $range eq "") {last}
+ $last = $range;
+ my $netip = Net::IP->new($range);
+ my $lastip = $netip->last_ip();
+ $lastip = Net::IP::ip_iptobin($lastip,$ipv);
+ my $firstip = $netip->ip();
+ $firstip = Net::IP::ip_iptobin($firstip,$ipv);
+ if (Net::IP::ip_bincomp($ip,'lt',$firstip) == 1) {
+ $end = $mid;
+ }
+ elsif (Net::IP::ip_bincomp($ip,'gt',$lastip) == 1) {
+ $start = $mid + 1;
+ } else {
+ $return[4] = "AS$asn $asnorg";
+ last;
+ }
+ $cnt++;
+ if ($cnt > 200) {last}
+ }
+ close ($CSV);
+ }
+ } elsif ($config{CC_SRC} eq "2") {
+ my %country_name;
+ open (my $CC, "<", "/var/lib/csf/Geo/countryInfo.txt");
+ flock ($CC, LOCK_SH);
+ foreach my $line (<$CC>) {
+ if ($line eq "" or $line =~ /^\#/ or $line =~ /^\s/) {next}
+ my ($cc,undef,undef,undef,$country,undef) = split(/\t/, $line);
+ if ($cc ne "" and $country ne "") {$country_name{$cc} = $country}
+ }
+ close ($CC);
+
+ my $file = "/var/lib/csf/Geo/dbip-country-lite.csv";
+ if ($config{CC_LOOKUPS} == 2 or $config{CC_LOOKUPS} == 3) {
+ $file = "/var/lib/csf/Geo/dbip-city-lite.csv";
+ }
+ my $start = 0;
+ my $end = -s $file;
+ $end += 4;
+ my $cnt = 0;
+ my $last;
+ my $range;
+ my $geoid;
+ open (my $CSV, "<", $file);
+ flock ($CSV, LOCK_SH);
+ while (1) {
+ my $mid = int (($end + $start) / 2);
+ seek ($CSV, $mid, 0);
+ my $a = <$CSV>;
+ my $b = <$CSV>;
+ chomp $b;
+ my ($firstip,$lastip,$cc_lookups1,$country_iso_code,$region,$city_name,undef) = split(/\,/,$b);
+ if ($firstip eq $lastip or $firstip eq "") {return}
+ if (checkip(\$firstip) ne $ipv) {
+ if ($ipv eq "6") {
+ $start = $mid;
+ } else {
+ $end = $mid;
+ }
+ } else {
+ my $netfirstip = Net::IP->new($firstip);
+ my $firstip = $netfirstip->binip();
+ my $netlastip = Net::IP->new($lastip);
+ my $lastip = $netlastip->binip();
+ if (Net::IP::ip_bincomp($ip,'lt',$firstip) == 1) {
+ $end = $mid;
+ }
+ elsif (Net::IP::ip_bincomp($ip,'gt',$lastip) == 1) {
+ $start = $mid + 1;
+ } else {
+ if ($config{CC_LOOKUPS} == 1) {$country_iso_code = $cc_lookups1}
+ if ($country_iso_code eq "ZZ") {last}
+ $return[0] = $country_iso_code;
+ $return[1] = $country_name{$country_iso_code};
+ $return[2] = $region;
+ $return[3] = $city_name;
+ last;
+ }
+ }
+ $cnt++;
+ if ($cnt > 200) {return}
+ }
+ close ($CSV);
+
+ if ($config{CC_LOOKUPS} == 3) {
+ my $file = "/var/lib/csf/Geo/ip2asn-combined.tsv";
+ my $start = 0;
+ my $end = -s $file;
+ $end += 4;
+ my $cnt = 0;
+ my $last;
+ my $range;
+ my $asn;
+ my $asnorg;
+ open (my $CSV, "<", $file);
+ flock ($CSV, LOCK_SH);
+ while (1) {
+ my $mid = int (($end + $start) / 2);
+ seek ($CSV, $mid, 0);
+ my $a = <$CSV>;
+ my $b = <$CSV>;
+ chomp $b;
+ my ($firstip,$lastip,$asn,undef,$asnorg) = split(/\t/,$b);
+ if ($firstip eq $lastip or $firstip eq "") {last}
+ if (checkip(\$firstip) ne $ipv) {
+ if ($ipv eq "6") {
+ $start = $mid;
+ } else {
+ $end = $mid;
+ }
+ } else {
+ my $netfirstip = Net::IP->new($firstip);
+ my $firstip = $netfirstip->binip();
+ my $netlastip = Net::IP->new($lastip);
+ my $lastip = $netlastip->binip();
+ if (Net::IP::ip_bincomp($ip,'lt',$firstip) == 1) {
+ $end = $mid;
+ }
+ elsif (Net::IP::ip_bincomp($ip,'gt',$lastip) == 1) {
+ $start = $mid + 1;
+ } else {
+ if ($asn eq "0") {last}
+ $return[4] = "AS$asn $asnorg";
+ last;
+ }
+ }
+ $cnt++;
+ if ($cnt > 200) {last}
+ }
+ close ($CSV);
+ }
+ }
+ return @return;
+}
+# end geo_binary
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/Messenger.pm b/src/redux/ConfigServer/Messenger.pm
new file mode 100644
index 000000000..ce6f26275
--- /dev/null
+++ b/src/redux/ConfigServer/Messenger.pm
@@ -0,0 +1,1277 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::Messenger;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use File::Copy;
+use JSON::Tiny;
+use IO::Socket::INET;
+use Net::CIDR::Lite;
+use Net::IP;
+use IPC::Open3;
+use ConfigServer::Config;
+use ConfigServer::CheckIP qw(checkip);
+use ConfigServer::Logger qw(logfile);
+use ConfigServer::URLGet;
+use ConfigServer::Slurp qw(slurp);
+use ConfigServer::GetIPs qw(getips);
+use ConfigServer::GetEthDev;
+
+use Exporter qw(import);
+our $VERSION = 3.00;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my $slurpreg = ConfigServer::Slurp->slurpreg;
+my $cleanreg = ConfigServer::Slurp->cleanreg;
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+my $ipv4reg = ConfigServer::Config->ipv4reg;
+my $ipv6reg = ConfigServer::Config->ipv6reg;
+
+my $childproc;
+my $hostname;
+
+my %ips;
+my $ipscidr6;
+my %sslcerts;
+my %sslkeys;
+my %ssldomains;
+my @ssldomainkeys;
+my $webserver = "apache";
+my $sslhost;
+my $sslcert;
+my $sslkey;
+my $sslca;
+my $osslcert;
+my $osslkey;
+my $osslca;
+my $sslaliases;
+my $litestart = 0;
+my $ssldir = "/var/lib/csf/ssl/";
+my $phphandler;
+my $version = 1;
+my $serverroot;
+
+# end main
+###############################################################################
+# start init
+sub init {
+ my $class = shift;
+ $version = shift;
+ my $self = {};
+ bless $self,$class;
+
+ if (-e "/proc/sys/kernel/hostname") {
+ open (my $IN, "<", "/proc/sys/kernel/hostname");
+ flock ($IN, LOCK_SH);
+ $hostname = <$IN>;
+ chomp $hostname;
+ close ($IN);
+ } else {
+ $hostname = "unknown";
+ }
+ if ($version == 1) {
+ if ($config{MESSENGER6}) {
+ eval('use IO::Socket::INET6;'); ##no critic
+ if ($@) {$config{MESSENGER6} = "0"}
+ }
+ $ipscidr6 = Net::CIDR::Lite->new;
+ &getethdev;
+ foreach my $ip (split(/,/,$config{RECAPTCHA_NAT})) {
+ $ip =~ s/\s*//g;
+ $ips{$ip} = 1;
+ }
+ }
+ elsif ($version == 2) {
+ }
+ elsif ($version == 3) {
+ mkdir $ssldir;
+ mkdir $ssldir."certs/";
+ mkdir $ssldir."keys/";
+ mkdir $ssldir."ca/";
+ }
+
+ return $self;
+}
+# end init
+###############################################################################
+# start start
+sub start {
+ my $self = shift;
+ my $port = shift;
+ my $user = shift;
+ my $type = shift;
+ my $status;
+ my $reason;
+ if ($version == 1) {
+ ($status,$reason) = &messenger($port, $user, $type);
+ }
+ elsif ($version == 2) {
+ ($status,$reason) = &messengerv2();
+ }
+ elsif ($version == 3) {
+ ($status,$reason) = &messengerv3();
+ }
+
+ return ($status,$reason);
+}
+# end start
+###############################################################################
+# start messenger
+sub messenger {
+ my $port = shift;
+ my $user = shift;
+ my $type = shift;
+ my $oldtype = $type;
+ my $server;
+ my %sslcerts;
+ my %sslkeys;
+
+ $SIG{CHLD} = 'IGNORE';
+ $SIG{INT} = \&childcleanup;
+ $SIG{TERM} = \&childcleanup;
+ $SIG{HUP} = \&childcleanup;
+ $SIG{__DIE__} = sub {&childcleanup(@_);};
+ $0 = "lfd $type messenger";
+ $childproc = "Messenger ($type)";
+
+ if ($type eq "HTTPS") {
+ eval {
+ local $SIG{__DIE__} = undef;
+ require IO::Socket::SSL;
+ import IO::Socket::SSL;
+ };
+
+ my $start = 0;
+ my $sslhost;
+ my $sslcert;
+ my $sslkey;
+ my $sslaliases;
+ my %messengerports;
+ foreach my $serverports (split(/\,/,$config{MESSENGER_HTTPS_IN})) {$messengerports{$serverports} = 1}
+ foreach my $file (glob($config{MESSENGER_HTTPS_CONF})) {
+ if (-e $file) {
+ foreach my $line (slurp($file)) {
+ $line =~ s/\'|\"//g;
+ if ($line =~ /^\s*
]+>/) {
+ $start = 1;
+ }
+ if ($webserver eq "apache" and $start) {
+ if ($line =~ /\s*ServerName\s+(\w+:\/\/)?([a-zA-Z0-9\.\-]+)(:\d+)?/) {$sslhost = $2}
+ if ($line =~ /\s*ServerAlias\s+(.*)/) {$sslaliases .= " ".$1}
+ if ($line =~ /\s*SSLCertificateFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {$sslcert = $match}
+ }
+ if ($line =~ /\s*SSLCertificateKeyFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {$sslkey = $match}
+ }
+ }
+
+ if (($webserver eq "apache" and $line =~ /^\s*<\/VirtualHost\s*>/)) {
+ $start = 0;
+ if ($sslhost ne "" and !checkip($sslhost) and $sslcert ne "") {
+ $sslcerts{$sslhost} = $sslcert;
+ if ($sslkey eq "") {$sslkey = $sslcert}
+ $sslkeys{$sslhost} = $sslkey;
+ foreach my $alias (split(/\s+/,$sslaliases)) {
+ if ($alias eq "") {next}
+ if (checkip($alias)) {next}
+ if ($alias =~ /^[a-zA-Z0-9\.\-]+$/) {
+ if ($config{MESSENGER_HTTPS_SKIPMAIL} and $alias =~ /^mail\./) {next}
+ $sslcerts{$alias} = $sslcert;
+ $sslkeys{$alias} = $sslkey;
+ }
+ }
+ }
+ $sslhost = "";
+ $sslcert = "";
+ $sslkey = "";
+ $sslaliases = "";
+ }
+ }
+ }
+ }
+ if (scalar(keys %sslcerts < 1)) {
+ return (1, "No SSL certs found in MESSENGER_HTTPS_CONF location");
+ }
+ if (-e $config{MESSENGER_HTTPS_KEY}) {
+ $sslkeys{''} = $config{MESSENGER_HTTPS_KEY};
+ }
+ if (-e $config{MESSENGER_HTTPS_CRT}) {
+ $sslcerts{''} = $config{MESSENGER_HTTPS_CRT};
+ }
+ if ($config{DEBUG} >= 1) {
+ foreach my $key (keys %sslcerts) {
+ logfile("SSL: [$key] [$sslcerts{$key}] [$sslkeys{$key}]");
+ }
+ }
+ eval {
+ local $SIG{__DIE__} = undef;
+ if ($config{MESSENGER6}) {
+ $server = IO::Socket::SSL->new(
+ Domain => AF_INET6,
+ LocalPort => $port,
+ Type => SOCK_STREAM,
+ ReuseAddr => 1,
+ Listen => $config{MESSENGER_CHILDREN},
+ SSL_server => 1,
+ SSL_use_cert => 1,
+ SSL_cert_file => \%sslcerts,
+ SSL_key_file => \%sslkeys,
+ ) or &error("MESSENGER: *Error* cannot open server on port $port: ".IO::Socket::SSL->errstr);
+ } else {
+ $server = IO::Socket::SSL->new(
+ Domain => AF_INET,
+ LocalPort => $port,
+ Type => SOCK_STREAM,
+ ReuseAddr => 1,
+ Listen => $config{MESSENGER_CHILDREN},
+ SSL_server => 1,
+ SSL_use_cert => 1,
+ SSL_cert_file => \%sslcerts,
+ SSL_key_file => \%sslkeys,
+ ) or &error("MESSENGER: *Error* cannot open server on port $port: ".IO::Socket::SSL->errstr);
+ }
+ &logfile("Messenger HTTPS Service started for ".scalar(keys %sslcerts)." domains");
+ $type = "HTML";
+ };
+ if ($@) {
+ return (1, $@);
+ }
+ }
+ elsif ($config{MESSENGER6}) {
+ $server = IO::Socket::INET6->new(
+ LocalPort => $port,
+ Type => SOCK_STREAM,
+ ReuseAddr => 1,
+ Listen => $config{MESSENGER_CHILDREN}) or &childcleanup(__LINE__,"*Error* cannot open server on port $port: $!");
+ } else {
+ $server = IO::Socket::INET->new(
+ LocalPort => $port,
+ Type => SOCK_STREAM,
+ ReuseAddr => 1,
+ Listen => $config{MESSENGER_CHILDREN}) or &childcleanup(__LINE__,"*Error* cannot open server on port $port: $!");
+ }
+
+ my $index;
+ if ($type eq "HTML" and $config{RECAPTCHA_SITEKEY} ne "") {$index = "/etc/csf/messenger/index.recaptcha.html"}
+ elsif ($type eq "HTML") {$index = "/etc/csf/messenger/index.html"}
+ else {$index = "/etc/csf/messenger/index.text"}
+ open (my $IN, "<", $index);
+ flock ($IN, LOCK_SH);
+ my @message = <$IN>;
+ close ($IN);
+ chomp @message;
+
+ my %images;
+ if ($type eq "HTML") {
+ opendir (DIR, "/etc/csf/messenger");
+ foreach my $file (readdir(DIR)) {
+ if ($file =~ /\.(gif|png|jpg)$/) {
+ open (my $IN, "<", "/etc/csf/messenger/$file");
+ flock ($IN, LOCK_SH);
+ my @data = <$IN>;
+ close ($IN);
+ chomp @data;
+ foreach my $line (@data) {
+ $images{$file} .= "$line\n";
+ }
+ }
+ }
+ closedir (DIR);
+ }
+ my $chldallow = $config{MESSENGER_CHILDREN};
+
+ if ($oldtype eq "HTTPS") {
+ open (my $STATUS,"<", "/proc/$$/status") or next;
+ flock ($STATUS, LOCK_SH);
+ my @status = <$STATUS>;
+ close ($STATUS);
+ chomp @status;
+ my $vmsize = 0;
+ my $vmrss = 0;
+ foreach my $line (@status) {
+ if ($line =~ /^VmSize:\s+(\d+) kB$/) {$vmsize = $1}
+ if ($line =~ /^VmRSS:\s+(\d+) kB$/) {$vmrss = $1}
+ }
+
+ logfile("lfd $oldtype messenger using $vmrss kB of RSS memory at startup, adding up to $config{MESSENGER_CHILDREN} children = ".(($config{MESSENGER_CHILDREN} + 1) * $vmrss)." kB");
+ logfile("lfd $oldtype messenger using $vmsize kB of VIRT memory at startup, adding up to $config{MESSENGER_CHILDREN} children = ".(($config{MESSENGER_CHILDREN} + 1) * $vmsize)." kB");
+ }
+
+ if ($user ne "") {
+ my (undef,undef,$uid,$gid,undef,undef,undef,$homedir) = getpwnam($user);
+ if (($uid > 0) and ($gid > 0)) {
+ local $( = $gid;
+ local $) = "$gid $gid";
+ local $> = local $< = $uid;
+ if (($) != $gid) or ($> != $uid) or ($( != $gid) or ($< != $uid)) {
+ logfile("MESSENGER_USER unable to drop privileges - stopping $oldtype Messenger");
+ exit;
+ }
+ my %children;
+ while (1) {
+ while (my $client = $server->accept()) {
+ while (scalar (keys %children) >= $chldallow) {
+ sleep 1;
+ foreach my $pid (keys %children) {
+ unless (kill(0,$pid)) {delete $children{$pid}}
+ }
+ $0 = "lfd $oldtype messenger (busy)";
+ }
+ $0 = "lfd $oldtype messenger";
+
+ $SIG{CHLD} = 'IGNORE';
+ my $pid = fork;
+ $children{$pid} = 1;
+ if ($pid == 0) {
+ eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die};
+ alarm(10);
+ close $server;
+
+ $0 = "lfd $oldtype messenger client";
+
+ binmode $client;
+ $| = 1;
+ my $firstline;
+
+ my $hostaddress = $client->sockhost();
+ my $peeraddress = $client->peerhost();
+ $peeraddress =~ s/^::ffff://;
+ $hostaddress =~ s/^::ffff://;
+
+ if ($type eq "HTML") {
+ while ($firstline !~ /\n$/) {
+ my $char;
+ $client->read($char,1);
+ $firstline .= $char;
+ if ($char eq "") {exit}
+ if (length $firstline > 2048) {last}
+ }
+ chomp $firstline;
+ if ($firstline =~ /\r$/) {chop $firstline}
+ }
+
+ &messengerlog($homedir,"Client connection [$peeraddress] [$firstline]");
+ my $error;
+ my $success;
+ my $failure;
+ if (($type eq "HTML") and ($firstline =~ /^GET \/unblk\?g-recaptcha-response=(\S+)/i)) {
+ my $recv = $1;
+ my $status = 1;
+ my $text;
+ eval {
+ local $SIG{__DIE__} = undef;
+ eval("no lib '/usr/local/csf/lib'");
+ my $urlget = ConfigServer::URLGet->new(2, "", $config{URLPROXY});
+ my $url = "https://www.google.com/recaptcha/api/siteverify?secret=$config{RECAPTCHA_SECRET}&response=$recv";
+ ($status, $text) = $urlget->urlget($url);
+ };
+ if ($status) {
+ &messengerlog($homedir,"*Error*, ReCaptcha ($peeraddress): $text");
+ if ($config{DEBUG} >= 1) {
+ if ($@) {$error .= "Error:".$@}
+ if ($!) {$error .= "Error:".$!}
+ $error .= " Error Status: $status";
+ }
+ $error .= "Unable to verify with Google reCAPTCHA";
+ } else {
+ my $resp = JSON::Tiny::decode_json($text);
+ if ($resp->{success}) {
+ my $ip = $resp->{hostname};
+ unless ($ip =~ /^($ipv4reg|$ipv6reg)$/) {$ip = (getips($ip))[0]}
+ if ($ips{$ip} or $ip eq $hostaddress or $ipscidr6->find($ip)) {
+ sysopen (my $UNBLOCK, "$homedir/unblock.txt", O_WRONLY | O_APPEND | O_CREAT) or $error .= "Unable to write to [$homedir/unblock.txt] (make sure that MESSENGER_USER has a home directory)";
+ flock($UNBLOCK, LOCK_EX);
+ print $UNBLOCK "$peeraddress;$resp->{hostname};$ip\n";
+ close ($UNBLOCK);
+ $success = 1;
+ &messengerlog($homedir,"*Success*, ReCaptcha ($peeraddress): [$resp->{hostname} ($ip)] requested unblock");
+ } else {
+ $error .= "Failed, [$resp->{hostname} ($ip)] does not appear to be hosted on this server.";
+ &messengerlog($homedir,"*Failed*, ReCaptcha ($peeraddress): [$resp->{hostname} ($ip)] does not appear to be hosted on this server");
+ }
+ } else {
+ $failure = 1;
+ my @codes = @{$resp->{'error-codes'}};
+ &messengerlog($homedir,"*Failure*, ReCaptcha ($peeraddress): [$codes[0]]");
+ }
+ }
+ }
+ if (($type eq "HTML") and ($firstline =~ /^GET\s+(\S*\/)?(\S*\.(gif|png|jpg))\s+/i)) {
+ my $type = $3;
+ if ($type eq "jpg") {$type = "jpeg"}
+ print $client "HTTP/1.1 200 OK\r\n";
+ print $client "Content-type: image/$type\r\n";
+ print $client "\r\n";
+ print $client $images{$2};
+ } else {
+ if ($type eq "HTML") {
+ print $client "HTTP/1.1 403 OK\r\n";
+ print $client "Content-type: text/html\r\n";
+ print $client "\r\n";
+ foreach my $line (@message) {
+ if ($line =~ /\[IPADDRESS\]/) {$line =~ s/\[IPADDRESS\]/$peeraddress/}
+ if ($line =~ /\[HOSTNAME\]/) {$line =~ s/\[HOSTNAME\]/$hostname/}
+ if ($line =~ /\[RECAPTCHA_SITEKEY\]/) {$line =~ s/\[RECAPTCHA_SITEKEY\]/$config{RECAPTCHA_SITEKEY}/}
+ if ($line =~ /\[RECAPTCHA_ERROR=\"([^\"]+)\"\]/) {
+ my $text = $1;
+ if ($error ne "") {$line =~ s/\[RECAPTCHA_ERROR=\"([^\"]+)\"\]/$text $error/} else {$line =~ s/\[RECAPTCHA_ERROR=\"([^\"]+)\"\]//}
+ }
+ if ($line =~ /\[RECAPTCHA_SUCCESS=\"([^\"]+)\"\]/) {
+ my $text = $1;
+ if ($success) {$line =~ s/\[RECAPTCHA_SUCCESS=\"([^\"]+)\"\]/$text/} else {$line =~ s/\[RECAPTCHA_SUCCESS=\"([^\"]+)\"\]//}
+ }
+ if ($line =~ /\[RECAPTCHA_FAILURE=\"([^\"]+)\"\]/) {
+ my $text = $1;
+ if ($failure) {$line =~ s/\[RECAPTCHA_FAILURE=\"([^\"]+)\"\]/$text/} else {$line =~ s/\[RECAPTCHA_FAILURE=\"([^\"]+)\"\]//}
+ }
+ print $client "$line\r\n";
+ }
+ print $client "\r\n";
+ } else {
+ foreach my $line (@message) {
+ if ($line =~ /\[IPADDRESS\]/) {$line =~ s/\[IPADDRESS\]/$peeraddress/}
+ if ($line =~ /\[HOSTNAME\]/) {$line =~ s/\[HOSTNAME\]/$hostname/}
+ print $client "$line ";
+ }
+ print $client "\n";
+ }
+ }
+ alarm(0);
+ };
+ shutdown ($client,2);
+ $client->close();
+ alarm(0);
+ exit;
+ }
+ if ($oldtype eq "HTTPS") {
+ $client->close(SSL_no_shutdown => 1);
+ } else {
+ $client->close();
+ }
+ }
+ }
+ } else {
+ logfile("MESSENGER_USER invalid - stopping $oldtype Messenger");
+ }
+ } else {
+ logfile("MESSENGER_USER not set - stopping $oldtype Messenger");
+ }
+ return;
+}
+# end messenger
+###############################################################################
+# start messengerv2
+sub messengerv2 {
+ my (undef,undef,$uid,$gid,undef,undef,undef,$homedir) = getpwnam($config{MESSENGER_USER});
+ if ($homedir eq "" or $homedir eq "/" or $homedir =~ m[/etc/csf]) {
+ return (1, "The home directory for $config{MESSENGER_USER} is not valid [$homedir]");
+ }
+ if (! -e $homedir) {
+ return (1, "The home directory for $config{MESSENGER_USER} does not exist [$homedir]");
+ }
+ system("chmod","711",$homedir);
+ my $public_html = $homedir."/public_html";
+ unless (-e $public_html) {
+ system("mkdir","-p",$public_html);
+ system("chown","$config{MESSENGER_USER}:nobody",$public_html);
+ system("chmod","711",$public_html);
+ }
+ unless (-e $public_html."/.htaccess") {
+ open (my $HTACCESS, ">", $public_html."/.htaccess");
+ flock ($HTACCESS, LOCK_EX);
+ print $HTACCESS "Require all granted\n";
+ print $HTACCESS "DirectoryIndex index.php index.cgi index.html index.htm\n";
+ print $HTACCESS "Options +FollowSymLinks +ExecCGI\n";
+ print $HTACCESS "RewriteEngine On\n";
+ print $HTACCESS "RewriteCond \%{REQUEST_FILENAME} !-f\n";
+ print $HTACCESS "RewriteCond \%{REQUEST_FILENAME} !-d\n";
+ print $HTACCESS "RewriteRule ^ /index.php [L,QSA]\n";
+ system("chown","$config{MESSENGER_USER}:$config{MESSENGER_USER}",$public_html."/.htaccess");
+ system("chmod","644",$public_html."/.htaccess");
+ }
+ unless (-e $public_html."/index.php") {
+ if ($config{RECAPTCHA_SITEKEY}) {
+ system("cp","/etc/csf/messenger/index.recaptcha.php",$public_html."/index.php");
+ } else {
+ system("cp","/etc/csf/messenger/index.php",$public_html."/index.php");
+ }
+ system("chown","$config{MESSENGER_USER}:$config{MESSENGER_USER}",$public_html."/index.php");
+ system("chmod","644",$public_html."/index.php");
+ }
+ unless (-e $homedir."/en.php") {
+ system("cp","/etc/csf/messenger/en.php",$homedir."/en.php");
+ system("chown","$config{MESSENGER_USER}:$config{MESSENGER_USER}",$homedir."/en.php");
+ system("chmod","644",$homedir."/en.php");
+ }
+ open (my $CONF, ">", $homedir."/recaptcha.php");
+ flock ($CONF, LOCK_EX);
+ print $CONF "\n";
+ system("chown","$config{MESSENGER_USER}:$config{MESSENGER_USER}",$homedir."/recaptcha.php");
+ system("chmod","644",$homedir."/recaptcha.php");
+
+
+ open (my $OUT, ">", "/var/lib/csf/csf.conf");
+ flock ($OUT, LOCK_EX);
+
+ if ($config{MESSENGER_HTML_IN} ne "") {
+ print $OUT "Listen 0.0.0.0:$config{MESSENGER_HTML}\n";
+ if ($config{IPV6}) {print $OUT "Listen [::]:$config{MESSENGER_HTML}\n"}
+ print $OUT "\n";
+ print $OUT " ServerName $hostname\n";
+ print $OUT " DocumentRoot $public_html\n";
+ print $OUT " \n";
+ print $OUT " AllowOverride All\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " suPHP_UserGroup $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " SuexecUserGroup $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " RMode config\n";
+ print $OUT " RUidGid $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " AssignUserID $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " KeepAlive Off\n";
+ print $OUT " \n";
+ }
+
+ if ($config{MESSENGER_HTTPS_IN} ne "") {
+ my %sslcerts;
+ my %sslkeys;
+ my %ssldomains;
+ my $start = 0;
+ my $sslhost;
+ my $sslcert;
+ my $sslkey;
+ my $sslaliases;
+ my $ssldir = "/var/lib/csf/ssl/";
+ unless (-d $ssldir) {
+ mkdir $ssldir;
+ mkdir $ssldir."certs/";
+ mkdir $ssldir."keys/";
+ }
+ foreach my $file (glob($config{MESSENGER_HTTPS_CONF})) {
+ if (-e $file) {
+ foreach my $line (slurp($file)) {
+ $line =~ s/\'|\"//g;
+ if ($line =~ /^\s*]+>/) {
+ $start = 1;
+ }
+ if ($webserver eq "apache" and $start) {
+ if ($line =~ /\s*ServerName\s+(\w+:\/\/)?([a-zA-Z0-9\.\-]+)(:\d+)?/) {$sslhost = $2}
+ if ($line =~ /\s*ServerAlias\s+(.*)/) {$sslaliases .= " ".$1}
+ if ($line =~ /\s*SSLCertificateFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {
+ copy($match, $ssldir."certs/".$sslhost."\.crt");
+ $sslcert = $ssldir."certs/".$sslhost."\.crt";
+ }
+ }
+ if ($line =~ /\s*SSLCertificateKeyFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {
+ copy($match, $ssldir."keys/".$sslhost."\.key");
+ $sslkey = $ssldir."keys/".$sslhost."\.key";
+ }
+ }
+ }
+
+ if (($webserver eq "apache" and $line =~ /^\s*<\/VirtualHost\s*>/)) {
+ $start = 0;
+ if ($sslhost ne "" and !checkip($sslhost) and $sslcert ne "") {
+ $ssldomains{$sslhost}{key} = $sslkey;
+ $ssldomains{$sslhost}{aliases} = $sslaliases;
+ $ssldomains{$sslhost}{cert} = $sslcert;
+ }
+ $sslhost = "";
+ $sslcert = "";
+ $sslkey = "";
+ $sslaliases = "";
+ }
+ }
+ }
+ }
+ if (scalar(keys %ssldomains < 1)) {
+ return (1, "No SSL domains found in MESSENGER_HTTPS_CONF location");
+ }
+
+ print $OUT "Listen 0.0.0.0:$config{MESSENGER_HTTPS}\n";
+ if ($config{IPV6}) {print $OUT "Listen [::]:$config{MESSENGER_HTTPS}\n"}
+ if (-e $config{MESSENGER_HTTPS_KEY}) {
+ print $OUT "\n";
+ print $OUT " ServerName $hostname\n";
+ print $OUT " DocumentRoot $public_html\n";
+ print $OUT " UseCanonicalName Off\n";
+ print $OUT " \n";
+ print $OUT " AllowOverride All\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " suPHP_UserGroup $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " SuexecUserGroup $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " RMode config\n";
+ print $OUT " RUidGid $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " AssignUserID $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " SSLEngine on\n";
+ if (-e $config{MESSENGER_HTTPS_KEY}) {
+ copy($config{MESSENGER_HTTPS_KEY}, $ssldir."keys/".$hostname."\.key");
+ print $OUT " SSLCertificateKeyFile ".$ssldir."keys/".$hostname."\.key\n";
+ }
+ if (-e $config{MESSENGER_HTTPS_CRT}) {
+ copy($config{MESSENGER_HTTPS_CRT}, $ssldir."certs/".$hostname."\.crt");
+ print $OUT " SSLCertificateFile ".$ssldir."certs/".$hostname."\.crt\n";
+ }
+ print $OUT " SSLUseStapling off\n";
+ print $OUT " KeepAlive Off\n";
+ print $OUT " \n";
+ }
+ foreach my $key (keys %ssldomains) {
+ if ($key eq "") {next}
+ if ($key =~ /^\s+$/) {next}
+ if (-e $ssldomains{$key}{cert}) {
+ print $OUT "\n";
+ print $OUT " ServerName $key\n";
+ print $OUT " ServerAlias $ssldomains{$key}{aliases}\n";
+ print $OUT " DocumentRoot $public_html\n";
+ print $OUT " UseCanonicalName Off\n";
+ print $OUT " \n";
+ print $OUT " AllowOverride All\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " suPHP_UserGroup $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " SuexecUserGroup $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " RMode config\n";
+ print $OUT " RUidGid $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " \n";
+ print $OUT " AssignUserID $config{MESSENGER_USER} $config{MESSENGER_USER}\n";
+ print $OUT " \n";
+ print $OUT " SSLEngine on\n";
+ if (-e $ssldomains{$key}{cert}) {print $OUT " SSLCertificateFile $ssldomains{$key}{cert}\n"}
+ if (-e $ssldomains{$key}{key}) {print $OUT " SSLCertificateKeyFile $ssldomains{$key}{key}\n"}
+ print $OUT " SSLUseStapling off\n";
+ print $OUT " KeepAlive Off\n";
+ print $OUT " \n";
+ }
+ }
+ }
+ close ($OUT);
+
+ system("cp","-f","/var/lib/csf/csf.conf","/etc/apache2/conf.d/csf.messenger.conf");
+
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/sbin/apachectl", "configtest");
+ my @data = <$childout>;
+ waitpid ($cmdpid, 0);
+
+ if (-e "/var/lib/csf/apachectl.error") {unlink("/var/lib/csf/apachectl.error")}
+ my $ok = 0;
+ foreach (@data) {
+ if ($_ =~ /^Syntax OK/) {$ok = 1}
+ }
+ if ($ok) {
+ system("/scripts/restartsrv_httpd");
+ logfile("MESSENGERV2: Started Apache MESSENGERV2 service using /etc/apache2/conf.d/csf.messenger.conf");
+ } else {
+ logfile("*MESSENGERV2*: Unable to generate a valid Apache configuration, see /var/lib/csf/apachectl.error");
+ if (-e "/etc/apache2/conf.d/csf.messenger.conf") {unlink("/etc/apache2/conf.d/csf.messenger.conf")}
+ system("/scripts/restartsrv_httpd");
+
+ open (my $ERROR, ">", "/var/lib/csf/apachectl.error");
+ flock ($ERROR, LOCK_EX);
+ foreach (@data) {print $ERROR $_}
+ close ($ERROR);
+ }
+ return;
+}
+# end messengerv2
+###############################################################################
+# start messengerv3
+sub messengerv3 {
+ my (undef,undef,$uid,$gid,undef,undef,undef,$homedir) = getpwnam($config{MESSENGER_USER});
+ if ($homedir eq "" or $homedir eq "/" or $homedir =~ m[/etc/csf]) {
+ return (1, "The home directory for $config{MESSENGER_USER} is not valid [$homedir]");
+ }
+ if (! -e $homedir) {
+ return (1, "The home directory for $config{MESSENGER_USER} does not exist [$homedir]");
+ }
+ my $public_html = $homedir."/public_html";
+ unless (-e $public_html) {
+ system("mkdir","-p",$public_html);
+ system("chown","$config{MESSENGER_USER}:$config{MESSENGERV3GROUP}",$public_html);
+ system("chmod",$config{MESSENGERV3PERMS},$public_html);
+ }
+ unless (-e $public_html."/.htaccess") {
+ open (my $HTACCESS, ">", $public_html."/.htaccess");
+ flock ($HTACCESS, LOCK_EX);
+ print $HTACCESS <", $homedir."/recaptcha.php");
+ flock ($CONF, LOCK_EX);
+ print $CONF "\n";
+ system("chown","$config{MESSENGER_USER}:$config{MESSENGER_USER}",$homedir."/recaptcha.php");
+ system("chmod","644",$homedir."/recaptcha.php");
+
+ if ($config{MESSENGERV3WEBSERVER} eq "apache") {
+ $webserver = "apache";
+ }
+ elsif ($config{MESSENGERV3WEBSERVER} eq "litespeed") {
+ $webserver = "litespeed";
+ }
+
+ open (my $OUT, ">", "/var/lib/csf/csf.conf");
+ flock ($OUT, LOCK_EX);
+
+ if ($config{MESSENGERV3PHPHANDLER} ne "") {
+ $phphandler = $config{MESSENGERV3PHPHANDLER};
+ } else {
+ my $file = "/etc/httpd/conf/extra/httpd-hostname.conf";
+ if (-e $file) {
+ foreach my $line (slurp($file)) {
+ if ($line =~ /^\s*AddHandler\s+.+\s+\.php/) {
+ $phphandler = $line;
+ if ($config{DEBUG} >= 1) {logfile("SSL: PHP Handler found in [$file]")}
+ }
+ }
+ }
+ }
+
+ foreach my $line (slurp("/usr/local/csf/tpl/$webserver.main.txt")) {
+ $line =~ s/\[PORT\]/$config{MESSENGER_HTML}/g;
+ if ($line =~ /Listen \[::\]:/ and !$config{IPV6}) {next}
+ $line =~ s/\[SERVERNAME\]/$hostname/g;
+ $line =~ s/\[DOCUMENTROOT\]/$public_html/g;
+ $line =~ s/\[DIRECTORY\]/$homedir/g;
+ $line =~ s/\[USER\]/$config{MESSENGER_USER}/g;
+ $line =~ s/\[PHPHANDLER\]/$phphandler/g;
+ print $OUT $line."\n";
+ }
+
+ if ($config{MESSENGER_HTML_IN} ne "") {
+ foreach my $line (slurp("/usr/local/csf/tpl/$webserver.http.txt")) {
+ $line =~ s/\[PORT\]/$config{MESSENGER_HTML}/g;
+ if ($line =~ /Listen \[::\]:/ and !$config{IPV6}) {next}
+ $line =~ s/\[SERVERNAME\]/$hostname/g;
+ $line =~ s/\[DOCUMENTROOT\]/$public_html/g;
+ $line =~ s/\[DIRECTORY\]/$homedir/g;
+ $line =~ s/\[USER\]/$config{MESSENGER_USER}/g;
+ $line =~ s/\[PHPHANDLER\]/$phphandler/g;
+ print $OUT $line."\n";
+ }
+ }
+
+ if ($config{MESSENGER_HTTPS_IN} ne "") {
+ if ($webserver eq "litespeed") {
+ if ($config{MESSENGERV3HTTPS_CONF} =~ /(.*\/lsws\/)/) {
+ $serverroot = $1;
+ }
+ }
+ &conftree($config{MESSENGERV3HTTPS_CONF});
+ if ($webserver eq "litespeed") {
+ if ($sslhost ne "" and $osslcert ne "" and $ssldomains{$sslhost}{cert} eq "") {
+ if (-e $osslcert) {
+ $sslcert = $ssldir."certs/".$sslhost."\.crt";
+ copy($osslcert, $ssldir."certs/".$sslhost."\.crt");
+ }
+ if (-e $osslkey) {
+ $sslkey = $ssldir."keys/".$sslhost."\.key";
+ copy($osslkey, $ssldir."keys/".$sslhost."\.key");
+ }
+ if (-e $osslca) {
+ $sslca = $ssldir."ca/".$sslhost."\.ca";
+ copy($osslca, $ssldir."ca/".$sslhost."\.ca");
+ }
+ $sslaliases =~ s/\$VH_NAME/$sslhost/;
+ $ssldomains{$sslhost}{key} = $sslkey;
+ $ssldomains{$sslhost}{aliases} = $sslaliases;
+ $ssldomains{$sslhost}{cert} = $sslcert;
+ $ssldomains{$sslhost}{ca} = $sslca;
+ push @ssldomainkeys, $sslhost;
+
+ $sslhost = "";
+ $sslcert = "";
+ $sslkey = "";
+ $sslca = "";
+ $osslcert = "";
+ $osslkey = "";
+ $osslca = "";
+ $sslaliases = "";
+ }
+ }
+
+ if (scalar(keys %ssldomains < 1)) {
+ return (1, "No SSL domains found in MESSENGERV3HTTPS_CONF location [$config{MESSENGERV3HTTPS_CONF}] for $webserver web server");
+ }
+
+ my @virtualhost;
+ my $start = 0;
+ my $key = $ssldomainkeys[0];
+ foreach my $line (slurp("/usr/local/csf/tpl/$webserver.https.txt")) {
+ if ($line =~ /^\# Virtualhost start/) {$start = 1}
+ if ($start) {
+ if ($line =~ /^\# Virtualhost end/) {$start = 0}
+ push @virtualhost, $line;
+ next;
+ }
+ $line =~ s/\[SSLPORT\]/$config{MESSENGER_HTTPS}/g;
+ if ($line =~ /Listen \[::\]:/ and !$config{IPV6}) {next}
+ $line =~ s/\[SERVERNAME\]/$hostname/g;
+ $line =~ s/\[DOCUMENTROOT\]/$public_html/g;
+ $line =~ s/\[DIRECTORY\]/$homedir/g;
+ $line =~ s/\[USER\]/$config{MESSENGER_USER}/g;
+ $line =~ s/\[PHPHANDLER\]/$phphandler/g;
+ if ($line =~ /[MAPS]/) {
+ my $mapping;
+ foreach my $map (@ssldomainkeys) {
+ if (-e $ssldomains{$map}{cert}) {
+ $mapping .= "map csfssl.${map} ${map}\n\t";
+ }
+ }
+ $line =~ s/\[MAPS\]/$mapping/g;
+ }
+ if ($line =~ /\[SSLCERTIFICATEFILE\]/) {
+ if ( -e $ssldomains{$key}{cert}) {
+ $line =~ s/\[SSLCERTIFICATEFILE\]/$ssldomains{$key}{cert}/g;
+ } else {next}
+ }
+
+ if ($line =~ /\[SSLCERTIFICATEKEYFILE\]/) {
+ if (-e $ssldomains{$key}{key}) {
+ $line =~ s/\[SSLCERTIFICATEKEYFILE\]/$ssldomains{$key}{key}/g;
+ } else {next}
+ }
+
+ if ($line =~ /\[SSLCACERTIFICATEFILE\]/) {
+ if (-e $ssldomains{$key}{ca}) {
+ $line =~ s/\[SSLCACERTIFICATEFILE\]/$ssldomains{$key}{ca}/g;
+ } else {next}
+ }
+
+ print $OUT $line."\n";
+ }
+
+ foreach my $key (@ssldomainkeys) {
+ if ($key eq "") {next}
+ if ($key =~ /^\s+$/) {next}
+ if ($config{DEBUG} >= 1) {logfile("SSL: Processing [$key]")}
+
+ if (-e $ssldomains{$key}{cert}) {
+ foreach (@virtualhost) {
+ my $line = $_;
+ $line =~ s/\[SSLPORT\]/$config{MESSENGER_HTTPS}/g;
+ $line =~ s/\[SERVERNAME\]/$key/g;
+ $line =~ s/\[SERVERALIAS\]/$ssldomains{$key}{aliases}/g;
+ $line =~ s/\[DOCUMENTROOT\]/$public_html/g;
+ $line =~ s/\[DIRECTORY\]/$homedir/g;
+ $line =~ s/\[USER\]/$config{MESSENGER_USER}/g;
+ $line =~ s/\[PHPHANDLER\]/$phphandler/g;
+
+ if ($line =~ /\[SSLCERTIFICATEFILE\]/) {
+ if ( -e $ssldomains{$key}{cert}) {
+ $line =~ s/\[SSLCERTIFICATEFILE\]/$ssldomains{$key}{cert}/g;
+ } else {next}
+ }
+
+ if ($line =~ /\[SSLCERTIFICATEKEYFILE\]/) {
+ if (-e $ssldomains{$key}{key}) {
+ $line =~ s/\[SSLCERTIFICATEKEYFILE\]/$ssldomains{$key}{key}/g;
+ } else {next}
+ }
+
+ if ($line =~ /\[SSLCACERTIFICATEFILE\]/) {
+ if (-e $ssldomains{$key}{ca}) {
+ $line =~ s/\[SSLCACERTIFICATEFILE\]/$ssldomains{$key}{ca}/g;
+ } else {next}
+ }
+
+ print $OUT $line."\n";
+ }
+ }
+ }
+ }
+ close ($OUT);
+
+ my $location;
+ if (-d $config{MESSENGERV3LOCATION}) {
+ system("cp","-f","/var/lib/csf/csf.conf",$config{MESSENGERV3LOCATION}."/csf.messenger.conf");
+ $location = $config{MESSENGERV3LOCATION}."/csf.messenger.conf";
+ }
+ elsif (-f $config{MESSENGERV3LOCATION}) {
+ my @conf = slurp($config{MESSENGERV3LOCATION});
+ unless (grep {$_ =~ m[^Include /var/lib/csf/csf.conf]i} @conf) {
+ sysopen (my $FILE, $config{MESSENGERV3LOCATION}, O_WRONLY | O_APPEND | O_CREAT);
+ flock ($FILE, LOCK_EX);
+ if ($webserver eq "apache") {
+ print $FILE "Include /var/lib/csf/csf.conf\n";
+ }
+ elsif ($webserver eq "litespeed") {
+ print $FILE "include /var/lib/csf/csf.conf\n";
+ }
+ close ($FILE);
+ }
+ $location = $config{MESSENGERV3LOCATION};
+ }
+ else {
+ logfile("MESSENGERV3: [$config{MESSENGERV3LOCATION}] is neither a directory nor a file. You must manually include /var/lib/csf/csf.conf into the $webserver configuration");
+ return;
+ }
+
+ if ($config{MESSENGERV3TEST} ne "") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, $config{MESSENGERV3TEST});
+ my @data = <$childout>;
+ waitpid ($cmdpid, 0);
+
+ if (-e "/var/lib/csf/messenger.error") {unlink("/var/lib/csf/messenger.error")}
+ my $ok = 0;
+ foreach (@data) {
+ if ($_ =~ /^Syntax OK/) {$ok = 1}
+ }
+ if ($ok) {
+ system($config{MESSENGERV3RESTART});
+ logfile("MESSENGERV3: Restarted $webserver MESSENGERV3 service using $location");
+ } else {
+ open (my $ERROR, ">", "/var/lib/csf/messenger.error");
+ flock ($ERROR, LOCK_EX);
+ foreach (@data) {print $ERROR $_}
+ close ($ERROR);
+
+ if (-d $config{MESSENGERV3LOCATION}) {
+ unlink ($config{MESSENGERV3LOCATION}."/csf.messenger.conf");
+ }
+ elsif (-f $config{MESSENGERV3LOCATION}) {
+ my @conf = slurp($config{MESSENGERV3LOCATION});
+ if (grep {$_ =~ m[^Include /var/lib/csf/csf.conf]i} @conf) {
+ sysopen (my $FILE, $config{MESSENGERV3LOCATION}, O_WRONLY | O_CREAT | O_TRUNC);
+ flock ($FILE, LOCK_EX);
+ foreach my $line (@conf) {
+ $line =~ s/$cleanreg//g;
+ if ($line =~ m[^Include /var/lib/csf/csf.conf]i) {next}
+ print $FILE $line."\n";
+ }
+ close ($FILE);
+ }
+ }
+
+ system($config{MESSENGERV3RESTART});
+
+ logfile("*MESSENGERV3*: Unable to generate a valid $webserver configuration, see /var/lib/csf/messenger.error");
+ }
+ } else {
+ system($config{MESSENGERV3RESTART});
+ logfile("MESSENGERV3: Restarted $webserver MESSENGERV3 service using $location");
+ }
+ return;
+}
+# end messengerv3
+###############################################################################
+# start messengerlog
+sub messengerlog {
+ my $homedir = shift;
+ my $message = shift;
+ if ($config{DEBUG}) {
+ sysopen (my $LOG, "/var/log/lfd_messenger.log", O_WRONLY | O_APPEND | O_CREAT);
+ print $LOG "[$$]: ".$message."\n";
+ close ($LOG);
+ }
+ return;
+}
+# end messengerlog
+###############################################################################
+# start childcleanup
+sub childcleanup {
+ $SIG{INT} = 'IGNORE';
+ $SIG{TERM} = 'IGNORE';
+ $SIG{HUP} = 'IGNORE';
+ my $line = shift;
+ my $message = shift;
+
+ if (($message eq "") and $line) {
+ $message = "Child $childproc: $line";
+ $line = "";
+ }
+
+ $0 = "child - aborting";
+
+ if ($message) {
+ if ($line ne "") {$message .= ", at line $line"}
+ logfile("$message");
+ }
+ exit;
+}
+# end childcleanup
+###############################################################################
+# start getethdev
+sub getethdev {
+ my $ethdev = ConfigServer::GetEthDev->new();
+ my %g_ipv4 = $ethdev->ipv4;
+ my %g_ipv6 = $ethdev->ipv6;
+ foreach my $key (keys %g_ipv4) {
+ my $netip = Net::IP->new($key);
+ my $type = $netip->iptype();
+ if ($type eq "PUBLIC") {$ips{$key} = 1}
+ }
+ if ($config{IPV6}) {
+ foreach my $key (keys %g_ipv6) {
+ if ($key !~ m[::1/128]) {
+ eval {
+ local $SIG{__DIE__} = undef;
+ $ipscidr6->add($key);
+ };
+ }
+ }
+ }
+ return;
+}
+# end getethdev
+###############################################################################
+# start error
+sub error {
+ my $error = shift;
+ logfile($error);
+ exit;
+}
+# end error
+###############################################################################
+# start conftree
+sub conftree {
+ my $fileglob = shift;
+ foreach my $file (glob($fileglob)) {
+ if ($file =~ /csf\.messenger\.conf$/) {next}
+ if ($file =~ /\/var\/lib\/csf\/csf.conf$/) {next}
+ if (-e $file) {
+ if ($config{DEBUG} >= 1) {logfile("SSL: Processing [$file]")}
+ my $start = 0;
+ foreach my $line (slurp($file)) {
+ if ($webserver eq "apache") {
+ $line =~ s/\'|\"//g;
+ if ($line =~ /^\s*ServerRoot\s+\"?(\S+)\"?/) {
+ $serverroot = $1;
+ unless (-d $serverroot) {$serverroot = ""}
+ }
+ if ($serverroot eq "" and -d "/etc/apache2") {$serverroot = "/etc/apache2"}
+ if ($line =~ /^\s*Include\s+(\S+)/) {
+ my $include = $1;
+ if ($include !~ /^\//) {$include = "$serverroot/$include"}
+ if ($config{DEBUG} >= 1) {logfile("SSL: Including [$include]")}
+ &conftree($include);
+ }
+ if ($line =~ /^\s*IncludeOptional\s+(\S+)/) {
+ my $include = $1;
+ if ($include !~ /^\//) {$include = "$serverroot/$include"}
+ if ($config{DEBUG} >= 1) {logfile("SSL: IncludeOptional [$include]")}
+ &conftree($include);
+ }
+ if ($line =~ /^\s*]+>/) {
+ $start = 1;
+ }
+ if ($start) {
+ if ($line =~ /\s*ServerName\s+(\w+:\/\/)?([a-zA-Z0-9\.\-]+)(:\d+)?/) {$sslhost = $2}
+ if ($line =~ /\s*ServerAlias\s+(.*)/) {$sslaliases .= " ".$1}
+ if ($line =~ /\s*SSLCertificateFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {
+ $osslcert = $match;
+ logfile("SSL: Found [$sslhost] certificate in [$file]");
+ }
+ }
+ if ($line =~ /\s*SSLCertificateKeyFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {
+ $osslkey = $match;
+ logfile("SSL: Found [$sslhost] key in [$file]");
+ }
+ }
+ if ($line =~ /\s*SSLCACertificateFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {
+ $osslca = $match;
+ logfile("SSL: Found [$sslhost] ca bundle in [$file]");
+ }
+ }
+ }
+
+ if ($line =~ /^\s*<\/VirtualHost\s*>/) {
+ $start = 0;
+ if ($sslhost ne "" and !checkip($sslhost) and $osslcert ne "") {
+ if (-e $osslcert) {
+ $sslcert = $ssldir."certs/".$sslhost."\.crt";
+ copy($osslcert, $ssldir."certs/".$sslhost."\.crt");
+ }
+ if (-e $osslkey) {
+ $sslkey = $ssldir."keys/".$sslhost."\.key";
+ copy($osslkey, $ssldir."keys/".$sslhost."\.key");
+ }
+ if (-e $osslca) {
+ $sslca = $ssldir."ca/".$sslhost."\.ca";
+ copy($osslca, $ssldir."ca/".$sslhost."\.ca");
+ }
+ $ssldomains{$sslhost}{key} = $sslkey;
+ $ssldomains{$sslhost}{aliases} = $sslaliases;
+ $ssldomains{$sslhost}{cert} = $sslcert;
+ $ssldomains{$sslhost}{ca} = $sslca;
+ push @ssldomainkeys, $sslhost;
+ if ($config{DEBUG} >= 1) {logfile("SSL: Found [$sslhost] in [$file]")}
+ }
+ $sslhost = "";
+ $sslcert = "";
+ $sslkey = "";
+ $sslca = "";
+ $osslcert = "";
+ $osslkey = "";
+ $osslca = "";
+ $sslaliases = "";
+ }
+ }
+ elsif ($webserver eq "litespeed") {
+ $line =~ s/\'|\"//g;
+ if ($line =~ /^\s*include\s+(\S+)/) {
+ my $include = $1;
+ $include =~ s/\$SERVER_ROOT/$serverroot/;
+ $include =~ s/\$VH_NAME/$sslhost/;
+ if ($include !~ /^\//) {$include = "$serverroot/$include"}
+ if ($config{DEBUG} >= 1) {logfile("SSL: include [$include]")}
+ &conftree($include);
+ }
+ if ($line =~ /^\s*configFile\s+(\S+)/) {
+ my $include = $1;
+ $include =~ s/\$SERVER_ROOT/$serverroot/;
+ $include =~ s/\$VH_NAME/$sslhost/;
+ if ($include !~ /^\//) {$include = "$serverroot/$include"}
+ if ($config{DEBUG} >= 1) {logfile("SSL: configFile [$include]")}
+ &conftree($include);
+ }
+ if ($line =~ /^\s*virtualHost\s+([^\{]+)\s+\{/) {
+ my $newsslhost = $1;
+ if ($newsslhost ne "" and $config{DEBUG} >= 1) {logfile("SSL: Found [$newsslhost] in [$file]")}
+ if ($litestart == 1) {
+ if ($sslhost ne "" and $osslcert ne "") {
+ if (-e $osslcert) {
+ $sslcert = $ssldir."certs/".$sslhost."\.crt";
+ copy($osslcert, $ssldir."certs/".$sslhost."\.crt");
+ }
+ if (-e $osslkey) {
+ $sslkey = $ssldir."keys/".$sslhost."\.key";
+ copy($osslkey, $ssldir."keys/".$sslhost."\.key");
+ }
+ if (-e $osslca) {
+ $sslca = $ssldir."ca/".$sslhost."\.ca";
+ copy($osslca, $ssldir."ca/".$sslhost."\.ca");
+ }
+ $sslaliases =~ s/\$VH_NAME/$sslhost/;
+ $ssldomains{$sslhost}{key} = $sslkey;
+ $ssldomains{$sslhost}{aliases} = $sslaliases;
+ $ssldomains{$sslhost}{cert} = $sslcert;
+ $ssldomains{$sslhost}{ca} = $sslca;
+ push @ssldomainkeys, $sslhost;
+
+ $sslhost = "";
+ $sslcert = "";
+ $sslkey = "";
+ $sslca = "";
+ $osslcert = "";
+ $osslkey = "";
+ $osslca = "";
+ $sslaliases = "";
+ }
+ }
+ $litestart = 1;
+ $sslhost = $newsslhost;
+ }
+ if ($litestart) {
+ if ($line =~ /\s*vhDomain\s+(\w+:\/\/)?([a-zA-Z0-9\.\-]+)(:\d+)?/) {$sslhost = $2}
+ if ($line =~ /\s*vhAliases\s+(.*)/) {$sslaliases .= " ".$1}
+ if ($line =~ /\s*certFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {
+ $osslcert = $match;
+ logfile("SSL: Found [$sslhost] certificate in [$file]");
+ }
+ }
+ if ($line =~ /\s*keyFile\s+(\S+)/) {
+ my $match = $1;
+ if (-e $match) {
+ $osslkey = $match;
+ logfile("SSL: Found [$sslhost] key in [$file]");
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return;
+}
+# end conftree
+###############################################################################
+
+1;
diff --git a/src/redux/ConfigServer/Ports.pm b/src/redux/ConfigServer/Ports.pm
new file mode 100644
index 000000000..1e12d2a0e
--- /dev/null
+++ b/src/redux/ConfigServer/Ports.pm
@@ -0,0 +1,213 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::Ports;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use ConfigServer::Config;
+
+use Exporter qw(import);
+our $VERSION = 1.02;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my %printable = ( ( map { chr($_), unpack('H2', chr($_)) } (0..255) ), "\\"=>'\\', "\r"=>'r', "\n"=>'n', "\t"=>'t', "\""=>'"' ); ##no critic
+my %tcpstates = ("01" => "ESTABLISHED",
+ "02" => "SYN_SENT",
+ "03" => "SYN_RECV",
+ "04" => "FIN_WAIT1",
+ "05" => "FIN_WAIT2",
+ "06" => "TIME_WAIT",
+ "07" => "CLOSE",
+ "08" => "CLOSE_WAIT",
+ "09" => "LAST_ACK",
+ "0A" => "LISTEN",
+ "0B" => "CLOSING");
+# end main
+###############################################################################
+# start listening
+sub listening {
+ my %net;
+ my %conn;
+ my %listen;
+
+ foreach my $proto ("tcp","udp","tcp6","udp6") {
+ open (my $IN, "<","/proc/net/$proto");
+ flock ($IN, LOCK_SH);
+ while (<$IN>) {
+ my @rec = split();
+ if ($rec[9] =~ /uid/) {next}
+
+ my ($dip,$dport) = split(/:/,$rec[1]);
+ $dport = hex($dport);
+
+ my ($sip,$sport) = split(/:/,$rec[2]);
+ $sport = hex($sport);
+
+ $dip = &hex2ip($dip);
+ $sip = &hex2ip($sip);
+
+ my $inode = $rec[9];
+ my $state = $tcpstates{$rec[3]};
+ my $protocol = $proto;
+ $protocol =~ s/6//;
+ if ($protocol eq "udp" and $state eq "CLOSE") {$state = "LISTEN"}
+
+ if ($state eq "ESTABLISHED") {$conn{$dport}{$protocol}++}
+
+ if ($dip =~ /^127\./) {next}
+ if ($dip =~ /^0\.0\.0\.1/) {next}
+ if ($state eq "LISTEN") {$net{$inode}{$protocol} = $dport}
+ }
+ close ($IN);
+ }
+
+ opendir (PROCDIR, "/proc");
+ while (my $pid = readdir(PROCDIR)) {
+ if ($pid !~ /^\d+$/) {next}
+ my $exe = readlink("/proc/$pid/exe") || "";
+ my $cwd = readlink("/proc/$pid/cwd") || "";
+ my $uid;
+ my $user;
+
+ if (defined $exe) {$exe =~ s/([\r\n\t\"\\\x00-\x1f\x7F-\xFF])/\\$printable{$1}/sg}
+ open (my $CMDLINE,"<","/proc/$pid/cmdline");
+ flock ($CMDLINE, LOCK_SH);
+ my $cmdline = <$CMDLINE>;
+ close ($CMDLINE);
+ if (defined $cmdline) {
+ chomp $cmdline;
+ $cmdline =~ s/\0$//g;
+ $cmdline =~ s/\0/ /g;
+ $cmdline =~ s/([\r\n\t\"\\\x00-\x1f\x7F-\xFF])/\\$printable{$1}/sg;
+ $cmdline =~ s/\s+$//;
+ $cmdline =~ s/^\s+//;
+ }
+ if ($exe eq "") {next}
+ my @fd;
+ opendir (DIR, "/proc/$pid/fd") or next;
+ while (my $file = readdir (DIR)) {
+ if ($file =~ /^\./) {next}
+ push (@fd, readlink("/proc/$pid/fd/$file"));
+ }
+ closedir (DIR);
+ open (my $STATUS,"<", "/proc/$pid/status") or next;
+ flock ($STATUS, LOCK_SH);
+ my @status = <$STATUS>;
+ close ($STATUS);
+ chomp @status;
+ foreach my $line (@status) {
+ if ($line =~ /^Uid:(.*)/) {
+ my $uidline = $1;
+ my @uids;
+ foreach my $bit (split(/\s/,$uidline)) {
+ if ($bit =~ /^(\d*)$/) {push @uids, $1}
+ }
+ $uid = $uids[-1];
+ $user = getpwuid($uid);
+ if ($user eq "") {$user = $uid}
+ }
+ }
+
+ my $files;
+ my $sockets;
+ foreach my $file (@fd) {
+ if ($file =~ /^socket:\[?([0-9]+)\]?$/) {
+ my $ino = $1;
+ if ($net{$ino}) {
+ foreach my $protocol (keys %{$net{$ino}}) {
+ $listen{$protocol}{$net{$ino}{$protocol}}{$pid}{user} = $user;
+ $listen{$protocol}{$net{$ino}{$protocol}}{$pid}{exe} = $exe;
+ $listen{$protocol}{$net{$ino}{$protocol}}{$pid}{cmd} = $cmdline;
+ $listen{$protocol}{$net{$ino}{$protocol}}{$pid}{cmd} = $cmdline;
+ $listen{$protocol}{$net{$ino}{$protocol}}{$pid}{conn} = $conn{$net{$ino}{$protocol}}{$protocol} | "-";
+ }
+ }
+ }
+ }
+
+ }
+ closedir (PROCDIR);
+ return %listen;
+}
+# end listening
+###############################################################################
+# start openports
+sub openports {
+ my $config = ConfigServer::Config->loadconfig();
+ my %config = $config->config();
+ my %ports;
+
+ $config{TCP_IN} =~ s/\s//g;
+ foreach my $entry (split(/,/,$config{TCP_IN})) {
+ if ($entry =~ /^(\d+):(\d+)$/) {
+ my $from = $1;
+ my $to = $2;
+ for (my $port = $from; $port < $to ; $port++) {
+ $ports{tcp}{$port} = 1;
+ }
+ } else {
+ $ports{tcp}{$entry} = 1;
+ }
+ }
+ $config{TCP6_IN} =~ s/\s//g;
+ foreach my $entry (split(/,/,$config{TCP6_IN})) {
+ if ($entry =~ /^(\d+):(\d+)$/) {
+ my $from = $1;
+ my $to = $2;
+ for (my $port = $from; $port < $to ; $port++) {
+ $ports{tcp6}{$port} = 1;
+ }
+ } else {
+ $ports{tcp6}{$entry} = 1;
+ }
+ }
+ $config{UDP_IN} =~ s/\s//g;
+ foreach my $entry (split(/,/,$config{UDP_IN})) {
+ if ($entry =~ /^(\d+):(\d+)$/) {
+ my $from = $1;
+ my $to = $2;
+ for (my $port = $from; $port < $to ; $port++) {
+ $ports{udp}{$port} = 1;
+ }
+ } else {
+ $ports{udp}{$entry} = 1;
+ }
+ }
+ $config{UDP6_IN} =~ s/\s//g;
+ foreach my $entry (split(/,/,$config{UDP6_IN})) {
+ if ($entry =~ /^(\d+):(\d+)$/) {
+ my $from = $1;
+ my $to = $2;
+ for (my $port = $from; $port < $to ; $port++) {
+ $ports{udp6}{$port} = 1;
+ }
+ } else {
+ $ports{udp6}{$entry} = 1;
+ }
+ }
+ return %ports;
+}
+# end openports
+###############################################################################
+## start hex2ip
+sub hex2ip {
+ my $bin = pack "C*" => map hex, $_[0] =~ /../g;
+ my @l = unpack "L*", $bin;
+ if (@l == 4) {
+ return join ':', map { sprintf "%x:%x", $_ >> 16, $_ & 0xffff } @l;
+ }
+ elsif (@l == 1) {
+ return join '.', map { $_ >> 24, ($_ >> 16 ) & 0xff, ($_ >> 8) & 0xff, $_ & 0xff } @l;
+ }
+}
+## end hex2ip
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/RBLCheck.pm b/src/redux/ConfigServer/RBLCheck.pm
new file mode 100644
index 000000000..cf1558597
--- /dev/null
+++ b/src/redux/ConfigServer/RBLCheck.pm
@@ -0,0 +1,242 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::RBLCheck;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use ConfigServer::Config;
+use ConfigServer::CheckIP qw(checkip);
+use ConfigServer::Slurp qw(slurp);
+use ConfigServer::GetIPs qw(getips);
+use ConfigServer::RBLLookup qw(rbllookup);
+use IPC::Open3;
+use Net::IP;
+use ConfigServer::GetEthDev;
+
+use Exporter qw(import);
+our $VERSION = 1.01;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my ($ui, $failures, $verbose, $cleanreg, $status, %ips, $images, %config,
+ $ipresult, $output);
+
+my $ipv4reg = ConfigServer::Config->ipv4reg;
+my $ipv6reg = ConfigServer::Config->ipv6reg;
+
+# end main
+###############################################################################
+# start report
+sub report {
+ $verbose = shift;
+ $images = shift;
+ $ui = shift;
+ my $config = ConfigServer::Config->loadconfig();
+ %config = $config->config();
+ $cleanreg = ConfigServer::Slurp->cleanreg;
+ $failures = 0;
+
+ $| = 1;
+
+ &startoutput;
+
+ &getethdev;
+
+ my @RBLS = slurp("/usr/local/csf/lib/csf.rbls");
+
+ if (-e "/etc/csf/csf.rblconf") {
+ my @entries = slurp("/etc/csf/csf.rblconf");
+ foreach my $line (@entries) {
+ if ($line =~ /^Include\s*(.*)$/) {
+ my @incfile = slurp($1);
+ push @entries,@incfile;
+ }
+ }
+ foreach my $line (@entries) {
+ $line =~ s/$cleanreg//g;
+ if ($line eq "") {next}
+ if ($line =~ /^\s*\#|Include/) {next}
+ if ($line =~ /^enablerbl:(.*)$/) {
+ push @RBLS, $1;
+ }
+ elsif ($line =~ /^disablerbl:(.*)$/) {
+ my $hit = $1;
+ for (0..@RBLS) {
+ my $x = $_;
+ my ($rbl,$rblurl) = split(/:/,$RBLS[$x],2);
+ if ($rbl eq $hit) {$RBLS[$x] = ""}
+ }
+ }
+ if ($line =~ /^enableip:(.*)$/) {
+ if (checkip(\$1)) {$ips{$1} = 1}
+ }
+ elsif ($line =~ /^disableip:(.*)$/) {
+ if (checkip(\$1)) {delete $ips{$1}}
+ }
+ }
+ }
+ @RBLS = sort @RBLS;
+
+ foreach my $ip (sort keys %ips) {
+ my $netip = Net::IP->new($ip);
+ my $type = $netip->iptype();
+ if ($type eq "PUBLIC") {
+
+ if ($verbose and -e "/var/lib/csf/${ip}.rbls") {
+ unlink "/var/lib/csf/${ip}.rbls";
+ }
+
+ if (-e "/var/lib/csf/${ip}.rbls") {
+ my $text = join("\n",slurp("/var/lib/csf/${ip}.rbls"));
+ if ($ui) {print $text} else {$output .= $text}
+ } else {
+ if ($verbose) {
+ $ipresult = "";
+ my $hits = 0;
+ &addtitle("Checked $ip ($type) on ".localtime());
+
+ foreach my $line (@RBLS) {
+ my ($rbl,$rblurl) = split(/:/,$line,2);
+ if ($rbl eq "") {next}
+
+ my ($rblhit,$rbltxt) = rbllookup($ip,$rbl);
+ my @tmptxt = $rbltxt;
+ $rbltxt = "";
+ foreach my $line (@tmptxt) {
+ $line =~ s/(http(\S+))/$1<\/a>/g;
+ $rbltxt .= "${line}\n";
+ }
+ $rbltxt =~ s/\n/ \n/g;
+
+ if ($rblhit eq "timeout") {
+ &addline(0,$rbl,$rblurl,"TIMEOUT");
+ }
+ elsif ($rblhit eq "") {
+ if ($verbose == 2) {
+ &addline(0,$rbl,$rblurl,"OK");
+ }
+ }
+ else {
+ &addline(1,$rbl,$rblurl,$rbltxt);
+ $hits++;
+ }
+ }
+ unless ($hits) {
+ my $text;
+ $text .= "OK
\n";
+ if ($ui) {print $text} else {$output .= $text}
+ $ipresult .= $text;
+ }
+ sysopen (my $OUT, "/var/lib/csf/${ip}.rbls", O_WRONLY | O_CREAT);
+ flock($OUT, LOCK_EX);
+ print $OUT $ipresult;
+ close ($OUT);
+ } else {
+ &addtitle("New $ip ($type)");
+ my $text;
+ $text .= "Not Checked
\n";
+ if ($ui) {print $text} else {$output .= $text}
+ }
+ }
+ } else {
+ if ($verbose == 2) {
+ &addtitle("Skipping $ip ($type)");
+ my $text;
+ $text .= "OK
\n";
+ if ($ui) {print $text} else {$output .= $text}
+ }
+ }
+ }
+ &endoutput;
+
+ return ($failures,$output);
+}
+# end report
+###############################################################################
+# start startoutput
+sub startoutput {
+ return;
+}
+# end startoutput
+###############################################################################
+# start addline
+sub addline {
+ my $status = shift;
+ my $rbl = shift;
+ my $rblurl = shift;
+ my $comment = shift;
+ my $text;
+ my $check = $rbl;
+ if ($rblurl ne "") {$check = " $rbl "}
+
+ if ($status) {
+ $text .= "\n";
+ $text .= "
$check
\n";
+ $text .= "
$comment
\n";
+ $text .= "
\n";
+ $failures ++;
+ $ipresult .= $text;
+ }
+ elsif ($verbose) {
+ $text .= "\n";
+ $text .= "
$check
\n";
+ $text .= "
$comment
\n";
+ $text .= "
\n";
+ }
+ if ($ui) {print $text} else {$output .= $text}
+
+ return;
+}
+# end addline
+###############################################################################
+# start addtitle
+sub addtitle {
+ my $title = shift;
+ my $text;
+
+ $text .= "$title
\n";
+
+ $ipresult .= $text;
+ if ($ui) {print $text} else {$output .= $text}
+
+ return;
+}
+# end addtitle
+###############################################################################
+# start endoutput
+sub endoutput {
+ if ($ui) {print " \n"} else {$output .= " \n"}
+
+ return;
+}
+# end endoutput
+###############################################################################
+# start getethdev
+sub getethdev {
+ my $ethdev = ConfigServer::GetEthDev->new();
+ my %g_ipv4 = $ethdev->ipv4;
+ my %g_ipv6 = $ethdev->ipv6;
+ foreach my $key (keys %g_ipv4) {
+ $ips{$key} = 1;
+ }
+# if ($config{IPV6}) {
+# foreach my $key (keys %g_ipv6) {
+# eval {
+# local $SIG{__DIE__} = undef;
+# $ipscidr6->add($key);
+# };
+# }
+# }
+
+ return;
+}
+# end getethdev
+###############################################################################
+
+1;
diff --git a/src/redux/ConfigServer/RBLLookup.pm b/src/redux/ConfigServer/RBLLookup.pm
new file mode 100644
index 000000000..e8686c436
--- /dev/null
+++ b/src/redux/ConfigServer/RBLLookup.pm
@@ -0,0 +1,103 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::RBLLookup;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use IPC::Open3;
+use Net::IP;
+use ConfigServer::Config;
+use ConfigServer::CheckIP qw(checkip);
+
+use Exporter qw(import);
+our $VERSION = 1.01;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(rbllookup);
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+my $ipv4reg = ConfigServer::Config->ipv4reg;
+my $ipv6reg = ConfigServer::Config->ipv6reg;
+
+# end main
+###############################################################################
+# start rbllookup
+sub rbllookup {
+ my $ip = shift;
+ my $rbl = shift;
+ my %rblhits;
+ my $netip;
+ my $reversed_ip;
+ my $timeout = 4;
+ my $rblhit;
+ my $rblhittxt;
+
+ if (checkip(\$ip)) {
+ eval {
+ local $SIG{__DIE__} = undef;
+ $netip = Net::IP->new($ip);
+ $reversed_ip = $netip->reverse_ip();
+ };
+
+ if ($reversed_ip =~ /^(\S+)\.in-addr\.arpa/) {$reversed_ip = $1}
+ if ($reversed_ip =~ /^(\S+)\s+(\S+)\.in-addr\.arpa/) {$reversed_ip = $2}
+ if ($reversed_ip =~ /^(\S+)\.ip6\.arpa/) {$reversed_ip = $1}
+ if ($reversed_ip =~ /^(\S+)\s+(\S+)\.ip6\.arpa/) {$reversed_ip = $2}
+
+ if ($reversed_ip ne "") {
+ my $lookup_ip = $reversed_ip.".".$rbl;
+
+ my $cmdpid;
+ eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die};
+ alarm($timeout);
+ my ($childin, $childout);
+ $cmdpid = open3($childin, $childout, $childout, $config{HOST},"-t","A",$lookup_ip);
+ close $childin;
+ my @results = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @results;
+ if ($results[0] =~ /^${reversed_ip}.+ ($ipv4reg|$ipv6reg)$/) {$rblhit = $1}
+ alarm(0);
+ };
+ alarm(0);
+ if ($@) {$rblhit = "timeout"}
+ if ($cmdpid =~ /\d+/ and $cmdpid > 1 and kill(0,$cmdpid)) {kill(9,$cmdpid)}
+
+ if ($rblhit ne "") {
+ if ($rblhit ne "timeout") {
+ my $cmdpid;
+ eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die};
+ alarm($timeout);
+ my ($childin, $childout);
+ $cmdpid = open3($childin, $childout, $childout, $config{HOST},"-t","TXT",$lookup_ip);
+ close $childin;
+ my @results = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @results;
+ foreach my $line (@results) {
+ if ($line =~ /^${reversed_ip}.+ "([^\"]+)"$/) {$rblhittxt .= "$1\n"}
+ }
+ alarm(0);
+ };
+ alarm(0);
+ if ($cmdpid =~ /\d+/ and $cmdpid > 1 and kill(0,$cmdpid)) {kill(9,$cmdpid)}
+ }
+ }
+ }
+ }
+ return ($rblhit,$rblhittxt);
+}
+# end rbllookup
+###############################################################################
+
+1;
diff --git a/src/redux/ConfigServer/RegexMain.pm b/src/redux/ConfigServer/RegexMain.pm
new file mode 100644
index 000000000..6a124ef29
--- /dev/null
+++ b/src/redux/ConfigServer/RegexMain.pm
@@ -0,0 +1,1015 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::RegexMain;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use IPC::Open3;
+use ConfigServer::Config;
+use ConfigServer::CheckIP qw(checkip);
+use ConfigServer::Slurp qw(slurp);
+use ConfigServer::Logger qw(logfile);
+use ConfigServer::GetEthDev;
+
+use Exporter qw(import);
+our $VERSION = 1.03;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+our (%config, %cpconfig, $slurpreg, $cleanreg, %globlogs, %brd, %ips);
+
+my $config = ConfigServer::Config->loadconfig();
+%config = $config->config;
+
+$slurpreg = ConfigServer::Slurp->slurpreg;
+$cleanreg = ConfigServer::Slurp->cleanreg;
+
+if (-e "/etc/wwwacct.conf") {
+ foreach my $line (slurp("/etc/wwwacct.conf")) {
+ $line =~ s/$cleanreg//g;
+ if ($line =~ /^(\s|\#|$)/) {next}
+ my ($name,$value) = split (/ /,$line,2);
+ $cpconfig{$name} = $value;
+ }
+}
+if (-e "/usr/local/cpanel/version") {
+ foreach my $line (slurp("/usr/local/cpanel/version")) {
+ $line =~ s/$cleanreg//g;
+ if ($line =~ /\d/) {$cpconfig{version} = $line}
+ }
+}
+
+if ($config{LF_APACHE_ERRPORT} == 0) {
+ my $apachebin = "";
+ if (-e "/usr/local/apache/bin/httpd") {$apachebin = "/usr/local/apache/bin/httpd"}
+ elsif (-e "/usr/sbin/httpd") {$apachebin = "/usr/sbin/httpd"}
+ elsif (-e "/usr/sbin/apache2") {$apachebin = "/usr/sbin/apache2"}
+ elsif (-e "/usr/sbin/httpd2") {$apachebin = "/usr/sbin/httpd2"}
+ if (-e $apachebin) {
+ my ($childin, $childout);
+ my $mypid = open3($childin, $childout, $childout, $apachebin,"-v");
+ my @version = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @version;
+ $version[0] =~ /Apache\/(\d+)\.(\d+)\.(\d+)/;
+ my $mas = $1;
+ my $maj = $2;
+ my $min = $3;
+ if ("$mas.$maj" < 2.4) {$config{LF_APACHE_ERRPORT} = 1}
+ }
+}
+unless ($config{LF_APACHE_ERRPORT} == 1) {$config{LF_APACHE_ERRPORT} = 2}
+ConfigServer::Logger::logfile("LF_APACHE_ERRPORT: Set to [$config{LF_APACHE_ERRPORT}]");
+
+my $ethdev = ConfigServer::GetEthDev->new();
+%brd = $ethdev->brd;
+%ips = $ethdev->ipv4;
+
+if (-e "/usr/local/csf/bin/regex.custom.pm") {require "/usr/local/csf/bin/regex.custom.pm"} ##no critic
+
+# end main
+###############################################################################
+# start processline
+sub processline {
+ my $line = shift;
+ my $lgfile = shift;
+ my $globlogs_ref = shift;
+ %globlogs = %{$globlogs_ref};
+ $line =~ s/\n//g;
+ $line =~ s/\r//g;
+
+ if (-e "/usr/local/csf/bin/regex.custom.pm") {
+ my ($text,$ip,$app,$trigger,$ports,$temp,$cf) = &custom_line($line,$lgfile);
+ if ($text) {
+ return ($text,$ip,$app,$trigger,$ports,$temp,$cf);
+ }
+ }
+
+#openSSH
+#RH
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: pam_unix\(sshd:auth\): authentication failure; logname=\S* uid=\S* euid=\S* tty=\S* ruser=\S* rhost=(\S+)\s+(user=(\S+))?/)) {
+ my $ip = $3;
+ my $acc = $5;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: Failed none for (\S*) from (\S+) port \S+/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: Failed password for (invalid user |illegal user )?(\S*) from (\S+)( port \S+ \S+\s*)?/)) {
+ my $ip = $5;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: Failed keyboard-interactive(\/pam)? for (invalid user )?(\S*) from (\S+) port \S+/)) {
+ my $ip = $6;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: Invalid user (\S*) from (\S+)/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: User (\S*) from (\S+)\s* not allowed because not listed in AllowUsers/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: Did not receive identification string from (\S+)/)) {
+ my $ip = $3;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: refused connect from (\S+)/)) {
+ my $ip = $3;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: error: maximum authentication attempts exceeded for (\S*) from (\S+)/)) {
+ my $ip = $4;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+
+#Debian/Ubuntu
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: Illegal user (\S*) from (\S+)/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+
+#Gentoo
+ if (($config{LF_SSHD}) and (($lgfile eq "/var/log/messages") or ($lgfile eq "/var/log/secure") or ($globlogs{SSHD_LOG}{$lgfile})) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: error: PAM: Authentication failure for (\S*) from (\S+)/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SSH login from","$ip|$acc","sshd")} else {return}
+ }
+
+#courier-imap
+ if (($config{LF_POP3D}) and ($globlogs{POP3D_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ pop3d(-ssl)?: LOGIN FAILED, user=(\S*), ip=\[(\S+)\]\s*$/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed POP3 login from","$ip|$acc","pop3d")} else {return}
+ }
+ if (($config{LF_IMAPD}) and ($globlogs{IMAPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ imapd(-ssl)?: LOGIN FAILED, user=(\S*), ip=\[(\S+)\]\s*$/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+
+#uw-imap
+ if (($config{LF_POP3D}) and ($globlogs{POP3D_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ ipop3d\[\d+\]: Login failed user=(\S*) auth=\S+ host=\S+ \[(\S+)\]\s*$/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed POP3 login from","$ip|$acc","pop3d")} else {return}
+ }
+ if (($config{LF_IMAPD}) and ($globlogs{IMAPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ imapd\[\d+\]: Login failed user=(\S*) auth=\S+ host=\S+ \[(\S+)\]\s*$/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+
+#dovecot
+ if (($config{LF_POP3D}) and ($globlogs{POP3D_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ dovecot(\[\d+\])?: pop3-login: (Disconnected: )?(Aborted login( by logging out)?|Connection closed|Disconnected|Disconnected: Inactivity)(:\s*\S+\sfailed: Connection reset by peer)?(\s*\(auth failed, \d+ attempts( in \d+ secs)?\))?: (user=(<\S*>)?, )?(method=\S+, )?rip=(\S+), lip=/)) {
+ my $ip = $12;
+ my $acc = $10;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/^<|>$//g;
+ if (checkip(\$ip)) {return ("Failed POP3 login from","$ip|$acc","pop3d")} else {return}
+ }
+ if (($config{LF_IMAPD}) and ($globlogs{IMAPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ dovecot(\[\d+\])?: imap-login: (Disconnected: )?(Aborted login( by logging out)?|Connection closed|Disconnected|Disconnected: Inactivity)(:\s*\S+\sfailed: Connection reset by peer)?(\s*\(auth failed, \d+ attempts( in \d+ secs)?\))?: (user=(<\S*>)?, )?(method=\S+, )?rip=(\S+), lip=/)) {
+ my $ip = $12;
+ my $acc = $10;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/^<|>$//g;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+ if (($config{LF_POP3D}) and ($globlogs{POP3D_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) pop3-login(\[\d+\])?: Info: (Aborted login( by logging out)?|Connection closed|Disconnected|Disconnected: Inactivity)(\s*\(auth failed, \d+ attempts( in \d+ secs)?\))?: (user=(<\S*>)?, )?(method=\S+, )?rip=(\S+), lip=/)) {
+ my $ip = $10;
+ my $acc = $8;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/^<|>$//g;
+ if (checkip(\$ip)) {return ("Failed POP3 login from","$ip|$acc","pop3d")} else {return}
+ }
+ if (($config{LF_IMAPD}) and ($globlogs{IMAPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) imap-login(\[\d+\])?: Info: (Aborted login( by logging out)?|Connection closed|Disconnected|Disconnected: Inactivity)(\s*\(auth failed, \d+ attempts( in \d+ secs)?\))?: (user=(<\S*>)?, )?(method=\S+, )?rip=(\S+), lip=/)) {
+ my $ip = $10;
+ my $acc = $8;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/^<|>$//g;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+
+#Kerio Mailserver
+ if (($config{LF_POP3D}) and ($globlogs{POP3D_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ POP3(\[\d+\])?: User (\S*) doesn\'t exist\. Attempt from IP address (\S+)\s*$/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed POP3 login from","$ip|$acc","pop3d")} else {return}
+ }
+ if (($config{LF_POP3D}) and ($globlogs{POP3D_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ POP3(\[\d+\])?: Invalid password for user (\S*)\. Attempt from IP address (\S+)\s*$/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed POP3 login from","$ip|$acc","pop3d")} else {return}
+ }
+ if (($config{LF_IMAPD}) and ($globlogs{IMAPD_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ IMAP(\[\d+\])?: User (\S*) doesn\'t exist\. Attempt from IP address (\S+)\s*$/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+ if (($config{LF_IMAPD}) and ($globlogs{IMAPD_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ IMAP(\[\d+\])?: Invalid password for user (\S*)\. Attempt from IP address (\S+)\s*$/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+ if (($config{LF_SMTPAUTH}) and ($globlogs{SMTPAUTH_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ smtp(\[\d+\])?: User (\S*) doesn\'t exist\. Attempt from IP address (\S+)\s*$/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+
+#pure-ftpd
+#Nov 10 04:28:04 w212 pure-ftpd[3269638]: (?@152.57.198.52) [WARNING] Authentication failed for user [www]
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ pure-ftpd(\[\d+\])?: \(\?\@(\S+)\) \[WARNING\] Authentication failed for user \[(\S*)\]/)) {
+ my $ip = $3;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ $ip =~ s/\_/\:/g;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+
+#proftpd
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ proftpd\[\d+\]:? \S+ \([^\[]+\[(\S+)\]\)( -)?:? - no such user \'(\S*)\'/)) {
+ my $ip = $2;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/:$//g;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ proftpd\[\d+\]:? \S+ \([^\[]+\[(\S+)\]\)( -)?:? USER (\S*) no such user found from/)) {
+ my $ip = $2;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/:$//g;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ proftpd\[\d+\]:? \S+ \([^\[]+\[(\S+)\]\)( -)?:? - SECURITY VIOLATION/)) {
+ my $ip = $2;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ $acc =~ s/:$//g;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ proftpd\[\d+\]:? \S+ \([^\[]+\[(\S+)\]\)( -)?:? - USER (\S*) \(Login failed\): Incorrect password/)) {
+ my $ip = $2;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/:$//g;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+
+#vsftpd
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^\S+\s+\S+\s+\d+\s+\S+\s+\d+ \[pid \d+] \[(\S+)\] FAIL LOGIN: Client "(\S+)"/)) {
+ my $ip = $2;
+ my $acc = $1;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ vsftpd\[\d+\]: pam_unix\(\S+\): authentication failure; logname=\S*\s+\S+\s+\S+\s+\S+\s+ruser=\S*\s+rhost=(\S+)(\s+user=(\S*))?/)) {
+ my $ip = $2;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ vsftpd\(pam_unix\)\[\d+\]: authentication failure; logname=\S*\s+\S+\s+\S+\s+\S+\s+ruser=\S*\s+rhost=(\S+)(\s+user=(\S*))?/)) {
+ my $ip = $2;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+
+#apache htaccess
+ if (($config{LF_HTACCESS}) and ($globlogs{HTACCESS_LOG}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?error\] (\[pid \d+(:tid \d+)?\] )?\[(client|remote) (\S+)\] (\w+: )?user (\S*)(( not found:)|(: authentication failure for))/)) {
+ my $ip = $5;
+ my $acc = $7;
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ if (checkip(\$ip)) {return ("Failed web page login from","$ip|$acc","htpasswd")} else {return}
+ }
+#nginx
+ if (($config{LF_HTACCESS}) and ($globlogs{HTACCESS_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ \[error\] \S+ \*\S+ no user\/password was provided for basic authentication, client: (\S+),/)) {
+ my $ip = $1;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed web page login from","$ip|$acc","htpasswd")} else {return}
+ }
+ if (($config{LF_HTACCESS}) and ($globlogs{HTACCESS_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ \[error\] \S+ \*\S+ user \"(\S*)\": password mismatch, client: (\S+),/)) {
+ my $ip = $2;
+ my $acc = $1;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed web page login from","$ip|$acc","htpasswd")} else {return}
+ }
+ if (($config{LF_HTACCESS}) and ($globlogs{HTACCESS_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ \[error\] \S+ \*\S+ user \"(\S*)\" was not found in \".*?\", client: (\S+),/)) {
+ my $ip = $2;
+ my $acc = $1;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed web page login from","$ip|$acc","htpasswd")} else {return}
+ }
+
+#cxs Apache
+ if (($config{LF_CXS}) and ($globlogs{MODSEC_LOG}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?error\] (\[pid \d+(:tid \d+)?\] )?\[client (\S+)\]( \[client \S+\])? (\w+: )?ModSecurity:(( \[[^]]+\])*)? Access denied with code \d\d\d \(phase 2\)\. File \"[^\"]*\" rejected by the approver script \"\/etc\/cxs\/cxscgi\.sh\"/)) {
+ my $ip = $4;
+ my $acc = "";
+ my $domain = "";
+ if ($line =~ /\] \[hostname "([^\"]+)"\] \[/) {$domain = $1}
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ if (checkip(\$ip)) {return ("cxs mod_security triggered by","$ip|$acc|$domain","cxs")} else {return}
+ }
+#cxs Litespeed
+ if (($config{LF_CXS}) and ($globlogs{MODSEC_LOG}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?error\] (\[pid \d+(:tid \d+)?\] )?\[client (\S+)\]( \[client \S+\])? (\w+: )?ModSecurity:(( \[[^]]+\])*)? Access denied with code \d\d\d, \[Rule: 'FILES_TMPNAMES' '\@inspectFile \/etc\/cxs\/cxscgi\.sh'\] \[id "1010101"\]/)) {
+ my $ip = $4;
+ my $acc = "";
+ my $domain = "";
+ if ($line =~ /\] \[hostname "([^\"]+)"\] \[/) {$domain = $1}
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ if (checkip(\$ip)) {return ("cxs mod_security triggered by","$ip|$acc|$domain","cxs")} else {return}
+ }
+
+#mod_security v1
+ if (($config{LF_MODSEC}) and ($globlogs{MODSEC_LOG}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[error\] \[client (\S+)\] mod_security: Access denied/)) {
+ my $ip = $1;
+ my $acc = "";
+ my $domain = "";
+ if ($line =~ /\] \[hostname "([^\"]+)"\] \[/) {$domain = $1}
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("mod_security triggered by","$ip|$acc|$domain","mod_security")} else {return}
+ }
+
+#mod_security v2 (apache)
+ if (($config{LF_MODSEC}) and ($globlogs{MODSEC_LOG}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?error\] (\[pid \d+(:tid \d+)?\] )?\[client (\S+)\]( \[client \S+\])? (\w+: )?ModSecurity:(( \[[^]]+\])*)? Access denied/)) {
+ my $ip = $4;
+ my $acc = "";
+ my $domain = "";
+ if ($line =~ /\] \[hostname "([^\"]+)"\] \[/) {$domain = $1}
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ my $ruleid = "unknown";
+ if ($line =~ /\[id "(\d+)"\]/) {$ruleid = $1}
+ if (checkip(\$ip)) {return ("mod_security (id:$ruleid) triggered by","$ip|$acc|$domain","mod_security")} else {return}
+ }
+#mod_security v2 (nginx)
+ if (($config{LF_MODSEC}) and ($globlogs{MODSEC_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ \[\S+\] \S+ \[client (\S+)\] ModSecurity:(( \[[^]]+\])*)? Access denied/)) {
+ my $ip = $1;
+ my $acc = "";
+ my $domain = "";
+ if ($line =~ /\] \[hostname "([^\"]+)"\] \[/) {$domain = $1}
+ $ip =~ s/^::ffff://;
+ my $ruleid = "unknown";
+ if ($line =~ /\[id "(\d+)"\]/) {$ruleid = $1}
+ if (checkip(\$ip)) {return ("mod_security (id:$ruleid) triggered by","$ip|$acc|$domain","mod_security")} else {return}
+ }
+
+#BIND
+ if (($config{LF_BIND}) and ($globlogs{BIND_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ named\[\d+\]: client( \S+)? (\S+)\#\d+(\s\(\S+\))?\:( view external\:)? (update|zone transfer|query \(cache\)) \'[^\']*\' denied$/)) {
+ my $ip = $3;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("bind triggered by","$ip|$acc","bind")} else {return}
+ }
+
+#suhosin
+ if (($config{LF_SUHOSIN}) and ($globlogs{SUHOSIN_LOG}{$lgfile})and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ suhosin\[\d+\]: ALERT - .* \(attacker \'(\S+)\'/)) {
+ my $ip = $2;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if ($line !~ /script tried to increase memory_limit/) {
+ if (checkip(\$ip)) {return ("Suhosin triggered by","$ip|$acc","suhosin")} else {return}
+ }
+ }
+
+#cPanel/WHM
+ if (($config{LF_CPANEL}) and ($globlogs{CPANEL_LOG}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\] \w+ \[\w+] (\S+) - (\S+) \"[^\"]+\" FAILED LOGIN/)) {
+ my $ip = $1;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed cPanel login from","$ip|$acc","cpanel")} else {return}
+ }
+ if (($config{LF_CPANEL}) and ($globlogs{CPANEL_LOG}{$lgfile}) and ($line =~ /^(\S+) - (\S+)? \[\S+ \S+\] \"[^\"]*\" FAILED LOGIN/)) {
+ my $ip = $1;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed cPanel login from","$ip|$acc","cpanel")} else {return}
+ }
+
+#webmin
+ if (($config{LF_WEBMIN}) and ($globlogs{WEBMIN_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ webmin\[\d+\]: Invalid login as (\S+) from (\S+)/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed Webmin login from","$ip|$acc","webmin")} else {return}
+ }
+
+#DirectAdmin
+ if (($config{LF_DIRECTADMIN}) and ($globlogs{DIRECTADMIN_LOG}{$lgfile}) and ($line =~ /^\S+ \'(\S+)\' \d+ (failed login attempts\. Account|failed login attempt on account) \'(\S+)\'/)) {
+ my $ip = $1;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed DirectAdmin login from","$ip|$acc","directadmin")} else {return}
+ }
+ if (($config{LF_DIRECTADMIN}) and ($globlogs{DIRECTADMIN_LOG_R}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\]: (<\S+> )?IMAP Error: Login failed for (\S+) (against \S+ )?from (\S+)\. AUTHENTICATE PLAIN: Authentication failed\. in \/var\/www\/html\/roundcubemail/)) {
+ my $ip = $4;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed DirectAdmin Roundcube login from","$ip|$acc","directadmin")} else {return}
+ }
+ if (($config{LF_DIRECTADMIN}) and ($globlogs{DIRECTADMIN_LOG_S}{$lgfile}) and ($line =~ /^\S+\s+\S+ \[LOGIN_ERROR\] (\S+)( \(\S+\))? from (\S+): Unknown user or password incorrect\.\s*$/)) {
+ my $ip = $3;
+ my $acc = $1;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed DirectAdmin SquirrelMail login from","$ip|$acc","directadmin")} else {return}
+ }
+#Jun 12 10:58:00 phpmyadmin: user denied: bill (mysql-denied) from 192.168.254.10
+ if (($config{LF_DIRECTADMIN}) and ($globlogs{DIRECTADMIN_LOG_P}{$lgfile}) and ($line =~ /^\S+\s+\S+\s+\S+: pma auth user='(\S+)' status='mysql-denied' ip='(\S+)'\s*$/)) {
+ my $ip = $2;
+ my $acc = $1;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed DirectAdmin phpMyAdmin login from","$ip|$acc","directadmin")} else {return}
+ }
+ if (($config{LF_DIRECTADMIN}) and ($globlogs{DIRECTADMIN_LOG_P}{$lgfile}) and ($line =~ /^\S+\s+\S+\s+\S+ phpmyadmin: user denied: (\S+) \(mysql-denied\) from (\S+)\s*$/)) {
+ my $ip = $2;
+ my $acc = $1;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed DirectAdmin phpMyAdmin login from","$ip|$acc","directadmin")} else {return}
+ }
+
+#Exim SMTP AUTH
+ if (($config{LF_SMTPAUTH}) and ($globlogs{SMTPAUTH_LOG}{$lgfile}) and ($line =~ /^\S+\s+\S+\s+(\[\d+\] )?(\S+) authenticator failed for \S+ (\S+ )?\[(\S+)\](:\S*:?)?( I=\S+| \d+\:)? 535 Incorrect authentication data( \(set_id=(\S+)\))?/)) {
+ my $ip = $4;
+ my $acc = $8;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SMTP AUTH login from","$ip|$acc","smtpauth")} else {return}
+ }
+
+#Exim Syntax Errors
+ if (($config{LF_EXIMSYNTAX}) and ($globlogs{SMTPAUTH_LOG}{$lgfile}) and ($line =~ /^\S+\s+\S+\s+(\[\d+\] )?SMTP call from (\S+ )?\[(\S+)\](:\S*:?)?( I=\S+)? dropped: too many syntax or protocol errors/)) {
+ my $ip = $3;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Exim syntax errors from","$ip|$acc","eximsyntax")} else {return}
+ }
+ if (($config{LF_EXIMSYNTAX}) and ($globlogs{SMTPAUTH_LOG}{$lgfile}) and ($line =~ /^\S+\s+\S+\s+(\[\d+\] )?SMTP protocol error in \"[^\"]+\" H=\S+ (\S+ )?\[(\S+)\](:\S*:?)?( I=\S+)? AUTH command used when not advertised/)) {
+ my $ip = $3;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Exim syntax errors from","$ip|$acc","eximsyntax")} else {return}
+ }
+
+#mod_qos
+ if (($config{LF_QOS}) and ($globlogs{HTACCESS_LOG}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?error\] (\[pid \d+(:tid \d+)?\] )?\[client (\S+)\] (\w+: )?mod_qos\(\d+\): access denied,/)) {
+ my $ip = $4;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ if (checkip(\$ip)) {return ("mod_qos triggered by","$ip|$acc","mod_qos")} else {return}
+ }
+
+#Apache symlink race condition
+ if (($config{LF_SYMLINK}) and ($globlogs{MODSEC_LOG}{$lgfile}) and ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?error\] (\[pid \d+(:tid \d+)?\] )?\[client (\S+)\] (\w+: )?Caught race condition abuser/)) {
+ my $ip = $4;
+ my $acc = "";
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ if ($line !~ /\/cgi-sys\/suspendedpage\.cgi$/) {
+ if (checkip(\$ip)) {return ("symlink race condition triggered by","$ip|$acc","symlink")} else {return}
+ }
+ }
+
+#courier-imap (Plesk)
+ if (($config{LF_POP3D}) and ($globlogs{POP3D_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ (courier-)?pop3(?:d|s)(-ssl)?(\[\d+\])?: LOGIN FAILED, user=(\S*), ip=\[(\S+)\]\s*$/)) {
+ my $ip = $6;
+ my $acc = $5;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed POP3 login from","$ip|$acc","pop3d")} else {return}
+ }
+ if (($config{LF_IMAPD}) and ($globlogs{IMAPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ (courier-)?imap(?:d|s)(-ssl)?(\[\d+\])?: LOGIN FAILED, user=(\S*), ip=\[(\S+)\]\s*$/)) {
+ my $ip = $6;
+ my $acc = $5;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+
+#Qmail SMTP AUTH (Plesk)
+ if (($config{LF_SMTPAUTH}) and ($globlogs{SMTPAUTH_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ smtp_auth(?:\[\d+\])?: FAILED: (\S*) - password incorrect from \S+ \[(\S+)\]\s*$/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SMTP AUTH login from","$ip|$acc","smtpauth")} else {return}
+ }
+
+#Postfix SMTP AUTH (Plesk)
+ if (($config{LF_SMTPAUTH}) and ($globlogs{SMTPAUTH_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ postfix\/(submission\/)?smtpd(?:\[\d+\])?: warning: \S+\[(\S+)\]: SASL (?:(?i)LOGIN|PLAIN|(?:CRAM|DIGEST)-MD5) authentication failed/)) {
+ my $ip = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SMTP AUTH login from","$ip","smtpauth")} else {return}
+ }
+
+#InterWorx (dovecot, proftpd, qmail)
+ if (($config{LF_POP3D}) and ($globlogs{POP3D_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) pop3-login(\[\d+\])?: Info: (Aborted login|Disconnected|Disconnected: Inactivity)( \(auth failed, \d+ attempts( in \d+ secs)?\))?: (user=(<\S*>)?, )?(method=\S+, )?rip=(\S+), lip=/)) {
+ my $ip = $9;
+ my $acc = $7;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/^<|>$//g;
+ if (checkip(\$ip)) {return ("Failed POP3 login from","$ip|$acc","pop3d")} else {return}
+ }
+ if (($config{LF_IMAPD}) and ($globlogs{IMAPD_LOG}{$lgfile}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) imap-login(\[\d+\])?: Info: (Aborted login|Disconnected|Disconnected: Inactivity)( \(auth failed, \d+ attempts( in \d+ secs)?\))?: (user=(<\S*>)?, )?(method=\S+, )?rip=(\S+), lip=/)) {
+ my $ip = $9;
+ my $acc = $7;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/^<|>$//g;
+ if (checkip(\$ip)) {return ("Failed IMAP login from","$ip|$acc","imapd")} else {return}
+ }
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ \S+ proftpd\[\d+\]:? \S+ \(\S+?[^\[]+\[(\S+)\]\)( -)?:? USER (\S*): no such user found from/)) {
+ my $ip = $1;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/:$//g;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+ if (($config{LF_FTPD}) and ($globlogs{FTPD_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ \S+ proftpd\[\d+\]:? \S+ \(\S+?[^\[]+\[(\S+)\]\)( -)?:? USER (\S*) \(Login failed\): Incorrect password/)) {
+ my $ip = $1;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ $acc =~ s/:$//g;
+ if (checkip(\$ip)) {return ("Failed FTP login from","$ip|$acc","ftpd")} else {return}
+ }
+ if (($config{LF_SMTPAUTH}) and ($globlogs{SMTPAUTH_LOG}{$lgfile}) and ($line =~ /^\S+ qmail-smtpd\[\d+\]: AUTH failed \[(\S+)\] (\S+)/)) {
+ my $ip = $1;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed SMTP AUTH login from","$ip|$acc","smtpauth")} else {return}
+ }
+ if (($config{LF_INTERWORX}) and ($globlogs{INTERWORX_LOG}{$lgfile}) and ($line =~ /^\S+ \S+ (\S+) (\S+) (\S+)/)) {
+ my $iw = "SiteWorx";
+ if ($1 eq "NW") {$iw = "NodeWorx"}
+ my $ip = $2;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed $iw login from","$ip|$acc","interworx")} else {return}
+ }
+
+# CWP
+ if (($config{LF_CWP}) and ($globlogs{CWP_LOG}{$lgfile}) and ($line =~ /^\S+\s+\S+\s+(\S+)\s+Failed Login from:\s+(\S+) on:/)) {
+ my $ip = $2;
+ my $acc = $1;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed CWP login from","$ip|$acc","cwp")} else {return}
+ }
+# VestaCP
+ if (($config{LF_VESTA}) and ($globlogs{VESTA_LOG}{$lgfile}) and ($line =~ /^\S+\s+\S+\s+(\S+)\s+(\S+) failed to login/)) {
+ my $ip = $2;
+ my $acc = $1;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("Failed VestaCP login from","$ip|$acc","vesta")} else {return}
+ }
+
+}
+# end processline
+###############################################################################
+# start processloginline
+sub processloginline {
+ my $line = shift;
+
+#courier-imap
+ if (($config{LT_POP3D}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ pop3d(-ssl)?: LOGIN, user=(\S*), ip=\[(\S+)\], port=\S+/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("pop3d",$acc,$ip)} else {return}
+ }
+ if (($config{LT_IMAPD}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ imapd(-ssl)?: LOGIN, user=(\S*), ip=\[(\S+)\], port=\S+/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("imapd",$acc,$ip)} else {return}
+ }
+
+#dovecot
+ if (($config{LT_POP3D}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ dovecot(\[\d+\])?: pop3-login: Login: user=<(\S*)>, method=\S+, rip=(\S+), lip=/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("pop3d",$acc,$ip)} else {return}
+ }
+ if (($config{LT_IMAPD}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ dovecot(\[\d+\])?: imap-login: Login: user=<(\S*)>, method=\S+, rip=(\S+), lip=/)) {
+ my $ip = $4;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("imapd",$acc,$ip)} else {return}
+ }
+
+#InterWorx (dovecot)
+ if (($config{LT_POP3D}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) pop3-login: Info: Login: user=<(\S*)>, method=\S+, rip=(\S+), lip=/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("pop3d",$acc,$ip)} else {return}
+ }
+ if (($config{LT_IMAPD}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) imap-login: Info: Login: user=<(\S*)>, method=\S+, rip=(\S+), lip=/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ("imapd",$acc,$ip)} else {return}
+ }
+}
+# end processloginline
+###############################################################################
+# start processsshline
+sub processsshline {
+ my $line = shift;
+
+ if (($config{LF_SSH_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sshd\[\d+\]: Accepted (\S+) for (\S+) from (\S+) port \S+/)) {
+ my $ip = $5;
+ my $acc = $4;
+ my $how = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($acc,$ip,$how)} else {return}
+ }
+}
+# end processsshline
+###############################################################################
+# start processsuline
+sub processsuline {
+ my $line = shift;
+
+#RH + Debian/Ubuntu
+ if (($config{LF_SU_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?su(\[\d+\])?: pam_unix\(su(-l)?:session\): session opened for user\s+(\S+)\s+by\s+(\S+)\s*$/)) {
+ return ($5,$6,"Successful login");
+ }
+ if (($config{LF_SU_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?su(\[\d+\])?: pam_unix\(su(-l)?:auth\): authentication failure; logname=\S*\s+\S+\s+\S+\s+\S+\s+ruser=(\S+)+\s+\S+\s+user=(\S+)\s*$/)) {
+ return ($6,$5,"Failed login");
+ }
+
+ if (($config{LF_SU_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?su(\[\d+\])?: pam_unix\(su(-l)?:session\): session opened for user\s+(\S+)\s+by\s+(\S+)\s*$/)) {
+ return ($5,$6,"Successful login");
+ }
+ if (($config{LF_SU_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?su(\[\d+\])?: pam_unix\(su(-l)?:auth\): authentication failure; logname=\S*\s+\S+\s+\S+\s+\S+\s+ruser=(\S+)+\s+\S+\s+user=(\S+)\s*$/)) {
+ return ($6,$5,"Failed login");
+ }
+
+ if (($config{LF_SU_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?su\(pam_unix\)\[\d+\]: session opened for user\s+(\S+)\s+by\s+(\S+)\s*$/)) {
+ return ($3,$4,"Successful login");
+ }
+ if (($config{LF_SU_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?su\(pam_unix\)\[\d+\]: authentication failure; logname=\S*\s+\S+\s+\S+\s+\S+\s+ruser=(\S+)+\s+\S+\s+user=(\S+)\s*$/)) {
+ return ($4,$3,"Failed login");
+ }
+ return;
+}
+# end processsuline
+###############################################################################
+# start processsudoline
+sub processsudoline {
+ my $line = shift;
+
+ if (($config{LF_SUDO_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sudo(\[\d+\])?: pam_unix\(sudo(-l)?:auth\): authentication failure; logname=\S*\s+\S+\s+\S+\s+\S+\s+ruser=(\S+)+\s+\S+\s+user=(\S+)\s*$/)) {
+ return ($6,$5,"Failed login");
+ }
+ if (($config{LF_SUDO_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sudo\(pam_unix\)\[\d+\]: authentication failure; logname=\S*\s+\S+\s+\S+\s+\S+\s+ruser=(\S+)+\s+\S+\s+user=(\S+)\s*$/)) {
+ return ($4,$3,"Failed login");
+ }
+
+ if (($config{LF_SUDO_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) (\S+ )?sudo(\[\d+\])?:\s+(\S+)\s+:\s+(.*)$/)) {
+ my $from = $4;
+ my @items = split(/\s+;\s+/, $5);
+ if ($items[0] =~ /^TTY/) {
+ if ($items[2] =~ /^USER=(\S+)$/) {
+ return ($1,$from,"Successful login");
+ }
+ }
+ elsif ($items[0] =~ /^user NOT in sudoers/) {
+ if ($items[3] =~ /^USER=(\w+)$/) {
+ return ($1,$from,"Failed login");
+ }
+ }
+ }
+ return;
+}
+# end processsudoline
+###############################################################################
+# start processconsoleline
+sub processconsoleline {
+ my $line = shift;
+
+ if (($config{LF_CONSOLE_EMAIL_ALERT}) and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ login(\[\d+\])?: ROOT LOGIN/)) {
+ return 1;
+ }
+}
+# end processconsoleline
+###############################################################################
+# start processcpanelline
+sub processcpanelline {
+ my $line = shift;
+
+ if ($config{LF_CPANEL_ALERT} and ($line =~ /^(\S+)\s+\-\s+(\w+)\s+\[[^\]]+\]\s\"[^\"]+\"\s200\s/)) {
+ my $ip = $1;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($ip,$acc)} else {return}
+ }
+}
+# end processcpanelline
+###############################################################################
+# start processwebminline
+sub processwebminline {
+ my $line = shift;
+
+ if ($config{LF_WEBMIN_EMAIL_ALERT} and ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ webmin\[\d+\]: Successful login as (\S+) from (\S+)/)) {
+ my $ip = $3;
+ my $acc = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($acc,$ip)} else {return}
+ }
+}
+# end processwebminline
+###############################################################################
+# start scriptlinecheck
+sub scriptlinecheck {
+ my $line = shift;
+
+ if ($config{LF_SCRIPT_ALERT}) {
+ my $fulldir;
+ if ($line =~ /^\S+\s+\S+\s+(\[\d+\]\s)?cwd=(.*) \d+ args:/) {$fulldir = $2}
+ elsif ($line =~ /^\S+\s+\S+\s+(\[\d+\]\s)?\S+ H=localhost (.*)PWD=(.*) REMOTE_ADDR=\S+$/) {$fulldir = $3}
+ if ($fulldir ne "") {
+ my (undef,$dir,undef) = split(/\//,$fulldir);
+ if ($dir eq "home") {return $fulldir}
+ if ($cpconfig{HOMEDIR} and ($fulldir =~ /^$cpconfig{HOMEDIR}/)) {return $fulldir}
+ if ($cpconfig{HOMEMATCH} and ($dir =~ /$cpconfig{HOMEMATCH}/)) {return $fulldir}
+ }
+ }
+}
+# end scriptlinecheck
+###############################################################################
+# start relaycheck
+sub relaycheck {
+ my $line = shift;
+ my $tline = $line;
+ $tline =~ s/".*"/""/g;
+ my @bits =split(/\s+/,$tline);
+ my $ip;
+
+ if ($tline !~ /^\S+\s+\S+\s+(\[\d+\]\s)?\S+ <=/) {return}
+
+#exim
+ if ($tline =~ / U=(\S+) P=local /) {
+ return ($1, "LOCALRELAY");
+ }
+
+ if ($tline =~ / H=[^=]*\[(\S+)\]/) {
+ $ip = $1;
+ unless (checkip(\$ip) or $ip eq "127.0.0.1" or $ip eq "::1") {return}
+ } else {
+ return;
+ }
+
+ if (($tline =~ / A=(courier_plain|courier_login|dovecot_plain|dovecot_login|fixed_login|fixed_plain|login|plain):/) and ($tline =~ / P=(esmtpa|esmtpsa) /)) {
+ return ($ip, "AUTHRELAY");
+ }
+
+ if ($tline =~ / P=(smtp|esmtp|esmtps) /) {
+ return ($ip, "RELAY");
+ }
+
+}
+# end relaycheck
+###############################################################################
+# start pslinecheck
+sub pslinecheck {
+ my $line = shift;
+ if ($line !~ /^(\S+|\S+\s+\d+\s+\S+) \S+ kernel:\s(\[[^\]]+\]\s)?Firewall:/) {return}
+ if ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ kernel:\s(\[[^\]]+\]\s)?Firewall: \*INVALID\*/ and $config{PS_PORTS} !~ /INVALID/) {return}
+
+ if ($line =~ /IN=\S+.*SRC=(\S+).*DST=(\S+).*PROTO=(\w+).*DPT=(\d+)/) {
+ my $ip = $1;
+ my $dst = $2;
+ my $proto = $3;
+ my $port = $4;
+ $ip =~ s/^::ffff://;
+ if ($config{PS_PORTS} !~ /BRD/ and $proto eq "UDP" and $brd{$dst} and !$ips{$dst}) {return}
+ if ($config{PS_PORTS} !~ /OPEN/) {
+ my $hit = 0;
+ if ($proto eq "TCP" and $line =~ /kernel:\s(\[[^\]]+\]\s)?Firewall: \*TCP_IN Blocked\*/) {
+ foreach my $ports (split(/\,/,$config{TCP_IN})) {
+ if ($ports =~ /\:/) {
+ my ($start,$end) = split(/\:/,$ports);
+ if ($port >= $start and $port <= $end) {$hit = 1}
+ }
+ elsif ($port == $ports) {$hit = 1}
+ if ($hit) {last}
+ }
+ if ($hit) {
+ if ($config{DEBUG} >= 1) {ConfigServer::Logger::logfile("debug: *Port Scan* ignored TCP_IN port: $ip:$port")}
+ return;
+ }
+ }
+ elsif ($proto eq "UDP" and $line =~ /kernel:\s(\[[^\]]+\]\s)?Firewall: \*UDP_IN Blocked\*/) {
+ foreach my $ports (split(/\,/,$config{UDP_IN})) {
+ if ($ports =~ /\:/) {
+ my ($start,$end) = split(/\:/,$ports);
+ if ($port >= $start and $port <= $end) {$hit = 1}
+ }
+ elsif ($port == $ports) {$hit = 1}
+ if ($hit) {last}
+ }
+ if ($hit) {
+ if ($config{DEBUG} >= 1) {ConfigServer::Logger::logfile("debug: *Port Scan* ignored UDP_IN port: $ip:$port")}
+ return;
+ }
+ }
+ }
+ if (checkip(\$ip)) {return ($ip,$port)} else {return}
+ }
+ if ($line =~ /IN=\S+.*SRC=(\S+).*PROTO=(ICMP)/) {
+ my $ip = $1;
+ my $port = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($ip,$port)} else {return}
+ }
+ if ($line =~ /IN=\S+.*SRC=(\S+).*PROTO=(ICMPv6)/) {
+ my $ip = $1;
+ my $port = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($ip,$port)} else {return}
+ }
+}
+# end pslinecheck
+###############################################################################
+# start uidlinecheck
+sub uidlinecheck {
+ my $line = shift;
+ if ($line !~ /^(\S+|\S+\s+\d+\s+\S+) \S+ kernel(\[\d+\])?:\s(\[[^\]]+\]\s)?Firewall:/) {return}
+ if ($line =~ /OUT=\S+.*DPT=(\S+).*UID=(\d+)/) {return ($1,$2)}
+}
+# end uidlinecheck
+###############################################################################
+# start portknockingcheck
+sub portknockingcheck {
+ my $line = shift;
+ if ($line !~ /^(\S+|\S+\s+\d+\s+\S+) \S+ kernel(\[\d+\])?:\s(\[[^\]]+\]\s)?Knock: \*\d+_IN\*/) {return}
+
+ if ($line =~ /SRC=(\S+).*DPT=(\d+)/) {
+ my $ip = $1;
+ my $port = $2;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($ip,$port)} else {return}
+ }
+}
+# end portknockingcheck
+###############################################################################
+# start processdistftpline
+sub processdistftpline {
+ my $line = shift;
+#pure-ftpd
+ if ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ pure-ftpd(\[\d+\])?: \(\?\@(\S+)\) \[INFO\] (\S*) is now logged in$/) {
+ my $ip = $3;
+ my $acc = $4;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($ip,$acc)} else {return}
+ }
+#proftpd
+ if ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ proftpd\[\d+\]: \S+ \([^\[]+\[(\S+)\]\) - USER (\S*): Login successful\.\s*$/) {
+ my $ip = $2;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($ip,$acc)} else {return}
+ }
+#InterWorx proftpd
+ if ($line =~ /^\S+ \S+ \S+ proftpd\[\d+\]:? \S+ \(\S+?[^\[]+\[(\S+)\]\)( -)?:? USER (\S*): Login successful/) {
+ my $ip = $1;
+ my $acc = $3;
+ $ip =~ s/^::ffff://;
+ if (checkip(\$ip)) {return ($ip,$acc)} else {return}
+ }
+}
+# end processdistftpline
+###############################################################################
+# start processdistsmtpline
+sub processdistsmtpline {
+ my $line = shift;
+ my $tline = $line;
+ $tline =~ s/".*"/""/g;
+ my @bits =split(/\s+/,$tline);
+ my $ip;
+
+#postfix
+ if ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ postfix\/(submission\/)?smtpd(?:\[\d+\])?: \w+: client=\S+\[(\S+)\], sasl_method=(?:(?i)LOGIN|PLAIN|(?:CRAM|DIGEST)-MD5), sasl_username=(\S+)$/) {
+ $ip = $3; my $account = $4; $ip =~ s/^::ffff://;
+ if (checkip(\$ip) and $ip ne "127.0.0.1" and $ip ne "::1") {return ($ip,$account)} else {return}
+ }
+
+#InterWorx qmail
+ if ($line =~ /^\S+ qmail-smtpd\[\d+\]: AUTH successful \[(\S+)\] (\S+)/) {
+ $ip = $1; my $account = $2; $ip =~ s/^::ffff://;
+ if (checkip(\$ip) and $ip ne "127.0.0.1" and $ip ne "::1") {return ($ip,$account)} else {return}
+ }
+
+#exim
+ if ($tline !~ /^\S+\s+\S+\s+(\[\d+\]\s)?\S+ <=/) {return}
+
+ if ($tline =~ / U=(\S+) P=local /) {return}
+
+ if ($tline =~ / H=[^=]*\[(\S+)\]/) {
+ $ip = $1;
+ unless (checkip(\$ip) or $ip eq "127.0.0.1" or $ip eq "::1") {return}
+ } else {
+ return;
+ }
+
+ if (($tline =~ / A=(courier_plain|courier_login|dovecot_plain|dovecot_login|fixed_login|fixed_plain|login|plain):(\S+)/)){
+ my $account = $2;
+ if (($tline =~ / P=(esmtpa|esmtpsa) /)) {return ($ip, $account)}
+ }
+}
+# end processdistsmtpline
+###############################################################################
+# start loginline404
+sub loginline404 {
+ my $line = shift;
+ if ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?(error|info)\] (\[pid \d+(:tid \d+)?\] )?\[client (\S+)\] (\w+: )?File does not exist\:/) {
+ my $ip = $5;
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ if (checkip(\$ip)) {return ($ip)} else {return}
+ }
+}
+# end loginline404
+###############################################################################
+# start loginline403
+sub loginline403 {
+ my $line = shift;
+ if ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?error\] (\[pid \d+(:tid \d+)?\] )?\[client (\S+)\] (\w+: )?client denied by server configuration\:/) {
+ my $ip = $4;
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ if (checkip(\$ip)) {return ($ip)} else {return}
+ }
+}
+# end loginline403
+###############################################################################
+# start loginline401
+sub loginline401 {
+ my $line = shift;
+ if ($line =~ /^\[\S+\s+\S+\s+\S+\s+\S+\s+\S+\] \[(\S*:)?error\] (\[pid \d+(:tid \d+)?\] )?\[client (\S+)\] (\w+: )?(user not found|user \w+ not found|user \w+: authentication failure for "\/\w+\/")\:/) {
+ my $ip = $4;
+ $ip =~ s/^::ffff://;
+ if ($config{LF_APACHE_ERRPORT} == 2 and $ip =~ /(.*):\d+$/) {$ip = $1}
+ if (checkip(\$ip)) {return ($ip)} else {return}
+ }
+}
+# end loginline401
+###############################################################################
+# start statscheck
+sub statscheck {
+ my $line = shift;
+ if ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ kernel:\s(\[[^\]]+\]\s)?(Firewall|Knock):/) {return 1}
+}
+# end statscheck
+###############################################################################
+# start syslogcheckline
+sub syslogcheckline {
+ my $line = shift;
+ my $syslogcheckcode = shift;
+ if ($line =~ /^(\S+|\S+\s+\d+\s+\S+) \S+ lfd\[\d+\]: SYSLOG check \[(\S+)\]\s*$/) {
+ if ($2 eq $syslogcheckcode) {return 1} else {return}
+ }
+}
+# end syslogcheckline
+###############################################################################
+
+1;
diff --git a/src/redux/ConfigServer/Sanity.pm b/src/redux/ConfigServer/Sanity.pm
new file mode 100644
index 000000000..81a5f290b
--- /dev/null
+++ b/src/redux/ConfigServer/Sanity.pm
@@ -0,0 +1,73 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::Sanity;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use Carp;
+use ConfigServer::Config;
+
+use Exporter qw(import);
+our $VERSION = 1.02;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(sanity);
+
+my %sanity;
+my %sanitydefault;
+my $sanityfile = "/usr/local/csf/lib/sanity.txt";
+
+open (my $IN, "<", $sanityfile);
+flock ($IN, LOCK_SH);
+my @data = <$IN>;
+close ($IN);
+chomp @data;
+foreach my $line (@data) {
+ my ($name,$value,$def) = split(/\=/,$line);
+ $sanity{$name} = $value;
+ $sanitydefault{$name} = $def;
+}
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+
+if ($config{IPSET}) {
+ delete $sanity{"DENY_IP_LIMIT"};
+ delete $sanitydefault{"DENY_IP_LIMIT"};
+}
+
+# end main
+###############################################################################
+# start sanity
+sub sanity {
+ my $sanity_item = shift;
+ my $sanity_value = shift;
+ my $insane = 0;
+
+ $sanity_item =~ s/\s//g;
+ $sanity_value =~ s/\s//g;
+
+ if (defined $sanity{$sanity_item}) {
+ $insane = 1;
+ foreach my $check (split(/\|/,$sanity{$sanity_item})) {
+ if ($check =~ /-/) {
+ my ($from,$to) = split(/\-/,$check);
+ if (($sanity_value >= $from) and ($sanity_value <= $to)) {$insane = 0}
+
+ } else {
+ if ($sanity_value eq $check) {$insane = 0}
+ }
+ }
+ $sanity{$sanity_item} =~ s/\|/ or /g;
+ }
+ return ($insane,$sanity{$sanity_item},$sanitydefault{$sanity_item});
+}
+# end sanity
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/Sendmail.pm b/src/redux/ConfigServer/Sendmail.pm
new file mode 100644
index 000000000..e0956499f
--- /dev/null
+++ b/src/redux/ConfigServer/Sendmail.pm
@@ -0,0 +1,166 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::Sendmail;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Carp;
+use POSIX qw(strftime);
+use Fcntl qw(:DEFAULT :flock);
+use ConfigServer::Config;
+use ConfigServer::CheckIP qw(checkip);
+
+use Exporter qw(import);
+our $VERSION = 1.02;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+my $tz = strftime("%z", localtime);
+my $hostname;
+if (-e "/proc/sys/kernel/hostname") {
+ open (my $IN, "<", "/proc/sys/kernel/hostname");
+ flock ($IN, LOCK_SH);
+ $hostname = <$IN>;
+ chomp $hostname;
+ close ($IN);
+} else {
+ $hostname = "unknown";
+}
+
+if ($config{LF_ALERT_SMTP}) {
+ require Net::SMTP;
+ import Net::SMTP;
+}
+
+# end main
+###############################################################################
+# start sendmail
+sub relay {
+ my ($to, $from, @message) = @_;
+ my $time = localtime(time);
+ if ($to eq "") {$to = $config{LF_ALERT_TO}} else {$config{LF_ALERT_TO} = $to}
+ if ($from eq "") {$from = $config{LF_ALERT_FROM}} else {$config{LF_ALERT_FROM} = $from}
+ my $data;
+
+ if ($from =~ /([\w\.\=\-\_]+\@[\w\.\-\_]+)/) {$from = $1}
+ if ($from eq "") {$from = "root"}
+ if ($to =~ /([\w\.\=\-\_]+\@[\w\.\-\_]+)/) {$to = $1}
+ if ($to eq "") {$to = "root"}
+
+ my $header = 1;
+ foreach my $line (@message) {
+ $line =~ s/\r//;
+ if ($line eq "") {$header = 0}
+ $line =~ s/\[time\]/$time $tz/ig;
+ $line =~ s/\[hostname\]/$hostname/ig;
+ if ($header) {
+ if ($line =~ /^To:\s*(.*)\s*$/i) {
+ my $totxt = $1;
+ if ($config{LF_ALERT_TO} ne "") {
+ $line =~ s/^To:.*$/To: $config{LF_ALERT_TO}/i;
+ } else {
+ $to = $totxt;
+ }
+ }
+ if ($line =~ /^From:\s*(.*)\s*$/i) {
+ my $fromtxt = $1;
+ if ($config{LF_ALERT_FROM} ne "") {
+ $line =~ s/^From:.*$/From: $config{LF_ALERT_FROM}/i;
+ } else {
+ $from = $1;
+ }
+ }
+ }
+ $data .= $line."\n";
+ }
+
+ $data = &wraptext($data, 990);
+
+ if ($config{LF_ALERT_SMTP}) {
+ if ($from !~ /\@/) {$from .= '@'.$hostname}
+ if ($to !~ /\@/) {$to .= '@'.$hostname}
+ my $smtp = Net::SMTP->new($config{LF_ALERT_SMTP}, Timeout => 10) or carp("Unable to send SMTP alert via [$config{LF_ALERT_SMTP}]: $!");
+ if (defined $smtp) {
+ $smtp->mail($from);
+ $smtp->to($to);
+ $smtp->data();
+ $smtp->datasend($data);
+ $smtp->dataend();
+ $smtp->quit();
+ }
+ } else {
+ local $SIG{CHLD} = 'DEFAULT';
+ my $error = 0;
+ open (my $MAIL, "|-", "$config{SENDMAIL} -f $from -t") or carp("Unable to send SENDMAIL alert via [$config{SENDMAIL}]: $!");
+ print $MAIL $data;
+ close ($MAIL) or $error = 1;
+ if ($error and $config{DEBUG}) {
+ logfile("Failed to send message via sendmail binary: $?");
+ logfile("Failed message: [$data]");
+ }
+ }
+
+ return;
+}
+# end sendmail
+###############################################################################
+# start wraptext
+sub wraptext {
+ my $text = shift;
+ my $column = shift;
+ my $original = $text;
+ my $return = "";
+ my $hit = 1;
+ my $loop = 0;
+ while ($hit) {
+ $hit = 0;
+ $return = "";
+ foreach my $line (split(/\n/, $text)) {
+ if (length($line) > $column) {
+ foreach ($line =~ /(.{1,$column})/g) {
+ my $chunk = $_;
+ my $newchunk = "";
+ my $thishit = 0;
+ my @chars = split(//,$chunk);
+ for (my $x = length($chunk)-1;$x >= 0; $x--) {
+ if ($chars[$x] =~ /\s/) {
+ for (0..$x) {$newchunk .= $chars[$_]}
+ $newchunk .= "\n";
+ for ($x+1..length($chunk)-1) {$newchunk .= $chars[$_]}
+ $thishit = 1;
+ last;
+ }
+ }
+ if ($thishit) {
+ $hit = 1;
+ $thishit = 0;
+ $return .= $newchunk;
+ } else {
+ $return .= $chunk."\n";
+ }
+ }
+ } else {
+ $return .= $line."\n";
+ }
+ }
+ $text = $return;
+ $loop++;
+ if ($loop > 1000) {
+ return $original;
+ last;
+ }
+ }
+ if (length($return) < length($original)) {$return = $original}
+ return $return;
+}
+# end wraptext
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/ServerCheck.pm b/src/redux/ConfigServer/ServerCheck.pm
new file mode 100644
index 000000000..df09f1718
--- /dev/null
+++ b/src/redux/ConfigServer/ServerCheck.pm
@@ -0,0 +1,1762 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::ServerCheck;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use File::Basename;
+use IPC::Open3;
+use ConfigServer::Slurp qw(slurp);
+use ConfigServer::Sanity qw(sanity);;
+use ConfigServer::Config;
+use ConfigServer::GetIPs qw(getips);
+use ConfigServer::CheckIP qw(checkip);
+use ConfigServer::Service;
+use ConfigServer::GetEthDev;
+
+use Exporter qw(import);
+our $VERSION = 1.05;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my (%config, $cpconf, %daconfig, $cleanreg, $mypid, $childin, $childout,
+ $verbose, $cpurl, @processes, $total, $failures, $current, $DEBIAN,
+ $output, $sysinit, %g_ifaces, %g_ipv4, %g_ipv6);
+
+my $ipv4reg = ConfigServer::Config->ipv4reg;
+my $ipv6reg = ConfigServer::Config->ipv6reg;
+
+use Exporter qw(import);
+# end main
+###############################################################################
+# start report
+sub report {
+ $verbose = shift;
+ my $config = ConfigServer::Config->loadconfig();
+ %config = $config->config();
+ $cleanreg = ConfigServer::Slurp->cleanreg;
+ $| = 1;
+
+ if (defined $ENV{WEBMIN_VAR} and defined $ENV{WEBMIN_CONFIG}) {
+ $config{GENERIC} = 1;
+ $config{DIRECTADMIN} = 0;
+ }
+ elsif (-e "/usr/local/cpanel/version") {
+ use lib "/usr/local/cpanel";
+ require Cpanel::Form;
+ import Cpanel::Form;
+ require Cpanel::Config;
+ import Cpanel::Config;
+ $cpconf = Cpanel::Config::loadcpconf();
+ }
+ elsif (-e "/usr/local/directadmin/conf/directadmin.conf") {
+ my ($childin, $childout);
+ my $mypid = open3($childin, $childout, $childout, "/usr/local/directadmin/directadmin", "c");
+ my @data = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @data;
+ foreach my $line (@data) {
+ my ($name,$value) = split(/\=/,$line);
+ $daconfig{lc($name)} = $value;
+ }
+ $config{DIRECTADMIN} = 1;
+ }
+ elsif (-e "/etc/psa/psa.conf") {
+ $config{PLESK} = 1;
+ }
+
+ $failures = 0;
+ $total = 0;
+ if ($ENV{cp_security_token}) {$cpurl = $ENV{cp_security_token}}
+ $DEBIAN = 0;
+ if (-e "/etc/lsb-release" or -e "/etc/debian_version") {$DEBIAN = 1}
+
+ $sysinit = ConfigServer::Service::type();
+ if ($sysinit ne "systemd") {$sysinit = "init"}
+
+ opendir (PROCDIR, "/proc");
+ while (my $pid = readdir(PROCDIR)) {
+ if ($pid !~ /^\d+$/) {next}
+ push @processes, readlink("/proc/$pid/exe");
+ }
+
+ my $ethdev = ConfigServer::GetEthDev->new();
+ %g_ifaces = $ethdev->ifaces;
+ %g_ipv4 = $ethdev->ipv4;
+ %g_ipv6 = $ethdev->ipv6;
+
+ &startoutput;
+
+ &firewallcheck;
+ &servercheck;
+ &sshtelnetcheck;
+ unless ($config{DNSONLY} or $config{GENERIC}) {&mailcheck}
+ unless ($config{DNSONLY} or $config{GENERIC}) {&apachecheck}
+ unless ($config{DNSONLY} or $config{GENERIC}) {&phpcheck}
+ unless ($config{DNSONLY} or $config{GENERIC}) {&whmcheck}
+ if ($config{DIRECTADMIN}) {
+ &mailcheck;
+ &apachecheck;
+ &phpcheck;
+ &dacheck;
+ }
+ &servicescheck;
+
+ &endoutput;
+ return $output;
+}
+# end report
+###############################################################################
+# start startoutput
+sub startoutput {
+ if ($config{THIS_UI} and !$config{GENERIC}) {
+ $output .= "Note: Internal WHM links will not work within the csf Integrated UI
\n";
+ }
+
+ return;
+}
+# end startoutput
+###############################################################################
+# start addline
+sub addline {
+ my $status = shift;
+ my $check = shift;
+ my $comment = shift;
+ $total++;
+
+ if ($status) {
+ $output .= "\n";
+ $output .= "
$check
\n";
+ $output .= "
$comment
\n";
+ $output .= "
\n";
+ $failures ++;
+ $current++;
+ }
+ elsif ($verbose) {
+ $output .= "\n";
+ $output .= "
$check
\n";
+ $output .= "
$comment
\n";
+ $output .= "
\n";
+ $current++;
+ }
+ return;
+}
+# end addline
+###############################################################################
+# start addtitle
+sub addtitle {
+ my $title = shift;
+ if (defined $current and $current == 0) {
+ $output .= "OK
\n";
+ }
+ $current = 0;
+ $output .= "$title
\n";
+ return;
+}
+# end addtitle
+###############################################################################
+# start endoutput
+sub endoutput {
+ if (defined $current and $current == 0) {
+ $output .= "OK
\n";
+ }
+ $output .= " \n";
+
+ my $gap = int(($total-3)/4);
+ my $score = ($total - $failures);
+ my $width = int ((400 / $total) * $score) - 4;
+ $output .= " \n\n\n";
+ $output .= "
Server Score: $score/$total* \n";
+ $output .= "
\n";
+ $output .= "
\n";
+ $output .= "\n";
+ $output .= " \n";
+ $output .= " \n";
+ $output .= " \n";
+ $output .= " $total (max) \n";
+ $output .= " \n";
+ $output .= "
\n";
+ $output .= "
\n";
+ $output .= "
\n";
+ $output .= "
\n";
+ $output .= "\n";
+ $output .= " \n";
+ $output .= " \n";
+ $output .= " $score (score) \n";
+ $output .= " \n";
+ $output .= "
\n";
+ $output .= "
\n";
+ $output .= "
* This scoring does not necessarily reflect the security of the server or the relative merits of each check
";
+ $output .= "
";
+ return;
+}
+# end endoutput
+###############################################################################
+# start firewallcheck
+sub firewallcheck {
+ &addtitle("Firewall Check");
+ my $status = 0;
+ open (my $IN, "<", "/etc/csf/csf.conf");
+ flock ($IN, LOCK_SH);
+ my @config = <$IN>;
+ chomp @config;
+
+ foreach my $line (@config) {
+ if ($line =~ /^\#/) {next}
+ if ($line !~ /=/) {next}
+ my ($name,$value) = split (/=/,$line,2);
+ $name =~ s/\s//g;
+ if ($value =~ /\"(.*)\"/) {
+ $value = $1;
+ } else {
+ &error(__LINE__,"Invalid configuration line");
+ }
+ $config{$name} = $value;
+ }
+
+ $status = 0;
+ if (-e "/etc/csf/csf.disable") {$status = 1}
+ &addline($status,"csf enabled check","csf is currently disabled and should be enabled otherwise it is not functioning");
+
+ if (-x $config{IPTABLES}) {
+ my ($childin, $childout);
+ my $mypid = open3($childin, $childout, $childout, "$config{IPTABLES} $config{IPTABLESWAIT} -L INPUT -n");
+ my @iptstatus = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @iptstatus;
+ if ($iptstatus[0] =~ /# Warning: iptables-legacy tables present/) {shift @iptstatus}
+ $status = 0;
+ if ($iptstatus[0] =~ /policy ACCEPT/) {$status = 1}
+ &addline($status,"csf running check","iptables is not configured. You need to start csf");
+ }
+
+ $status = 0;
+ if ($config{TESTING}) {$status = 1}
+ &addline($status,"TESTING mode check","csf is in TESTING mode. If the firewall is working set TESTING to \"0\" in the Firewall Configuration otherwise it will continue to be stopped");
+
+ $status = 0;
+ unless ($config{RESTRICT_SYSLOG}) {$status = 1}
+ &addline($status,"RESTRICT_SYSLOG option check","Due to issues with syslog/rsyslog you should consider enabling this option. See the Firewall Configuration (/etc/csf/csf.conf) for more information");
+
+ $status = 0;
+ unless ($config{AUTO_UPDATES}) {$status = 1}
+ &addline($status,"AUTO_UPDATES option check","To keep csf up to date and secure you should enable AUTO_UPDATES. You should also monitor our blog ");
+
+ $status = 0;
+ unless ($config{LF_DAEMON}) {$status = 1}
+ &addline($status,"lfd enabled check","lfd is disabled in the csf configuration which limits the affectiveness of this application");
+
+ $status = 0;
+ if ($config{TCP_IN} =~ /\b3306\b/) {$status = 1}
+ &addline($status,"Incoming MySQL port check","The TCP incoming MySQL port (3306) is open. This can pose both a security and server abuse threat since not only can hackers attempt to break into MySQL, any user can host their SQL database on your server and access it from another host and so (ab)use your server resources");
+
+ unless ($config{DNSONLY} or $config{GENERIC}) {
+ unless ($config{VPS}) {
+ $status = 0;
+ unless ($config{SMTP_BLOCK}) {$status = 1}
+ &addline($status,"SMTP_BLOCK option check","This option will help prevent the most common form of spam abuse on a server that bypasses exim and sends spam directly out through port 25. Enabling this option will prevent any web script from sending out using socket connection, such scripts should use the exim or sendmail binary instead");
+ }
+
+ $status = 0;
+ unless ($config{LF_SCRIPT_ALERT}) {$status = 1}
+ &addline($status,"LF_SCRIPT_ALERT option check","This option will notify you when a large amount of email is sent from a particular script on the server, helping track down spam scripts");
+ }
+
+ $status = 0;
+ my @options = ("LF_SSHD","LF_FTPD","LF_SMTPAUTH","LF_POP3D","LF_IMAPD","LF_HTACCESS","LF_MODSEC","LF_CPANEL","LF_CPANEL_ALERT","SYSLOG_CHECK","RESTRICT_UI");
+ if ($config{GENERIC}) {@options = ("LF_SSHD","LF_FTPD","LF_SMTPAUTH","LF_POP3D","LF_IMAPD","LF_HTACCESS","LF_MODSEC","SYSLOG_CHECK","FASTSTART","RESTRICT_UI");}
+ if ($config{DNSONLY}) {@options = ("LF_SSHD","LF_CPANEL","SYSLOG_CHECK","FASTSTART","RESTRICT_UI")}
+
+ foreach my $option (@options) {
+ $status = 0;
+ unless ($config{$option}) {$status = 1}
+ &addline($status,"$option option check","This option helps prevent brute force attacks on your server services or overall server stability");
+ }
+
+ $status = 0;
+ unless ($config{LF_DIRWATCH}) {$status = 1}
+ &addline($status,"LF_DIRWATCH option check","This option will notify when a suspicious file is found in one of the common temp directories on the server");
+
+ $status = 0;
+ unless ($config{LF_INTEGRITY}) {$status = 1}
+ &addline($status,"LF_INTEGRITY option check","This option will notify when an executable in one of the common directories on the server changes in some way. This helps alert you to potential rootkit installation or server compromise");
+
+ $status = 0;
+ unless ($config{FASTSTART}) {$status = 1}
+ &addline($status,"FASTSTART option check","This option can dramatically improve the startup time of csf and the rule loading speed of lfd");
+
+ $status = 0;
+ if ($config{URLGET} == 1) {$status = 1}
+ &addline($status,"URLGET option check","This option determines which perl module is used to upgrade csf. It is recommended to set this to use LWP rather than HTTP::Tiny so that upgrades are performed over an SSL connection");
+
+ $status = 0;
+ if ($config{PT_USERKILL} == 1) {$status = 1}
+ &addline($status,"PT_USERKILL option check","This option should not normally be enabled as it can easily lead to legitimate processes being terminated, use csf.pignore instead");
+
+ unless ($config{DNSONLY} or $config{GENERIC}) {
+ $status = 0;
+ if ($config{PT_SKIP_HTTP}) {$status = 1}
+ &addline($status,"PT_SKIP_HTTP option check","This option disables checking of processes running under apache and can limit false-positives but may then miss running exploits");
+ }
+
+ $status = 0;
+ if (!$config{LF_IPSET} and !$config{VPS} and ($config{CC_DENY} or $config{CC_ALLOW} or $config{CC_ALLOW_FILTER} or $config{CC_ALLOW_PORTS} or $config{CC_DENY_PORTS})) {$status = 1}
+ &addline($status,"LF_IPSET option check","If support by your OS, you should install ipset and enable LF_IPSET when using Country Code (CC_*) filters");
+
+ unless ($config{DNSONLY} or $config{GENERIC}) {
+ $status = 0;
+ unless ($config{PT_ALL_USERS}) {$status = 1}
+ &addline($status,"PT_ALL_USERS option check","This option ensures that almost all Linux accounts are checked with Process Tracking, not just the cPanel ones");
+ }
+
+ sysopen (my $CONF, "/etc/csf/csf.conf", O_RDWR | O_CREAT);
+ flock ($CONF, LOCK_SH);
+ my @confdata = <$CONF>;
+ close ($CONF);
+ chomp @confdata;
+
+ foreach my $line (@confdata) {
+ if (($line !~ /^\#/) and ($line =~ /=/)) {
+ my ($start,$end) = split (/=/,$line,2);
+ my $name = $start;
+ $name =~ s/\s/\_/g;
+ if ($end =~ /\"(.*)\"/) {$end = $1}
+ my ($insane,$range,$default) = sanity($start,$end);
+ if ($insane) {
+ &addline(1,"$start sanity check","$start = $end. Recommended range: $range (Default: $default)");
+ }
+ }
+ }
+ return;
+}
+# end firewallcheck
+###############################################################################
+# start servercheck
+sub servercheck {
+ &addtitle("Server Check");
+ my $status = 0;
+
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat("/tmp");
+ my $pmode = sprintf "%03o", $mode & oct("07777");
+
+ $status = 0;
+ if ($pmode != 1777) {$status = 1}
+ &addline($status,"Check /tmp permissions","/tmp should be chmod 1777");
+
+ $status = 0;
+ if (($uid != 0) or ($gid != 0)) {$status = 1}
+ &addline($status,"Check /tmp ownership","/tmp should be owned by root:root");
+
+ if (-d "/var/tmp") {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat("/var/tmp");
+ $pmode = sprintf "%04o", $mode & oct("07777");
+
+ $status = 0;
+ if ($pmode != 1777) {$status = 1}
+ &addline($status,"Check /var/tmp permissions","/var/tmp should be chmod 1777");
+
+ $status = 0;
+ if (($uid != 0) or ($gid != 0)) {$status = 1}
+ &addline($status,"Check /var/tmp ownership","/var/tmp should be owned by root:root");
+ }
+
+ if (-d "/usr/tmp") {
+ ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat("/usr/tmp");
+ $pmode = sprintf "%04o", $mode & oct("07777");
+
+ $status = 0;
+ if ($pmode != 1777) {$status = 1}
+ &addline($status,"Check /usr/tmp permissions","/usr/tmp should be chmod 1777");
+
+ $status = 0;
+ if (($uid != 0) or ($gid != 0)) {$status = 1}
+ &addline($status,"Check /usr/tmp ownership","/usr/tmp should be owned by root:root");
+ }
+
+ $status = 0;
+ if (&getportinfo(53)) {
+ my @files = ("/var/named/chroot/etc/named.conf","/etc/named.conf","/etc/bind/named.conf","/var/named/chroot/etc/bind/named.conf");
+ my @namedconf;
+ my @morefiles;
+ my $hit;
+ foreach my $file (@files) {
+ if (-e $file) {
+ $hit = 1;
+ open (my $IN, "<", "$file");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ if (my @ls = grep {$_ =~ /^\s*include\s+(.*)\;\s*$/i} @conf) {
+ foreach my $more (@ls) {
+ if ($more =~ /^\s*include\s+\"(.*)\"\s*\;\s*$/i) {push @morefiles, $1}
+ }
+ }
+ @namedconf = (@namedconf, @conf);
+ }
+ }
+ foreach my $file (@morefiles) {
+ if (-e $file) {
+ open (my $IN, "<", "$file");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ @namedconf = (@namedconf, @conf);
+ }
+ }
+
+ if ($hit) {
+# if (my @ls = grep {$_ =~ /^\s*(recursion\s+no|allow-recursion)/} @namedconf) {$status = 0} else {$status = 1}
+# &addline($status,"Check for DNS recursion restrictions","You have a local DNS server running but do not appear to have any recursion restrictions set. This is a security and performance risk and you should look at restricting recursive lookups to the local IP addresses only");
+
+ if (my @ls = grep {$_ =~ /^\s*(query-source\s[^\;]*53)/} @namedconf) {$status = 1} else {$status = 0}
+ &addline($status,"Check for DNS random query source port","ISC recommend that you do not configure BIND to use a static query port. You should remove/disable the query-source line that specifies port 53 from the named configuration files");
+ }
+ }
+
+ if (!$DEBIAN and $sysinit eq "init" and -x "/sbin/runlevel") {
+ $status = 0;
+ $mypid = open3($childin, $childout, $childout, "/sbin/runlevel");
+ my @conf = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @conf;
+ my (undef,$runlevel) = split(/\s/,$conf[0]);
+ if ($runlevel != 3) {$status = 1}
+ &addline($status,"Check server runlevel","The servers runlevel is currently set to $runlevel. For a secure server environment you should only run the server at runlevel 3. You can fix this by editing /etc/inittab and changing the initdefault line to:id:3:initdefault: and then rebooting the server");
+ }
+
+ $status = 0;
+ if ((-e "/var/spool/cron/nobody") and !(-z "/var/spool/cron/nobody")) {$status = 1}
+ &addline($status,"Check nobody cron","You have a nobody cron log file - you should check that this has not been created by an exploit");
+
+ $status = 0;
+ my ($isfedora, $isrh, $version, $conf) = 0;
+ if (-e "/etc/fedora-release") {
+ open (my $IN, "<", "/etc/fedora-release");
+ flock ($IN, LOCK_SH);
+ $conf = <$IN>;
+ close ($IN);
+ $isfedora = 1;
+ if ($conf =~ /release (\d+)/i) {$version = $1}
+ } elsif (-e "/etc/redhat-release") {
+ open (my $IN, "<", "/etc/redhat-release");
+ flock ($IN, LOCK_SH);
+ $conf = <$IN>;
+ close ($IN);
+ $isrh = 1;
+ if ($conf =~ /release (\d+)/i) {$version = $1}
+ }
+ chomp $conf;
+
+ if ($isrh or $isfedora) {
+ if (($isfedora and $version < 30) or ($isrh and $version < 6)) {$status = 1}
+ &addline($status,"Check Operating System support","You are running an OS - $conf - that is no longer supported by the OS vendor, or is about to become obsolete. This means that you will be receiving no OS updates (i.e. application or security bug fixes) or kernel updates and should consider moving to an OS that is supported as soon as possible");
+ }
+
+ $status = 0;
+ if ($] < 5.008008) {
+ $status = 1;
+ } else {$status = 0}
+ &addline($status,"Check perl version","The version of perl (v$]) is out of date and you should upgrade it");
+
+ $status = 0;
+ while (my ($name,undef,$uid) = getpwent()) {
+ if (($uid == 0) and ($name ne "root")) {$status = 1}
+ }
+ &addline($status,"Check SUPERUSER accounts","You have accounts other than root set up with UID 0. This is a considerable security risk. You should use su , or best of all sudo for such access");
+
+ if (-e "/usr/local/cpanel/version" or $config{DIRECTADMIN}) {
+ $status = 0;
+ unless (-e "/etc/cxs/cxs.pl") {
+ $status = 1;
+ }
+ &addline($status,"Check for cxs","You should consider using cxs to scan web script uploads and user accounts for exploits uploaded to the server");
+ $status = 0;
+ unless (-e "/etc/osm/osmd.pl") {
+ $status = 1;
+ }
+ &addline($status,"Check for osm","You should consider using osm to provide protection from spammers exploiting the server");
+ }
+
+ unless ($config{IPV6}) {
+ $status = 0;
+ my $ipv6 = "";
+ foreach my $key (keys %g_ipv6) {
+ if ($ipv6) {$ipv6 .= ", "}
+ $ipv6 .= $key;
+ $status = 1;
+ }
+ if ($ipv6 eq "::1") {$ipv6 = ""; $status = 0}
+ &addline($status,"Check for IPv6","IPv6 appears to be enabled [$ipv6 ]. If ip6tables is installed, you should enable the csf IPv6 firewall (IPV6 in csf.conf)");
+ }
+
+ if ($sysinit eq "init") {
+ $status = 1;
+ my $syslog = 0;
+ if (grep {$_ =~ /\/syslogd\s*/} @processes) {
+ $syslog = 1;
+ if (grep {$_ =~ /\/klogd$/} @processes) {$status = 0}
+ &addline($status,"Check for kernel logger","syslogd appears to be running, but not klogd which logs kernel firewall messages to syslog. You should ensure that klogd is running");
+ }
+ if (grep {$_ =~ /\/rsyslogd\s*/} @processes) {
+ $syslog = 1;
+ if (grep {$_ =~ /\/rklogd\s*/} @processes) {
+ $status = 0;
+ } else {
+ open (my $IN, "<", "/etc/rsyslog.conf");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ if (grep {$_ =~ /^\$ModLoad imklog/} @conf) {$status = 0}
+ }
+ &addline($status,"Check for kernel logger","rsyslogd appears to be running, but klog may not be loaded which logs kernel firewall messages to rsyslog. You should modify /etc/rsyslogd to load the klog module with:\$ModLoad imklog Then restart rsyslog");
+ }
+ unless ($syslog) {
+ $status = 1;
+ &addline($status,"Check for syslog or rsyslog","Neither syslog nor rsyslog appear to be running");
+ }
+ }
+
+ $status = 0;
+ if (grep {$_ =~ /\/dhclient\s*/} @processes) {$status = 1}
+ &addline($status,"Check for dhclient","dhclient appears to be running which suggests that the server is obtaining an IP address via DHCP. This can pose a security risk. You should configure static IP addresses for all ethernet controllers");
+
+ unless ($config{VPS}) {
+ $status = 1;
+ open (my $IN, "<", "/proc/swaps");
+ flock ($IN, LOCK_SH);
+ my @swaps = <$IN>;
+ close ($IN);
+ if (scalar(@swaps) > 1) {$status = 0}
+ &addline($status,"Check for swap file","The server appears to have no swap file. This is usually considered a stability and performance risk. You should either add a swap partition, or create one via a normal file on an existing partition ");
+
+ if (-e "/etc/redhat-release") {
+ open (my $IN, "<", "/etc/redhat-release");
+ flock ($IN, LOCK_SH);
+ $conf = <$IN>;
+ close ($IN);
+ chomp $conf;
+
+ if ($conf =~ /^CloudLinux/i) {
+ $status = 0;
+ if (-e "/usr/sbin/cagefsctl") {
+ } else {$status = 1}
+ &addline($status,"CloudLinux CageFS","CloudLinux CageFS is not installed. This CloudLinux option greatly improves server security on we servers by separating user accounts into their own environment");
+
+ unless ($status) {
+ $status = 0;
+ $mypid = open3($childin, $childout, $childout, "/usr/sbin/cagefsctl","--cagefs-status");
+ my @conf = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @conf;
+ if ($conf[0] !~ /^Enabled/) {$status = 1}
+ &addline($status,"CloudLinux CageFS Enabled","CloudLinux CageFS is not enabled. This CloudLinux option greatly improves server security on we servers by separating user accounts into their own environment");
+ }
+
+ $status = 0;
+ open (my $ENFORCE_SYMLINKSIFOWNER, "<", "/proc/sys/fs/enforce_symlinksifowner");
+ flock ($ENFORCE_SYMLINKSIFOWNER, LOCK_SH);
+ $conf = <$ENFORCE_SYMLINKSIFOWNER>;
+ close ($ENFORCE_SYMLINKSIFOWNER);
+ chomp $conf;
+ if ($conf < 1) {$status = 1}
+ &addline($status,"CloudLinux Symlink Protection","CloudLinux Symlink Protection is not configured. You should configure it in /etc/sysctl.conf to prevent symlink attacks on web servers");
+
+ $status = 0;
+ open (my $PROC_CAN_SEE_OTHER_UID, "<", "/proc/sys/fs/proc_can_see_other_uid");
+ flock ($PROC_CAN_SEE_OTHER_UID, LOCK_SH);
+ $conf = <$PROC_CAN_SEE_OTHER_UID>;
+ close ($PROC_CAN_SEE_OTHER_UID);
+ chomp $conf;
+ if ($conf > 0) {$status = 1}
+ &addline($status,"CloudLinux Virtualised /proc","CloudLinux Virtualised /proc is not configured. You should configure it in /etc/sysctl.conf to prevent users accessing server resources that they do not need on web servers");
+
+ $status = 0;
+ open (my $USER_PTRACE, "<", "/proc/sys/kernel/user_ptrace");
+ flock ($USER_PTRACE, LOCK_SH);
+ $conf = <$USER_PTRACE>;
+ close ($USER_PTRACE);
+ chomp $conf;
+ if ($conf > 0) {$status = 1}
+ &addline($status,"CloudLinux Disable ptrace","CloudLinux Disable ptrace is not configured. You should configure it in /etc/sysctl.conf to prevent users accessing server resources that they do not need on web servers");
+ }
+ }
+ }
+ return;
+}
+# end servercheck
+###############################################################################
+# start whmcheck
+sub whmcheck {
+ my $status = 0;
+ &addtitle("WHM Settings Check");
+
+ $status = 0;
+ unless ($cpconf->{alwaysredirecttossl}) {$status = 1}
+ &addline($status,"Check cPanel login is SSL only","You should check WHM > Tweak Settings > Choose the closest matched domain for which that the system has a valid certificate when redirecting from non-SSL to SSL URLs ");
+
+ $status = 0;
+ unless ($cpconf->{skipboxtrapper}) {$status = 1}
+ &addline($status,"Check boxtrapper is disabled","Having boxtrapper enabled can very easily lead to your server being listed in common RBLs and usually has the effect of increasing the overall spam load, not reducing it. You should disable it in WHM > Tweak Settings > BoxTrapper Spam Trap ");
+
+ $status = 0;
+ if (-e "/var/cpanel/greylist/enabled") {$status = 1}
+ &addline($status,"Check GreyListing is disabled","Using GreyListing can and will lead to lost legitimate emails. It can also cause significant problems with \"password verification\" systems. See here for more information");
+
+ if (defined $cpconf->{popbeforesmtp}) {
+ $status = 0;
+ if ($cpconf->{popbeforesmtp}) {$status = 1}
+ &addline($status,"Check popbeforesmtp is disabled","Using pop before smtp is considered a security risk, SMTP AUTH should be used instead. You should disable it in WHM > Tweak Settings > Allow users to relay mail if they use an IP address through which someone has validated an IMAP or POP3 login ");
+ }
+
+ $status = 0;
+ unless ($cpconf->{maxemailsperhour}) {$status = 1}
+ &addline($status,"Check max emails per hour is set","To limit the damage that can be caused by potential spammers on the server you should set a value for WHM > Tweak Settings > Max hourly emails per domain ");
+
+ $status = 0;
+ if ($cpconf->{resetpass}) {$status = 1}
+ &addline($status,"Check Reset Password for cPanel accounts","This poses a potential security risk and should be disabled unless necessary in WHM > Tweak Settings > Reset Password for cPanel accounts ");
+
+ $status = 0;
+ if ($cpconf->{resetpass_sub}) {$status = 1}
+ &addline($status,"Check Reset Password for Subaccounts","This poses a potential security risk and should be disabled unless necessary in WHM > Tweak Settings > Reset Password for Subaccounts ");
+
+ foreach my $openid (glob "/var/cpanel/authn/openid_connect/*") {
+ open (my $IN, "<", $openid);
+ flock ($IN, LOCK_SH);
+ my $line = <$IN>;
+ close ($IN);
+ chomp $line;
+
+ my ($file, $filedir) = fileparse($openid);
+ $status = 0;
+ if ($line =~ /\{"cpanelid"/) {$status = 1}
+ &addline($status,"Check cPanelID for $file","You should only enable this option if you are going to use it otherwise it is a potential security risk in WHM > Manage External Authentications > $file ");
+ }
+
+ unless ($cpconf->{nativessl} eq undef) {
+ $status = 0;
+ unless ($cpconf->{nativessl}) {$status = 1}
+ &addline($status,"Check whether native cPanel SSL is enabled","You should enable this option so that lfd tracks SSL cpanel login attempts WHM > Tweak Settings > Use native SSL support if possible, negating need for Stunnel ");
+ }
+
+ $status = 0;
+ my $cc = '/usr/bin/cc';
+ while ( readlink($cc) ) {
+ $cc = readlink($cc);
+ }
+ if ( $cc !~ /^\// ) { $cc = '/usr/bin/' . $cc; }
+ my $mode = substr( sprintf( "%o", ( ( stat($cc) )[2] ) ), 2, 4 );
+ if ( $mode > 750 ) {$status = 1}
+ &addline($status,"Check compilers","You should disable compilers WHM > Security Center > Compilers Access ");
+
+ if (-e "/etc/pure-ftpd.conf" and ($cpconf->{ftpserver} eq "pure-ftpd") and !(-e "/etc/ftpddisable")) {
+ $status = 0;
+ open (my $IN, "<", "/etc/pure-ftpd.conf");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ if (my @ls = grep {$_ =~ /^\s*NoAnonymous\s*(no|off)/i} @conf) {$status = 1}
+ &addline($status,"Check Anonymous FTP Logins","Used as an attack vector by hackers and should be disabled unless actively used WHM > FTP Server Configuration > Allow Anonymous Logins > No ");
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^\s*AnonymousCantUpload\s*(no|off)/i} @conf) {$status = 1}
+ &addline($status,"Check Anonymous FTP Uploads","Used as an attack vector by hackers and should be disabled unless actively used WHM > FTP Server Configuration > Allow Anonymous Uploads > No ");
+
+ $status = 0;
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^\s*TLSCipherSuite/} @conf) {
+ if ($ls[0] =~ /TLSCipherSuite\s+(.*)$/) {$ciphers = $1}
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ }
+ elsif ($ciphers !~ /SSL/) {
+ $status = 0
+ } else {
+ if (-x "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check pure-ftpd weak SSL/TLS Ciphers (TLSCipherSuite)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ &addline($status,"Check pure-ftpd weak SSL/TLS Ciphers (TLSCipherSuite)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should disable SSLv2 in WHM > FTP Server Configuration > TLS Cipher Suite > Remove +SSLv2 or Add -SSLv2 ");
+
+ $status = 0;
+ unless (-e "/var/cpanel/conf/pureftpd/root_password_disabled") {$status = 1}
+ &addline($status,"Check FTP Logins with Root Password","Allowing root login via FTP is a considerable security risk and should be disabled WHM > FTP Server Configuration > Allow Logins with Root Password > No ");
+ }
+
+ if (-e "/var/cpanel/conf/proftpd/main" and ($cpconf->{ftpserver} eq "proftpd") and !(-e "/etc/ftpddisable")) {
+ $status = 0;
+ open (my $IN, "<", "/var/cpanel/conf/proftpd/main");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ if (my @ls = grep {$_ =~ /^cPanelAnonymousAccessAllowed: 'yes'/i} @conf) {$status = 1}
+ &addline($status,"Check Anonymous FTP Logins","Used as an attack vector by hackers and should be disabled unless actively used WHM > FTP Server Configuration > Allow Anonymous Logins > No ");
+
+ $status = 0;
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^\s*TLSCipherSuite/} @conf) {
+ if ($ls[0] =~ /TLSCipherSuite\:\s+(.*)$/) {$ciphers = $1}
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ } else {
+ if (-e "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check proftpd weak SSL/TLS Ciphers (TLSCipherSuite)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ &addline($status,"Check proftpd weak SSL/TLS Ciphers (TLSCipherSuite)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should disable SSLv2 in WHM > FTP Server Configuration > TLS Cipher Suite > Remove +SSLv2 or Add -SSLv2 ");
+
+ if ($config{VPS}) {
+ $status = 0;
+ open (my $IN, "<", "/etc/proftpd.conf");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ if (my @ls = grep {$_ =~ /^\s*PassivePorts\s+(\d+)\s+(\d+)/} @conf) {
+ if ($config{TCP_IN} !~ /\b$1:$2\b/) {$status = 1}
+ } else {$status = 1}
+ &addline($status,"Check VPS FTP PASV hole","Since the Virtuozzo VPS iptables ip_conntrack_ftp kernel module is currently broken you have to open a PASV port hole in iptables for incoming FTP connections to work correctly. See the csf readme.txt under 'A note about FTP Connection Issues' on how to do this");
+ }
+ }
+
+ $status = 0;
+ if ($cpconf->{allowremotedomains}) {$status = 1}
+ &addline($status,"Check allow remote domains","User can park domains that resolve to other servers on this server. You should disable WHM > Tweak Settings > Allow Remote Domains");
+
+ $status = 0;
+ unless ($cpconf->{blockcommondomains}) {$status = 1}
+ &addline($status,"Check block common domains","User can park common domain names on this server. You should disable WHM > Tweak Settings > Prevent cPanel users from creating specific domains");
+
+ $status = 0;
+ if ($cpconf->{allowparkonothers}) {$status = 1}
+ &addline($status,"Check allow park domains","User can park/addon domains that belong to other users on this server. You should disable WHM > Tweak Settings > Allow cPanel users to create subdomains across accounts");
+
+ $status = 0;
+ if ($cpconf->{proxysubdomains}) {$status = 1}
+ &addline($status,"Check proxy subdomains","This option can mask a users real IP address and hinder security. You should disable WHM > Tweak Settings > Service subdomains");
+
+ $status = 1;
+ if ($cpconf->{cpaddons_notify_owner}) {$status = 0}
+ &addline($status,"Check cPAddons update email to resellers","You should have cPAddons email users if cPAddon installations require updating WHM > Tweak Settings > Notify reseller of cPAddons Site Software installations");
+
+ $status = 1;
+ if ($cpconf->{cpaddons_notify_root}) {$status = 0}
+ &addline($status,"Check cPAddons update email to root","You should have cPAddons email root if cPAddon installations require updating WHM > Tweak Settings > Notify root of cPAddons Site Software installations");
+
+ if (-e "/etc/cpupdate.conf") {
+ open (my $IN, "<", "/etc/cpupdate.conf");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^CPANEL=(edge|beta|nightly)/i} @conf) {$status = 1}
+ &addline($status,"Check cPanel tree","Running EDGE/BETA on a production server could lead to server instability");
+
+ $status = 1;
+ if (my @ls = grep {$_ =~ /^UPDATES=daily/i} @conf) {$status = 0}
+ &addline($status,"Check cPanel updates","You have cPanel updating disabled, this can pose a security and stability risk. WHM > Update Preferences > Enabled Automatic Updates ");
+
+# $status = 0;
+# if (grep {$_ =~ /^SYSUP=/i} @conf) {$status = 1}
+# if (grep {$_ =~ /^SYSUP=daily/i} @conf) {$status = 0}
+# &addline($status,"Check package updates","You have package updating disabled, this can pose a security and stability risk. WHM > Update Config >cPanel Package Updates > Automatic ");
+
+# $status = 1;
+# if (my @ls = grep {$_ =~ /^RPMUP=daily/i} @conf) {$status = 0}
+# &addline($status,"Check security updates","You have security updating disabled, this can pose a security and stability risk. WHM > Update Config >Operating System Package Updates > Automatic ");
+ } else {&addline(1,"Check cPanel updates","Unable to find /etc/cpupdate.conf");}
+
+ $status = 1;
+ if ($cpconf->{account_login_access} eq "user") {$status = 0}
+ &addline($status,"Check accounts that can access a cPanel user","You should consider setting this option to \"user\" after use. WHM > Tweak Settings > Accounts that can access a cPanel user account");
+
+ unless ($status) {
+ $status = 0;
+ open (my $IN, "<", "/usr/local/cpanel/3rdparty/etc/php.ini");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ if (my @ls = grep {$_ =~ /^\s*register_globals\s*=\s*on/i} @conf) {$status = 1}
+ &addline($status,"Check cPanel php.ini file for register_globals","PHP register_globals is considered a high security risk. It is currently enabled in /usr/local/cpanel/3rdparty/etc/php.ini and should be disabled (disabling may break 3rd party PHP cPanel apps)");
+ }
+
+ $status = 0;
+ if ($cpconf->{emailpasswords}) {$status = 1}
+ &addline($status,"Check cPanel passwords in email","You should not send passwords out in plain text emails. You should disable WHM > Tweak Settings > Send passwords when creating a new account");
+
+ $status = 0;
+ if ($cpconf->{coredump}) {$status = 1}
+ &addline($status,"Check core dumps","You should disable WHM > Tweak Settings > Allow WHM/Webmail/cPanel services to create core dumps for debugging purposes");
+
+ $status = 1;
+ if ($cpconf->{cookieipvalidation} eq "strict") {$status = 0}
+ &addline($status,"Check Cookie IP Validation","You should enable strict Cookie IP validation in WHM > Tweak Settings > Cookie IP validation");
+
+ $status = 1;
+ if ($cpconf->{use_apache_md5_for_htaccess}) {$status = 0}
+ &addline($status,"Check MD5 passwords with Apache","You should enable WHM > Tweak Settings > Use MD5 passwords with Apache");
+
+ $status = 1;
+ if ($cpconf->{referrerblanksafety}) {$status = 0}
+ &addline($status,"Check Referrer Blank Security","You should enable WHM > Tweak Settings > Blank referrer safety check");
+
+ $status = 1;
+ if ($cpconf->{referrersafety}) {$status = 0}
+ &addline($status,"Check Referrer Security","You should enable WHM > Tweak Settings > Referrer safety check");
+
+ $status = 1;
+ if ($cpconf->{skiphttpauth}) {$status = 0}
+ &addline($status,"Check HTTP Authentication","You should disable skiphttpauth in /var/cpanel/cpanel.config");
+
+ $status = 0;
+ if ($cpconf->{skipparentcheck}) {$status = 1}
+ &addline($status,"Check Parent Security","You should disable WHM > Tweak Settings > Allow other applications to run the cPanel and admin binaries");
+
+ $status = 0;
+ if ($cpconf->{"cpsrvd-domainlookup"}) {$status = 1}
+ &addline($status,"Check Domain Lookup Security","You should disable WHM > Tweak Settings > cpsrvd username domain lookup");
+
+ $status = 1;
+ if ($cpconf->{"cgihidepass"}) {$status = 0}
+ &addline($status,"Check Password ENV variable","You should enable WHM > Tweak Settings > Hide login password from cgi scripts ");
+
+ $status = 0;
+ if (-e "/var/cpanel/smtpgidonlytweak") {$status = 1}
+ &addline($status,"Check SMTP Restrictions","This option in WHM will not function when running csf. You should disable WHM > Security Center > SMTP Restrictions and use the csf configuration option SMTP_BLOCK instead");
+
+ if (-e "/etc/wwwacct.conf") {
+ $status = 1;
+ open (my $IN, "<", "/etc/wwwacct.conf");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+
+ my %ips;
+ foreach my $key (keys %g_ipv4) {
+ $ips{$key} = 1;
+ }
+
+ my $nameservers;
+ my $local = 0;
+ my $allns = 0;
+ foreach my $line (@conf) {
+ if ($line =~ /^NS(\d)?\s+(.*)\s*$/) {
+ my $ns = $2;
+ $ns =~ s/\s//g;
+ if ($ns) {
+ $allns++;
+ $nameservers .= "$ns \n";
+ my $ip;
+ if (checkip(\$ns)) {
+ $ip = $ns;
+ if ($ips{$ip}) {$local++}
+ } else {
+ my @ips = getips($ns);
+ unless (scalar @ips) {&addline(1,"Check nameservers","Unable to resolve nameserver [$ns]")}
+ my $hit = 0;
+ foreach my $oip (@ips) {
+ if ($ips{$oip}) {$hit = 1}
+ }
+ if ($hit) {$local++}
+ }
+ }
+ }
+ }
+ if ($local < $allns) {$status = 0}
+ &addline($status,"Check nameservers","At least one of the configured nameservers: \n$nameservers should be located in a topologically and geographically dispersed location on the Internet - See RFC 2182 (Section 3.1)");
+ }
+
+ if (-e "/usr/local/cpanel/bin/register_appconfig") {
+ $status = 0;
+ if ($cpconf->{permit_unregistered_apps_as_reseller}) {$status = 1}
+ &addline($status,"Check AppConfig Required","You should disable WHM > Tweak Settings > Allow apps that have not registered with AppConfig to be run when logged in as a reseller in WHM");
+
+ $status = 0;
+ if ($cpconf->{permit_unregistered_apps_as_root}) {$status = 1}
+ &addline($status,"Check AppConfig as root","You should disable WHM > Tweak Settings > Allow apps that have not registered with AppConfig to be run when logged in as root or a reseller with the \"all\" ACL in WHM");
+
+ $status = 0;
+ if ($cpconf->{permit_appconfig_entries_without_acls}) {$status = 1}
+ &addline($status,"Check AppConfig ACLs","You should disable WHM > Tweak Settings > Allow WHM apps registered with AppConfig to be executed even if a Required ACLs list has not been defined");
+
+ $status = 0;
+ if ($cpconf->{permit_appconfig_entries_without_features}) {$status = 1}
+ &addline($status,"Check AppConfig Feature List","You should disable WHM > Tweak Settings > Allow cPanel and Webmail apps registered with AppConfig to be executed even if a Required Features list has not been defined");
+ }
+
+ $status = 0;
+ if ($cpconf->{"disable-security-tokens"}) {$status = 1}
+ &addline($status,"Check Security Tokens","Security Tokens should not be disabled as without them security of WHM/cPanel is compromised. The setting disable-security-tokens=0 should be set in /var/cpanel/cpanel.config");
+ return;
+}
+# end whmcheck
+###############################################################################
+# start dacheck
+sub dacheck {
+ my $status = 0;
+ &addtitle("DirectAdmin Settings Check");
+
+ $status = 0;
+ unless ($daconfig{ssl}) {$status = 1}
+ &addline($status,"Check DirectAdmin login is SSL only","You should enable SSL only login to DirectAdmin ");
+
+ if (($daconfig{ftpconfig} =~ /proftpd.conf/) and ($daconfig{pureftp} != 1)) {
+ $status = 0;
+ open (my $IN, "<", $daconfig{ftpconfig});
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^\s*TLSCipherSuite/} @conf) {
+ if ($ls[0] =~ /TLSCipherSuite\s+(.*)$/) {$ciphers = $1}
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ } else {
+ if (-e "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check proftpd weak SSL/TLS Ciphers (TLSCipherSuite)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ &addline($status,"Check proftpd weak SSL/TLS Ciphers (TLSCipherSuite)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should add a TLSCipherSuite with SSLv2 disabled in $daconfig{ftpconfig}. For example,<IfModule mod_tls.c> TLSCipherSuite HIGH </IfModule> container ");
+
+ if ($config{VPS}) {
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^\s*PassivePorts\s+(\d+)\s+(\d+)/} @conf) {
+ if ($config{TCP_IN} !~ /\b$1:$2\b/) {$status = 1}
+ } else {$status = 1}
+ &addline($status,"Check VPS FTP PASV hole","Since the Virtuozzo VPS iptables ip_conntrack_ftp kernel module is currently broken you have to open a PASV port hole in iptables for incoming FTP connections to work correctly. See the csf readme.txt under 'A note about FTP Connection Issues' on how to do this");
+ }
+ }
+
+ $status = 1;
+
+ my %ips;
+ foreach my $key (keys %g_ipv4) {
+ $ips{$key} = 1;
+ }
+
+ my $nameservers;
+ for (my $x = 1; $x < 3; $x++) {
+ my $ns = $daconfig{"ns$x"};
+ $ns =~ s/\s//g;
+ if ($ns) {
+ $nameservers .= "$ns \n";
+ my $ip;
+ if ($ns =~ /\d+\.\d+\.\d+\.d+/) {
+ $ip = $ns;
+ } else {
+ eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die};
+ alarm(5);
+ $ip = gethostbyname($ns);
+ $ip = inet_ntoa($ip);
+ alarm(0);
+ };
+ alarm(0);
+ unless ($ip) {&addline(1,"Check nameservers","Unable to resolve nameserver [$ns] within 5 seconds")}
+ }
+ if ($ip) {
+ unless ($ips{$ip}) {$status = 0}
+ }
+ }
+ }
+ &addline($status,"Check nameservers","At least one of the configured nameservers: \n$nameservers should be located in a topologically and geographically dispersed location on the Internet - See RFC 2182 (Section 3.1)");
+ return;
+}
+# end dacheck
+###############################################################################
+# start mailcheck
+sub mailcheck {
+ &addtitle("Mail Check");
+
+ my $status = 0;
+ unless ($config{DIRECTADMIN}) {
+ if (-e "/root/.forward") {
+ if (-z "/root/.forward") {$status = 1}
+ } else {$status = 1}
+ &addline($status,"Check root forwarder","The root account should have a forwarder set so that you receive essential email from your server");
+ }
+
+ if (-e "/etc/exim.conf" and -x "/usr/sbin/exim") {
+ $status = 0;
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/sbin/exim","-bP");
+ my @eximconf = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @eximconf;
+ if (my @ls = grep {$_ =~ /^\s*log_selector/} @eximconf) {
+ if (($ls[0] !~ /\+all/) and ($ls[0] !~ /\+arguments/) and ($ls[0] !~ /\+arguments/)) {$status = 1}
+ } else {$status = 1}
+ if ($config{DIRECTADMIN}) {
+ &addline($status,"Check exim for extended logging (log_selector)","You should enable extended exim logging to enable easier tracking potential outgoing spam issues. Add:log_selector = +arguments +subject +received_recipients to /etc/exim.conf");
+ } else {
+ &addline($status,"Check exim for extended logging (log_selector)","You should enable extended exim logging to enable easier tracking potential outgoing spam issues. Add:log_selector = +arguments +subject +received_recipients in WHM > Exim Configuration Manager > Advanced Editor > log_selector");
+ }
+
+ $status = 0;
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^\s*tls_require_ciphers/} @eximconf) {
+ (undef,$ciphers) = split(/\=/,$ls[0]);
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ } else {
+ if (-x "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check exim weak SSL/TLS Ciphers (tls_require_ciphers)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ if ($config{DIRECTADMIN}) {
+ &addline($status,"Check exim weak SSL/TLS Ciphers (tls_require_ciphers)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should edit /etc/exim.conf and set tls_require_ciphers to explicitly exclude it. For example:tls_require_ciphers=ALL:!ADH:RC4+RSA:+HIGH:+MEDIUM:-LOW:-SSLv2:-EXP ");
+ } else {
+ &addline($status,"Check exim weak SSL/TLS Ciphers (tls_require_ciphers)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should disable WHM > Exim Configuration Manager > Allow weak ssl/tls ciphers to be used, and also ensure tls_require_ciphers in /etc/exim.conf does not allow SSLv2 as openssl currently shows that it does");
+ }
+ } else {&addline(1,"Check exim configuration","Unable to find /etc/exim.conf and/or /usr/sbin/exim");}
+
+ if (-e "/etc/exim.conf.localopts") {
+ $status = 0;
+ open (my $IN, "<", "/etc/exim.conf.localopts");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+
+ if (my @ls = grep {$_ =~ /require_secure_auth=0/i} @conf) {$status = 1}
+ &addline($status,"Check exim for secure authentication","You should require clients to connect with SSL or issue the STARTTLS command before they are allowed to authenticate with the server, otherwise passwords may be sent in plain text in WHM > Exim Configuration Manager ");
+ }
+
+ if ($config{DIRECTADMIN}) {
+ if (-e "/etc/dovecot.conf" and ($daconfig{dovecot})) {
+ $status = 0;
+ open (my $IN, "<", "/etc/dovecot.conf");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+
+ my @morefiles;
+ if (my @ls = grep {$_ =~ /^\s*\!\s*include(_try)?\s+(.*)\s*$/i} @conf) {
+ foreach my $more (@ls) {
+ if ($more =~ /^\s*\!\s*include(_try)?\s+(.*)\s*$/i) {
+ my $conf = $2;
+ if ($conf !~ /^\//) {$conf = "/etc/dovecot/".$conf}
+ push @morefiles, $conf;
+ }
+ }
+ }
+ foreach my $file (@morefiles) {
+ if (-e $file) {
+ open (my $IN, "<", "$file");
+ flock ($IN, LOCK_SH);
+ my @moreconf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ @conf = (@conf, @moreconf);
+ }
+ }
+
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^ssl_cipher_list/} @conf) {
+ (undef,$ciphers) = split(/\=/,$ls[0]);
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ } else {
+ if (-x "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check dovecot weak SSL/TLS Ciphers (ssl_cipher_list)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ &addline($status,"Check dovecot weak SSL/TLS Ciphers (ssl_cipher_list)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should /etc/dovecot.conf and set ssl_cipher_list to explicitly exclude it. For example:ssl_cipher_list = ALL:!ADH:RC4+RSA:+HIGH:+MEDIUM:-LOW:-SSLv2:-EXP ");
+ }
+ } else {
+ if (-e "/etc/dovecot/dovecot.conf" and ($cpconf->{mailserver} eq "dovecot")) {
+ $status = 0;
+ open (my $IN, "<", "/etc/dovecot/dovecot.conf");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+
+ my @morefiles;
+ if (my @ls = grep {$_ =~ /^\s*\!?include(_try)?\s+(.*)\s*$/i} @conf) {
+ foreach my $more (@ls) {
+ if ($more =~ /^\s*\!?include(_try)?\s+(.*)\s*$/i) {push @morefiles, $2}
+ }
+ }
+ foreach my $file (@morefiles) {
+ if (-e $file) {
+ open (my $IN, "<", "$file");
+ flock ($IN, LOCK_SH);
+ my @moreconf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ @conf = (@conf, @moreconf);
+ }
+ }
+
+ $status = 0;
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^ssl_cipher_list/} @conf) {
+ (undef,$ciphers) = split(/\=/,$ls[0]);
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ } else {
+ if (-x "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check dovecot weak SSL/TLS Ciphers (ssl_cipher_list)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ &addline($status,"Check dovecot weak SSL/TLS Ciphers (ssl_cipher_list)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should disable SSLv2 in WHM > Mailserver Configuration > SSL Cipher List > Remove +SSLv2 or Add -SSLv2 ");
+ }
+
+ if (-e "/usr/lib/courier-imap/etc/imapd-ssl" and ($cpconf->{mailserver} eq "courier")) {
+ $status = 0;
+ open (my $IN, "<", "/usr/lib/courier-imap/etc/imapd-ssl");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ $status = 0;
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^TLS_CIPHER_LIST/} @conf) {
+ (undef,$ciphers) = split(/\=/,$ls[0]);
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ } else {
+ if (-x "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check Courier IMAP weak SSL/TLS Ciphers (TLS_CIPHER_LIST)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ &addline($status,"Check Courier IMAP weak SSL/TLS Ciphers (TLS_CIPHER_LIST)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should disable SSLv2 in WHM > Mailserver Configuration > IMAP TLS/SSL Cipher List > Remove +SSLv2 or Add -SSLv2 ");
+ }
+
+ if (-e "/usr/lib/courier-imap/etc/pop3d-ssl" and ($cpconf->{mailserver} eq "courier")) {
+ $status = 0;
+ open (my $IN, "<", "/usr/lib/courier-imap/etc/pop3d-ssl");
+ flock ($IN, LOCK_SH);
+ my @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ $status = 0;
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^TLS_CIPHER_LIST/} @conf) {
+ (undef,$ciphers) = split(/\=/,$ls[0]);
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ } else {
+ if (-x "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check Courier POP3D weak SSL/TLS Ciphers (TLS_CIPHER_LIST)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ &addline($status,"Check Courier POP3D weak SSL/TLS Ciphers (TLS_CIPHER_LIST)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should disable SSLv2 in WHM > Mailserver Configuration > POP3 TLS/SSL Cipher List > Remove +SSLv2 or Add -SSLv2 ");
+ }
+ }
+ return;
+}
+# end mailcheck
+###############################################################################
+# start phpcheck
+sub phpcheck {
+ &addtitle("PHP Check");
+ my %phpbinaries;
+ my %phpinis;
+
+ if (-e "/usr/local/cpanel/version" and -e "/etc/cpanel/ea4/is_ea4") {
+ foreach my $phpdir (glob("/opt/cpanel/ea-*")) {
+ if (-e "${phpdir}/root/usr/bin/php") {$phpbinaries{"${phpdir}/root/usr/bin/php"} = 1}
+ }
+ }
+ elsif ($config{DIRECTADMIN}) {
+ foreach my $phpdir (glob("/usr/local/php*")) {
+ if (-e "${phpdir}/bin/php") {$phpbinaries{"${phpdir}/bin/php"} = 1}
+ }
+ }
+ elsif (-e "/usr/local/bin/php") {$phpbinaries{"/usr/local/bin/php"} = 1}
+ elsif (-e "/usr/bin/php") {$phpbinaries{"/usr/bin/php"} = 1}
+
+ if (-e "/opt/alt/alt-php-config") {
+ foreach my $phpdir (glob("/opt/alt/php*")) {
+ if (-e "${phpdir}/usr/bin/php") {$phpbinaries{"${phpdir}/usr/bin/php"} = 1}
+ }
+ }
+
+ if (scalar(keys %phpbinaries) == 0) {
+ &addline(1,"PHP Binary","PHP binary not found or not executable");
+ return;
+ }
+
+ foreach my $phpbin (keys %phpbinaries) {
+ if ($phpbin =~ /php44/) {$phpinis{"/opt/alt/php44/etc/php.ini"} = $phpbin}
+ elsif ($phpbin =~ /php51/) {$phpinis{"/opt/alt/php51/etc/php.ini"} = $phpbin}
+ else {
+ my ($childin, $childout);
+ my $mypid = open3($childin, $childout, $childout, $phpbin,"-d","zlib.output_compression=Off","--ini");
+ my @conf = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @conf;
+ foreach my $line (@conf) {
+ if ($line =~ /^Loaded Configuration File:\s*(\S+)$/) {$phpinis{$1} = $phpbin}
+ }
+ }
+ }
+ my %phpconf;
+ foreach my $phpini (sort keys %phpinis) {
+ my $phpbin = $phpinis{$phpini};
+
+ my $status = 0;
+ my ($childin, $childout);
+ my $mypid;
+ if ($phpbin =~ /php44|php51/) {
+ $mypid = open3($childin, $childout, $childout, $phpbin,"-i");
+ } else {
+ $mypid = open3($childin, $childout, $childout, $phpbin,"-d","zlib.output_compression=Off","-i");
+ }
+ my @conf = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @conf;
+
+ if (my @ls = grep {$_ =~ /^PHP License/} @conf) {
+ my $version = 0;
+ my ($mas,$maj,$min);
+ if (my @ls = grep {$_ =~ /^PHP Version\s*=>\s*/i} @conf) {
+ my $line = $ls[0];
+ $line =~ /^PHP Version\s*=>\s*(.*)/i;
+ ($mas,$maj,$min) = split(/\./,$1);
+ $version = "$mas.$maj.$min";
+ if ($mas < 8) {$status = 1}
+ if ($mas == 8 and $maj < 1) {$status = 1}
+ }
+ open (my $IN, "<", "/usr/local/apache/conf/php.conf.yaml");
+ flock ($IN, LOCK_SH);
+ my @phpyamlconf = <$IN>;
+ close ($IN);
+ chomp @phpyamlconf;
+
+ if (my @ls = grep {$_ =~ /php4:/i} @phpyamlconf) {
+ if ($ls[0] !~ /none/) {
+ $status = 1;
+ $version = "4.*";
+ }
+ }
+ unless ($phpbin =~ m[^/opt/alt/php]) {
+ if ($status) {$phpconf{version} .= "$version ($phpbin),"}
+ }
+
+ $status = 1;
+ if (my @ls = grep {$_ =~ /^enable_dl\s*=>\s*Off/i} @conf) {
+ $status = 0;
+ }
+ if (my @ls = grep {$_ =~ /^disable_functions\s*=>.*dl.*/i} @conf) {
+ $status = 0;
+ }
+
+ if ($status) {$phpconf{enable_dl} .= "$phpini ($phpbin),"}
+
+ $status = 1;
+ if (my @ls = grep {$_ =~ /^disable_functions\s*=>.*\,/i} @conf) {
+ $status = 0;
+ }
+ if ($status) {$phpconf{disable_functions} .= "$phpini ($phpbin),"}
+
+ $status = 1;
+ if (my @ls = grep {$_ =~ /^disable_functions\s*=>.*ini_set.*/i} @conf) {
+ $status = 0;
+ }
+ if ($status) {$phpconf{ini_set} .= "$phpini ($phpbin),"}
+
+ my $oldver = "$mas.$maj";
+ if ($oldver < 5.4) {
+ $status = 1;
+ if (my @ls = grep {$_ =~ /^register_globals\s*=>\s*Off/i} @conf) {
+ $status = 0;
+ }
+ if ($status) {$phpconf{register_globals} .= "$phpini ($phpbin),"}
+
+ }
+ } else {
+ $status = 1;
+ &addline($status,"Check php [$phpbin]","Unable to examine PHP settings due to an error in the output from: [$phpbin -i]");
+ }
+ }
+ foreach my $key ("version","enable_dl","disable_functions","ini_set","register_globals") {
+ my $values;
+ foreach my $value (split(/\,/,$phpconf{$key})) {
+ if ($value eq "") {next}
+ $values .= " $value\n";
+ }
+ if ($key eq "version") {
+ my $status = 0;
+ if ($values ne "") {$status = 1}
+ &addline($status,"Check php version","Any version of PHP older than v8.1.* is now obsolete and should be considered a security threat. You should upgrade to at least PHP v8.1+:Affected PHP versions: $values");
+ }
+ if ($key eq "enable_dl") {
+ my $status = 0;
+ if ($values ne "") {$status = 1}
+ &addline($status,"Check php for enable_dl or disabled dl()","You should set:enable_dl = Off This prevents users from loading php modules that affect everyone on the server. Note that if use dynamic libraries, such as ioncube, you will have to load them directly in the PHP configuration:Affected PHP versions: $values");
+ }
+ if ($key eq "disable_functions") {
+ my $status = 0;
+ if ($values ne "") {$status = 1}
+ &addline($status,"Check php for disable_functions","You should consider disabling commonly abused php functions, e.g.:disable_functions = show_source, system, shell_exec, passthru, exec, popen, proc_open Some client web scripts may break with some of these functions disabled, so you may have to remove them from this list:Affected PHP versions: $values");
+ }
+ if ($key eq "register_globals") {
+ my $status = 0;
+ if ($values ne "") {$status = 1}
+ &addline($status,"Check php for register_globals","You should set:register_globals = Off unless it is absolutely necessary as it is seen as a significant security risk:Affected PHP versions: $values");
+ }
+ }
+ return;
+}
+# end phpcheck
+###############################################################################
+# start apachecheck
+sub apachecheck {
+ &addtitle("Apache Check");
+
+ my $status = 0;
+ my $mypid;
+ my ($childin, $childout);
+ my %ea4;
+
+ if (-e "/usr/local/cpanel/version" and -e "/etc/cpanel/ea4/is_ea4" and -e "/etc/cpanel/ea4/paths.conf") {
+ my @file = slurp("/etc/cpanel/ea4/paths.conf");
+ $ea4{enabled} = 1;
+ foreach my $line (@file) {
+ $line =~ s/$cleanreg//g;
+ if ($line =~ /^(\s|\#|$)/) {next}
+ if ($line !~ /=/) {next}
+ my ($name,$value) = split (/=/,$line,2);
+ $value =~ s/^\s+//g;
+ $value =~ s/\s+$//g;
+ $ea4{$name} = $value;
+ }
+ }
+
+ if ($ea4{enabled}) {
+ unless (-x $ea4{bin_httpd}) {&addline(1,"HTTP Binary","$ea4{bin_httpd} not found or not executable"); return}
+ }
+ elsif ($config{DIRECTADMIN}) {
+ unless (-x "/usr/sbin/httpd") {&addline(1,"HTTP Binary","/usr/sbin/httpd not found or not executable"); return}
+ }
+ else {
+ unless (-x "/usr/local/apache/bin/httpd") {&addline(1,"HTTP Binary","/usr/local/apache/bin/httpd not found or not executable"); return}
+ }
+
+ if ($ea4{enabled}) {
+ $mypid = open3($childin, $childout, $childout, $ea4{bin_httpd},"-v");
+ }
+ elsif ($config{DIRECTADMIN}) {
+ $mypid = open3($childin, $childout, $childout, "/usr/sbin/httpd","-v");
+ }
+ else {
+ $mypid = open3($childin, $childout, $childout, "/usr/local/apache/bin/httpd","-v");
+ }
+ my @version = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @version;
+ $version[0] =~ /Apache\/(\d+)\.(\d+)\.(\d+)/;
+ my $mas = $1;
+ my $maj = $2;
+ my $min = $3;
+ if ("$mas.$maj" < 2.2) {$status = 1}
+ &addline($status,"Check apache version","You are running a legacy version of apache (v$mas.$maj.$min) and should consider upgrading to v2.2.* as recommended by the Apache developers");
+
+ unless ($config{DIRECTADMIN}) {
+ my $ruid2 = 0;
+ if ($ea4{enabled}) {
+ $mypid = open3($childin, $childout, $childout, $ea4{bin_httpd},"-M");
+ }
+ else {
+ $mypid = open3($childin, $childout, $childout, "/usr/local/apache/bin/httpd","-M");
+ }
+ my @modules = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @modules;
+ if (my @ls = grep {$_ =~ /ruid2_module/} @modules) {$ruid2 = 1}
+ if (my @ls = grep {$_ =~ /mpm_itk_module/} @modules) {$ruid2 = 1}
+
+ $status = 0;
+ if (my @ls = grep {$_ =~ /security2_module/} @modules) {$status = 0} else {$status = 1}
+ &addline($status,"Check apache for ModSecurity","You should install the ModSecurity apache module during the easyapache build process to help prevent exploitation of vulnerable web scripts, together with a set of rules");
+
+ $status = 0;
+ if (my @ls = grep {$_ =~ /cloudflare_module/} @modules) {$status = 1} else {$status = 0}
+ if ($config{CF_ENABLE}) {$status = 0}
+ &addline($status,"Check apache for mod_cloudflare","This module logs the real users IP address to Apache. If this is reported to lfd via ModSecurity, cxs or some other vector through Apache it will lead to that IP being blocked, but because the IP is coming through the CloudFlare service the IP will not be blocked as so far as iptables is concerned the originating IP address is CloudFlare itself and the abuse will continue. To block these IP's in the CloudFlare Firewall look at using CF_ENABLE in csf.conf");
+
+ $status = 0;
+ if (my @ls = grep {$_ =~ /frontpage_module/} @modules) {$status = 1}
+ &addline($status,"Check apache for FrontPage","Microsoft Frontpage Extensions were EOL in 2006 and there is no support for bugs or security issues. For this reason, it should be considered a security risk to continue using them. You should rebuild apache through easyapache and deselect the option to build them");
+
+ my @conf;
+ if (-e "/usr/local/apache/conf/httpd.conf") {
+ open (my $IN, "<", "/usr/local/apache/conf/httpd.conf");
+ flock ($IN, LOCK_SH);
+ @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ }
+ if (-e "$ea4{file_conf}") {
+ open (my $IN, "<", "$ea4{file_conf}");
+ flock ($IN, LOCK_SH);
+ @conf = <$IN>;
+ close ($IN);
+ chomp @conf;
+ }
+ if (@conf) {
+ $status = 0;
+ my $ciphers;
+ my $error;
+ if (my @ls = grep {$_ =~ /^\s*SSLCipherSuite/} @conf) {
+ $ls[0] =~ s/^\s+//g;
+ (undef,$ciphers) = split(/\ /,$ls[0]);
+ $ciphers =~ s/\s*|\"|\'//g;
+ if ($ciphers eq "") {
+ $status = 1;
+ } else {
+ if (-x "/usr/bin/openssl") {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, "/usr/bin/openssl","ciphers","-v",$ciphers);
+ my @openssl = <$childout>;
+ waitpid ($cmdpid, 0);
+ chomp @openssl;
+ if (my @ls = grep {$_ =~ /error/i} @openssl) {$error = $openssl[0]; $status=2}
+ if (my @ls = grep {$_ =~ /SSLv2/} @openssl) {$status = 1}
+ }
+ }
+ } else {$status = 1}
+ if ($status == 2) {
+ &addline($status,"Check Apache weak SSL/TLS Ciphers (SSLCipherSuite)","Unable to determine cipher list for [$ciphers] from openssl: [$error]");
+ }
+ &addline($status,"Check Apache weak SSL/TLS Ciphers (SSLCipherSuite)","Cipher list [$ciphers]. Due to weaknesses in the SSLv2 cipher you should disable SSLv2 in WHM > Apache Configuration > Global Configuration > SSLCipherSuite > Add -SSLv2 to SSLCipherSuite and/or remove +SSLv2. Do not forget to Save AND then Rebuild Configuration and Restart Apache, otherwise the changes will not take effect in httpd.conf");
+
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^\s*TraceEnable Off/} @conf) {
+ $status = 0;
+ } else {$status = 1}
+ &addline($status,"Check apache for TraceEnable","You should set TraceEnable to Off in: WHM > Apache Configuration > Global Configuration > Trace Enable > Off. Do not forget to Save AND then Rebuild Configuration and Restart Apache, otherwise the changes will not take effect in httpd.conf");
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^\s*ServerSignature Off/} @conf) {
+ $status = 0;
+ } else {$status = 1}
+ &addline($status,"Check apache for ServerSignature","You should set ServerSignature to Off in: WHM > Apache Configuration > Global Configuration > Server Signature > Off. Do not forget to Save AND then Rebuild Configuration and Restart Apache, otherwise the changes will not take effect in httpd.conf");
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^\s*ServerTokens ProductOnly/} @conf) {
+ $status = 0;
+ } else {$status = 1}
+ &addline($status,"Check apache for ServerTokens","You should set ServerTokens to ProductOnly in: WHM > Apache Configuration > Global Configuration > Server Tokens > Product Only. Do not forget to Save AND then Rebuild Configuration and Restart Apache, otherwise the changes will not take effect in httpd.conf");
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^\s*FileETag None/} @conf) {
+ $status = 0;
+ } else {$status = 1}
+ &addline($status,"Check apache for FileETag","You should set FileETag to None in: WHM > Apache Configuration > Global Configuration > File ETag > None. Do not forget to Save AND then Rebuild Configuration and Restart Apache, otherwise the changes will not take effect in httpd.conf");
+ }
+
+ my @apacheconf;
+ if (-e "/usr/local/apache/conf/php.conf.yaml") {
+ open (my $IN, "<", "/usr/local/apache/conf/php.conf.yaml");
+ flock ($IN, LOCK_SH);
+ @apacheconf = <$IN>;
+ close ($IN);
+ chomp @apacheconf;
+ }
+ if (-e "$ea4{dir_conf}/php.conf.yaml") {
+ open (my $IN, "<", "$ea4{dir_conf}/php.conf.yaml");
+ flock ($IN, LOCK_SH);
+ @apacheconf = <$IN>;
+ close ($IN);
+ chomp @apacheconf;
+ }
+ if (@apacheconf) {
+ unless ($ruid2) {
+ $status = 0;
+ if (my @ls = grep {$_ =~ /suphp/} @apacheconf) {
+ $status = 0;
+ } else {$status = 1}
+ &addline($status,"Check suPHP","To reduce the risk of hackers accessing all sites on the server from a compromised PHP web script, you should enable suPHP when you build apache/php. Note that there are sideeffects when enabling suPHP on a server and you should be aware of these before enabling it. Don\'t forget to enable it as the default PHP handler in WHM > PHP 5 Handler ");
+
+ $status = 0;
+ unless ($cpconf->{userdirprotect}) {$status = 1}
+ &addline($status,"Check mod_userdir protection","To prevents users from stealing bandwidth or hackers hiding access to your servers, you should check WHM > Security Center > mod_userdir Tweak ");
+
+ $status = 1;
+ if (my @ls = grep {$_ =~ /suexec_module/} @modules) {$status = 0}
+ &addline($status,"Check Suexec","To reduce the risk of hackers accessing all sites on the server from a compromised CGI web script, you should set WHM > Suexec on ");
+ }
+ }
+ }
+ return;
+}
+# end apachecheck
+###############################################################################
+# start sshtelnetcheck
+sub sshtelnetcheck {
+ my $status = 0;
+ &addtitle("SSH/Telnet Check");
+
+ if (-e "/etc/ssh/sshd_config") {
+ open (my $IN, "<", "/etc/ssh/sshd_config");
+ flock ($IN, LOCK_SH);
+ my @sshconf = <$IN>;
+ close ($IN);
+ chomp @sshconf;
+ if (my @ls = grep {$_ =~ /^\s*Protocol/i} @sshconf) {
+ if ($ls[0] =~ /1/) {$status = 1}
+ } else {$status = 0}
+ &addline($status,"Check SSHv1 is disabled","You should disable SSHv1 by editing /etc/ssh/sshd_config and setting:Protocol 2 ");
+
+ $status = 0;
+ my $sshport = "22";
+ if (my @ls = grep {$_ =~ /^\s*Port/i} @sshconf) {
+ if ($ls[0] =~ /^\s*Port\s+(\d*)/i) {
+ $sshport = $1;
+ if ($sshport eq "22") {$status = 1}
+ } else {$status = 1}
+ } else {$status = 1}
+ &addline($status,"Check SSH on non-standard port","You should consider moving SSH to a non-standard port [currently:$sshport] to evade basic SSH port scans. Don't forget to open the port in the firewall first if necessary");
+
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^\s*PasswordAuthentication/i} @sshconf) {
+ if ($ls[0] =~ /\byes\b/i) {$status = 1}
+ } else {$status = 1}
+ &addline($status,"Check SSH PasswordAuthentication","You should disable PasswordAuthentication and only allow access using PubkeyAuthentication to improve brute-force SSH security");
+
+ $status = 0;
+ if (my @ls = grep {$_ =~ /^\s*UseDNS/i} @sshconf) {
+ if ($ls[0] !~ /\bno\b/i) {$status = 1}
+ } else {$status = 1}
+ &addline($status,"Check SSH UseDNS","You should disable UseDNS by editing /etc/ssh/sshd_config and setting:UseDNS no Otherwise, lfd will be unable to track SSHD login failures successfully as the log files will not report IP addresses");
+ } else {&addline(1,"Check SSH configuration","Unable to find /etc/ssh/sshd_config");}
+
+ $status = 0;
+ my $check = &getportinfo("23");
+ if ($check) {$status = 1}
+ &addline($status,"Check telnet port 23 is not in use","It appears that something is listening on port 23 which is normally used for telnet. Telnet is an insecure protocol and you should disable the telnet daemon if it is running");
+
+ unless ($config{DNSONLY} or $config{GENERIC}) {
+ unless ($config{VPS}) {
+ if (-e "/etc/redhat-release") {
+ open (my $IN, "<", "/etc/redhat-release");
+ flock ($IN, LOCK_SH);
+ my $conf = <$IN>;
+ close ($IN);
+ chomp $conf;
+
+ unless ($conf =~ /^CloudLinux/i) {
+ if (-e "/etc/profile") {
+ $status = 0;
+ open (my $IN, "<", "/etc/profile");
+ flock ($IN, LOCK_SH);
+ my @profile = <$IN>;
+ close ($IN);
+ chomp @profile;
+ if (grep {$_ =~ /^LIMITUSER=\$USER/} @profile) {
+ $status = 0;
+ } else {$status = 1}
+ &addline($status,"Check shell limits","You should enable shell resource limits to prevent shell users from consuming server resources - DOS exploits typically do this. A quick way to set this is to use WHM > Shell Fork Bomb Protection ");
+ } else {
+ &addline(1,"Check shell limits","Unable to find /etc/profile");
+ }
+ }
+ }
+ }
+
+ $status = 0;
+ if (-e "/var/cpanel/killproc.conf") {
+ open (my $IN, "<", "/var/cpanel/killproc.conf");
+ flock ($IN, LOCK_SH);
+ my @proc = <$IN>;
+ close ($IN);
+ chomp @proc;
+ if (@proc < 9) {$status = 1}
+ &addline($status,"Check Background Process Killer","You should enable each item in the WHM > Background Process Killer ");
+ } else {&addline(1,"Check Background Process Killer","You should enable each item in the WHM > Background Process Killer ")}
+ }
+ return;
+}
+# end sshtelnetcheck
+###############################################################################
+# start servicescheck
+sub servicescheck {
+ my $systemctl = "/usr/bin/systemctl";
+ my $chkconfig = "/sbin/chkconfig";
+ my $servicebin = "/sbin/service";
+ if (-e "/bin/systemctl") {$systemctl = "/bin/systemctl"}
+ if (-e "/usr/sbin/chkconfig") {$chkconfig = "/usr/sbin/chkconfig"}
+ if (-e "/usr/sbin/service") {$servicebin = "/usr/sbin/service"}
+ &addtitle("Server Services Check");
+ my @services = ("abrt-xorg", "abrtd", "alsa-state", "anacron", "avahi-daemon", "avahi-dnsconfd", "bluetooth", "bolt", "canna", "colord", "cups", "cups-config-daemon", "cupsd", "firewalld", "FreeWnn", "gdm", "gpm", "gssproxy", "hidd", "iiim", "ksmtuned", "mDNSResponder", "ModemManager", "nfslock", "nifd", "packagekit", "pcscd", "portreserve", "pulseaudio", "qpidd", "rpcbind", "rpcidmapd", "saslauthd", "sbadm", "wpa_supplicant", "xfs", "xinetd");
+
+ my $disable;
+ my ($childin, $childout);
+ my $mypid;
+ if ($sysinit eq "init") {
+ $disable = "$servicebin [service] stop $chkconfig [service] off";
+ $mypid = open3($childin, $childout, $childout, $chkconfig,"--list");
+ } else {
+ $disable = "$systemctl stop [service] $systemctl disable [service]";
+ $mypid = open3($childin, $childout, $childout, $systemctl,"list-unit-files","--state=enabled","--no-pager","--no-legend");
+ }
+ my @chkconfig = <$childout>;
+ waitpid ($mypid, 0);
+ chomp @chkconfig;
+
+ my @enabled;
+ foreach my $service (@services) {
+ if ($service eq "xinetd" and $config{PLESK}) {next}
+ if ($sysinit eq "init") {
+ if (my @ls = grep {$_ =~ /^$service\b/} @chkconfig) {
+ if ($ls[0] =~ /\:on/) {push @enabled, $service}
+ }
+ } else {
+ if (my @ls = grep {$_ =~ /^$service\.service/} @chkconfig) {push @enabled, $service}
+ }
+ }
+ if (scalar @enabled > 0) {
+ my $list;
+ foreach my $service (@enabled) {
+ if (length($list) == 0) {
+ $list = $service;
+ } else {
+ $list .= ",".$service;
+ }
+ }
+ &addline("1","Check server services","On most servers the following services are not needed and should be stopped and disabled from starting unless used:$list
\nEach service can usually be disabled using:$disable ");
+ } else {
+ &addline("0","Check server services","On most servers the following services are not needed and should be stopped and disabled from starting unless used:none found
\nEach service can usually be disabled using:$disable ");
+ }
+ return;
+}
+# end servicescheck
+###############################################################################
+# start getportinfo
+sub getportinfo {
+ my $port = shift;
+ my $hit = 0;
+
+ foreach my $proto ("udp","tcp","udp6","tcp6") {
+ open (my $IN, "<", "/proc/net/$proto");
+ flock ($IN, LOCK_SH);
+ while (<$IN>) {
+ my @rec = split();
+ if ($rec[9] =~ /uid/) {next}
+ my (undef,$sport) = split(/:/,$rec[1]);
+ if (hex($sport) == $port) {$hit = 1}
+ }
+ close ($IN);
+ }
+
+ return $hit;
+}
+# end getportinfo
+###############################################################################
+
+1;
diff --git a/src/redux/ConfigServer/ServerStats.pm b/src/redux/ConfigServer/ServerStats.pm
new file mode 100644
index 000000000..a42656bda
--- /dev/null
+++ b/src/redux/ConfigServer/ServerStats.pm
@@ -0,0 +1,3547 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::ServerStats;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+
+use Exporter qw(import);
+our $VERSION = 1.02;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my %minmaxavg;
+
+# end main
+###############################################################################
+# start init
+sub init {
+ eval ('use GD::Graph::bars;'); ##no critic
+ if ($@) {return undef}
+ eval ('use GD::Graph::pie;'); ##no critic
+ if ($@) {return undef}
+ eval ('use GD::Graph::lines;'); ##no critic
+ if ($@) {return undef}
+}
+# end init
+###############################################################################
+# start graphs
+sub graphs {
+ my $type = shift;
+ my $system_maxdays = shift;
+ my $imghddir = shift;
+ my $img;
+ $| = 1;
+
+ require GD::Graph::bars;
+ import GD::Graph::bars;
+ require GD::Graph::pie;
+ import GD::Graph::pie;
+ require GD::Graph::lines;
+ import GD::Graph::lines;
+
+ sysopen (my $STATS,"/var/lib/csf/stats/system", O_RDWR | O_CREAT);
+ flock ($STATS, LOCK_SH);
+ my @stats = <$STATS>;
+ chomp @stats;
+ close ($STATS);
+
+ if (@stats > 1) {
+ local $SIG{__DIE__} = undef;
+ my $time = time;
+ my %stata;
+ foreach my $line (@stats) {
+ my ($thistime,undef) = split(/\,/,$line);
+ if (time - $thistime > (86400 * $system_maxdays)) {next}
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($thistime);
+ $stata{$year}{$mon}{$mday}{$hour}{$min} = $line;
+ }
+
+ if ($type eq "cpu") {
+ my (@h,@p,@t);
+ my $cputotal_prev;
+ my $cpuidle_prev;
+ my $cpuiowait_prev;
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $cputotal eq "") {
+ $cputotal_prev = 0;
+ $cpuidle_prev = 0;
+ $cpuiowait_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ my $idle_diff = $cpuidle - $cpuidle_prev;
+ my $iowait_diff = $cpuiowait - $cpuiowait_prev;
+ my $total_diff = $cputotal - $cputotal_prev;
+ if ($total_diff == 0) {
+ $cputotal_prev = 0;
+ $cpuidle_prev = 0;
+ $cpuiowait_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ next;
+ }
+ my $idle_use = 100 - 100 * ($total_diff - $idle_diff) / $total_diff;
+ my $iowait_use = 100 - 100 * ($total_diff - $iowait_diff) / $total_diff;
+ $cpuidle_prev = $cpuidle;
+ $cpuiowait_prev = $cpuiowait;
+ $cputotal_prev = $cputotal;
+ push @p,$idle_use;
+ push @t,$iowait_use;
+
+ &minmaxavg("HOUR","1Idle",$idle_use);
+ &minmaxavg("HOUR","2IOWAIT",$iowait_use);
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Idle"}{CNT} > 0) {$minmaxavg{HOUR}{"1Idle"}{AVG} /= $minmaxavg{HOUR}{"1Idle"}{CNT}}
+ if ($minmaxavg{HOUR}{"2IOWAIT"}{CNT} > 0) {$minmaxavg{HOUR}{"2IOWAIT"}{AVG} /= $minmaxavg{HOUR}{"2IOWAIT"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => '% CPU',
+ x_label_skip => 3,
+ line_width => 2,
+ title => 'CPU Usage in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Idle IOWAIT));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "cpu") {
+ my (@h,@p,@t);
+ my $cputotal_prev;
+ my $cpuidle_prev;
+ my $cpuiowait_prev;
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $cputotal eq "") {
+ $cputotal_prev = 0;
+ $cpuidle_prev = 0;
+ $cpuiowait_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ my $idle_diff = $cpuidle - $cpuidle_prev;
+ my $iowait_diff = $cpuiowait - $cpuiowait_prev;
+ my $total_diff = $cputotal - $cputotal_prev;
+ if ($total_diff == 0) {
+ $cputotal_prev = 0;
+ $cpuidle_prev = 0;
+ $cpuiowait_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ next;
+ }
+ my $idle_use = 100 - 100 * ($total_diff - $idle_diff) / $total_diff;
+ my $iowait_use = 100 - 100 * ($total_diff - $iowait_diff) / $total_diff;
+ $cpuidle_prev = $cpuidle;
+ $cpuiowait_prev = $cpuiowait;
+ $cputotal_prev = $cputotal;
+ push @p,$idle_use;
+ push @t,$iowait_use;
+
+ &minmaxavg("DAY","1Idle",$idle_use);
+ &minmaxavg("DAY","2IOWAIT",$iowait_use);
+ }
+ }
+ if ($minmaxavg{DAY}{"1Idle"}{CNT} > 0) {$minmaxavg{DAY}{"1Idle"}{AVG} /= $minmaxavg{DAY}{"1Idle"}{CNT}}
+ if ($minmaxavg{DAY}{"2IOWAIT"}{CNT} > 0) {$minmaxavg{DAY}{"2IOWAIT"}{AVG} /= $minmaxavg{DAY}{"2IOWAIT"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => '% CPU',
+ x_label_skip => 60,
+ title => 'CPU Usage in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Idle IOWAIT));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "cpu") {
+ my (@h,@p,@t);
+ my $cputotal_prev;
+ my $cpuidle_prev;
+ my $cpuiowait_prev;
+ $minmaxavg{WEEK}{"1Idle"}{MIN} = 100;
+ $minmaxavg{WEEK}{"1Idle"}{MAX} = 0;
+ $minmaxavg{WEEK}{"2IOWAIT"}{MIN} = 100;
+ $minmaxavg{WEEK}{"2IOWAIT"}{MAX} = 0;
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $idle_avg;
+ my $iowait_avg;
+ my $cnt_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $cputotal ne "") {
+ my $idle_diff = $cpuidle - $cpuidle_prev;
+ my $iowait_diff = $cpuiowait - $cpuiowait_prev;
+ my $total_diff = $cputotal - $cputotal_prev;
+ if ($total_diff == 0) {
+ $cputotal_prev = 0;
+ $cpuidle_prev = 0;
+ $cpuiowait_prev = 0;
+ next;
+ }
+ my $idle_use = 100 - 100 * ($total_diff - $idle_diff) / $total_diff;
+ my $iowait_use = 100 - 100 * ($total_diff - $iowait_diff) / $total_diff;
+ $cpuidle_prev = $cpuidle;
+ $cpuiowait_prev = $cpuiowait;
+ $cputotal_prev = $cputotal;
+ $idle_avg += $idle_use;
+ $iowait_avg += $iowait_use;
+ $cnt_avg++;
+ } else {
+ $cputotal_prev = 0;
+ $cpuidle_prev = 0;
+ $cpuiowait_prev = 0;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$idle_avg/$cnt_avg;
+ push @t,$iowait_avg/$cnt_avg;
+ &minmaxavg("WEEK","1Idle",($idle_avg/$cnt_avg));
+ &minmaxavg("WEEK","2IOWAIT",($iowait_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Idle"}{CNT} > 0) {$minmaxavg{WEEK}{"1Idle"}{AVG} /= $minmaxavg{WEEK}{"1Idle"}{CNT}}
+ if ($minmaxavg{WEEK}{"2IOWAIT"}{CNT} > 0) {$minmaxavg{WEEK}{"2IOWAIT"}{AVG} /= $minmaxavg{WEEK}{"2IOWAIT"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => '% CPU',
+ x_label_skip => 24,
+ title => 'CPU Usage in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Idle IOWAIT));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "cpu") {
+ my (@h,@p,@t);
+ my $cputotal_prev;
+ my $cpuidle_prev;
+ my $cpuiowait_prev;
+ $minmaxavg{MONTH}{"1Idle"}{MIN} = 100;
+ $minmaxavg{MONTH}{"1Idle"}{MAX} = 0;
+ $minmaxavg{MONTH}{"2IOWAIT"}{MIN} = 100;
+ $minmaxavg{MONTH}{"2IOWAIT"}{MAX} = 0;
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $idle_avg;
+ my $iowait_avg;
+ my $cnt_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $cputotal ne "") {
+ my $idle_diff = $cpuidle - $cpuidle_prev;
+ my $iowait_diff = $cpuiowait - $cpuiowait_prev;
+ my $total_diff = $cputotal - $cputotal_prev;
+ if ($total_diff == 0) {
+ $cputotal_prev = 0;
+ $cpuidle_prev = 0;
+ $cpuiowait_prev = 0;
+ next;
+ }
+ my $idle_use = 100 - 100 * ($total_diff - $idle_diff) / $total_diff;
+ my $iowait_use = 100 - 100 * ($total_diff - $iowait_diff) / $total_diff;
+ $cpuidle_prev = $cpuidle;
+ $cpuiowait_prev = $cpuiowait;
+ $cputotal_prev = $cputotal;
+ $idle_avg += $idle_use;
+ $iowait_avg += $iowait_use;
+ $cnt_avg++;
+ } else {
+ $cputotal_prev = 0;
+ $cpuidle_prev = 0;
+ $cpuiowait_prev = 0;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$idle_avg/$cnt_avg;
+ push @t,$iowait_avg/$cnt_avg;
+ &minmaxavg("MONTH","1Idle",($idle_avg/$cnt_avg));
+ &minmaxavg("MONTH","2IOWAIT",($iowait_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Idle"}{CNT} > 0) {$minmaxavg{MONTH}{"1Idle"}{AVG} /= $minmaxavg{MONTH}{"1Idle"}{CNT}}
+ if ($minmaxavg{MONTH}{"2IOWAIT"}{CNT} > 0) {$minmaxavg{MONTH}{"2IOWAIT"}{AVG} /= $minmaxavg{MONTH}{"2IOWAIT"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => '% CPU',
+ x_label_skip => 24,
+ title => "CPU Usage in last $system_maxdays days",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Idle IOWAIT));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mem") {
+ my (@h,@p,@t,@c,@a,@b);
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $memtotal eq "") {
+ push @p,undef;
+ push @t,undef;
+ push @c,undef;
+ push @a,undef;
+ push @b,undef;
+ } else {
+ $memfree = $memtotal - $memfree;
+ $memswapfree = $memswaptotal - $memswapfree;
+ push @p,$memtotal;
+ push @t,$memfree;
+ push @c,$memcached;
+ push @a,$memswaptotal;
+ push @b,$memswapfree;
+
+ &minmaxavg("HOUR","1Used",$memfree);
+ &minmaxavg("HOUR","2Cached",$memcached);
+ &minmaxavg("HOUR","3SwapUsed",$memswapfree);
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Used"}{CNT} > 0) {$minmaxavg{HOUR}{"1Used"}{AVG} /= $minmaxavg{HOUR}{"1Used"}{CNT}}
+ if ($minmaxavg{HOUR}{"2Cached"}{CNT} > 0) {$minmaxavg{HOUR}{"2Cached"}{AVG} /= $minmaxavg{HOUR}{"2Cached"}{CNT}}
+ if ($minmaxavg{HOUR}{"3SwapUsed"}{CNT} > 0) {$minmaxavg{HOUR}{"3SwapUsed"}{AVG} /= $minmaxavg{HOUR}{"3SwapUsed"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t],[reverse @c],[reverse @a],[reverse @b]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple blue green) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Memory (KB)',
+ x_label_skip => 3,
+ title => 'Memory Usage in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Total Used Cached SwapTotal SwapUsed));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mem") {
+ my (@h,@p,@c,@t,@a,@b);
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $memtotal eq "") {
+ push @p,undef;
+ push @t,undef;
+ push @c,undef;
+ push @a,undef;
+ push @b,undef;
+ } else {
+ $memfree = $memtotal - $memfree;
+ $memswapfree = $memswaptotal - $memswapfree;
+ push @p,$memtotal;
+ push @t,$memfree;
+ push @c,$memcached;
+ push @a,$memswaptotal;
+ push @b,$memswapfree;
+
+ &minmaxavg("DAY","1Used",$memfree);
+ &minmaxavg("DAY","2Cached",$memcached);
+ &minmaxavg("DAY","3SwapUsed",$memswapfree);
+ }
+ }
+ if ($minmaxavg{DAY}{"1Used"}{CNT} > 0) {$minmaxavg{DAY}{"1Used"}{AVG} /= $minmaxavg{DAY}{"1Used"}{CNT}}
+ if ($minmaxavg{DAY}{"2Cached"}{CNT} > 0) {$minmaxavg{DAY}{"2Cached"}{AVG} /= $minmaxavg{DAY}{"2Cached"}{CNT}}
+ if ($minmaxavg{DAY}{"3SwapUsed"}{CNT} > 0) {$minmaxavg{DAY}{"3SwapUsed"}{AVG} /= $minmaxavg{DAY}{"3SwapUsed"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t],[reverse @c],[reverse @a],[reverse @b]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple blue green) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Memory (KB)',
+ x_label_skip => 60,
+ title => 'Memory Usage in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Total Used Cached SwapTotal SwapUsed));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mem") {
+ my (@h,@p,@t,@c,@a,@b);
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $memtotal_avg;
+ my $memfree_avg;
+ my $memcached_avg;
+ my $memswaptotal_avg;
+ my $memswapfree_avg;
+ my $cnt_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $memtotal ne "") {
+ $memfree = $memtotal - $memfree;
+ $memswapfree = $memswaptotal - $memswapfree;
+ $memtotal_avg += $memtotal;
+ $memfree_avg += $memfree;
+ $memcached_avg += $memcached;
+ $memswaptotal_avg += $memswaptotal;
+ $memswapfree_avg += $memswapfree;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ push @c,undef;
+ push @a,undef;
+ push @b,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$memtotal_avg/$cnt_avg;
+ push @t,$memfree_avg/$cnt_avg;
+ push @c,$memcached_avg/$cnt_avg;
+ push @a,$memswaptotal_avg/$cnt_avg;
+ push @b,$memswapfree_avg/$cnt_avg;
+
+ &minmaxavg("WEEK","1Used",($memfree_avg/$cnt_avg));
+ &minmaxavg("WEEK","2Cached",($memcached_avg/$cnt_avg));
+ &minmaxavg("WEEK","3SwapUsed",($memswapfree_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Used"}{CNT} > 0) {$minmaxavg{WEEK}{"1Used"}{AVG} /= $minmaxavg{WEEK}{"1Used"}{CNT}}
+ if ($minmaxavg{WEEK}{"2Cached"}{CNT} > 0) {$minmaxavg{WEEK}{"2Cached"}{AVG} /= $minmaxavg{WEEK}{"2Cached"}{CNT}}
+ if ($minmaxavg{WEEK}{"3SwapUsed"}{CNT} > 0) {$minmaxavg{WEEK}{"3SwapUsed"}{AVG} /= $minmaxavg{WEEK}{"3SwapUsed"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t],[reverse @c],[reverse @a],[reverse @b]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple blue green) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Memory (KB)',
+ x_label_skip => 24,
+ title => 'Memory Usage in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Total Used Cached SwapTotal SwapUsed));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mem") {
+ my (@h,@p,@t,@c,@a,@b);
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $memtotal_avg;
+ my $memfree_avg;
+ my $memcached_avg;
+ my $memswaptotal_avg;
+ my $memswapfree_avg;
+ my $cnt_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $memtotal ne "") {
+ $memfree = $memtotal - $memfree;
+ $memswapfree = $memswaptotal - $memswapfree;
+ $memtotal_avg += $memtotal;
+ $memfree_avg += $memfree;
+ $memcached_avg += $memcached;
+ $memswaptotal_avg += $memswaptotal;
+ $memswapfree_avg += $memswapfree;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ push @c,undef;
+ push @a,undef;
+ push @b,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$memtotal_avg/$cnt_avg;
+ push @t,$memfree_avg/$cnt_avg;
+ push @c,$memcached_avg/$cnt_avg;
+ push @a,$memswaptotal_avg/$cnt_avg;
+ push @b,$memswapfree_avg/$cnt_avg;
+
+ &minmaxavg("MONTH","1Used",($memfree_avg/$cnt_avg));
+ &minmaxavg("MONTH","2Cached",($memcached_avg/$cnt_avg));
+ &minmaxavg("MONTH","3SwapUsed",($memswapfree_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Used"}{CNT} > 0) {$minmaxavg{MONTH}{"1Used"}{AVG} /= $minmaxavg{MONTH}{"1Used"}{CNT}}
+ if ($minmaxavg{MONTH}{"2Cached"}{CNT} > 0) {$minmaxavg{MONTH}{"2Cached"}{AVG} /= $minmaxavg{MONTH}{"2Cached"}{CNT}}
+ if ($minmaxavg{MONTH}{"3SwapUsed"}{CNT} > 0) {$minmaxavg{MONTH}{"3SwapUsed"}{AVG} /= $minmaxavg{MONTH}{"3SwapUsed"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t],[reverse @c],[reverse @a],[reverse @b]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple blue green) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Memory (Bytes)',
+ x_label_skip => 24,
+ title => "Memory Usage in last $system_maxdays days",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Total Used Cached SwapTotal SwapUsed));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "load") {
+ my (@h,@p,@t,@a);
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $load1 eq "") {
+ push @p,undef;
+ push @t,undef;
+ push @a,undef;
+ } else {
+ push @p,$load1;
+ push @t,$load5;
+ push @a,$load15;
+
+ &minmaxavg("HOUR","1Load_1",$load1);
+ &minmaxavg("HOUR","2Load_5",$load5);
+ &minmaxavg("HOUR","3Load_15",$load15);
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Load_1"}{CNT} > 0) {$minmaxavg{HOUR}{"1Load_1"}{AVG} /= $minmaxavg{HOUR}{"1Load_1"}{CNT}}
+ if ($minmaxavg{HOUR}{"2Load_5"}{CNT} > 0) {$minmaxavg{HOUR}{"2Load_5"}{AVG} /= $minmaxavg{HOUR}{"2Load_5"}{CNT}}
+ if ($minmaxavg{HOUR}{"3Load_15"}{CNT} > 0) {$minmaxavg{HOUR}{"3Load_15"}{AVG} /= $minmaxavg{HOUR}{"3Load_15"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t],[reverse @a]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Load Average',
+ x_label_skip => 3,
+ title => 'Load Averages in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Load_1 Load_5 Load_15));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "load") {
+ my (@h,@p,@t,@a);
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $load1 eq "") {
+ push @p,undef;
+ push @t,undef;
+ push @a,undef;
+ } else {
+ push @p,$load1;
+ push @t,$load5;
+ push @a,$load15;
+
+ &minmaxavg("DAY","1Load_1",$load1);
+ &minmaxavg("DAY","2Load_5",$load5);
+ &minmaxavg("DAY","3Load_15",$load15);
+ }
+ }
+ if ($minmaxavg{DAY}{"1Load_1"}{CNT} > 0) {$minmaxavg{DAY}{"1Load_1"}{AVG} /= $minmaxavg{DAY}{"1Load_1"}{CNT}}
+ if ($minmaxavg{DAY}{"2Load_5"}{CNT} > 0) {$minmaxavg{DAY}{"2Load_5"}{AVG} /= $minmaxavg{DAY}{"2Load_5"}{CNT}}
+ if ($minmaxavg{DAY}{"3Load_15"}{CNT} > 0) {$minmaxavg{DAY}{"3Load_15"}{AVG} /= $minmaxavg{DAY}{"3Load_15"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t],[reverse @a]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Load Average',
+ x_label_skip => 60,
+ title => 'Load Averages in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Load_1 Load_5 Load_15));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "load") {
+ my (@h,@p,@t,@a);
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $load1_avg;
+ my $load5_avg;
+ my $load15_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $load1 ne "") {
+ $load1_avg += $load1;
+ $load5_avg += $load5;
+ $load15_avg += $load15;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ push @a,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$load1_avg/$cnt_avg;
+ push @t,$load5_avg/$cnt_avg;
+ push @a,$load15_avg/$cnt_avg;
+
+ &minmaxavg("WEEK","1Load_1",($load1_avg/$cnt_avg));
+ &minmaxavg("WEEK","2Load_5",($load5_avg/$cnt_avg));
+ &minmaxavg("WEEK","3Load_15",($load15_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Load_1"}{CNT} > 0) {$minmaxavg{WEEK}{"1Load_1"}{AVG} /= $minmaxavg{WEEK}{"1Load_1"}{CNT}}
+ if ($minmaxavg{WEEK}{"2Load_5"}{CNT} > 0) {$minmaxavg{WEEK}{"2Load_5"}{AVG} /= $minmaxavg{WEEK}{"2Load_5"}{CNT}}
+ if ($minmaxavg{WEEK}{"3Load_15"}{CNT} > 0) {$minmaxavg{WEEK}{"3Load_15"}{AVG} /= $minmaxavg{WEEK}{"3Load_15"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t],[reverse @a]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Load Average',
+ x_label_skip => 24,
+ title => 'Load Averages in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Load_1 Load_5 Load_15));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "load") {
+ my (@h,@p,@t,@a);
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $load1_avg;
+ my $load5_avg;
+ my $load15_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $load1 ne "") {
+ $load1_avg += $load1;
+ $load5_avg += $load5;
+ $load15_avg += $load15;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ push @a,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$load1_avg/$cnt_avg;
+ push @t,$load5_avg/$cnt_avg;
+ push @a,$load15_avg/$cnt_avg;
+
+ &minmaxavg("MONTH","1Load_1",($load1_avg/$cnt_avg));
+ &minmaxavg("MONTH","2Load_5",($load5_avg/$cnt_avg));
+ &minmaxavg("MONTH","3Load_15",($load15_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Load_1"}{CNT} > 0) {$minmaxavg{MONTH}{"1Load_1"}{AVG} /= $minmaxavg{MONTH}{"1Load_1"}{CNT}}
+ if ($minmaxavg{MONTH}{"2Load_5"}{CNT} > 0) {$minmaxavg{MONTH}{"2Load_5"}{AVG} /= $minmaxavg{MONTH}{"2Load_5"}{CNT}}
+ if ($minmaxavg{MONTH}{"3Load_15"}{CNT} > 0) {$minmaxavg{MONTH}{"3Load_15"}{AVG} /= $minmaxavg{MONTH}{"3Load_15"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t],[reverse @a]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple blue) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Load Average',
+ x_label_skip => 24,
+ title => "Load Averages in last $system_maxdays days",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Load_1 Load_5 Load_15));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "net") {
+ my (@h,@p,@t);
+ my $netin_prev;
+ my $netout_prev;
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $netin eq "") {
+ $netin_prev = 0;
+ $netout_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($netin_prev < $netin or $netin eq "") {
+ push @p,undef;
+ $netin_prev = $netin;
+ } else {
+ my $netin_val = ($netin_prev - $netin) / 60;
+ push @p,$netin_val;
+ $netin_prev = $netin;
+ &minmaxavg("HOUR","1Inbound",$netin_val);
+ }
+ if ($netout_prev < $netout or $netout eq "") {
+ push @t,undef;
+ $netout_prev = $netout;
+ } else {
+ my $netout_val = ($netout_prev - $netout) / 60;
+ push @t,$netout_val;
+ $netout_prev = $netout;
+ &minmaxavg("HOUR","2Outbound",$netout_val);
+ }
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Inbound"}{CNT} > 0) {$minmaxavg{HOUR}{"1Inbound"}{AVG} /= $minmaxavg{HOUR}{"1Inbound"}{CNT}}
+ if ($minmaxavg{HOUR}{"2Outbound"}{CNT} > 0) {$minmaxavg{HOUR}{"2Outbound"}{AVG} /= $minmaxavg{HOUR}{"2Outbound"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Bytes/Second',
+ x_label_skip => 3,
+ title => 'Network Usage in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Inbound Outbound));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "net") {
+ my (@h,@p,@t);
+ my $netin_prev;
+ my $netout_prev;
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $netin eq "") {
+ $netin_prev = 0;
+ $netout_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($netin_prev < $netin or $netin eq "") {
+ push @p,undef;
+ $netin_prev = $netin;
+ } else {
+ my $netin_val = ($netin_prev - $netin) / 60;
+ push @p,$netin_val;
+ $netin_prev = $netin;
+ &minmaxavg("DAY","1Inbound",$netin_val);
+ }
+ if ($netout_prev < $netout or $netout eq "") {
+ push @t,undef;
+ $netout_prev = $netout;
+ } else {
+ my $netout_val = ($netout_prev - $netout) / 60;
+ push @t,$netout_val;
+ $netout_prev = $netout;
+ &minmaxavg("DAY","2Outbound",$netout_val);
+ }
+ }
+ }
+ if ($minmaxavg{DAY}{"1Inbound"}{CNT} > 0) {$minmaxavg{DAY}{"1Inbound"}{AVG} /= $minmaxavg{DAY}{"1Inbound"}{CNT}}
+ if ($minmaxavg{DAY}{"2Outbound"}{CNT} > 0) {$minmaxavg{DAY}{"2Outbound"}{AVG} /= $minmaxavg{DAY}{"2Outbound"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Bytes/Second',
+ x_label_skip => 60,
+ title => 'Network Usage in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Inbound Outbound));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "net") {
+ my (@h,@p,@t);
+ my $netin_prev;
+ my $netout_prev;
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $netin_avg;
+ my $netout_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $netin eq "") {
+ $netin_prev = 0;
+ $netout_prev = 0;
+ } else {
+ if ($netin_prev < $netin or $netin eq "") {
+ $netin_prev = $netin;
+ } else {
+ my $netin_val = ($netin_prev - $netin) / 60;
+ $netin_avg = $netin_avg + $netin_val;
+ $netin_prev = $netin;
+ }
+ if ($netout_prev < $netout or $netout eq "") {
+ $netout_prev = $netout;
+ } else {
+ my $netout_val = ($netout_prev - $netout) / 60;
+ $netout_avg = $netout_avg + $netout_val;
+ $netout_prev = $netout;
+ }
+ }
+ }
+ unless (defined $netin_avg) {
+ push @p,undef;
+ } else {
+ push @p,($netin_avg/60);
+ &minmaxavg("WEEK","1Inbound",($netin_avg/60));
+ }
+ unless (defined $netout_avg) {
+ push @t,undef;
+ } else {
+ push @t,($netout_avg/60);
+ &minmaxavg("WEEK","2Outbound",($netout_avg/60));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Inbound"}{CNT} > 0) {$minmaxavg{WEEK}{"1Inbound"}{AVG} /= $minmaxavg{WEEK}{"1Inbound"}{CNT}}
+ if ($minmaxavg{WEEK}{"2Outbound"}{CNT} > 0) {$minmaxavg{WEEK}{"2Outbound"}{AVG} /= $minmaxavg{WEEK}{"2Outbound"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Bytes/Second',
+ x_label_skip => 24,
+ title => 'Network Usage in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Inbound Outbound));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "net") {
+ my (@h,@p,@t);
+ my $netin_prev;
+ my $netout_prev;
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $netin_avg;
+ my $netout_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $netin eq "") {
+ $netin_prev = 0;
+ $netout_prev = 0;
+ } else {
+ if ($netin_prev < $netin or $netin eq "") {
+ $netin_prev = $netin;
+ } else {
+ my $netin_val = ($netin_prev - $netin) / 60;
+ $netin_avg = $netin_avg + $netin_val;
+ $netin_prev = $netin;
+ }
+ if ($netout_prev < $netout or $netout eq "") {
+ $netout_prev = $netout;
+ } else {
+ my $netout_val = ($netout_prev - $netout) / 60;
+ $netout_avg = $netout_avg + $netout_val;
+ $netout_prev = $netout;
+ }
+ }
+ }
+ unless (defined $netin_avg) {
+ push @p,undef;
+ } else {
+ push @p,($netin_avg/60);
+ &minmaxavg("MONTH","1Inbound",($netin_avg/60));
+ }
+ unless (defined $netout_avg) {
+ push @t,undef;
+ } else {
+ push @t,($netout_avg/60);
+ &minmaxavg("MONTH","2Outbound",($netout_avg/60));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Inbound"}{CNT} > 0) {$minmaxavg{MONTH}{"1Inbound"}{AVG} /= $minmaxavg{MONTH}{"1Inbound"}{CNT}}
+ if ($minmaxavg{MONTH}{"2Outbound"}{CNT} > 0) {$minmaxavg{MONTH}{"2Outbound"}{AVG} /= $minmaxavg{MONTH}{"2Outbound"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Bytes/Second',
+ x_label_skip => 24,
+ title => "Network Usage in last $system_maxdays days",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Inbound Outbound));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "disk") {
+ my (@h,@p,@t);
+ my $diskread_prev;
+ my $diskwrite_prev;
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $diskread eq "") {
+ $diskread_prev = 0;
+ $diskwrite_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($diskread_prev < $diskread or $diskread eq "") {
+ push @p,undef;
+ $diskread_prev = $diskread;
+ } else {
+ my $diskread_val = ($diskread_prev - $diskread) / 60;
+ push @p,$diskread_val;
+ $diskread_prev = $diskread;
+ &minmaxavg("HOUR","1Reads",$diskread_val);
+ }
+ if ($diskwrite_prev < $diskwrite or $diskwrite eq "") {
+ push @t,undef;
+ $diskwrite_prev = $diskwrite;
+ } else {
+ my $diskwrite_val = ($diskwrite_prev - $diskwrite) / 60;
+ push @t,$diskwrite_val;
+ $diskwrite_prev = $diskwrite;
+ &minmaxavg("HOUR","2Writes",$diskwrite_val);
+ }
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Reads"}{CNT} > 0) {$minmaxavg{HOUR}{"1Reads"}{AVG} /= $minmaxavg{HOUR}{"1Reads"}{CNT}}
+ if ($minmaxavg{HOUR}{"2Writes"}{CNT} > 0) {$minmaxavg{HOUR}{"2Writes"}{AVG} /= $minmaxavg{HOUR}{"2Writes"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'IO/Second',
+ x_label_skip => 3,
+ title => 'Disk Usage in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Reads Writes));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "disk") {
+ my (@h,@p,@t);
+ my $diskread_prev;
+ my $diskwrite_prev;
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $diskread eq "") {
+ $diskread_prev = 0;
+ $diskwrite_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($diskread_prev < $diskread or $diskread eq "") {
+ push @p,undef;
+ $diskread_prev = $diskread;
+ } else {
+ my $diskread_val = ($diskread_prev - $diskread) / 60;
+ push @p,$diskread_val;
+ $diskread_prev = $diskread;
+ &minmaxavg("DAY","1Reads",$diskread_val);
+ }
+ if ($diskwrite_prev < $diskwrite or $diskwrite eq "") {
+ push @t,undef;
+ $diskwrite_prev = $diskwrite;
+ } else {
+ my $diskwrite_val = ($diskwrite_prev - $diskwrite) / 60;
+ push @t,$diskwrite_val;
+ $diskwrite_prev = $diskwrite;
+ &minmaxavg("DAY","2Writes",$diskwrite_val);
+ }
+ }
+ }
+ if ($minmaxavg{DAY}{"1Reads"}{CNT} > 0) {$minmaxavg{DAY}{"1Reads"}{AVG} /= $minmaxavg{DAY}{"1Reads"}{CNT}}
+ if ($minmaxavg{DAY}{"2Writes"}{CNT} > 0) {$minmaxavg{DAY}{"2Writes"}{AVG} /= $minmaxavg{DAY}{"2Writes"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'IO/Second',
+ x_label_skip => 60,
+ title => 'Disk Usage in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Reads Writes));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "disk") {
+ my (@h,@p,@t);
+ my $diskread_prev;
+ my $diskwrite_prev;
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $diskread_avg;
+ my $diskwrite_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $diskread eq "") {
+ $diskread_prev = 0;
+ $diskwrite_prev = 0;
+ } else {
+ if ($diskread_prev < $diskread or $diskread eq "") {
+ $diskread_prev = $diskread;
+ } else {
+ $diskread_avg = $diskread_avg + ($diskread_prev - $diskread)/60;
+ $diskread_prev = $diskread;
+ }
+ if ($diskwrite_prev < $diskwrite or $diskwrite eq "") {
+ $diskwrite_prev = $diskwrite;
+ } else {
+ $diskwrite_avg = $diskwrite_avg + ($diskwrite_prev - $diskwrite)/60;
+ $diskwrite_prev = $diskwrite;
+ }
+ }
+ }
+ unless (defined $diskread_avg) {
+ push @p,undef;
+ } else {
+ push @p,($diskread_avg/60);
+ &minmaxavg("WEEK","1Reads",($diskread_avg/60));
+ }
+ unless (defined $diskwrite_avg) {
+ push @t,undef;
+ } else {
+ push @t,($diskwrite_avg/60);
+ &minmaxavg("WEEK","2Writes",($diskwrite_avg/60));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Reads"}{CNT} > 0) {$minmaxavg{WEEK}{"1Reads"}{AVG} /= $minmaxavg{WEEK}{"1Reads"}{CNT}}
+ if ($minmaxavg{WEEK}{"2Writes"}{CNT} > 0) {$minmaxavg{WEEK}{"2Writes"}{AVG} /= $minmaxavg{WEEK}{"2Writes"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'IO/Second',
+ x_label_skip => 24,
+ title => 'Disk Usage in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Reads Writes));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "disk") {
+ my (@h,@p,@t);
+ my $diskread_prev;
+ my $diskwrite_prev;
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $diskread_avg;
+ my $diskwrite_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $diskread eq "") {
+ $diskread_prev = 0;
+ $diskwrite_prev = 0;
+ } else {
+ if ($diskread_prev < $diskread or $diskread eq "") {
+ $diskread_prev = $diskread;
+ } else {
+ $diskread_avg = $diskread_avg + ($diskread_prev - $diskread)/60;
+ $diskread_prev = $diskread;
+ }
+ if ($diskwrite_prev < $diskwrite or $diskwrite eq "") {
+ $diskwrite_prev = $diskwrite;
+ } else {
+ $diskwrite_avg = $diskwrite_avg + ($diskwrite_prev - $diskwrite)/60;
+ $diskwrite_prev = $diskwrite;
+ }
+ }
+ }
+ unless (defined $diskread_avg) {
+ push @p,undef;
+ } else {
+ push @p,($diskread_avg/60);
+ &minmaxavg("MONTH","1Reads",($diskread_avg/60));
+ }
+ unless (defined $diskwrite_avg) {
+ push @t,undef;
+ } else {
+ push @t,($diskwrite_avg/60);
+ &minmaxavg("MONTH","2Writes",($diskwrite_avg/60));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Reads"}{CNT} > 0) {$minmaxavg{MONTH}{"1Reads"}{AVG} /= $minmaxavg{MONTH}{"1Reads"}{CNT}}
+ if ($minmaxavg{MONTH}{"2Writes"}{CNT} > 0) {$minmaxavg{MONTH}{"2Writes"}{AVG} /= $minmaxavg{MONTH}{"2Writes"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'IO/Second',
+ x_label_skip => 24,
+ title => "Disk Usage in last $system_maxdays days",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Reads Writes));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "email") {
+ my (@h,@p,@t);
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mailin eq "") {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ push @p,$mailin;
+ push @t,$mailout;
+
+ &minmaxavg("HOUR","1Received",$mailin);
+ &minmaxavg("HOUR","2Sent",$mailout);
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Received"}{CNT} > 0) {$minmaxavg{HOUR}{"1Received"}{AVG} /= $minmaxavg{HOUR}{"1Received"}{CNT}}
+ if ($minmaxavg{HOUR}{"2Sent"}{CNT} > 0) {$minmaxavg{HOUR}{"2Sent"}{AVG} /= $minmaxavg{HOUR}{"2Sent"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Emails',
+ x_label_skip => 3,
+ title => 'Email Usage in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Received Sent));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "email") {
+ my (@h,@p,@t);
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mailin eq "") {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ push @p,$mailin;
+ push @t,$mailout;
+
+ &minmaxavg("DAY","1Received",$mailin);
+ &minmaxavg("DAY","2Sent",$mailout);
+ }
+ }
+ if ($minmaxavg{DAY}{"1Received"}{CNT} > 0) {$minmaxavg{DAY}{"1Received"}{AVG} /= $minmaxavg{DAY}{"1Received"}{CNT}}
+ if ($minmaxavg{DAY}{"2Sent"}{CNT} > 0) {$minmaxavg{DAY}{"2Sent"}{AVG} /= $minmaxavg{DAY}{"2Sent"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Emails',
+ x_label_skip => 60,
+ title => 'Email Usage in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Received Sent));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "email") {
+ my (@h,@p,@t);
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mailin_avg;
+ my $mailout_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $mailin ne "") {
+ $mailin_avg += $mailin;
+ $mailout_avg += $mailout;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$mailin_avg/$cnt_avg;
+ push @t,$mailout_avg/$cnt_avg;
+
+ &minmaxavg("WEEK","1Received",($mailin_avg/$cnt_avg));
+ &minmaxavg("WEEK","2Sent",($mailout_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Received"}{CNT} > 0) {$minmaxavg{WEEK}{"1Received"}{AVG} /= $minmaxavg{WEEK}{"1Received"}{CNT}}
+ if ($minmaxavg{WEEK}{"2Sent"}{CNT} > 0) {$minmaxavg{WEEK}{"2Sent"}{AVG} /= $minmaxavg{WEEK}{"2Sent"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Emails',
+ x_label_skip => 24,
+ title => 'Email Usage in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Received Sent));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "email") {
+ my (@h,@p,@t);
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mailin_avg;
+ my $mailout_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $mailin ne "") {
+ $mailin_avg += $mailin;
+ $mailout_avg += $mailout;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$mailin_avg/$cnt_avg;
+ push @t,$mailout_avg/$cnt_avg;
+
+ &minmaxavg("MONTH","1Received",($mailin_avg/$cnt_avg));
+ &minmaxavg("MONTH","2Sent",($mailout_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Received"}{CNT} > 0) {$minmaxavg{MONTH}{"1Received"}{AVG} /= $minmaxavg{MONTH}{"1Received"}{CNT}}
+ if ($minmaxavg{MONTH}{"2Sent"}{CNT} > 0) {$minmaxavg{MONTH}{"2Sent"}{AVG} /= $minmaxavg{MONTH}{"2Sent"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Emails',
+ x_label_skip => 24,
+ title => "Email Usage in last $system_maxdays",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Received Sent));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "temp") {
+ my (@h,@p);
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $cputemp eq "") {
+ push @p,undef;
+ } else {
+ push @p,$cputemp;
+
+ &minmaxavg("HOUR","1CPU",$cputemp);
+ }
+ }
+ if ($minmaxavg{HOUR}{"1CPU"}{CNT} > 0) {$minmaxavg{HOUR}{"1CPU"}{AVG} /= $minmaxavg{HOUR}{"1CPU"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Centigrade',
+ x_label_skip => 3,
+ title => 'CPU Temp in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Highest Core Temperature");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "temp") {
+ my (@h,@p);
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $cputemp eq "") {
+ push @p,undef;
+ } else {
+ push @p,$cputemp;
+
+ &minmaxavg("DAY","1CPU",$cputemp);
+ }
+ }
+ if ($minmaxavg{DAY}{"1CPU"}{CNT} > 0) {$minmaxavg{DAY}{"1CPU"}{AVG} /= $minmaxavg{DAY}{"1CPU"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Centigrade',
+ x_label_skip => 60,
+ title => 'CPU Temp in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Highest Core Temperature");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "temp") {
+ my (@h,@p);
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $cputemp_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $cputemp ne "") {
+ $cputemp_avg += $cputemp;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$cputemp_avg/$cnt_avg;
+
+ &minmaxavg("WEEK","1CPU",($cputemp_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1CPU"}{CNT} > 0) {$minmaxavg{WEEK}{"1CPU"}{AVG} /= $minmaxavg{WEEK}{"1CPU"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Centigrade',
+ x_label_skip => 24,
+ title => 'CPU Temp in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Highest Core Temperature");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "temp") {
+ my (@h,@p);
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $cputemp_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $cputemp ne "") {
+ $cputemp_avg += $cputemp;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$cputemp_avg/$cnt_avg;
+
+ &minmaxavg("MONTH","1CPU",($cputemp_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1CPU"}{CNT} > 0) {$minmaxavg{MONTH}{"1CPU"}{AVG} /= $minmaxavg{MONTH}{"1CPU"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Centigrade',
+ x_label_skip => 24,
+ title => "CPU Temp in last $system_maxdays days",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Highest Core Temperature");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqldata") {
+ my (@h,@p,@t);
+ my $mysqlin_prev;
+ my $mysqlout_prev;
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mysqlin eq "") {
+ $mysqlin_prev = 0;
+ $mysqlout_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($mysqlin_prev < $mysqlin or $mysqlin eq "") {
+ push @p,undef;
+ $mysqlin_prev = $mysqlin;
+ } else {
+ my $mysqlin_val = ($mysqlin_prev - $mysqlin) / 60;
+ push @p,$mysqlin_val;
+ $mysqlin_prev = $mysqlin;
+ &minmaxavg("HOUR","1Inbound",$mysqlin_val);
+ }
+ if ($mysqlout_prev < $mysqlout or $mysqlout eq "") {
+ push @t,undef;
+ $mysqlout_prev = $mysqlout;
+ } else {
+ my $mysqlout_val = ($mysqlout_prev - $mysqlout) / 60;
+ push @t,$mysqlout_val;
+ $mysqlout_prev = $mysqlout;
+ &minmaxavg("HOUR","2Outbound",$mysqlout_val);
+ }
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Inbound"}{CNT} > 0) {$minmaxavg{HOUR}{"1Inbound"}{AVG} /= $minmaxavg{HOUR}{"1Inbound"}{CNT}}
+ if ($minmaxavg{HOUR}{"2Outbound"}{CNT} > 0) {$minmaxavg{HOUR}{"2Outbound"}{AVG} /= $minmaxavg{HOUR}{"2Outbound"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Bytes/Second',
+ x_label_skip => 3,
+ title => 'MySQL Data in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Inbound Outbound));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqldata") {
+ my (@h,@p,@t);
+ my $mysqlin_prev;
+ my $mysqlout_prev;
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mysqlin eq "") {
+ $mysqlin_prev = 0;
+ $mysqlout_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($mysqlin_prev < $mysqlin or $mysqlin eq "") {
+ push @p,undef;
+ $mysqlin_prev = $mysqlin;
+ } else {
+ my $mysqlin_val = ($mysqlin_prev - $mysqlin) / 60;
+ push @p,$mysqlin_val;
+ $mysqlin_prev = $mysqlin;
+ &minmaxavg("DAY","1Inbound",$mysqlin_val);
+ }
+ if ($mysqlout_prev < $mysqlout or $mysqlout eq "") {
+ push @t,undef;
+ $mysqlout_prev = $mysqlout;
+ } else {
+ my $mysqlout_val = ($mysqlout_prev - $mysqlout) / 60;
+ push @t,$mysqlout_val;
+ $mysqlout_prev = $mysqlout;
+ &minmaxavg("DAY","2Outbound",$mysqlout_val);
+ }
+ }
+ }
+ if ($minmaxavg{DAY}{"1Inbound"}{CNT} > 0) {$minmaxavg{DAY}{"1Inbound"}{AVG} /= $minmaxavg{DAY}{"1Inbound"}{CNT}}
+ if ($minmaxavg{DAY}{"2Outbound"}{CNT} > 0) {$minmaxavg{DAY}{"2Outbound"}{AVG} /= $minmaxavg{DAY}{"2Outbound"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Bytes/Second',
+ x_label_skip => 60,
+ title => 'MySQL Data in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Inbound Outbound));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqldata") {
+ my (@h,@p,@t);
+ my $mysqlin_prev;
+ my $mysqlout_prev;
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mysqlin_avg;
+ my $mysqlout_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $mysqlin eq "") {
+ $mysqlin_prev = 0;
+ $mysqlout_prev = 0;
+ } else {
+ if ($mysqlin_prev < $mysqlin or $mysqlin eq "") {
+ $mysqlin_prev = $mysqlin;
+ } else {
+ my $mysqlin_val = ($mysqlin_prev - $mysqlin) / 60;
+ $mysqlin_avg = $mysqlin_avg + $mysqlin_val;
+ $mysqlin_prev = $mysqlin;
+ }
+ if ($mysqlout_prev < $mysqlout or $mysqlout eq "") {
+ $mysqlout_prev = $mysqlout;
+ } else {
+ my $mysqlout_val = ($mysqlout_prev - $mysqlout) / 60;
+ $mysqlout_avg = $mysqlout_avg + $mysqlout_val;
+ $mysqlout_prev = $mysqlout;
+ }
+ }
+ }
+ unless (defined $mysqlin_avg) {
+ push @p,undef;
+ } else {
+ push @p,($mysqlin_avg/60);
+ &minmaxavg("WEEK","1Inbound",($mysqlin_avg/60));
+ }
+ unless (defined $mysqlout_avg) {
+ push @t,undef;
+ } else {
+ push @t,($mysqlout_avg/60);
+ &minmaxavg("WEEK","2Outbound",($mysqlout_avg/60));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Inbound"}{CNT} > 0) {$minmaxavg{WEEK}{"1Inbound"}{AVG} /= $minmaxavg{WEEK}{"1Inbound"}{CNT}}
+ if ($minmaxavg{WEEK}{"2Outbound"}{CNT} > 0) {$minmaxavg{WEEK}{"2Outbound"}{AVG} /= $minmaxavg{WEEK}{"2Outbound"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Bytes/Second',
+ x_label_skip => 24,
+ title => 'MySQL Data in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Inbound Outbound));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqldata") {
+ my (@h,@p,@t);
+ my $mysqlin_prev;
+ my $mysqlout_prev;
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mysqlin_avg;
+ my $mysqlout_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $mysqlin eq "") {
+ $mysqlin_prev = 0;
+ $mysqlout_prev = 0;
+ } else {
+ if ($mysqlin_prev < $mysqlin or $mysqlin eq "") {
+ $mysqlin_prev = $mysqlin;
+ } else {
+ my $mysqlin_val = ($mysqlin_prev - $mysqlin) / 60;
+ $mysqlin_avg = $mysqlin_avg + $mysqlin_val;
+ $mysqlin_prev = $mysqlin;
+ }
+ if ($mysqlout_prev < $mysqlout or $mysqlout eq "") {
+ $mysqlout_prev = $mysqlout;
+ } else {
+ my $mysqlout_val = ($mysqlout_prev - $mysqlout) / 60;
+ $mysqlout_avg = $mysqlout_avg + $mysqlout_val;
+ $mysqlout_prev = $mysqlout;
+ }
+ }
+ }
+ unless (defined $mysqlin_avg) {
+ push @p,undef;
+ } else {
+ push @p,($mysqlin_avg/60);
+ &minmaxavg("MONTH","1Inbound",($mysqlin_avg/60));
+ }
+ unless (defined $mysqlout_avg) {
+ push @t,undef;
+ } else {
+ push @t,($mysqlout_avg/60);
+ &minmaxavg("MONTH","2Outbound",($mysqlout_avg/60));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Inbound"}{CNT} > 0) {$minmaxavg{MONTH}{"1Inbound"}{AVG} /= $minmaxavg{MONTH}{"1Inbound"}{CNT}}
+ if ($minmaxavg{MONTH}{"2Outbound"}{CNT}) {$minmaxavg{MONTH}{"2Outbound"}{AVG} /= $minmaxavg{MONTH}{"2Outbound"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Bytes/Second',
+ x_label_skip => 24,
+ title => "MySQL Data in last $system_maxdays days",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Inbound Outbound));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlqueries") {
+ my (@h,@p,@t);
+ my $mysqlq_prev;
+ my $mysqlsq_prev;
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlq_prev = 0;
+ push @p,undef;
+ } else {
+ if ($mysqlq_prev < $mysqlq or $mysqlq eq "") {
+ push @p,undef;
+ $mysqlq_prev = $mysqlq;
+ } else {
+ my $mysqlq_val = ($mysqlq_prev - $mysqlq);
+ push @p,$mysqlq_val;
+ $mysqlq_prev = $mysqlq;
+ &minmaxavg("HOUR","1Queries",$mysqlq_val);
+ }
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Queries"}{CNT} > 0) {$minmaxavg{HOUR}{"1Queries"}{AVG} /= $minmaxavg{HOUR}{"1Queries"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Queries',
+ x_label_skip => 3,
+ title => 'MySQL Queries in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Queries));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlqueries") {
+ my (@h,@p,@t);
+ my $mysqlq_prev;
+ my $mysqlsq_prev;
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlq_prev = 0;
+ push @p,undef;
+ } else {
+ if ($mysqlq_prev < $mysqlq or $mysqlq eq "") {
+ push @p,undef;
+ $mysqlq_prev = $mysqlq;
+ } else {
+ my $mysqlq_val = ($mysqlq_prev - $mysqlq);
+ push @p,$mysqlq_val;
+ $mysqlq_prev = $mysqlq;
+ &minmaxavg("DAY","1Queries",$mysqlq_val);
+ }
+ }
+ }
+ if ($minmaxavg{DAY}{"1Queries"}{CNT} > 0) {$minmaxavg{DAY}{"1Queries"}{AVG} /= $minmaxavg{DAY}{"1Queries"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Queries',
+ x_label_skip => 60,
+ title => 'MySQL Queries in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Queries));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlqueries") {
+ my (@h,@p,@t);
+ my $mysqlq_prev;
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mysqlq_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlq_prev = 0;
+ } else {
+ if ($mysqlq_prev < $mysqlq or $mysqlq eq "") {
+ $mysqlq_prev = $mysqlq;
+ } else {
+ my $mysqlq_val = ($mysqlq_prev - $mysqlq);
+ $mysqlq_avg = $mysqlq_avg + $mysqlq_val;
+ $mysqlq_prev = $mysqlq;
+ }
+ }
+ }
+ unless (defined $mysqlq_avg) {
+ push @p,undef;
+ } else {
+ push @p,($mysqlq_avg/60);
+ &minmaxavg("WEEK","1Queries",($mysqlq_avg/60));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Queries"}{CNT} > 0) {$minmaxavg{WEEK}{"1Queries"}{AVG} /= $minmaxavg{WEEK}{"1Queries"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Queries',
+ x_label_skip => 24,
+ title => 'MySQL Queries in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Queries));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlqueries") {
+ my (@h,@p,@t);
+ my $mysqlq_prev;
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mysqlq_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlq_prev = 0;
+ } else {
+ if ($mysqlq_prev < $mysqlq or $mysqlq eq "") {
+ $mysqlq_prev = $mysqlq;
+ } else {
+ my $mysqlq_val = ($mysqlq_prev - $mysqlq);
+ $mysqlq_avg = $mysqlq_avg + $mysqlq_val;
+ $mysqlq_prev = $mysqlq;
+ }
+ }
+ }
+ unless (defined $mysqlq_avg) {
+ push @p,undef;
+ } else {
+ push @p,($mysqlq_avg/60);
+ &minmaxavg("MONTH","1Queries",($mysqlq_avg/60));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Queries"}{CNT} > 0) {$minmaxavg{MONTH}{"1Queries"}{AVG} /= $minmaxavg{MONTH}{"1Queries"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Queries',
+ x_label_skip => 24,
+ title => "MySQL Queries in last $system_maxdays",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Queries));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlslowqueries") {
+ my (@h,@p,@t);
+ my $mysqlsq_prev;
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlsq_prev = 0;
+ push @t,undef;
+ } else {
+ if ($mysqlsq_prev < $mysqlsq or $mysqlsq eq "") {
+ push @t,undef;
+ $mysqlsq_prev = $mysqlsq;
+ } else {
+ my $mysqlsq_val = ($mysqlsq_prev - $mysqlsq);
+ push @t,$mysqlsq_val;
+ $mysqlsq_prev = $mysqlsq;
+ &minmaxavg("HOUR","1Slow_Queries",$mysqlsq_val);
+ }
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Slow_Queries"}{CNT} > 0) {$minmaxavg{HOUR}{"1Slow_Queries"}{AVG} /= $minmaxavg{HOUR}{"1Slow_Queries"}{CNT}}
+ my @data = ([reverse @h],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Slow Queries',
+ x_label_skip => 3,
+ title => 'MySQL Slow Queries in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Slow_Queries));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlslowqueries") {
+ my (@h,@p,@t);
+ my $mysqlsq_prev;
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlsq_prev = 0;
+ push @t,undef;
+ } else {
+ if ($mysqlsq_prev < $mysqlsq or $mysqlsq eq "") {
+ push @t,undef;
+ $mysqlsq_prev = $mysqlsq;
+ } else {
+ my $mysqlsq_val = ($mysqlsq_prev - $mysqlsq);
+ push @t,$mysqlsq_val;
+ $mysqlsq_prev = $mysqlsq;
+ &minmaxavg("DAY","1Slow_Queries",$mysqlsq_val);
+ }
+ }
+ }
+ if ($minmaxavg{DAY}{"1Slow_Queries"}{CNT} > 0) {$minmaxavg{DAY}{"1Slow_Queries"}{AVG} /= $minmaxavg{DAY}{"1Slow_Queries"}{CNT}}
+ my @data = ([reverse @h],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Slow Queries',
+ x_label_skip => 60,
+ title => 'MySQL Slow Queries in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Slow_Queries));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlslowqueries") {
+ my (@h,@p,@t);
+ my $mysqlsq_prev;
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mysqlsq_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $mysqlsq eq "") {
+ $mysqlsq_prev = 0;
+ } else {
+ if ($mysqlsq_prev < $mysqlsq or $mysqlsq eq "") {
+ $mysqlsq_prev = $mysqlsq;
+ } else {
+ my $mysqlsq_val = ($mysqlsq_prev - $mysqlsq);
+ $mysqlsq_avg = $mysqlsq_avg + $mysqlsq_val;
+ $mysqlsq_prev = $mysqlsq;
+ }
+ }
+ }
+ unless (defined $mysqlsq_avg) {
+ push @t,undef;
+ } else {
+ push @t,($mysqlsq_avg/60);
+ &minmaxavg("WEEK","1Slow_Queries",($mysqlsq_avg/60));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Slow_Queries"}{CNT} > 0) {$minmaxavg{WEEK}{"1Slow_Queries"}{AVG} /= $minmaxavg{WEEK}{"1Slow_Queries"}{CNT}}
+ my @data = ([reverse @h],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Slow Queries',
+ x_label_skip => 24,
+ title => 'MySQL Slow Queries in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Slow_Queries));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlslowqueries") {
+ my (@h,@p,@t);
+ my $mysqlsq_prev;
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mysqlsq_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $mysqlsq eq "") {
+ $mysqlsq_prev = 0;
+ } else {
+ if ($mysqlsq_prev < $mysqlsq or $mysqlsq eq "") {
+ $mysqlsq_prev = $mysqlsq;
+ } else {
+ my $mysqlsq_val = ($mysqlsq_prev - $mysqlsq);
+ $mysqlsq_avg = $mysqlsq_avg + $mysqlsq_val;
+ $mysqlsq_prev = $mysqlsq;
+ }
+ }
+ }
+ unless (defined $mysqlsq_avg) {
+ push @t,undef;
+ } else {
+ push @t,($mysqlsq_avg/60);
+ &minmaxavg("MONTH","1Slow_Queries",($mysqlsq_avg/60));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Slow_Queries"}{CNT} > 0) {$minmaxavg{MONTH}{"1Slow_Queries"}{AVG} /= $minmaxavg{MONTH}{"1Slow_Queries"}{CNT}}
+ my @data = ([reverse @h],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Slow Queries',
+ x_label_skip => 24,
+ title => "MySQL Slow Queries in last $system_maxdays",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Slow_Queries));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlconns") {
+ my (@h,@p,@t);
+ my $mysqlcn_prev;
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlcn_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($mysqlcn_prev < $mysqlcn or $mysqlcn eq "") {
+ push @p,undef;
+ $mysqlcn_prev = $mysqlcn;
+ } else {
+ my $mysqlcn_val = ($mysqlcn_prev - $mysqlcn);
+ push @p,$mysqlcn_val;
+ $mysqlcn_prev = $mysqlcn;
+ &minmaxavg("HOUR","1Connections",$mysqlcn_val);
+ }
+ if ($mysqlth eq "") {
+ push @t,undef;
+ } else {
+ push @t,$mysqlth;
+ &minmaxavg("HOUR","2Threads",$mysqlth);
+ }
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Connections"}{CNT} > 0) {$minmaxavg{HOUR}{"1Connections"}{AVG} /= $minmaxavg{HOUR}{"1Connections"}{CNT}}
+ if ($minmaxavg{HOUR}{"2Threads"}{CNT} > 0) {$minmaxavg{HOUR}{"2Threads"}{AVG} /= $minmaxavg{HOUR}{"2Threads"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => '',
+ x_label_skip => 3,
+ title => 'MySQL Connections & Threads in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Connections Threads));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlconns") {
+ my (@h,@p,@t);
+ my $mysqlcn_prev;
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlcn_prev = 0;
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($mysqlcn_prev < $mysqlcn or $mysqlcn eq "") {
+ push @p,undef;
+ $mysqlcn_prev = $mysqlcn;
+ } else {
+ my $mysqlcn_val = ($mysqlcn_prev - $mysqlcn);
+ push @p,$mysqlcn_val;
+ $mysqlcn_prev = $mysqlcn;
+ &minmaxavg("DAY","1Connections",$mysqlcn_val);
+ }
+ if ($mysqlth eq "") {
+ push @t,undef;
+ } else {
+ push @t,$mysqlth;
+ &minmaxavg("DAY","2Threads",$mysqlth);
+ }
+ }
+ }
+ if ($minmaxavg{DAY}{"1Connections"}{CNT} > 0) {$minmaxavg{DAY}{"1Connections"}{AVG} /= $minmaxavg{DAY}{"1Connections"}{CNT}}
+ if ($minmaxavg{DAY}{"2Threads"}{CNT} > 0) {$minmaxavg{DAY}{"2Threads"}{AVG} /= $minmaxavg{DAY}{"2Threads"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => '',
+ x_label_skip => 60,
+ title => 'MySQL Connections & Threads in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Connections Threads));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlconns") {
+ my (@h,@p,@t);
+ my $mysqlcn_prev;
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mysqlcn_avg;
+ my $mysqlth_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlcn_prev = 0;
+ } else {
+ if ($mysqlcn_prev < $mysqlcn or $mysqlcn eq "") {
+ $mysqlcn_prev = $mysqlcn;
+ } else {
+ my $mysqlcn_val = ($mysqlcn_prev - $mysqlcn);
+ $mysqlcn_avg = $mysqlcn_avg + $mysqlcn_val;
+ $mysqlcn_prev = $mysqlcn;
+ }
+ $mysqlth_avg = $mysqlth_avg + $mysqlth;
+ }
+ }
+ unless (defined $mysqlcn_avg) {
+ push @p,undef;
+ } else {
+ push @p,($mysqlcn_avg/60);
+ &minmaxavg("WEEK","1Connections",($mysqlcn_avg/60));
+ }
+ unless (defined $mysqlth_avg) {
+ push @t,undef;
+ } else {
+ push @t,($mysqlth_avg/60);
+ &minmaxavg("WEEK","2Threads",($mysqlth_avg/60));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Connections"}{CNT} > 0) {$minmaxavg{WEEK}{"1Connections"}{AVG} /= $minmaxavg{WEEK}{"1Connections"}{CNT}}
+ if ($minmaxavg{WEEK}{"2Threads"}{CNT} > 0) {$minmaxavg{WEEK}{"2Threads"}{AVG} /= $minmaxavg{WEEK}{"2Threads"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => '',
+ x_label_skip => 24,
+ title => 'MySQL Connections & Threads in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Connections Threads));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "mysqlconns") {
+ my (@h,@p,@t);
+ my $mysqlcn_prev;
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $mysqlcn_avg;
+ my $mysqlth_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $mysqlq eq "") {
+ $mysqlcn_prev = 0;
+ } else {
+ if ($mysqlcn_prev < $mysqlcn or $mysqlcn eq "") {
+ $mysqlcn_prev = $mysqlcn;
+ } else {
+ my $mysqlcn_val = ($mysqlcn_prev - $mysqlcn);
+ $mysqlcn_avg = $mysqlcn_avg + $mysqlcn_val;
+ $mysqlcn_prev = $mysqlcn;
+ }
+ $mysqlth_avg = $mysqlth_avg + $mysqlth;
+ }
+ }
+ unless (defined $mysqlcn_avg) {
+ push @p,undef;
+ } else {
+ push @p,($mysqlcn_avg/60);
+ &minmaxavg("MONTH","1Connections",($mysqlcn_avg/60));
+ }
+ unless (defined $mysqlth_avg) {
+ push @t,undef;
+ } else {
+ push @t,($mysqlth_avg/60);
+ &minmaxavg("MONTH","2Threads",($mysqlth_avg/60));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Connections"}{CNT} > 0) {$minmaxavg{MONTH}{"1Connections"}{AVG} /= $minmaxavg{MONTH}{"1Connections"}{CNT}}
+ if ($minmaxavg{MONTH}{"2Threads"}{CNT} > 0) {$minmaxavg{MONTH}{"2Threads"}{AVG} /= $minmaxavg{MONTH}{"2Threads"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => '',
+ x_label_skip => 24,
+ title => "MySQL Connections & Threads in last $system_maxdays days",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Connections Threads));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apachecpu") {
+ my (@h,@p);
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $apachecpu eq "") {
+ push @p,undef;
+ } else {
+ push @p,$apachecpu;
+
+ &minmaxavg("HOUR","1Apache_CPU",$apachecpu);
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Apache_CPU"}{CNT} > 0) {$minmaxavg{HOUR}{"1Apache_CPU"}{AVG} /= $minmaxavg{HOUR}{"1Apache_CPU"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Percentage',
+ x_label_skip => 3,
+ title => 'Apache CPU Usage in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Apache CPU");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apachecpu") {
+ my (@h,@p);
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $apachecpu eq "") {
+ push @p,undef;
+ } else {
+ push @p,$apachecpu;
+
+ &minmaxavg("DAY","1Apache_CPU",$apachecpu);
+ }
+ }
+ if ($minmaxavg{DAY}{"1Apache_CPU"}{CNT} > 0) {$minmaxavg{DAY}{"1Apache_CPU"}{AVG} /= $minmaxavg{DAY}{"1Apache_CPU"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Percentage',
+ x_label_skip => 60,
+ title => 'Apache CPU Usage in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Apache CPU");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apachecpu") {
+ my (@h,@p);
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $apachecpu_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $apachecpu ne "") {
+ $apachecpu_avg += $apachecpu;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$apachecpu_avg/$cnt_avg;
+
+ &minmaxavg("WEEK","1Apache_CPU",($apachecpu_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Apache_CPU"}{CNT} > 0) {$minmaxavg{WEEK}{"1Apache_CPU"}{AVG} /= $minmaxavg{WEEK}{"1Apache_CPU"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Percentage',
+ x_label_skip => 24,
+ title => 'Apache CPU Usage in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Apache CPU");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apachecpu") {
+ my (@h,@p);
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $apachecpu_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $apachecpu ne "") {
+ $apachecpu_avg += $apachecpu;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$apachecpu_avg/$cnt_avg;
+
+ &minmaxavg("MONTH","1Apache_CPU",($apachecpu_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Apache_CPU"}{CNT} > 0) {$minmaxavg{MONTH}{"1Apache_CPU"}{AVG} /= $minmaxavg{MONTH}{"1Apache_CPU"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Percentage',
+ x_label_skip => 24,
+ title => "Apache CPU Usage in last $system_maxdays",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Apache CPU");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apacheconn") {
+ my (@h,@p);
+ my $apacheacc_prev;
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $apacheacc eq "") {
+ $apacheacc_prev = 0;
+ push @p,undef;
+ } else {
+ if ($apacheacc_prev < $apacheacc or $apacheacc eq "") {
+ push @p,undef;
+ $apacheacc_prev = $apacheacc;
+ } else {
+ my $apacheacc_val = ($apacheacc_prev - $apacheacc);
+ push @p,$apacheacc_val;
+ $apacheacc_prev = $apacheacc;
+ &minmaxavg("HOUR","1Connections",$apacheacc_val);
+ }
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Connections"}{CNT} > 0) {$minmaxavg{HOUR}{"1Connections"}{AVG} /= $minmaxavg{HOUR}{"1Connections"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => '',
+ x_label_skip => 3,
+ title => 'Apache Connections in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Connections));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apacheconn") {
+ my (@h,@p,@t);
+ my $apacheacc_prev;
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $apacheacc eq "") {
+ $apacheacc_prev = 0;
+ push @p,undef;
+ } else {
+ if ($apacheacc_prev < $apacheacc or $apacheacc eq "") {
+ push @p,undef;
+ $apacheacc_prev = $apacheacc;
+ } else {
+ my $apacheacc_val = ($apacheacc_prev - $apacheacc);
+ push @p,$apacheacc_val;
+ $apacheacc_prev = $apacheacc;
+ &minmaxavg("DAY","1Connections",$apacheacc_val);
+ }
+ }
+ }
+ if ($minmaxavg{DAY}{"1Connections"}{CNT} > 0) {$minmaxavg{DAY}{"1Connections"}{AVG} /= $minmaxavg{DAY}{"1Connections"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => '',
+ x_label_skip => 60,
+ title => 'Apache Connections in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Connections));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apacheconn") {
+ my (@h,@p,@t);
+ my $apacheacc_prev;
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $apacheacc_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $apacheacc eq "") {
+ $apacheacc_prev = 0;
+ } else {
+ if ($apacheacc_prev < $apacheacc or $apacheacc eq "") {
+ $apacheacc_prev = $apacheacc;
+ } else {
+ my $apacheacc_val = ($apacheacc_prev - $apacheacc);
+ $apacheacc_avg = $apacheacc_avg + $apacheacc_val;
+ $apacheacc_prev = $apacheacc;
+ }
+ }
+ }
+ unless (defined $apacheacc_avg) {
+ push @p,undef;
+ } else {
+ push @p,($apacheacc_avg/60);
+ &minmaxavg("WEEK","1Connections",($apacheacc_avg/60));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Connections"}{CNT} > 0) {$minmaxavg{WEEK}{"1Connections"}{AVG} /= $minmaxavg{WEEK}{"1Connections"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => '',
+ x_label_skip => 24,
+ title => 'Apache Connections in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Connections Threads));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apacheconn") {
+ my (@h,@p,@t);
+ my $apacheacc_prev;
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $apacheacc_avg;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time eq "" or $apacheacc eq "") {
+ $apacheacc_prev = 0;
+ } else {
+ if ($apacheacc_prev < $apacheacc or $apacheacc eq "") {
+ $apacheacc_prev = $apacheacc;
+ } else {
+ my $apacheacc_val = ($apacheacc_prev - $apacheacc);
+ $apacheacc_avg = $apacheacc_avg + $apacheacc_val;
+ $apacheacc_prev = $apacheacc;
+ }
+ }
+ }
+ unless (defined $apacheacc_avg) {
+ push @p,undef;
+ } else {
+ push @p,($apacheacc_avg/60);
+ &minmaxavg("MONTH","1Connections",($apacheacc_avg/60));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Connections"}{CNT} > 0) {$minmaxavg{MONTH}{"1Connections"}{AVG} /= $minmaxavg{MONTH}{"1Connections"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => '',
+ x_label_skip => 24,
+ title => "Apache Connections in last $system_maxdays",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Connections Threads));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apachework") {
+ my (@h,@p,@t);
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $apachebwork eq "") {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ push @p,$apachebwork;
+ push @t,$apacheiwork;
+
+ &minmaxavg("HOUR","1Busy",$apachebwork);
+ &minmaxavg("HOUR","2Idle",$apacheiwork);
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Busy"}{CNT} > 0) {$minmaxavg{HOUR}{"1Busy"}{AVG} /= $minmaxavg{HOUR}{"1Busy"}{CNT}}
+ if ($minmaxavg{HOUR}{"2Idle"}{CNT} > 0) {$minmaxavg{HOUR}{"2Idle"}{AVG} /= $minmaxavg{HOUR}{"2Idle"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'Workers',
+ x_label_skip => 3,
+ title => 'Apache Workers in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Busy Idle));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apachework") {
+ my (@h,@p,@t);
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $apachebwork eq "") {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ push @p,$apachebwork;
+ push @t,$apacheiwork;
+
+ &minmaxavg("DAY","1Busy",$apachebwork);
+ &minmaxavg("DAY","2Idle",$apacheiwork);
+ }
+ }
+ if ($minmaxavg{DAY}{"1Busy"}{CNT} > 0) {$minmaxavg{DAY}{"1Busy"}{AVG} /= $minmaxavg{DAY}{"1Busy"}{CNT}}
+ if ($minmaxavg{DAY}{"2Idle"}{CNT} > 0) {$minmaxavg{DAY}{"2Idle"}{AVG} /= $minmaxavg{DAY}{"2Idle"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Workers',
+ x_label_skip => 60,
+ title => 'Apache Workers in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Busy Idle));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apachework") {
+ my (@h,@p,@t);
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $apachebwork_avg;
+ my $apacheiwork_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $apachebwork ne "") {
+ $apachebwork_avg += $apachebwork;
+ $apacheiwork_avg += $apacheiwork;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$apachebwork_avg/$cnt_avg;
+ push @t,$apacheiwork_avg/$cnt_avg;
+
+ &minmaxavg("WEEK","1Busy",($apachebwork_avg/$cnt_avg));
+ &minmaxavg("WEEK","2Idle",($apacheiwork_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Busy"}{CNT} > 0) {$minmaxavg{WEEK}{"1Busy"}{AVG} /= $minmaxavg{WEEK}{"1Busy"}{CNT}}
+ if ($minmaxavg{WEEK}{"2Idle"}{CNT} > 0) {$minmaxavg{WEEK}{"2Idle"}{AVG} /= $minmaxavg{WEEK}{"2Idle"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Workers',
+ x_label_skip => 24,
+ title => 'Apache Workers in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Busy Idle));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "apachework") {
+ my (@h,@p,@t);
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $apachebwork_avg;
+ my $apacheiwork_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $apachebwork ne "") {
+ $apachebwork_avg += $apachebwork;
+ $apacheiwork_avg += $apacheiwork;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ push @t,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$apachebwork_avg/$cnt_avg;
+ push @t,$apacheiwork_avg/$cnt_avg;
+
+ &minmaxavg("MONTH","1Busy",($apachebwork_avg/$cnt_avg));
+ &minmaxavg("MONTH","2Idle",($apacheiwork_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Busy"}{CNT} > 0) {$minmaxavg{MONTH}{"1Busy"}{AVG} /= $minmaxavg{MONTH}{"1Busy"}{CNT}}
+ if ($minmaxavg{MONTH}{"2Idle"}{CNT} > 0) {$minmaxavg{MONTH}{"2Idle"}{AVG} /= $minmaxavg{MONTH}{"2Idle"}{CNT}}
+ my @data = ([reverse @h],[reverse @p],[reverse @t]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'Workers',
+ x_label_skip => 24,
+ title => "Apache Workers in last $system_maxdays",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend( qw(Busy Idle));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+ if ($type eq "diskw") {
+ my (@h,@p);
+ for (my $mins = 0; $mins < 60;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$min;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $diskw eq "") {
+ push @p,undef;
+ } else {
+ push @p,$diskw;
+
+ &minmaxavg("HOUR","1Disk_Write",$diskw);
+ }
+ }
+ if ($minmaxavg{HOUR}{"1Disk_Write"}{CNT} > 0) {$minmaxavg{HOUR}{"1Disk_Write"}{AVG} /= $minmaxavg{HOUR}{"1Disk_Write"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Minute',
+ y_label => 'MB/s',
+ x_label_skip => 3,
+ title => 'Disk Write Performance in last hour',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Disk_Write");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemhour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "diskw") {
+ my (@h,@p);
+ for (my $mins = 0; $mins < 1440;$mins++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($mins * 60));
+ push @h,$hour;
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$min});
+ if ($time eq "" or $diskw eq "") {
+ push @p,undef;
+ } else {
+ push @p,$diskw;
+
+ &minmaxavg("DAY","1Disk_Write",$diskw);
+ }
+ }
+ if ($minmaxavg{DAY}{"1Disk_Write"}{CNT} > 0) {$minmaxavg{DAY}{"1Disk_Write"}{AVG} /= $minmaxavg{DAY}{"1Disk_Write"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred purple) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'MB/s',
+ x_label_skip => 60,
+ title => 'Disk Write Performance in last 24 hours',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Disk_Write");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemday.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "diskw") {
+ my (@h,@p);
+ for (my $hours = 0; $hours < 168;$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $diskw_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $diskw ne "") {
+ $diskw_avg += $diskw;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$diskw_avg/$cnt_avg;
+
+ &minmaxavg("WEEK","1Disk_Write",($diskw_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{WEEK}{"1Disk_Write"}{CNT} > 0) {$minmaxavg{WEEK}{"1Disk_Write"}{AVG} /= $minmaxavg{WEEK}{"1Disk_Write"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'MB/s',
+ x_label_skip => 24,
+ title => 'Disk Write Performance in last 7 days',
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Disk_Write");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemweek.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+
+ if ($type eq "diskw") {
+ my (@h,@p);
+ for (my $hours = 0; $hours < (24 * $system_maxdays);$hours++) {
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time - ($hours * 60 * 60));
+ push @h,$mday;
+ my $diskw_avg;
+ my $cnt_avg = 0;
+ for (my $mins = 59; $mins >= 0;$mins--) {
+ my ($time,$cputotal,$cpuidle,$cpuiowait,$memtotal,$memfree,$memswaptotal,$memswapfree,$load1,$load5,$load15,$netin,$netout,$diskread,$diskwrite,$mailin,$mailout,$cputemp,$mysqlin,$mysqlout,$mysqlq,$mysqlsq,$mysqlcn,$mysqlth,$apachecpu,$apacheacc,$apachebwork,$apacheiwork,$diskw,$memcached) = split(/\,/,$stata{$year}{$mon}{$mday}{$hour}{$mins});
+ if ($time and $diskw ne "") {
+ $diskw_avg += $diskw;
+ $cnt_avg++;
+ }
+ }
+ unless (defined $cnt_avg) {
+ push @p,undef;
+ } else {
+ if ($cnt_avg == 0) {$cnt_avg = 1}
+ push @p,$diskw_avg/$cnt_avg;
+
+ &minmaxavg("MONTH","1Disk_Write",($diskw_avg/$cnt_avg));
+ }
+ }
+ if ($minmaxavg{MONTH}{"1Disk_Write"}{CNT} > 0) {$minmaxavg{MONTH}{"1Disk_Write"}{AVG} /= $minmaxavg{MONTH}{"1Disk_Write"}{CNT}}
+ my @data = ([reverse @h],[reverse @p]);
+ my $hour_graph = GD::Graph::lines->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Day (Hourly Average)',
+ y_label => 'MB/s',
+ x_label_skip => 24,
+ title => "Disk Write Performance in last $system_maxdays",
+ borderclrs => $hour_graph->{dclrs},
+ transparent => 0,
+ );
+ $hour_graph->set_legend("Disk_Write");
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_systemmonth.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+ }
+ }
+
+ return;
+}
+# end graphs
+###############################################################################
+# start charts
+sub charts {
+ my $cc_lookups = shift;
+ my $imghddir = shift;
+ my $img;
+ $| = 1;
+
+ require GD::Graph::bars;
+ import GD::Graph::bars;
+ require GD::Graph::pie;
+ import GD::Graph::pie;
+ require GD::Graph::lines;
+ import GD::Graph::lines;
+
+ sysopen (my $STATS,"/var/lib/csf/stats/lfdstats", O_RDWR | O_CREAT);
+ flock ($STATS, LOCK_SH);
+ my @stats = <$STATS>;
+ chomp @stats;
+ close ($STATS);
+
+ if (@stats) {
+ my $time = time;
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($time);
+
+ # Blocks by lfd in the last 24 hours
+ my $cnt = $hour + 1;
+ if ($cnt > 23) {$cnt = 0}
+ my (@h,@p,@t,@hp,@cp);
+ my %triggers;
+ for (my $hours = 0; $hours < 24;$hours++) {
+ push @h,$cnt;
+ my ($permdate,$permcount,$tempdate,$tempcount) = split(/\,/,$stats[$cnt]);
+ if ($time - $permdate > (24 * 60 * 60)) {$permdate = 0; $permcount = 0}
+ if ($time - $tempdate > (24 * 60 * 60)) {$tempdate = 0; $tempcount = 0}
+ push @p,$permcount;
+ push @t,$tempcount;
+ my @line = split(/\,/,$stats[$cnt]);
+ for (my $loop = 4; $loop < @line; $loop+=2) {
+ if ($time - $line[$loop] > (24 * 60 * 60)) {next}
+ my ($triggerstat,$triggercount) = split(/\:/,$line[$loop+1]);
+ $triggers{$triggerstat} += $triggercount;
+ }
+ $cnt++;
+ if ($cnt > 23) {$cnt = 0}
+ }
+ my @data = ([@h],[@p],[@t]);
+ my $hour_graph = GD::Graph::bars->new(750,350);
+ $hour_graph->set( dclrs => [ qw(yellow dred) ] );
+ $hour_graph->set(
+ x_label => 'Hour',
+ y_label => 'Total Blocks',
+ long_ticks => 1,
+ tick_length => 0,
+ x_ticks => 0,
+ title => 'Blocks by lfd in the last 24 hours',
+ cumulate => 1,
+ borderclrs => $hour_graph->{dclrs},
+ bar_spacing => 4,
+ shadow_depth => 1,
+ transparent => 0,
+ x_label_position => 1/2,
+ );
+ $hour_graph->set_legend( qw(Permanent Temporary));
+ $hour_graph->plot(\@data);
+ $img = $imghddir."lfd_hour.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $hour_graph->gd->gif();
+ close ($OUT);
+
+ foreach my $key (keys %triggers) {
+ push @hp, "$key ($triggers{$key})";
+ push @cp, $triggers{$key};
+ }
+ my @piedata = ([@hp],[@cp]);
+ my $hour_pie_graph = GD::Graph::pie->new( 400, 300 );
+ $hour_pie_graph->set(
+ title => 'Block triggers in the last 24 hours',
+ label => 'Trigger in csf.conf',
+ axislabelclr => 'black',
+ pie_height => 36,
+ l_margin => 15,
+ r_margin => 15,
+ start_angle => 235,
+ transparent => 0,
+ );
+ $hour_pie_graph->plot(\@piedata);
+ $img = $imghddir."lfd_pie_hour.gif";
+ open (my $OUT2, ">", "$img");
+ flock ($OUT2, LOCK_EX);
+ binmode ($OUT2);
+ print $OUT2 $hour_pie_graph->gd->gif();
+ close ($OUT2);
+
+
+ # Blocks by lfd in the last 30 Days
+ my $maxdays = 30;
+ my ($hsec,$hmin,$hhour,$hmday,$hmon,$hyear,$hwday,$hyday,$hisdst) = localtime($time - (29 * 24 * 60 * 60));
+ my $hdim = (31,28,31,30,31,30,31,31,30,31,30,31)[$hmon];
+ if ($hmon == 1 && (($hyear % 4 == 0) && ($hyear % 100 != 0) && ($hyear % 400 == 0))) {$hdim++}
+ if ($hmon == 1) {
+ $maxdays = $hdim;
+ ($hsec,$hmin,$hhour,$hmday,$hmon,$hyear,$hwday,$hyday,$hisdst) = localtime($time - (($maxdays - 1) * 24 * 60 * 60));
+ }
+ $cnt = $hmday;
+ my (@hh,@ph,@th,@hhp,@hcp);
+ my %htriggers;
+ for (my $days = 1; $days <= $maxdays;$days++) {
+ push @hh,$cnt;
+ my ($permdate,$permcount,$tempdate,$tempcount) = split(/\,/,$stats[$cnt+24]);
+ if ($time - $permdate > (($maxdays - 1) * 24 * 60 * 60)) {$permdate = 0; $permcount = 0}
+ if ($time - $tempdate > (($maxdays - 1) * 24 * 60 * 60)) {$tempdate = 0; $tempcount = 0}
+ push @ph,$permcount;
+ push @th,$tempcount;
+ my @line = split(/\,/,$stats[$cnt+24]);
+ for (my $loop = 4; $loop < @line; $loop+=2) {
+ if ($time - $line[$loop] > (($maxdays - 1) * 24 * 60 * 60)) {next}
+ my ($triggerstat,$triggercount) = split(/\:/,$line[$loop+1]);
+ $htriggers{$triggerstat} += $triggercount;
+ }
+ $cnt++;
+ if ($cnt > $hdim) {$cnt = 1}
+ }
+ my @datah = ([@hh],[@ph],[@th]);
+ my $day_graph = GD::Graph::bars->new(750,350);
+ $day_graph->set( dclrs => [ qw(yellow dred) ] );
+ $day_graph->set(
+ x_label => 'Day',
+ y_label => 'Total Blocks',
+ long_ticks => 1,
+ tick_length => 0,
+ x_ticks => 0,
+ title => "Blocks by lfd in the last $maxdays Days",
+ cumulate => 1,
+ borderclrs => $day_graph->{dclrs},
+ bar_spacing => 4,
+ shadow_depth => 1,
+ transparent => 0,
+ x_label_position => 1/2,
+ );
+ $day_graph->set_legend( qw(Permanent Temporary));
+ $day_graph->plot(\@datah);
+ $img = $imghddir."lfd_month.gif";
+ open (my $OUT3, ">", "$img");
+ flock ($OUT3, LOCK_EX);
+ binmode ($OUT3);
+ print $OUT3 $day_graph->gd->gif();
+ close ($OUT3);
+
+ foreach my $key (keys %htriggers) {
+ push @hhp, "$key ($htriggers{$key})";
+ push @hcp, $htriggers{$key};
+ }
+ my @hpiedata = ([@hhp],[@hcp]);
+ my $day_pie_graph = GD::Graph::pie->new( 400, 300 );
+ $day_pie_graph->set(
+ title => "Block triggers in the last $maxdays days",
+ label => 'Trigger in csf.conf',
+ axislabelclr => 'black',
+ pie_height => 36,
+ l_margin => 15,
+ r_margin => 15,
+ start_angle => 235,
+ transparent => 0,
+ );
+ $day_pie_graph->plot(\@hpiedata);
+ $img = $imghddir."lfd_pie_day.gif";
+ open (my $OUT4, ">", "$img");
+ flock ($OUT4, LOCK_EX);
+ binmode ($OUT4);
+ print $OUT4 $day_pie_graph->gd->gif();
+ close ($OUT4);
+
+ # Blocks by lfd in the last 12 months
+ $cnt = $mon + 2;
+ if ($cnt > 12) {$cnt = 1}
+ my (@hy,@py,@ty,@yhp,@ycp);
+ my %ytriggers;
+ for (my $months = 1; $months < 13;$months++) {
+ push @hy,$cnt;
+ my ($permdate,$permcount,$tempdate,$tempcount) = split(/\,/,$stats[$cnt+55]);
+ if ($time - $permdate > (364 * 24 * 60 * 60)) {$permdate = 0; $permcount = 0}
+ if ($time - $tempdate > (364 * 24 * 60 * 60)) {$tempdate = 0; $tempcount = 0}
+ push @py,$permcount;
+ push @ty,$tempcount;
+ my @line = split(/\,/,$stats[$cnt+55]);
+ for (my $loop = 4; $loop < @line; $loop+=2) {
+ if ($time - $line[$loop] > (364 * 24 * 60 * 60)) {next}
+ my ($triggerstat,$triggercount) = split(/\:/,$line[$loop+1]);
+ $ytriggers{$triggerstat} += $triggercount;
+ }
+ $cnt++;
+ if ($cnt > 12) {$cnt = 1}
+ }
+ my @datay = ([@hy],[@py],[@ty]);
+ my $year_graph = GD::Graph::bars->new(750,350);
+ $year_graph->set( dclrs => [ qw(yellow dred) ] );
+ $year_graph->set(
+ x_label => 'Month',
+ y_label => 'Total Blocks',
+ long_ticks => 1,
+ tick_length => 0,
+ x_ticks => 0,
+ title => 'Blocks by lfd in the last 12 months',
+ cumulate => 1,
+ borderclrs => $year_graph->{dclrs},
+ bar_spacing => 4,
+ shadow_depth => 1,
+ transparent => 0,
+ x_label_position => 1/2,
+ );
+ $year_graph->set_legend( qw(Permanent Temporary));
+ $year_graph->plot(\@datay);
+ $img = $imghddir."lfd_year.gif";
+ open (my $OUT5, ">", "$img");
+ flock ($OUT5, LOCK_EX);
+ binmode ($OUT5);
+ print $OUT5 $year_graph->gd->gif();
+ close ($OUT5);
+
+ foreach my $key (keys %ytriggers) {
+ push @yhp, "$key ($ytriggers{$key})";
+ push @ycp, $ytriggers{$key};
+ }
+ my @ypiedata = ([@yhp],[@ycp]);
+ my $year_pie_graph = GD::Graph::pie->new( 400, 300 );
+ $year_pie_graph->set(
+ title => 'Block triggers in the last 12 months',
+ label => 'Trigger in csf.conf',
+ axislabelclr => 'black',
+ pie_height => 36,
+ l_margin => 15,
+ r_margin => 15,
+ start_angle => 235,
+ transparent => 0,
+ );
+ $year_pie_graph->plot(\@ypiedata);
+ $img = $imghddir."lfd_pie_year.gif";
+ open (my $OUT6, ">", "$img");
+ flock ($OUT6, LOCK_EX);
+ binmode ($OUT6);
+ print $OUT6 $year_pie_graph->gd->gif();
+ close ($OUT6);
+
+ if ($cc_lookups) {
+ # Total Top 30 Country Code blocks by lfd
+ my (@ccy,@ccx);
+ my %ccs;
+ my $cntcc;
+ my @line = split(/\,/,$stats[69]);
+ for (my $x = 0; $x < @line; $x+=2) {$ccs{$line[$x]} = $line[$x+1]}
+ foreach my $key (sort {$ccs{$b} <=> $ccs{$a}} keys %ccs) {
+ push @ccy,$key;
+ push @ccx,$ccs{$key};
+ $cntcc++;
+ if ($cntcc > 29) {last}
+ }
+ my @datacc = ([@ccy],[@ccx]);
+ my $cc_graph = GD::Graph::bars->new(750,350);
+ $cc_graph->set( dclrs => [ qw(yellow) ] );
+ $cc_graph->set(
+ x_label => 'Country Code',
+ y_label => 'Total Blocks',
+ long_ticks => 1,
+ tick_length => 0,
+ x_ticks => 0,
+ title => 'Total Top 30 Country Code blocks by lfd',
+ cumulate => 1,
+ borderclrs => $cc_graph->{dclrs},
+ bar_spacing => 4,
+ shadow_depth => 1,
+ transparent => 0,
+ x_label_position => 1/2,
+ );
+ $cc_graph->plot(\@datacc);
+ $img = $imghddir."lfd_cc.gif";
+ open (my $OUT, ">", "$img");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ print $OUT $cc_graph->gd->gif();
+ close ($OUT);
+ }
+ }
+
+ return;
+}
+# end charts
+###############################################################################
+# start minmaxavg
+sub minmaxavg {
+ my $graph = shift;
+ my $name = shift;
+ my $value = shift;
+
+ unless (defined $minmaxavg{$graph}{$name}{MIN}) {$minmaxavg{$graph}{$name}{MIN} = $value}
+ unless (defined $minmaxavg{$graph}{$name}{MAX}) {$minmaxavg{$graph}{$name}{MAX} = $value}
+ if ($minmaxavg{$graph}{$name}{MIN} > $value) {$minmaxavg{$graph}{$name}{MIN} = $value}
+ if ($minmaxavg{$graph}{$name}{MAX} < $value) {$minmaxavg{$graph}{$name}{MAX} = $value}
+ $minmaxavg{$graph}{$name}{AVG} += $value;
+ $minmaxavg{$graph}{$name}{CNT}++;
+
+ return;
+}
+# end minmaxavg
+###############################################################################
+# start graphs_html
+sub graphs_html {
+ my $imgdir = shift;
+ my $html;
+
+ $html .= "\n";
+ $html .= "\n";
+ $html .= "
\n";
+ foreach my $key (sort keys %{$minmaxavg{HOUR}}) {
+ my $item = $key;
+ if ($key =~ /^\d(.*)$/) {$item = $1}
+ $html .= "$item ";
+ $html .= "Min:".sprintf("%.2f",$minmaxavg{HOUR}{$key}{MIN})." ";
+ $html .= "Max:".sprintf("%.2f",$minmaxavg{HOUR}{$key}{MAX})." ";
+ $html .= "Avg:".sprintf("%.2f",$minmaxavg{HOUR}{$key}{AVG})." \n";
+ }
+ $html .= "
Note: This graph displays per minute statistics unless otherwise stated
\n";
+ $html .= "
\n";
+ foreach my $key (sort keys %{$minmaxavg{DAY}}) {
+ my $item = $key;
+ if ($key =~ /^\d(.*)$/) {$item = $1}
+ $html .= "$item ";
+ $html .= "Min:".sprintf("%.2f",$minmaxavg{DAY}{$key}{MIN})." ";
+ $html .= "Max:".sprintf("%.2f",$minmaxavg{DAY}{$key}{MAX})." ";
+ $html .= "Avg:".sprintf("%.2f",$minmaxavg{DAY}{$key}{AVG})." \n";
+ }
+ $html .= "
Note: This graph displays per minute statistics unless otherwise stated
\n";
+ $html .= "
\n";
+ foreach my $key (sort keys %{$minmaxavg{WEEK}}) {
+ my $item = $key;
+ if ($key =~ /^\d(.*)$/) {$item = $1}
+ $html .= "$item ";
+ $html .= "Min:".sprintf("%.2f",$minmaxavg{WEEK}{$key}{MIN})." ";
+ $html .= "Max:".sprintf("%.2f",$minmaxavg{WEEK}{$key}{MAX})." ";
+ $html .= "Avg:".sprintf("%.2f",$minmaxavg{WEEK}{$key}{AVG})." \n";
+ }
+ $html .= "
Note: This graph displays an hourly average of the per minute statistics, so you will not see the peak minute values
\n";
+ $html .= "
\n";
+ foreach my $key (sort keys %{$minmaxavg{MONTH}}) {
+ my $item = $key;
+ if ($key =~ /^\d(.*)$/) {$item = $1}
+ $html .= "$item ";
+ $html .= "Min:".sprintf("%.2f",$minmaxavg{MONTH}{$key}{MIN})." ";
+ $html .= "Max:".sprintf("%.2f",$minmaxavg{MONTH}{$key}{MAX})." ";
+ $html .= "Avg:".sprintf("%.2f",$minmaxavg{MONTH}{$key}{AVG})." \n";
+ }
+ $html .= "
Note: This graph displays an hourly average of the per minute statistics, so you will not see the peak minute values
\n
\n";
+ return $html;
+}
+# end graphs_html
+###############################################################################
+# start charts_html
+sub charts_html {
+ my $cc_lookups = shift;
+ my $imgdir = shift;
+ my $html;
+
+ $html .= "\n";
+ $html .= "\n";
+ $html .= "
\n";
+ $html .= "
\n";
+ $html .= " \n";
+ $html .= "
\n";
+ $html .= "
\n";
+ if ($cc_lookups) {
+ $html .= " \n";
+ $html .= "
\n";
+ $html .= "
\n";
+ $html .= " \n\n";
+ $html .= "
\n";
+ } else {
+ $html .= " \n\n";
+ $html .= "
\n";
+ $html .= "
\n";
+ }
+ $html .= " \n
\n";
+
+ return $html;
+}
+# end charts_html
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/Service.pm b/src/redux/ConfigServer/Service.pm
new file mode 100644
index 000000000..e679c2921
--- /dev/null
+++ b/src/redux/ConfigServer/Service.pm
@@ -0,0 +1,118 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::Service;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Carp;
+use IPC::Open3;
+use Fcntl qw(:DEFAULT :flock);
+use ConfigServer::Config;
+
+use Exporter qw(import);
+our $VERSION = 1.01;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+
+open (my $IN, "<", "/proc/1/comm");
+flock ($IN, LOCK_SH);
+my $sysinit = <$IN>;
+close ($IN);
+chomp $sysinit;
+if ($sysinit ne "systemd") {$sysinit = "init"}
+
+# end main
+###############################################################################
+# start type
+sub type {
+ return $sysinit;
+}
+# end type
+###############################################################################
+# start startlfd
+sub startlfd {
+ if ($sysinit eq "systemd") {
+ &printcmd($config{SYSTEMCTL},"start","lfd.service");
+ &printcmd($config{SYSTEMCTL},"status","lfd.service");
+ } else {
+ &printcmd("/etc/init.d/lfd","start");
+ }
+
+ return;
+}
+# end startlfd
+###############################################################################
+# start stoplfd
+sub stoplfd {
+ if ($sysinit eq "systemd") {
+ &printcmd($config{SYSTEMCTL},"stop","lfd.service");
+ }
+ else {
+ &printcmd("/etc/init.d/lfd","stop");
+ }
+
+ return;
+}
+# end stoplfd
+###############################################################################
+# start restartlfd
+sub restartlfd {
+ if ($sysinit eq "systemd") {
+ &printcmd($config{SYSTEMCTL},"restart","lfd.service");
+ &printcmd($config{SYSTEMCTL},"status","lfd.service");
+ }
+ else {
+ &printcmd("/etc/init.d/lfd","restart");
+ }
+
+ return;
+}
+# end restartlfd
+###############################################################################
+# start restartlfd
+sub statuslfd {
+ if ($sysinit eq "systemd") {
+ &printcmd($config{SYSTEMCTL},"status","lfd.service");
+ }
+ else {
+ &printcmd("/etc/init.d/lfd","status");
+ }
+
+ return 0
+}
+# end restartlfd
+###############################################################################
+# start printcmd
+sub printcmd {
+ my @command = @_;
+
+ if ($config{DIRECTADMIN}) {
+ my $doublepid = fork;
+ if ($doublepid == 0) {
+ my ($childin, $childout);
+ my $pid = open3($childin, $childout, $childout, @command);
+ while (<$childout>) {print $_}
+ waitpid ($pid, 0);
+ exit;
+ }
+ waitpid ($doublepid, 0);
+ } else {
+ my ($childin, $childout);
+ my $pid = open3($childin, $childout, $childout, @command);
+ while (<$childout>) {print $_}
+ waitpid ($pid, 0);
+ }
+ return;
+}
+# end printcmd
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/Slurp.pm b/src/redux/ConfigServer/Slurp.pm
new file mode 100644
index 000000000..0772997ee
--- /dev/null
+++ b/src/redux/ConfigServer/Slurp.pm
@@ -0,0 +1,55 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::Slurp;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use Carp;
+
+use Exporter qw(import);
+our $VERSION = 1.02;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(slurp);
+
+our $slurpreg = qr/(?>\x0D\x0A?|[\x0A-\x0C\x85\x{2028}\x{2029}])/;
+our $cleanreg = qr/(\r)|(\n)|(^\s+)|(\s+$)/;
+
+# end main
+###############################################################################
+# start slurp
+sub slurp {
+ my $file = shift;
+ if (-e $file) {
+ sysopen (my $FILE, $file, O_RDONLY) or carp "*Error* Unable to open [$file]: $!";
+ flock ($FILE, LOCK_SH) or carp "*Error* Unable to lock [$file]: $!";
+ my $text = do {local $/; <$FILE>};
+ close ($FILE);
+ return split(/$slurpreg/,$text);
+ } else {
+ carp "*Error* File does not exist: [$file]";
+ }
+
+ return;
+}
+# end slurp
+###############################################################################
+# start slurpreg
+sub slurpreg {
+ return $slurpreg;
+}
+# end slurpreg
+###############################################################################
+# start cleanreg
+sub cleanreg {
+ return $cleanreg;
+}
+# end cleanreg
+###############################################################################
+
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/URLGet.pm b/src/redux/ConfigServer/URLGet.pm
new file mode 100644
index 000000000..892c84b9f
--- /dev/null
+++ b/src/redux/ConfigServer/URLGet.pm
@@ -0,0 +1,292 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+# start main
+package ConfigServer::URLGet;
+
+use strict;
+use lib '/usr/local/csf/lib';
+use Fcntl qw(:DEFAULT :flock);
+use Carp;
+use IPC::Open3;
+use ConfigServer::Config;
+
+use Exporter qw(import);
+our $VERSION = 2.00;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+my $agent = "ConfigServer";
+my $option = 1;
+my $proxy = "";
+
+my $config = ConfigServer::Config->loadconfig();
+my %config = $config->config();
+$SIG{PIPE} = 'IGNORE';
+
+# end main
+###############################################################################
+# start new
+sub new {
+ my $class = shift;
+ $option = shift;
+ $agent = shift;
+ $proxy = shift;
+ my $self = {};
+ bless $self,$class;
+
+ if ($option == 3) {
+ return $self;
+ }
+ elsif ($option == 2) {
+ eval ('use LWP::UserAgent;'); ##no critic
+ if ($@) {return undef}
+ }
+ else {
+ eval {
+ local $SIG{__DIE__} = undef;
+ eval ('use HTTP::Tiny;'); ##no critic
+ };
+ }
+
+ return $self;
+}
+# end new
+###############################################################################
+# start urlget
+sub urlget {
+ my $self = shift;
+ my $url = shift;
+ my $file = shift;
+ my $quiet = shift;
+ my $status;
+ my $text;
+
+ if (!defined $url) {carp "url not specified"; return}
+
+ if ($option == 3) {
+ ($status, $text) = &binget($url,$file,$quiet);
+ }
+ elsif ($option == 2) {
+ ($status, $text) = &urlgetLWP($url,$file,$quiet);
+ }
+ else {
+ ($status, $text) = &urlgetTINY($url,$file,$quiet);
+ }
+ return ($status, $text);
+}
+# end urlget
+###############################################################################
+# start urlgetTINY
+sub urlgetTINY {
+ my $url = shift;
+ my $file = shift;
+ my $quiet = shift;
+ my $status = 0;
+ my $timeout = 1200;
+ if ($proxy eq "") {undef $proxy}
+ my $ua = HTTP::Tiny->new(
+ 'agent' => $agent,
+ 'timeout' => 300,
+ 'proxy' => $proxy
+ );
+ my $res;
+ my $text;
+ ($status, $text) = eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die "Download timeout after $timeout seconds"};
+ alarm($timeout);
+ if ($file) {
+ local $|=1;
+ my $expected_length;
+ my $bytes_received = 0;
+ my $per = 0;
+ my $oldper = 0;
+ open (my $OUT, ">", "$file\.tmp") or return (1, "Unable to open $file\.tmp: $!");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ $res = $ua->request('GET', $url, {
+ data_callback => sub {
+ my($chunk, $res) = @_;
+ $bytes_received += length($chunk);
+ unless (defined $expected_length) {$expected_length = $res->{headers}->{'content-length'} || 0}
+ if ($expected_length) {
+ my $per = int(100 * $bytes_received / $expected_length);
+ if ((int($per / 5) == $per / 5) and ($per != $oldper) and !$quiet) {
+ print "...$per\%\n";
+ $oldper = $per;
+ }
+ } else {
+ unless ($quiet) {print "."}
+ }
+ print $OUT $chunk;
+ }
+ });
+ close ($OUT);
+ unless ($quiet) {print "\n"}
+ } else {
+ $res = $ua->request('GET', $url);
+ }
+ alarm(0);
+ if ($res->{success}) {
+ if ($file) {
+ rename ("$file\.tmp","$file") or return (1, "Unable to rename $file\.tmp to $file: $!");
+ return (0, $file);
+ } else {
+ return (0, $res->{content});
+ }
+ } else {
+ my $reason = $res->{reason};
+ if ($res->{status} == 599) {$reason = $res->{content}}
+ ($status, $text) = &binget($url,$file,$quiet,$reason);
+ return ($status, $text);
+ }
+ };
+ alarm(0);
+ if ($@) {return (1, $@)}
+ return ($status,$text);
+}
+# end urlgetTINY
+###############################################################################
+# start urlgetLWP
+sub urlgetLWP {
+ my $url = shift;
+ my $file = shift;
+ my $quiet = shift;
+ my $status = 0;
+ my $timeout = 300;
+ my $ua = LWP::UserAgent->new;
+ $ua->agent($agent);
+ $ua->timeout(30);
+ if ($proxy ne "") {$ua->proxy([ 'http', 'https' ], $proxy)}
+#use LWP::ConnCache;
+#my $cache = LWP::ConnCache->new;
+#$cache->total_capacity([1]);
+#$ua->conn_cache($cache);
+ my $req = HTTP::Request->new(GET => $url);
+ my $res;
+ my $text;
+ ($status, $text) = eval {
+ local $SIG{__DIE__} = undef;
+ local $SIG{'ALRM'} = sub {die "Download timeout after $timeout seconds"};
+ alarm($timeout);
+ if ($file) {
+ local $|=1;
+ my $expected_length;
+ my $bytes_received = 0;
+ my $per = 0;
+ my $oldper = 0;
+ open (my $OUT, ">", "$file\.tmp") or return (1, "Unable to open $file\.tmp: $!");
+ flock ($OUT, LOCK_EX);
+ binmode ($OUT);
+ $res = $ua->request($req,
+ sub {
+ my($chunk, $res) = @_;
+ $bytes_received += length($chunk);
+ unless (defined $expected_length) {$expected_length = $res->content_length || 0}
+ if ($expected_length) {
+ my $per = int(100 * $bytes_received / $expected_length);
+ if ((int($per / 5) == $per / 5) and ($per != $oldper) and !$quiet) {
+ print "...$per\%\n";
+ $oldper = $per;
+ }
+ } else {
+ unless ($quiet) {print "."}
+ }
+ print $OUT $chunk;
+ });
+ close ($OUT);
+ unless ($quiet) {print "\n"}
+ } else {
+ $res = $ua->request($req);
+ }
+ alarm(0);
+ if ($res->is_success) {
+ if ($file) {
+ rename ("$file\.tmp","$file") or return (1, "Unable to rename $file\.tmp to $file: $!");
+ return (0, $file);
+ } else {
+ return (0, $res->content);
+ }
+ } else {
+ ($status, $text) = &binget($url,$file,$quiet,$res->message);
+ return ($status, $text);
+ }
+ };
+ alarm(0);
+ if ($@) {
+ return (1, $@);
+ }
+ if ($text) {
+ return ($status,$text);
+ } else {
+ return (1, "Download timeout after $timeout seconds");
+ }
+}
+# end urlget
+###############################################################################
+# start binget
+sub binget {
+ my $url = shift;
+ my $file = shift;
+ my $quiet = shift;
+ my $errormsg = shift;
+ $url = "'$url'";
+
+ my $cmd;
+ if (-e $config{CURL}) {
+ $cmd = $config{CURL}." -skLf -m 120";
+ if ($file) {$cmd = $config{CURL}." -kLf -m 120 -o";}
+ }
+ elsif (-e $config{WGET}) {
+ $cmd = $config{WGET}." -qT 120 -O-";
+ if ($file) {$cmd = $config{WGET}." -T 120 -O"}
+ }
+ if ($cmd ne "") {
+ if ($file) {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, $cmd." $file\.tmp $url");
+ my @output = <$childout>;
+ waitpid ($cmdpid, 0);
+ unless ($quiet and $option != 3) {
+ print "Using fallback [$cmd]\n";
+ print @output;
+ }
+ if (-e "$file\.tmp") {
+ rename ("$file\.tmp","$file") or return (1, "Unable to rename $file\.tmp to $file: $!");
+ return (0, $file);
+ } else {
+ if ($option == 3) {
+ return (1, "Unable to download: ".$cmd." $file\.tmp $url".join("",@output));
+ } else {
+ return (1, "Unable to download: ".$errormsg);
+ }
+ }
+ } else {
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, $cmd." $url");
+ my @output = <$childout>;
+ waitpid ($cmdpid, 0);
+ if (scalar @output > 0) {
+ return (0, join("",@output));
+ } else {
+ if ($option == 3) {
+ return (1, "Unable to download: [$cmd $url]".join("",@output));
+ } else {
+ return (1, "Unable to download: ".$errormsg);
+ }
+ }
+ }
+ }
+ if ($option == 3) {
+ return (1, "Unable to download (CURL/WGET also not present, see csf.conf)");
+ } else {
+ return (1, "Unable to download (CURL/WGET also not present, see csf.conf): ".$errormsg);
+ }
+}
+# end binget
+###############################################################################
+1;
\ No newline at end of file
diff --git a/src/redux/ConfigServer/cseUI.pm b/src/redux/ConfigServer/cseUI.pm
new file mode 100644
index 000000000..d1249ebc3
--- /dev/null
+++ b/src/redux/ConfigServer/cseUI.pm
@@ -0,0 +1,1029 @@
+###############################################################################
+# Copyright 2006-2023, Way to the Web Limited
+# URL: http://www.configserver.com
+# Email: sales@waytotheweb.com
+###############################################################################
+## no critic (RequireUseWarnings, ProhibitExplicitReturnUndef, ProhibitMixedBooleanOperators, RequireBriefOpen)
+package ConfigServer::cseUI;
+
+use strict;
+use Fcntl qw(:DEFAULT :flock);
+use File::Find;
+use File::Copy;
+use IPC::Open3;
+
+use Exporter qw(import);
+our $VERSION = 2.03;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+umask(0177);
+
+our ($chart, $ipscidr6, $ipv6reg, $ipv4reg, %config, %ips, $mobile,
+ %FORM, $script, $script_da, $images, $myv);
+
+our ($act, $destpath, $element, $extramessage, $fieldname, $fileinc,
+ $filetemp, $message, $name, $origpath, $storepath, $tgid, $thisdir,
+ $tuid, $value, $webpath, %ele, %header, @bits, @dirs, @filebodies,
+ @filenames, @files, @months, @parts, @passrecs, @thisdirs, @thisfiles,
+ $files);
+#
+###############################################################################
+# start main
+sub main {
+ my $FORM_ref = shift;
+ %FORM = %{$FORM_ref};
+ $fileinc = shift;
+ $script = shift;
+ $script_da = shift;
+ $images = shift;
+ $myv = shift;
+ $| = 1;
+
+ &loadconfig;
+
+ $webpath = '/';
+
+ if ($FORM{do} eq "view") {
+ &view;
+ exit;
+ }
+
+ print "Content-type: text/html\r\n\r\n";
+
+ my $bootstrapcss = " ";
+ my $jqueryjs = "";
+ my $bootstrapjs = "";
+
+ print <
+
+
+ ConfigServer Explorer
+
+
+ $bootstrapcss
+
+ $jqueryjs
+ $bootstrapjs
+
+
+
+EOF
+
+ unless ($FORM{do} eq "console") {
+ print "\n";
+ print "
\n";
+ if ($config{UI_CXS} or $config{UI_CSE}) {
+ print "
\n";
+ }
+ print "
cse Logout \n";
+ print "
\n";
+ print <
+ ConfigServer Explorer - cse
+
+EOF
+ }
+
+ $message = "";
+
+ if ($fileinc) {&uploadfile}
+ elsif ($FORM{do} eq "") {&browse}
+ elsif ($FORM{quit} == 2) {&browse}
+ elsif ($FORM{do} eq "b") {&browse}
+ elsif ($FORM{do} eq "p") {&browse}
+ elsif ($FORM{do} eq "o") {&browse}
+ elsif ($FORM{do} eq "c") {&browse}
+ elsif ($FORM{do} eq "m") {&browse}
+ elsif ($FORM{do} eq "pw") {&browse}
+ elsif ($FORM{do} eq "r") {&browse}
+ elsif ($FORM{do} eq "newf") {&browse}
+ elsif ($FORM{do} eq "newd") {&browse}
+ elsif ($FORM{do} eq "cnewf") {&cnewf}
+ elsif ($FORM{do} eq "cnewd") {&cnewd}
+ elsif ($FORM{do} eq "ren") {&ren}
+ elsif ($FORM{do} eq "del") {&del}
+ elsif ($FORM{do} eq "setp") {&setp}
+ elsif ($FORM{do} eq "seto") {&seto}
+ elsif ($FORM{do} eq "cd") {&cd}
+ elsif ($FORM{do} eq "console") {&console}
+ elsif ($FORM{do} eq "edit") {&edit}
+ elsif ($FORM{do} eq "Cancel") {&browse}
+ elsif ($FORM{do} eq "Save") {&save}
+ elsif ($FORM{do} eq "copyit") {©it}
+ elsif ($FORM{do} eq "moveit") {&moveit}
+ else {print "Invalid action"};
+
+ unless ($FORM{do} eq "console") {
+ print "©2006-2023, ConfigServer Services (Way to the Web Limited)
\n";
+ }
+ print <
+
+
+
+EOF
+ exit;
+}
+# end main
+###############################################################################
+# start browse
+sub browse {
+ my $extra;
+ if ($FORM{c}) {
+ if (-e "$webpath$FORM{c}") {
+ $extra = "&c=$FORM{c}";
+ } else {
+ $FORM{c} = "";
+ }
+ }
+ if ($FORM{m}) {
+ if (-e "$webpath$FORM{m}") {
+ $extra = "&m=$FORM{m}"
+ } else {
+ $FORM{m} = "";
+ }
+ }
+
+ print "\n";
+
+ $thisdir = $webpath;
+ if ($thisdir !~ /\/$/) {$thisdir .= "/"}
+ $thisdir .= $FORM{p};
+ $thisdir =~ s/\/+/\//g;
+ @months = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec");
+
+ my $errordir = 0;
+ opendir (DIR, "$thisdir") or $errordir = 1;
+ while (my $file = readdir(DIR)) {
+ if (-d "$thisdir/$file") {
+ if ($file !~ /^\.$|^\.\.$/) {push (@thisdirs, $file)}
+ } else {
+ push (@thisfiles, $file);
+ }
+
+ }
+ closedir (DIR);
+
+ @thisdirs = sort @thisdirs;
+ @thisfiles = sort @thisfiles;
+
+ print "\n";
+ print "WARNING! While this utility can be very useful it is also very dangerous indeed. You can easily render your server inoperable and unrecoverable by performing ill advised actions. No warranty or guarantee is provided with the product that protects against system damage.\n";
+ print "
\n";
+
+ if ($message) {print "
$message \n";}
+ print "\n";
+ print "";
+ print "[Home ]";
+ my $path = "";
+ my $cnt = 2;
+ my @path = split(/\//,$FORM{p});
+ foreach my $dir (@path) {
+ if ($dir ne "" and ($dir ne "/")) {
+ if ($cnt == @path) {
+ print "/$dir
";
+ } else {
+ print "/
$dir ";
+ }
+ $path .= "/$dir";
+ $cnt++;
+ }
+ }
+ if ($FORM{c}) {print " Copy buffer:$FORM{c}
\n"}
+ if ($FORM{m}) {print " Move buffer:$FORM{m}
\n"}
+ print " \n";
+ if ($errordir) {
+ print "Permission Denied ";
+ } else {
+ if (@thisdirs > 0) {
+ print "\n";
+ print "";
+ print "Directory Name ";
+ print "Size ";
+ print "Date ";
+ print "User(uid)/Group(gid) ";
+ print "Perms ";
+ print "Actions ";
+ print " \n";
+ }
+ my $class = "tdshade2";
+ foreach my $dir (@thisdirs) {
+ if ($dir =~/'|"|\||\`/) {
+ print "".quotemeta($dir)."Invalid directory name - ignored ";
+ next;
+ }
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat("$thisdir/$dir");
+ if ($size < 1024) {
+ }
+ elsif ($size < (1024 * 1024)) {
+ $size = sprintf("%.1f",($size/1024));
+ $size .= "k";
+ }
+ else {
+ $size = sprintf("%.1f",($size/(1024 * 1024)));
+ $size .= "M";
+ }
+ $mode = sprintf "%04o", $mode & oct("07777");
+ $tgid = getgrgid($gid);
+ if ($tgid eq "") {$tgid = $gid}
+ $tuid = getpwuid($uid);
+ if ($tuid eq "") {$tuid = $uid}
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($mtime);
+ $year += 1900;
+ my $time = sprintf "%02d:%02d:%02d", $hour, $min, $sec;
+ $mday = sprintf "%02d", $mday;
+ $mtime = "$mday-$months[$mon]-$year $time";
+ my $pp = "";
+ my $passfile = "$FORM{p}/$dir";
+ $passfile =~ s/\//\_/g;
+ $passfile =~ s/\\/\_/g;
+ $passfile =~ s/\:/\_/g;
+ if (-e "$storepath/$passfile.htpasswd") {
+ open (my $PASSFILE, "<","$storepath/$passfile.htpasswd") or die $!;
+ flock ($PASSFILE, LOCK_SH);
+ @passrecs = <$PASSFILE>;
+ close ($PASSFILE);
+ chomp @passrecs;
+ if (@passrecs > 0) {$pp = "**"}
+ }
+
+ print "";
+ if ($FORM{do} eq "r" and ($FORM{f} eq $dir)) {
+ print "\n";
+ }
+ elsif (-r "$webpath$FORM{p}/$dir") {
+ print "$dir $pp ";
+ }
+ else {
+ print "$dir ";
+ }
+ print "$size ";
+ print "$mtime ";
+ if ($FORM{do} eq "o" and ($FORM{f} eq $dir)) {
+ print "\n";
+ }
+ else {
+ print "$tuid($uid)/$tgid($gid) ";
+ }
+ if ($FORM{do} eq "p" and ($FORM{f} eq $dir)) {
+ print "\n";
+ }
+ else {
+ print "$mode ";
+ }
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " \n";
+ }
+ if ($FORM{do} eq "newd") {
+ print "";
+ print "\n";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " \n";
+ }
+ if (($FORM{do} eq "c") and (-d "$webpath$FORM{c}")) {
+ my $newf = (split(/\//,$FORM{c}))[-1];
+ print "";
+ print "\n";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " \n";
+ }
+ if (($FORM{do} eq "m") and (-d "$webpath$FORM{m}")) {
+ my $newf = (split(/\//,$FORM{m}))[-1];
+ print "";
+ print "\n";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " \n";
+ }
+
+ if (@thisfiles > 0) {
+ print " \n";
+ print "";
+ print "File Name ";
+ print "Size ";
+ print "Date ";
+ print "User(uid)/Group(gid) ";
+ print "Perms ";
+ print "Actions ";
+ print " \n";
+ }
+ $class = "tdshade2";
+ foreach my $file (@thisfiles) {
+ if ($file =~/'|"|\||\`/) {
+ print "".quotemeta($file)."Invalid file name - ignored ";
+ next;
+ }
+ my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat("$thisdir/$file");
+ if ($size < 1024) {
+ }
+ elsif ($size < (1024 * 1024)) {
+ $size = sprintf("%.1f",($size/1024));
+ $size .= "k";
+ }
+ else {
+ $size = sprintf("%.1f",($size/(1024 * 1024)));
+ $size .= "M";
+ }
+ $mode = sprintf "%03o", $mode & oct("00777");
+ $tgid = getgrgid($gid);
+ if ($tgid eq "") {$tgid = $gid}
+ $tuid = getpwuid($uid);
+ if ($tuid eq "") {$tuid = $uid}
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($mtime);
+ $year += 1900;
+ my $time = sprintf "%02d:%02d:%02d", $hour, $min, $sec;
+ $mday = sprintf "%02d", $mday;
+ $mtime = "$mday-$months[$mon]-$year $time";
+ print "";
+ if ($FORM{do} eq "r" and ($FORM{f} eq $file)) {
+ print "\n";
+ }
+ else {
+ $act = "$script?do=view&p=$FORM{p}&f=$file$extra\#new";
+ print "$file ";
+ }
+ print "$size ";
+ print "$mtime ";
+ if ($FORM{do} eq "o" and ($FORM{f} eq $file)) {
+ print "\n";
+ }
+ else {
+ print "$tuid($uid)/$tgid($gid) ";
+ }
+ if ($FORM{do} eq "p" and ($FORM{f} eq $file)) {
+ print "\n";
+ }
+ else {
+ print "$mode ";
+ }
+ my $ext = (split(/\./,$file))[-1];
+ if (-T "$webpath$FORM{p}/$file") {
+ my $act = "";
+ print " $act ";
+ } else {
+ print " ";
+ }
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " \n";
+ }
+ if ($FORM{do} eq "newf") {
+ print "";
+ print "\n";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " \n";
+ }
+ if (($FORM{do} eq "c") and (-f "$webpath$FORM{c}")) {
+ my $newf = (split(/\//,$FORM{c}))[-1];
+ print "";
+ print "\n";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " \n";
+ }
+ if (($FORM{do} eq "m") and (-f "$webpath$FORM{m}")) {
+ my $newf = (split(/\//,$FORM{m}))[-1];
+ print "";
+ print "\n";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " ";
+ print " \n";
+ }
+ }
+ print "
\n";
+
+ print "All the following actions apply to the current directory
\n";
+ print "\n";
+ print "\n";
+ print "\n";
+ print "\n";
+
+ print "\n";
+ return;
+}
+# end browse
+###############################################################################
+# start setp
+sub setp {
+ my $status = 0;
+ chmod (oct("0$FORM{newp}"),"$webpath$FORM{p}/$FORM{f}") or $status = $!;
+ if ($status) {$message = "Operation Failed - $status"} else {$message = ""}
+ &browse;
+ return;
+}
+# end setp
+###############################################################################
+# start seto
+sub seto {
+ my $status = "";
+ my ($uid,$gid) = split (/\:/,$FORM{newo});
+ if ($uid !~ /^\d/) {$uid = (getpwnam($uid))[2]}
+ if ($gid !~ /^\d/) {$gid = (getgrnam($gid))[2]}
+ if ($uid eq "") {$message .= "No such user \n"}
+ if ($gid eq "") {$message .= "No such group \n"}
+
+ if ($message eq "") {
+ chown ($uid,$gid,"$webpath$FORM{p}/$FORM{f}") or $status = $!;
+ if ($status) {$message = "Operation Failed - $status"} else {$message = ""}
+ }
+ &browse;
+ return;
+}
+# end seto
+###############################################################################
+# start ren
+sub ren {
+ my $status = 0;
+ rename ("$webpath$FORM{p}/$FORM{f}","$webpath$FORM{p}/$FORM{newf}") or $status = $!;
+ if ($status) {$message = "Operation Failed - $status"} else {$message = ""}
+ &browse;
+ return;
+}
+# end ren
+###############################################################################
+# start moveit
+sub moveit {
+ if ("$webpath$FORM{m}" eq "$webpath$FORM{p}/$FORM{newf}") {
+ $message = "Move Failed - Cannot overwrite original";
+ }
+ elsif ((-d "$webpath$FORM{m}") and ("$webpath$FORM{p}/$FORM{newf}" =~ /^$webpath$FORM{m}\//)) {
+ $message = "Move Failed - Cannot move inside original";
+ }
+ else {
+ my $status = 0;
+ rename ("$webpath$FORM{m}","$webpath$FORM{p}/$FORM{newf}") or $status = $!;
+ if ($status) {$message = "Operation Failed - $status"} else {$message = ""}
+ }
+ if ($message eq "") {$FORM{m} = ""}
+ &browse;
+ return;
+}
+# end moveit
+###############################################################################
+# start copyit
+sub copyit {
+ if ("$webpath$FORM{c}" eq "$webpath$FORM{p}/$FORM{newf}") {
+ $message = "Copy Failed - Cannot overwrite original";
+ }
+ elsif ((-d "$webpath$FORM{c}") and ("$webpath$FORM{p}/$FORM{newf}" =~ /^$webpath$FORM{c}\//)) {
+ $message = "Copy Failed - Cannot copy inside original";
+ }
+ else {
+ if (-d "$webpath$FORM{c}") {
+ $origpath = "$webpath$FORM{c}";
+ $destpath = "$webpath$FORM{p}/$FORM{newf}";
+ find(\&mycopy, $origpath);
+ } else {
+ copy ("$webpath$FORM{c}","$webpath$FORM{p}/$FORM{newf}") or $message = "Copy Failed - $!";
+ if ($message eq "") {
+ my $mode = sprintf "%04o", (stat("$webpath$FORM{c}"))[2] & oct("00777");
+ chmod (oct($mode),"$webpath$FORM{p}/$FORM{newf}") or $message = "Permission Change Failed - $!";
+ }
+ }
+ }
+ if ($message eq "") {$FORM{c} = ""}
+ &browse;
+ return;
+}
+# end copyit
+###############################################################################
+# start mycopy
+sub mycopy {
+ my $file = $File::Find::name;
+ (my $dest = $file) =~ s/^\Q$origpath/$destpath/;
+ my $status = "";
+ if (-d $file) {
+ my $err = (split(/\//,$dest))[-1];
+ mkpath ($dest) or $status = "Copy Failed Making New Dir [$err] - $! \n";
+ } elsif (-f $file) {
+ my $err = (split(/\//,$file))[-1];
+ copy ($file,$dest) or $status = "Copy Failed [$err] - $! \n";
+ }
+ if ($status eq "") {
+ my $err = (split(/\//,$file))[-1];
+ my $mode = sprintf "%04o", (stat("$file"))[2] & oct("00777");
+ chmod (oct($mode),"$dest") or $message .= "Copy Failed Setting Perms [$err] - $! \n";
+ } else {
+ $message .= $status;
+ }
+ return;
+}
+# end mycopy
+###############################################################################
+# start cnewd
+sub cnewd {
+ my $status = 0;
+ if ($FORM{newf} ne "") {
+ mkdir ("$webpath$FORM{p}/$FORM{newf}",0777) or $status = $!;
+ }
+ if ($status) {$message = "Operation Failed - $status"} else {$message = ""}
+ &browse;
+ return;
+}
+# end cnewd
+###############################################################################
+# start cnewf
+sub cnewf {
+ my $status = 0;
+ if ($FORM{newf} ne "") {
+ if (-f "$webpath$FORM{p}/$FORM{newf}") {
+ $status = "File exists";
+ } else {
+ open (my $OUT, ">","$webpath$FORM{p}/$FORM{newf}") or $status = $!;
+ flock ($OUT, LOCK_EX);
+ close ($OUT);
+ }
+ }
+ if ($status) {$message = "Operation Failed - $status"} else {$message = ""}
+ &browse;
+ return;
+}
+# end cnewf
+###############################################################################
+# start del
+sub del {
+ my $status = 0;
+ if (-d "$webpath$FORM{p}/$FORM{f}") {
+ rmtree("$webpath$FORM{p}/$FORM{f}", 0, 0) or $status = $!;
+ } else {
+ unlink ("$webpath$FORM{p}/$FORM{f}") or $status = $!;
+ }
+ if ($status) {$message = "Operation Failed - $status"} else {$message = ""}
+ &browse;
+ return;
+}
+# end del
+###############################################################################
+# start view
+sub view {
+ if (-e "$webpath$FORM{p}/$FORM{f}" ) {
+ if (-T "$webpath$FORM{p}/$FORM{f}") {
+ print "content-type: text/plain\r\n";
+ } else {
+ print "content-type: application/octet-stream\r\n";
+ }
+ print "content-disposition: attachment; filename=$FORM{f}\r\n\r\n";
+
+ open(my $IN,"<","$webpath$FORM{p}/$FORM{f}") or die $!;
+ flock ($IN, LOCK_SH);
+ while (<$IN>) {print}
+ close($IN);
+ }else{
+ print "content-type: text/html\r\n\r\n";
+ print "File [$webpath$FORM{p}/$FORM{f}] not found!";
+ }
+ return;
+}
+# end view
+###############################################################################
+# start console
+sub console {
+ my $thisdir = "$webpath$FORM{p}";
+ $thisdir =~ s/\/+/\//g;
+
+ print "
\n";
+ print "root [$thisdir]# $FORM{cmd}\n";
+ chdir $thisdir;
+
+ $| = 1;
+ my ($childin, $childout);
+ my $cmdpid = open3($childin, $childout, $childout, $FORM{cmd});
+ while (my $line = <$childout>) {
+ $line =~ s/\\<\;/g;
+ $line =~ s/\>/\>\;/g;
+ print $line;
+ }
+ waitpid ($cmdpid, 0);
+ print "root [$thisdir]# _ \n";
+ print "";
+ return;
+}
+# end console
+###############################################################################
+# start cd
+sub cd {
+ if (-d $FORM{directory}) {
+ $FORM{p} = $FORM{directory};
+ } else {
+ $message = "No such directory [$FORM{directory}]";
+ }
+
+ &browse;
+ return;
+}
+# end cd
+###############################################################################
+# start edit
+sub edit {
+ open (my $IN, "<","$webpath$FORM{p}/$FORM{f}") or die $!;
+ flock ($IN, LOCK_SH);
+ my @data = <$IN>;
+ close ($IN);
+
+ my $filedata;
+ foreach my $line (@data) {
+ $line =~ s/\</g;
+ $line =~ s/\>/>/g;
+ $filedata .= $line;
+ }
+
+ my $lf = 0;
+ if ($filedata =~ /\r/) {$lf = 1}
+
+ print "\n";
+ print "\n";
+ return;
+}
+# end edit
+###############################################################################
+# start save
+sub save {
+ unless ($FORM{lf}) {$FORM{newf} =~ s/\r//g}
+ my $status = 0;
+ open (my $OUT, ">","$webpath$FORM{p}/$FORM{f}") or $status = $!;
+ flock ($OUT, LOCK_EX);
+ print $OUT $FORM{newf};
+ close ($OUT);
+
+ if ($status) {$message = "Operation Failed - $status"} else {$message = ""}
+ &browse;
+ return;
+}
+# end save
+###############################################################################
+# start uploadfile
+sub uploadfile {
+ my $crlf = "\r\n";
+ my @data = split (/$crlf/,$fileinc);
+
+ my $boundary = $data[0];
+
+ $boundary =~ s/\"//g;
+ $boundary =~ s/$crlf//g;
+
+ my $start = 0;
+ my $part_cnt=-1;
+ undef @parts;
+ my $fileno = 0;
+
+ foreach my $line (@data) {
+ if ($line =~ /^$boundary--/) {
+ last;
+ }
+ if ($line =~ /^$boundary/) {
+ $part_cnt++;
+ $start = 1;
+ next;
+ }
+ if ($start) {
+ $parts[$part_cnt] .= $line.$crlf;
+ }
+ }
+
+ foreach my $part (@parts) {
+ my @partdata = split(/$crlf/,$part);
+ undef %header;
+ my $body = "";
+ my $dobody = 0;
+ my $lastfieldname = "";
+
+ foreach my $line (@partdata) {
+ if (($line eq "") and !($dobody)) {
+ $dobody = 1;
+ next;
+ }
+
+ if ($dobody) {
+ $body .= $line.$crlf;
+ } else {
+ if ($line =~ /^\s/) {
+ $header{$lastfieldname} .= $line;
+ } else {
+ ($fieldname, $value) = split (/\:\s/,$line,2);
+ $fieldname = lc $fieldname;
+ $fieldname =~ s/-/_/g;
+ $header{$fieldname} = $value;
+ $lastfieldname = $fieldname;
+ }
+ }
+ }
+
+ my @elements = split(/\;/,$header{content_disposition});
+ foreach my $element (@elements) {
+ $element =~ s/\s//g;
+ $element =~ s/\"//g;
+ ($name,$value) = split(/\=/,$element);
+ $FORM{$value} = $body;
+ $ele{$name} = $value;
+ $ele{$ele{name}} = $value;
+ if ($value =~ /^file(.*)$/) {$files = $1}
+ }
+
+ my $filename = $ele{"file$files"};
+ if ($filename ne "") {
+ $fileno++;
+ $filename =~ s/\"//g;
+ $filename =~ s/\r//g;
+ $filename =~ s/\n//g;
+ @bits = split(/\\/,$filename);
+ $filetemp=$bits[-1];
+ @bits = split(/\//,$filetemp);
+ $filetemp=$bits[-1];
+ @bits = split(/\:/,$filetemp);
+ $filetemp=$bits[-1];
+ @bits = split(/\"/,$filetemp);
+ $filename=$bits[0];
+ push (@filenames, $filename);
+ push (@filebodies, $body);
+ }
+ }
+
+ $FORM{p} =~ s/\r//g;
+ $FORM{p} =~ s/\n//g;
+ $FORM{type} =~ s/\r//g;
+ $FORM{type} =~ s/\n//g;
+ $FORM{c} =~ s/\r//g;
+ $FORM{c} =~ s/\n//g;
+ $FORM{m} =~ s/\r//g;
+ $FORM{m} =~ s/\n//g;
+ $FORM{caller} =~ s/\r//g;
+ $FORM{caller} =~ s/\n//g;
+
+ for (my $x = 0;$x < @filenames ;$x++) {
+ $filenames[$x] =~ s/\r//g;
+ $filenames[$x] =~ s/\n//g;
+ $filenames[$x] =~ s/^file-//g;
+ $filenames[$x] = (split (/\\/,$filenames[$x]))[-1];
+ $filenames[$x] = (split (/\//,$filenames[$x]))[-1];
+ if ($FORM{type} eq "ascii") {$filebodies[$x] =~ s/\r//g}
+ if (-e "$webpath$FORM{p}/$filenames[$x]") {
+ $extramessage .= " $filenames[$x] - Already exists, delete the original first";
+ $fileno--;
+ next;
+ }
+ sysopen (my $OUT,"$webpath$FORM{p}/$filenames[$x]", O_WRONLY | O_CREAT);
+ flock ($OUT, LOCK_EX);
+ print $OUT $filebodies[$x];
+ close ($OUT);
+ $extramessage .= " $filenames[$x] - Uploaded";
+ }
+
+ $message = "$fileno File(s) Uploaded".$extramessage;
+
+ &browse;
+ return;
+}
+# end uploadfile
+###############################################################################
+# start countfiles
+sub countfiles {
+ if (-d $File::Find::name) {push (@dirs, $File::Find::name)} else {push (@files, $File::Find::name)}
+ return;
+}
+# end countfiles
+###############################################################################
+# loadconfig
+sub loadconfig {
+ sysopen (my $IN, "/etc/csf/csf.conf", O_RDWR | O_CREAT) or die "Unable to open file: $!";
+ flock ($IN, LOCK_SH);
+ my @config = <$IN>;
+ close ($IN);
+ chomp @config;
+
+ foreach my $line (@config) {
+ if ($line =~ /^\#/) {next}
+ if ($line !~ /=/) {next}
+ my ($name,$value) = split (/=/,$line,2);
+ $name =~ s/\s//g;
+ if ($value =~ /\"(.*)\"/) {
+ $value = $1;
+ } else {
+ &error(__LINE__,"Invalid configuration line");
+ }
+ $config{$name} = $value;
+ }
+ return;
+}
+# end loadconfig
+###############################################################################
+
+1;
diff --git a/src/redux/Crypt/Blowfish_PP.pm b/src/redux/Crypt/Blowfish_PP.pm
new file mode 100644
index 000000000..455e3fc1e
--- /dev/null
+++ b/src/redux/Crypt/Blowfish_PP.pm
@@ -0,0 +1,519 @@
+# This is Crypt/Blowfish_PP.pm which is an implementation of Bruce Schneier's
+# blowfish cryptographic algorithm. I will write some proper docs when I get
+# time....
+# code is (c) copyright Matthew Byng-Maddick 2000-2023, and
+# some bits are copyright Bruce Schneier. For more information see his website
+# at http://www.counterpane.com/
+
+=head1 NAME
+
+B - Blowfish encryption algorithm implemented purely in Perl
+
+=head1 SYNOPSIS
+
+C;
+
+$blowfish=new Crypt::Blowfish_PP($key);
+
+$ciphertextBlock=$blowfish->encrypt($plaintextBlock);
+
+$plaintextBlock=$blowfish->decrypt($ciphertextBlock);
+
+=head1 DESCRIPTION
+
+The B module provides for users to use the Blowfish encryption
+algorithm in perl. The implementation is entirely Object Oriented, as there is
+quite a lot of context inherent in making blowfish as fast as it is. The key is
+anywhere between 64 and 448 bits (8 and 56 bytes), and should be passed as a
+packed string. The transformation itself is a 16-round Feistel Network, and
+operates on a 64 bit block.
+
+Object methods for the Crypt::Blowfish_PP module:
+
+=cut
+package Crypt::Blowfish_PP;
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION="1.12";
+
+=head2 B(I)
+
+The B() method initialises a blowfish object with the key that is passed.
+This is the slow part of doing a blowfish encryption or decryption, as it
+initialises the 18 p-boxes and the 1024 s-boxes that are used for the algorithm.
+It will return undef if the key is not of a valid length.
+
+=cut
+
+sub new
+ {
+ my $pack=shift;
+ my $key=shift;
+ return undef if(!defined($key));
+ my %h=(
+ p_boxes =>
+ [
+ 0x243f6a88, 0x85a308d3, 0x13198a2e, 0x03707344,
+ 0xa4093822, 0x299f31d0, 0x082efa98, 0xec4e6c89,
+ 0x452821e6, 0x38d01377, 0xbe5466cf, 0x34e90c6c,
+ 0xc0ac29b7, 0xc97c50dd, 0x3f84d5b5, 0xb5470917,
+ 0x9216d5d9, 0x8979fb1b
+ ],
+ s_boxes =>
+ [
+ [
+ 0xd1310ba6, 0x98dfb5ac, 0x2ffd72db, 0xd01adfb7,
+ 0xb8e1afed, 0x6a267e96, 0xba7c9045, 0xf12c7f99,
+ 0x24a19947, 0xb3916cf7, 0x0801f2e2, 0x858efc16,
+ 0x636920d8, 0x71574e69, 0xa458fea3, 0xf4933d7e,
+ 0x0d95748f, 0x728eb658, 0x718bcd58, 0x82154aee,
+ 0x7b54a41d, 0xc25a59b5, 0x9c30d539, 0x2af26013,
+ 0xc5d1b023, 0x286085f0, 0xca417918, 0xb8db38ef,
+ 0x8e79dcb0, 0x603a180e, 0x6c9e0e8b, 0xb01e8a3e,
+ 0xd71577c1, 0xbd314b27, 0x78af2fda, 0x55605c60,
+ 0xe65525f3, 0xaa55ab94, 0x57489862, 0x63e81440,
+ 0x55ca396a, 0x2aab10b6, 0xb4cc5c34, 0x1141e8ce,
+ 0xa15486af, 0x7c72e993, 0xb3ee1411, 0x636fbc2a,
+ 0x2ba9c55d, 0x741831f6, 0xce5c3e16, 0x9b87931e,
+ 0xafd6ba33, 0x6c24cf5c, 0x7a325381, 0x28958677,
+ 0x3b8f4898, 0x6b4bb9af, 0xc4bfe81b, 0x66282193,
+ 0x61d809cc, 0xfb21a991, 0x487cac60, 0x5dec8032,
+ 0xef845d5d, 0xe98575b1, 0xdc262302, 0xeb651b88,
+ 0x23893e81, 0xd396acc5, 0x0f6d6ff3, 0x83f44239,
+ 0x2e0b4482, 0xa4842004, 0x69c8f04a, 0x9e1f9b5e,
+ 0x21c66842, 0xf6e96c9a, 0x670c9c61, 0xabd388f0,
+ 0x6a51a0d2, 0xd8542f68, 0x960fa728, 0xab5133a3,
+ 0x6eef0b6c, 0x137a3be4, 0xba3bf050, 0x7efb2a98,
+ 0xa1f1651d, 0x39af0176, 0x66ca593e, 0x82430e88,
+ 0x8cee8619, 0x456f9fb4, 0x7d84a5c3, 0x3b8b5ebe,
+ 0xe06f75d8, 0x85c12073, 0x401a449f, 0x56c16aa6,
+ 0x4ed3aa62, 0x363f7706, 0x1bfedf72, 0x429b023d,
+ 0x37d0d724, 0xd00a1248, 0xdb0fead3, 0x49f1c09b,
+ 0x075372c9, 0x80991b7b, 0x25d479d8, 0xf6e8def7,
+ 0xe3fe501a, 0xb6794c3b, 0x976ce0bd, 0x04c006ba,
+ 0xc1a94fb6, 0x409f60c4, 0x5e5c9ec2, 0x196a2463,
+ 0x68fb6faf, 0x3e6c53b5, 0x1339b2eb, 0x3b52ec6f,
+ 0x6dfc511f, 0x9b30952c, 0xcc814544, 0xaf5ebd09,
+ 0xbee3d004, 0xde334afd, 0x660f2807, 0x192e4bb3,
+ 0xc0cba857, 0x45c8740f, 0xd20b5f39, 0xb9d3fbdb,
+ 0x5579c0bd, 0x1a60320a, 0xd6a100c6, 0x402c7279,
+ 0x679f25fe, 0xfb1fa3cc, 0x8ea5e9f8, 0xdb3222f8,
+ 0x3c7516df, 0xfd616b15, 0x2f501ec8, 0xad0552ab,
+ 0x323db5fa, 0xfd238760, 0x53317b48, 0x3e00df82,
+ 0x9e5c57bb, 0xca6f8ca0, 0x1a87562e, 0xdf1769db,
+ 0xd542a8f6, 0x287effc3, 0xac6732c6, 0x8c4f5573,
+ 0x695b27b0, 0xbbca58c8, 0xe1ffa35d, 0xb8f011a0,
+ 0x10fa3d98, 0xfd2183b8, 0x4afcb56c, 0x2dd1d35b,
+ 0x9a53e479, 0xb6f84565, 0xd28e49bc, 0x4bfb9790,
+ 0xe1ddf2da, 0xa4cb7e33, 0x62fb1341, 0xcee4c6e8,
+ 0xef20cada, 0x36774c01, 0xd07e9efe, 0x2bf11fb4,
+ 0x95dbda4d, 0xae909198, 0xeaad8e71, 0x6b93d5a0,
+ 0xd08ed1d0, 0xafc725e0, 0x8e3c5b2f, 0x8e7594b7,
+ 0x8ff6e2fb, 0xf2122b64, 0x8888b812, 0x900df01c,
+ 0x4fad5ea0, 0x688fc31c, 0xd1cff191, 0xb3a8c1ad,
+ 0x2f2f2218, 0xbe0e1777, 0xea752dfe, 0x8b021fa1,
+ 0xe5a0cc0f, 0xb56f74e8, 0x18acf3d6, 0xce89e299,
+ 0xb4a84fe0, 0xfd13e0b7, 0x7cc43b81, 0xd2ada8d9,
+ 0x165fa266, 0x80957705, 0x93cc7314, 0x211a1477,
+ 0xe6ad2065, 0x77b5fa86, 0xc75442f5, 0xfb9d35cf,
+ 0xebcdaf0c, 0x7b3e89a0, 0xd6411bd3, 0xae1e7e49,
+ 0x00250e2d, 0x2071b35e, 0x226800bb, 0x57b8e0af,
+ 0x2464369b, 0xf009b91e, 0x5563911d, 0x59dfa6aa,
+ 0x78c14389, 0xd95a537f, 0x207d5ba2, 0x02e5b9c5,
+ 0x83260376, 0x6295cfa9, 0x11c81968, 0x4e734a41,
+ 0xb3472dca, 0x7b14a94a, 0x1b510052, 0x9a532915,
+ 0xd60f573f, 0xbc9bc6e4, 0x2b60a476, 0x81e67400,
+ 0x08ba6fb5, 0x571be91f, 0xf296ec6b, 0x2a0dd915,
+ 0xb6636521, 0xe7b9f9b6, 0xff34052e, 0xc5855664,
+ 0x53b02d5d, 0xa99f8fa1, 0x08ba4799, 0x6e85076a
+ ],
+ [
+ 0x4b7a70e9, 0xb5b32944, 0xdb75092e, 0xc4192623,
+ 0xad6ea6b0, 0x49a7df7d, 0x9cee60b8, 0x8fedb266,
+ 0xecaa8c71, 0x699a17ff, 0x5664526c, 0xc2b19ee1,
+ 0x193602a5, 0x75094c29, 0xa0591340, 0xe4183a3e,
+ 0x3f54989a, 0x5b429d65, 0x6b8fe4d6, 0x99f73fd6,
+ 0xa1d29c07, 0xefe830f5, 0x4d2d38e6, 0xf0255dc1,
+ 0x4cdd2086, 0x8470eb26, 0x6382e9c6, 0x021ecc5e,
+ 0x09686b3f, 0x3ebaefc9, 0x3c971814, 0x6b6a70a1,
+ 0x687f3584, 0x52a0e286, 0xb79c5305, 0xaa500737,
+ 0x3e07841c, 0x7fdeae5c, 0x8e7d44ec, 0x5716f2b8,
+ 0xb03ada37, 0xf0500c0d, 0xf01c1f04, 0x0200b3ff,
+ 0xae0cf51a, 0x3cb574b2, 0x25837a58, 0xdc0921bd,
+ 0xd19113f9, 0x7ca92ff6, 0x94324773, 0x22f54701,
+ 0x3ae5e581, 0x37c2dadc, 0xc8b57634, 0x9af3dda7,
+ 0xa9446146, 0x0fd0030e, 0xecc8c73e, 0xa4751e41,
+ 0xe238cd99, 0x3bea0e2f, 0x3280bba1, 0x183eb331,
+ 0x4e548b38, 0x4f6db908, 0x6f420d03, 0xf60a04bf,
+ 0x2cb81290, 0x24977c79, 0x5679b072, 0xbcaf89af,
+ 0xde9a771f, 0xd9930810, 0xb38bae12, 0xdccf3f2e,
+ 0x5512721f, 0x2e6b7124, 0x501adde6, 0x9f84cd87,
+ 0x7a584718, 0x7408da17, 0xbc9f9abc, 0xe94b7d8c,
+ 0xec7aec3a, 0xdb851dfa, 0x63094366, 0xc464c3d2,
+ 0xef1c1847, 0x3215d908, 0xdd433b37, 0x24c2ba16,
+ 0x12a14d43, 0x2a65c451, 0x50940002, 0x133ae4dd,
+ 0x71dff89e, 0x10314e55, 0x81ac77d6, 0x5f11199b,
+ 0x043556f1, 0xd7a3c76b, 0x3c11183b, 0x5924a509,
+ 0xf28fe6ed, 0x97f1fbfa, 0x9ebabf2c, 0x1e153c6e,
+ 0x86e34570, 0xeae96fb1, 0x860e5e0a, 0x5a3e2ab3,
+ 0x771fe71c, 0x4e3d06fa, 0x2965dcb9, 0x99e71d0f,
+ 0x803e89d6, 0x5266c825, 0x2e4cc978, 0x9c10b36a,
+ 0xc6150eba, 0x94e2ea78, 0xa5fc3c53, 0x1e0a2df4,
+ 0xf2f74ea7, 0x361d2b3d, 0x1939260f, 0x19c27960,
+ 0x5223a708, 0xf71312b6, 0xebadfe6e, 0xeac31f66,
+ 0xe3bc4595, 0xa67bc883, 0xb17f37d1, 0x018cff28,
+ 0xc332ddef, 0xbe6c5aa5, 0x65582185, 0x68ab9802,
+ 0xeecea50f, 0xdb2f953b, 0x2aef7dad, 0x5b6e2f84,
+ 0x1521b628, 0x29076170, 0xecdd4775, 0x619f1510,
+ 0x13cca830, 0xeb61bd96, 0x0334fe1e, 0xaa0363cf,
+ 0xb5735c90, 0x4c70a239, 0xd59e9e0b, 0xcbaade14,
+ 0xeecc86bc, 0x60622ca7, 0x9cab5cab, 0xb2f3846e,
+ 0x648b1eaf, 0x19bdf0ca, 0xa02369b9, 0x655abb50,
+ 0x40685a32, 0x3c2ab4b3, 0x319ee9d5, 0xc021b8f7,
+ 0x9b540b19, 0x875fa099, 0x95f7997e, 0x623d7da8,
+ 0xf837889a, 0x97e32d77, 0x11ed935f, 0x16681281,
+ 0x0e358829, 0xc7e61fd6, 0x96dedfa1, 0x7858ba99,
+ 0x57f584a5, 0x1b227263, 0x9b83c3ff, 0x1ac24696,
+ 0xcdb30aeb, 0x532e3054, 0x8fd948e4, 0x6dbc3128,
+ 0x58ebf2ef, 0x34c6ffea, 0xfe28ed61, 0xee7c3c73,
+ 0x5d4a14d9, 0xe864b7e3, 0x42105d14, 0x203e13e0,
+ 0x45eee2b6, 0xa3aaabea, 0xdb6c4f15, 0xfacb4fd0,
+ 0xc742f442, 0xef6abbb5, 0x654f3b1d, 0x41cd2105,
+ 0xd81e799e, 0x86854dc7, 0xe44b476a, 0x3d816250,
+ 0xcf62a1f2, 0x5b8d2646, 0xfc8883a0, 0xc1c7b6a3,
+ 0x7f1524c3, 0x69cb7492, 0x47848a0b, 0x5692b285,
+ 0x095bbf00, 0xad19489d, 0x1462b174, 0x23820e00,
+ 0x58428d2a, 0x0c55f5ea, 0x1dadf43e, 0x233f7061,
+ 0x3372f092, 0x8d937e41, 0xd65fecf1, 0x6c223bdb,
+ 0x7cde3759, 0xcbee7460, 0x4085f2a7, 0xce77326e,
+ 0xa6078084, 0x19f8509e, 0xe8efd855, 0x61d99735,
+ 0xa969a7aa, 0xc50c06c2, 0x5a04abfc, 0x800bcadc,
+ 0x9e447a2e, 0xc3453484, 0xfdd56705, 0x0e1e9ec9,
+ 0xdb73dbd3, 0x105588cd, 0x675fda79, 0xe3674340,
+ 0xc5c43465, 0x713e38d8, 0x3d28f89e, 0xf16dff20,
+ 0x153e21e7, 0x8fb03d4a, 0xe6e39f2b, 0xdb83adf7
+ ],
+ [
+ 0xe93d5a68, 0x948140f7, 0xf64c261c, 0x94692934,
+ 0x411520f7, 0x7602d4f7, 0xbcf46b2e, 0xd4a20068,
+ 0xd4082471, 0x3320f46a, 0x43b7d4b7, 0x500061af,
+ 0x1e39f62e, 0x97244546, 0x14214f74, 0xbf8b8840,
+ 0x4d95fc1d, 0x96b591af, 0x70f4ddd3, 0x66a02f45,
+ 0xbfbc09ec, 0x03bd9785, 0x7fac6dd0, 0x31cb8504,
+ 0x96eb27b3, 0x55fd3941, 0xda2547e6, 0xabca0a9a,
+ 0x28507825, 0x530429f4, 0x0a2c86da, 0xe9b66dfb,
+ 0x68dc1462, 0xd7486900, 0x680ec0a4, 0x27a18dee,
+ 0x4f3ffea2, 0xe887ad8c, 0xb58ce006, 0x7af4d6b6,
+ 0xaace1e7c, 0xd3375fec, 0xce78a399, 0x406b2a42,
+ 0x20fe9e35, 0xd9f385b9, 0xee39d7ab, 0x3b124e8b,
+ 0x1dc9faf7, 0x4b6d1856, 0x26a36631, 0xeae397b2,
+ 0x3a6efa74, 0xdd5b4332, 0x6841e7f7, 0xca7820fb,
+ 0xfb0af54e, 0xd8feb397, 0x454056ac, 0xba489527,
+ 0x55533a3a, 0x20838d87, 0xfe6ba9b7, 0xd096954b,
+ 0x55a867bc, 0xa1159a58, 0xcca92963, 0x99e1db33,
+ 0xa62a4a56, 0x3f3125f9, 0x5ef47e1c, 0x9029317c,
+ 0xfdf8e802, 0x04272f70, 0x80bb155c, 0x05282ce3,
+ 0x95c11548, 0xe4c66d22, 0x48c1133f, 0xc70f86dc,
+ 0x07f9c9ee, 0x41041f0f, 0x404779a4, 0x5d886e17,
+ 0x325f51eb, 0xd59bc0d1, 0xf2bcc18f, 0x41113564,
+ 0x257b7834, 0x602a9c60, 0xdff8e8a3, 0x1f636c1b,
+ 0x0e12b4c2, 0x02e1329e, 0xaf664fd1, 0xcad18115,
+ 0x6b2395e0, 0x333e92e1, 0x3b240b62, 0xeebeb922,
+ 0x85b2a20e, 0xe6ba0d99, 0xde720c8c, 0x2da2f728,
+ 0xd0127845, 0x95b794fd, 0x647d0862, 0xe7ccf5f0,
+ 0x5449a36f, 0x877d48fa, 0xc39dfd27, 0xf33e8d1e,
+ 0x0a476341, 0x992eff74, 0x3a6f6eab, 0xf4f8fd37,
+ 0xa812dc60, 0xa1ebddf8, 0x991be14c, 0xdb6e6b0d,
+ 0xc67b5510, 0x6d672c37, 0x2765d43b, 0xdcd0e804,
+ 0xf1290dc7, 0xcc00ffa3, 0xb5390f92, 0x690fed0b,
+ 0x667b9ffb, 0xcedb7d9c, 0xa091cf0b, 0xd9155ea3,
+ 0xbb132f88, 0x515bad24, 0x7b9479bf, 0x763bd6eb,
+ 0x37392eb3, 0xcc115979, 0x8026e297, 0xf42e312d,
+ 0x6842ada7, 0xc66a2b3b, 0x12754ccc, 0x782ef11c,
+ 0x6a124237, 0xb79251e7, 0x06a1bbe6, 0x4bfb6350,
+ 0x1a6b1018, 0x11caedfa, 0x3d25bdd8, 0xe2e1c3c9,
+ 0x44421659, 0x0a121386, 0xd90cec6e, 0xd5abea2a,
+ 0x64af674e, 0xda86a85f, 0xbebfe988, 0x64e4c3fe,
+ 0x9dbc8057, 0xf0f7c086, 0x60787bf8, 0x6003604d,
+ 0xd1fd8346, 0xf6381fb0, 0x7745ae04, 0xd736fccc,
+ 0x83426b33, 0xf01eab71, 0xb0804187, 0x3c005e5f,
+ 0x77a057be, 0xbde8ae24, 0x55464299, 0xbf582e61,
+ 0x4e58f48f, 0xf2ddfda2, 0xf474ef38, 0x8789bdc2,
+ 0x5366f9c3, 0xc8b38e74, 0xb475f255, 0x46fcd9b9,
+ 0x7aeb2661, 0x8b1ddf84, 0x846a0e79, 0x915f95e2,
+ 0x466e598e, 0x20b45770, 0x8cd55591, 0xc902de4c,
+ 0xb90bace1, 0xbb8205d0, 0x11a86248, 0x7574a99e,
+ 0xb77f19b6, 0xe0a9dc09, 0x662d09a1, 0xc4324633,
+ 0xe85a1f02, 0x09f0be8c, 0x4a99a025, 0x1d6efe10,
+ 0x1ab93d1d, 0x0ba5a4df, 0xa186f20f, 0x2868f169,
+ 0xdcb7da83, 0x573906fe, 0xa1e2ce9b, 0x4fcd7f52,
+ 0x50115e01, 0xa70683fa, 0xa002b5c4, 0x0de6d027,
+ 0x9af88c27, 0x773f8641, 0xc3604c06, 0x61a806b5,
+ 0xf0177a28, 0xc0f586e0, 0x006058aa, 0x30dc7d62,
+ 0x11e69ed7, 0x2338ea63, 0x53c2dd94, 0xc2c21634,
+ 0xbbcbee56, 0x90bcb6de, 0xebfc7da1, 0xce591d76,
+ 0x6f05e409, 0x4b7c0188, 0x39720a3d, 0x7c927c24,
+ 0x86e3725f, 0x724d9db9, 0x1ac15bb4, 0xd39eb8fc,
+ 0xed545578, 0x08fca5b5, 0xd83d7cd3, 0x4dad0fc4,
+ 0x1e50ef5e, 0xb161e6f8, 0xa28514d9, 0x6c51133c,
+ 0x6fd5c7e7, 0x56e14ec4, 0x362abfce, 0xddc6c837,
+ 0xd79a3234, 0x92638212, 0x670efa8e, 0x406000e0
+ ],
+ [
+ 0x3a39ce37, 0xd3faf5cf, 0xabc27737, 0x5ac52d1b,
+ 0x5cb0679e, 0x4fa33742, 0xd3822740, 0x99bc9bbe,
+ 0xd5118e9d, 0xbf0f7315, 0xd62d1c7e, 0xc700c47b,
+ 0xb78c1b6b, 0x21a19045, 0xb26eb1be, 0x6a366eb4,
+ 0x5748ab2f, 0xbc946e79, 0xc6a376d2, 0x6549c2c8,
+ 0x530ff8ee, 0x468dde7d, 0xd5730a1d, 0x4cd04dc6,
+ 0x2939bbdb, 0xa9ba4650, 0xac9526e8, 0xbe5ee304,
+ 0xa1fad5f0, 0x6a2d519a, 0x63ef8ce2, 0x9a86ee22,
+ 0xc089c2b8, 0x43242ef6, 0xa51e03aa, 0x9cf2d0a4,
+ 0x83c061ba, 0x9be96a4d, 0x8fe51550, 0xba645bd6,
+ 0x2826a2f9, 0xa73a3ae1, 0x4ba99586, 0xef5562e9,
+ 0xc72fefd3, 0xf752f7da, 0x3f046f69, 0x77fa0a59,
+ 0x80e4a915, 0x87b08601, 0x9b09e6ad, 0x3b3ee593,
+ 0xe990fd5a, 0x9e34d797, 0x2cf0b7d9, 0x022b8b51,
+ 0x96d5ac3a, 0x017da67d, 0xd1cf3ed6, 0x7c7d2d28,
+ 0x1f9f25cf, 0xadf2b89b, 0x5ad6b472, 0x5a88f54c,
+ 0xe029ac71, 0xe019a5e6, 0x47b0acfd, 0xed93fa9b,
+ 0xe8d3c48d, 0x283b57cc, 0xf8d56629, 0x79132e28,
+ 0x785f0191, 0xed756055, 0xf7960e44, 0xe3d35e8c,
+ 0x15056dd4, 0x88f46dba, 0x03a16125, 0x0564f0bd,
+ 0xc3eb9e15, 0x3c9057a2, 0x97271aec, 0xa93a072a,
+ 0x1b3f6d9b, 0x1e6321f5, 0xf59c66fb, 0x26dcf319,
+ 0x7533d928, 0xb155fdf5, 0x03563482, 0x8aba3cbb,
+ 0x28517711, 0xc20ad9f8, 0xabcc5167, 0xccad925f,
+ 0x4de81751, 0x3830dc8e, 0x379d5862, 0x9320f991,
+ 0xea7a90c2, 0xfb3e7bce, 0x5121ce64, 0x774fbe32,
+ 0xa8b6e37e, 0xc3293d46, 0x48de5369, 0x6413e680,
+ 0xa2ae0810, 0xdd6db224, 0x69852dfd, 0x09072166,
+ 0xb39a460a, 0x6445c0dd, 0x586cdecf, 0x1c20c8ae,
+ 0x5bbef7dd, 0x1b588d40, 0xccd2017f, 0x6bb4e3bb,
+ 0xdda26a7e, 0x3a59ff45, 0x3e350a44, 0xbcb4cdd5,
+ 0x72eacea8, 0xfa6484bb, 0x8d6612ae, 0xbf3c6f47,
+ 0xd29be463, 0x542f5d9e, 0xaec2771b, 0xf64e6370,
+ 0x740e0d8d, 0xe75b1357, 0xf8721671, 0xaf537d5d,
+ 0x4040cb08, 0x4eb4e2cc, 0x34d2466a, 0x0115af84,
+ 0xe1b00428, 0x95983a1d, 0x06b89fb4, 0xce6ea048,
+ 0x6f3f3b82, 0x3520ab82, 0x011a1d4b, 0x277227f8,
+ 0x611560b1, 0xe7933fdc, 0xbb3a792b, 0x344525bd,
+ 0xa08839e1, 0x51ce794b, 0x2f32c9b7, 0xa01fbac9,
+ 0xe01cc87e, 0xbcc7d1f6, 0xcf0111c3, 0xa1e8aac7,
+ 0x1a908749, 0xd44fbd9a, 0xd0dadecb, 0xd50ada38,
+ 0x0339c32a, 0xc6913667, 0x8df9317c, 0xe0b12b4f,
+ 0xf79e59b7, 0x43f5bb3a, 0xf2d519ff, 0x27d9459c,
+ 0xbf97222c, 0x15e6fc2a, 0x0f91fc71, 0x9b941525,
+ 0xfae59361, 0xceb69ceb, 0xc2a86459, 0x12baa8d1,
+ 0xb6c1075e, 0xe3056a0c, 0x10d25065, 0xcb03a442,
+ 0xe0ec6e0e, 0x1698db3b, 0x4c98a0be, 0x3278e964,
+ 0x9f1f9532, 0xe0d392df, 0xd3a0342b, 0x8971f21e,
+ 0x1b0a7441, 0x4ba3348c, 0xc5be7120, 0xc37632d8,
+ 0xdf359f8d, 0x9b992f2e, 0xe60b6f47, 0x0fe3f11d,
+ 0xe54cda54, 0x1edad891, 0xce6279cf, 0xcd3e7e6f,
+ 0x1618b166, 0xfd2c1d05, 0x848fd2c5, 0xf6fb2299,
+ 0xf523f357, 0xa6327623, 0x93a83531, 0x56cccd02,
+ 0xacf08162, 0x5a75ebb5, 0x6e163697, 0x88d273cc,
+ 0xde966292, 0x81b949d0, 0x4c50901b, 0x71c65614,
+ 0xe6c6c7bd, 0x327a140a, 0x45e1d006, 0xc3f27b9a,
+ 0xc9aa53fd, 0x62a80f00, 0xbb25bfe2, 0x35bdd2f6,
+ 0x71126905, 0xb2040222, 0xb6cbcf7c, 0xcd769c2b,
+ 0x53113ec0, 0x1640e3d3, 0x38abbd60, 0x2547adf0,
+ 0xba38209c, 0xf746ce76, 0x77afa1c5, 0x20756060,
+ 0x85cbfe4e, 0x8ae88dd8, 0x7aaaf9b0, 0x4cf9aa7e,
+ 0x1948c25c, 0x02fb8a8c, 0x01c36ae4, 0xd6ebe1f9,
+ 0x90d4f869, 0xa65cdea0, 0x3f09252d, 0xc208e69f,
+ 0xb74e6132, 0xce77e25b, 0x578fdfe3, 0x3ac372e6
+ ]
+ ]
+ );
+ my $keylen=length($key);
+ return undef if(($keylen < 8) || ($keylen > 56));
+ my @keybytes=split//,$key;
+ my $b;
+ for $b (@keybytes)
+ {
+ $b=unpack("C",$b);
+ }
+ my $j=0;
+ my $i=0;
+ my($l,$r)=(0,0);
+
+ # BEGIN PROCESS OF SETTING UP S & P-BOXES FOR THE KEY
+ for ($i=0;$i<18;$i++)
+ {
+ my $temp= ($keybytes[$j]<<24) +
+ ($keybytes[($j+1)%($keylen)]<<16) +
+ ($keybytes[($j+2)%($keylen)]<<8) +
+ ($keybytes[($j+3)%($keylen)]) ;
+ $h{"p_boxes"}->[$i]^=$temp;
+ $j=($j+4)%($keylen);
+ }
+ for ($i=0;$i<18;$i+=2)
+ {
+ ($l,$r)=crypt_block(\%h,$l,$r,0);
+ $h{"p_boxes"}->[$i]=$l;
+ $h{"p_boxes"}->[$i+1]=$r;
+ }
+ for $i (0..3)
+ {
+ for($j=0;$j<256;$j+=2)
+ {
+ ($l,$r)=crypt_block(\%h,$l,$r,0);
+ $h{"s_boxes"}->[$i]->[$j]=$l;
+ $h{"s_boxes"}->[$i]->[$j+1]=$r;
+ }
+ }
+ # S-BOXES AND P-BOXES NOW SET UP, NEED NO LONGER CARE
+ # ABOUT ACTUAL KEY
+ return bless \%h, $pack;
+ }
+
+sub F
+ {
+ my $S0=$_[0]->{"s_boxes"}->[0]->[($_[1]&0xFF000000)>>24];
+ my $S1=$_[0]->{"s_boxes"}->[1]->[($_[1]&0x00FF0000)>>16];
+ my $S2=$_[0]->{"s_boxes"}->[2]->[($_[1]&0x0000FF00)>>8];
+ my $S3=$_[0]->{"s_boxes"}->[3]->[($_[1]&0x000000FF)];
+ # this is horrid, but otherwise Perl overflows. :(
+ if($S0>$S1)
+ {
+ $S0=$S0-4294967296 if($S0>2147483647);
+ }
+ else
+ {
+ $S1=$S1-4294967296 if($S1>2147483647);
+ }
+ my $F=($S0+$S1);
+ $F+=4294967296 if($F<0);
+ $F^=$S2;
+ if($F>$S3)
+ {
+ $F=$F-4294967296 if($F>2147483647);
+ }
+ else
+ {
+ $S3=$S3-4294967296 if($S3>2147483647);
+ }
+ $F+=$S3;
+ $F&=0xFFFFFFFF;
+ return $F;
+ }
+
+sub ROUND
+ {
+ return($_[1],($_[2]^($_[0]->{"p_boxes"}->[$_[3]]))^F($_[0],$_[1]));
+ }
+
+sub crypt_block
+ {
+ my $self=shift;
+ my $l=shift;
+ my $r=shift;
+ my $d=shift;
+ if(!$d)
+ {
+ $l^=$self->{"p_boxes"}->[0];
+ my $i;
+ for $i (1..16)
+ {
+ ($r,$l)=ROUND($self,$l,$r,$i);
+ }
+ $r^=$self->{"p_boxes"}->[17];
+ }
+ else
+ {
+ $l^=$self->{"p_boxes"}->[17];
+ my $i;
+ for $i (1..16)
+ {
+ ($r,$l)=ROUND($self,$l,$r,17-$i);
+ }
+ $r^=$self->{"p_boxes"}->[0];
+ }
+ return($r,$l);
+ }
+
+=head2 B(I)
+
+The B() method uses the initialised blowfish object to encrypt 8 bytes
+of data of the string passed to it. It returns the encrypted block.
+
+=cut
+
+sub encrypt
+ {
+ my($self)=shift;
+ my($block)=shift;
+ my(@block)=split//,$block;
+ map{$_=unpack("C",$_)}@block;
+ # I'm not sure what endianness these are.... so hey.
+ my($l)=$block[3]|($block[2]<<8)|($block[1]<<16)|($block[0]<<24);
+ my($r)=$block[7]|($block[6]<<8)|($block[5]<<16)|($block[4]<<24);
+
+ ($l,$r)=crypt_block($self,$l,$r,0);
+
+ @block=(
+ $l>>24,($l>>16)&0xFF,($l>>8)&0xFF,$l&0xFF,
+ $r>>24,($r>>16)&0xFF,($r>>8)&0xFF,$r&0xFF
+ );
+ map{$_=pack("C",$_)}@block;
+ return join"",@block;
+ }
+
+=head2 B(I)
+
+The B() method uses the initialised blowfish object to decrypt 8 bytes
+of data of the string passed to it. It returns the decrypted block.
+
+=cut
+
+sub decrypt
+ {
+ my($self)=shift;
+ my($block)=shift;
+ my(@block)=split//,$block;
+ map{$_=unpack("C",$_)}@block;
+ my($l)=$block[3]|($block[2]<<8)|($block[1]<<16)|($block[0]<<24);
+ my($r)=$block[7]|($block[6]<<8)|($block[5]<<16)|($block[4]<<24);
+
+ ($l,$r)=crypt_block($self,$l,$r,1);
+
+ @block=(
+ $l>>24,($l>>16)&0xFF,($l>>8)&0xFF,$l&0xFF,
+ $r>>24,($r>>16)&0xFF,($r>>8)&0xFF,$r&0xFF
+ );
+ map{$_=pack("C",$_)}@block;
+ return join"",@block;
+ }
+
+sub blocksize
+ {
+ return 8;
+ }
+
+sub keysize
+ {
+ return 56;
+ }
+
+=head1 COMMENTS
+
+This is probably crap software, but hey, its for general use. I'm happy to patch
+it with other people's code... :)
+
+If you want speed, then see the Crypt::Blowfish module.
+
+=head1 AUTHOR
+
+Matthew Byng-Maddick >
+
+=head1 SEE ALSO
+
+http://www.counterpane.com/,L
+
+=cut
+
+1;
diff --git a/src/redux/Crypt/CBC.pm b/src/redux/Crypt/CBC.pm
new file mode 100644
index 000000000..39ff251d4
--- /dev/null
+++ b/src/redux/Crypt/CBC.pm
@@ -0,0 +1,1064 @@
+package Crypt::CBC;
+
+use Digest::MD5 'md5';
+use Carp;
+use strict;
+use bytes;
+use vars qw($VERSION);
+$VERSION = '2.33';
+
+use constant RANDOM_DEVICE => '/dev/urandom';
+
+sub new {
+ my $class = shift;
+
+ my $options = {};
+
+ # hashref arguments
+ if (ref $_[0] eq 'HASH') {
+ $options = shift;
+ }
+
+ # CGI style arguments
+ elsif ($_[0] =~ /^-[a-zA-Z_]{1,20}$/) {
+ my %tmp = @_;
+ while ( my($key,$value) = each %tmp) {
+ $key =~ s/^-//;
+ $options->{lc $key} = $value;
+ }
+ }
+
+ else {
+ $options->{key} = shift;
+ $options->{cipher} = shift;
+ }
+
+ my $cipher_object_provided = $options->{cipher} && ref $options->{cipher};
+
+ # "key" is a misnomer here, because it is actually usually a passphrase that is used
+ # to derive the true key
+ my $pass = $options->{key};
+
+ if ($cipher_object_provided) {
+ carp "Both a key and a pre-initialized Crypt::* object were passed. The key will be ignored"
+ if defined $pass;
+ $pass ||= '';
+ }
+ elsif (!defined $pass) {
+ croak "Please provide an encryption/decryption passphrase or key using -key"
+ }
+
+ # header mode
+ my %valid_modes = map {$_=>1} qw(none salt randomiv);
+ my $header_mode = $options->{header};
+ $header_mode ||= 'none' if exists $options->{prepend_iv} && !$options->{prepend_iv};
+ $header_mode ||= 'none' if exists $options->{add_header} && !$options->{add_header};
+ $header_mode ||= 'salt'; # default
+ croak "Invalid -header mode '$header_mode'" unless $valid_modes{$header_mode};
+
+ croak "The -salt argument is incompatible with a -header mode of $header_mode"
+ if exists $options->{salt} && $header_mode ne 'salt';
+
+ my $cipher = $options->{cipher};
+ $cipher = 'Crypt::DES' unless $cipher;
+ my $cipherclass = ref $cipher || $cipher;
+
+ unless (ref $cipher) { # munge the class name if no object passed
+ $cipher = $cipher=~/^Crypt::/ ? $cipher : "Crypt::$cipher";
+ $cipher->can('encrypt') or eval "require $cipher; 1" or croak "Couldn't load $cipher: $@";
+ # some crypt modules use the class Crypt::, and others don't
+ $cipher =~ s/^Crypt::// unless $cipher->can('keysize');
+ }
+
+ # allow user to override these values
+ my $ks = $options->{keysize};
+ my $bs = $options->{blocksize};
+
+ # otherwise we get the values from the cipher
+ $ks ||= eval {$cipher->keysize};
+ $bs ||= eval {$cipher->blocksize};
+
+ # Some of the cipher modules are busted and don't report the
+ # keysize (well, Crypt::Blowfish in any case). If we detect
+ # this, and find the blowfish module in use, then assume 56.
+ # Otherwise assume the least common denominator of 8.
+ $ks ||= $cipherclass =~ /blowfish/i ? 56 : 8;
+ $bs ||= $ks;
+
+ my $pcbc = $options->{'pcbc'};
+
+ # Default behavior is to treat -key as a passphrase.
+ # But if the literal_key option is true, then use key as is
+ croak "The options -literal_key and -regenerate_key are incompatible with each other"
+ if exists $options->{literal_key} && exists $options->{regenerate_key};
+ my $key;
+ $key = $pass if $options->{literal_key};
+ $key = $pass if exists $options->{regenerate_key} && !$options->{regenerate_key};
+
+ # Get the salt.
+ my $salt = $options->{salt};
+ my $random_salt = 1 unless defined $salt && $salt ne '1';
+ croak "Argument to -salt must be exactly 8 bytes long" if defined $salt && length $salt != 8 && $salt ne '1';
+
+ # note: iv will be autogenerated by start() if not specified in options
+ my $iv = $options->{iv};
+ my $random_iv = 1 unless defined $iv;
+ croak "Initialization vector must be exactly $bs bytes long when using the $cipherclass cipher" if defined $iv and length($iv) != $bs;
+
+ my $literal_key = $options->{literal_key} || (exists $options->{regenerate_key} && !$options->{regenerate_key});
+ my $legacy_hack = $options->{insecure_legacy_decrypt};
+ my $padding = $options->{padding} || 'standard';
+
+ if ($padding && ref($padding) eq 'CODE') {
+ # check to see that this code does its padding correctly
+ for my $i (1..$bs-1) {
+ my $rbs = length($padding->(" "x$i,$bs,'e'));
+ croak "padding method callback does not behave properly: expected $bs bytes back, got $rbs bytes back."
+ unless ($rbs == $bs);
+ }
+ } else {
+ $padding = $padding eq 'none' ? \&_no_padding
+ :$padding eq 'null' ? \&_null_padding
+ :$padding eq 'space' ? \&_space_padding
+ :$padding eq 'oneandzeroes' ? \&_oneandzeroes_padding
+ :$padding eq 'rijndael_compat'? \&_rijndael_compat
+ :$padding eq 'standard' ? \&_standard_padding
+ :croak "'$padding' padding not supported. See perldoc Crypt::CBC for instructions on creating your own.";
+ }
+
+ # CONSISTENCY CHECKS
+ # HEADER consistency
+ if ($header_mode eq 'salt') {
+ croak "Cannot use salt-based key generation if literal key is specified"
+ if $options->{literal_key};
+ croak "Cannot use salt-based IV generation if literal IV is specified"
+ if exists $options->{iv};
+ }
+ elsif ($header_mode eq 'randomiv') {
+ croak "Cannot encrypt using a non-8 byte blocksize cipher when using randomiv header mode"
+ unless $bs == 8 || $legacy_hack;
+ }
+ elsif ($header_mode eq 'none') {
+ croak "You must provide an initialization vector using -iv when using -header=>'none'"
+ unless exists $options->{iv};
+ }
+
+ # KEYSIZE consistency
+ if (defined $key && length($key) != $ks) {
+ croak "If specified by -literal_key, then the key length must be equal to the chosen cipher's key length of $ks bytes";
+ }
+
+ # IV consistency
+ if (defined $iv && length($iv) != $bs) {
+ croak "If specified by -iv, then the initialization vector length must be equal to the chosen cipher's blocksize of $bs bytes";
+ }
+
+
+ return bless {'cipher' => $cipher,
+ 'passphrase' => $pass,
+ 'key' => $key,
+ 'iv' => $iv,
+ 'salt' => $salt,
+ 'padding' => $padding,
+ 'blocksize' => $bs,
+ 'keysize' => $ks,
+ 'header_mode' => $header_mode,
+ 'legacy_hack' => $legacy_hack,
+ 'literal_key' => $literal_key,
+ 'pcbc' => $pcbc,
+ 'make_random_salt' => $random_salt,
+ 'make_random_iv' => $random_iv,
+ },$class;
+}
+
+sub encrypt (\$$) {
+ my ($self,$data) = @_;
+ $self->start('encrypting');
+ my $result = $self->crypt($data);
+ $result .= $self->finish;
+ $result;
+}
+
+sub decrypt (\$$){
+ my ($self,$data) = @_;
+ $self->start('decrypting');
+ my $result = $self->crypt($data);
+ $result .= $self->finish;
+ $result;
+}
+
+sub encrypt_hex (\$$) {
+ my ($self,$data) = @_;
+ return join('',unpack 'H*',$self->encrypt($data));
+}
+
+sub decrypt_hex (\$$) {
+ my ($self,$data) = @_;
+ return $self->decrypt(pack'H*',$data);
+}
+
+# call to start a series of encryption/decryption operations
+sub start (\$$) {
+ my $self = shift;
+ my $operation = shift;
+ croak "Specify ncryption or ecryption" unless $operation=~/^[ed]/i;
+
+ $self->{'buffer'} = '';
+ $self->{'decrypt'} = $operation=~/^d/i;
+}
+
+# call to encrypt/decrypt a bit of data
+sub crypt (\$$){
+ my $self = shift;
+ my $data = shift;
+
+ my $result;
+
+ croak "crypt() called without a preceding start()"
+ unless exists $self->{'buffer'};
+
+ my $d = $self->{'decrypt'};
+
+ unless ($self->{civ}) { # block cipher has not yet been initialized
+ $result = $self->_generate_iv_and_cipher_from_datastream(\$data) if $d;
+ $result = $self->_generate_iv_and_cipher_from_options() unless $d;
+ }
+
+ my $iv = $self->{'civ'};
+ $self->{'buffer'} .= $data;
+
+ my $bs = $self->{'blocksize'};
+
+ croak "When using no padding, plaintext size must be a multiple of $bs"
+ if $self->{'padding'} eq \&_no_padding
+ and length($data) % $bs;
+
+ croak "When using rijndael_compat padding, plaintext size must be a multiple of $bs"
+ if $self->{'padding'} eq \&_rijndael_compat
+ and length($data) % $bs;
+
+ return $result unless (length($self->{'buffer'}) >= $bs);
+
+ my @blocks = unpack("a$bs "x(int(length($self->{'buffer'})/$bs)) . "a*", $self->{'buffer'});
+ $self->{'buffer'} = '';
+
+ if ($d) { # when decrypting, always leave a free block at the end
+ $self->{'buffer'} = length($blocks[-1]) < $bs ? join '',splice(@blocks,-2) : pop(@blocks);
+ } else {
+ $self->{'buffer'} = pop @blocks if length($blocks[-1]) < $bs; # what's left over
+ }
+
+ foreach my $block (@blocks) {
+ if ($d) { # decrypting
+ $result .= $iv = $iv ^ $self->{'crypt'}->decrypt($block);
+ $iv = $block unless $self->{pcbc};
+ } else { # encrypting
+ $result .= $iv = $self->{'crypt'}->encrypt($iv ^ $block);
+ }
+ $iv = $iv ^ $block if $self->{pcbc};
+ }
+ $self->{'civ'} = $iv; # remember the iv
+ return $result;
+}
+
+# this is called at the end to flush whatever's left
+sub finish (\$) {
+ my $self = shift;
+ my $bs = $self->{'blocksize'};
+ my $block = defined $self->{'buffer'} ? $self->{'buffer'} : '';
+
+ $self->{civ} ||= '';
+
+ my $result;
+ if ($self->{'decrypt'}) { #decrypting
+ $block = length $block ? pack("a$bs",$block) : ''; # pad and truncate to block size
+
+ if (length($block)) {
+ $result = $self->{'civ'} ^ $self->{'crypt'}->decrypt($block);
+ $result = $self->{'padding'}->($result, $bs, 'd');
+ } else {
+ $result = '';
+ }
+
+ } else { # encrypting
+ $block = $self->{'padding'}->($block,$bs,'e') || '';
+ $result = length $block ? $self->{'crypt'}->encrypt($self->{'civ'} ^ $block) : '';
+ }
+ delete $self->{'civ'};
+ delete $self->{'buffer'};
+ return $result;
+}
+
+# this subroutine will generate the actual {en,de}cryption key, the iv
+# and the block cipher object. This is called when reading from a datastream
+# and so it uses previous values of salt or iv if they are encoded in datastream
+# header
+sub _generate_iv_and_cipher_from_datastream {
+ my $self = shift;
+ my $input_stream = shift;
+ my $bs = $self->blocksize;
+
+ # use our header mode to figure out what to do with the data stream
+ my $header_mode = $self->header_mode;
+
+ if ($header_mode eq 'none') {
+ croak "You must specify a $bs byte initialization vector by passing the -iv option to new() when using -header_mode=>'none'"
+ unless exists $self->{iv};
+ $self->{civ} = $self->{iv}; # current IV equals saved IV
+ $self->{key} ||= $self->_key_from_key($self->{passphrase});
+ }
+
+ elsif ($header_mode eq 'salt') {
+ my ($salt) = $$input_stream =~ /^Salted__(.{8})/s;
+ croak "Ciphertext does not begin with a valid header for 'salt' header mode" unless defined $salt;
+ $self->{salt} = $salt; # new salt
+ substr($$input_stream,0,16) = '';
+ my ($key,$iv) = $self->_salted_key_and_iv($self->{passphrase},$salt);
+ $self->{iv} = $self->{civ} = $iv;
+ $self->{key} = $key;
+ }
+
+ elsif ($header_mode eq 'randomiv') {
+ my ($iv) = $$input_stream =~ /^RandomIV(.{8})/s;
+ croak "Ciphertext does not begin with a valid header for 'randomiv' header mode" unless defined $iv;
+ croak "randomiv header mode cannot be used securely when decrypting with a >8 byte block cipher.\nUse the -insecure_legacy_decrypt flag if you are sure you want to do this" unless $self->blocksize == 8 || $self->legacy_hack;
+ $self->{iv} = $self->{civ} = $iv;
+ $self->{key} = $self->_key_from_key($self->{passphrase});
+ undef $self->{salt}; # paranoia
+ substr($$input_stream,0,16) = ''; # truncate
+ }
+
+ else {
+ croak "Invalid header mode '$header_mode'";
+ }
+
+ # we should have the key and iv now, or we are dead in the water
+ croak "Cipher stream did not contain IV or salt, and you did not specify these values in new()"
+ unless $self->{key} && $self->{civ};
+
+ # now we can generate the crypt object itself
+ $self->{crypt} = ref $self->{cipher} ? $self->{cipher}
+ : $self->{cipher}->new($self->{key})
+ or croak "Could not create $self->{cipher} object: $@";
+ return '';
+}
+
+sub _generate_iv_and_cipher_from_options {
+ my $self = shift;
+ my $blocksize = $self->blocksize;
+
+ my $result = '';
+
+ my $header_mode = $self->header_mode;
+ if ($header_mode eq 'none') {
+ croak "You must specify a $blocksize byte initialization vector by passing the -iv option to new() when using -header_mode=>'none'"
+ unless exists $self->{iv};
+ $self->{civ} = $self->{iv};
+ $self->{key} ||= $self->_key_from_key($self->{passphrase});
+ }
+
+ elsif ($header_mode eq 'salt') {
+ $self->{salt} = $self->_get_random_bytes(8) if $self->{make_random_salt};
+ defined (my $salt = $self->{salt}) or croak "No header_mode of 'salt' specified, but no salt value provided"; # shouldn't happen
+ length($salt) == 8 or croak "Salt must be exactly 8 bytes long";
+ my ($key,$iv) = $self->_salted_key_and_iv($self->{passphrase},$salt);
+ $self->{key} = $key;
+ $self->{civ} = $self->{iv} = $iv;
+ $result = "Salted__${salt}";
+ }
+
+ elsif ($header_mode eq 'randomiv') {
+ croak "randomiv header mode cannot be used when encrypting with a >8 byte block cipher. There is no option to allow this"
+ unless $blocksize == 8;
+ $self->{key} ||= $self->_key_from_key($self->{passphrase});
+ $self->{iv} = $self->_get_random_bytes(8) if $self->{make_random_iv};
+ length($self->{iv}) == 8 or croak "IV must be exactly 8 bytes long when used with header mode of 'randomiv'";
+ $self->{civ} = $self->{iv};
+ $result = "RandomIV$self->{iv}";
+ }
+
+ croak "key and/or iv are missing" unless defined $self->{key} && defined $self->{civ};
+
+ $self->_taintcheck($self->{key});
+ $self->{crypt} = ref $self->{cipher} ? $self->{cipher}
+ : $self->{cipher}->new($self->{key})
+ or croak "Could not create $self->{cipher} object: $@";
+ return $result;
+}
+
+sub _taintcheck {
+ my $self = shift;
+ my $key = shift;
+ return unless ${^TAINT};
+
+ my $has_scalar_util = eval "require Scalar::Util; 1";
+ my $tainted;
+
+
+ if ($has_scalar_util) {
+ $tainted = Scalar::Util::tainted($key);
+ } else {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ local $^W = 0;
+ eval { kill 0 * $key };
+ $tainted = $@ =~ /^Insecure/;
+ }
+
+ croak "Taint checks are turned on and your key is tainted. Please untaint the key and try again"
+ if $tainted;
+}
+
+sub _key_from_key {
+ my $self = shift;
+ my $pass = shift;
+ my $ks = $self->{keysize};
+
+ return $pass if $self->{literal_key};
+
+ my $material = md5($pass);
+ while (length($material) < $ks) {
+ $material .= md5($material);
+ }
+ return substr($material,0,$ks);
+}
+
+sub _salted_key_and_iv {
+ my $self = shift;
+ my ($pass,$salt) = @_;
+
+ croak "Salt must be 8 bytes long" unless length $salt == 8;
+
+ my $key_len = $self->{keysize};
+ my $iv_len = $self->{blocksize};
+
+ my $desired_len = $key_len+$iv_len;
+
+ my $data = '';
+ my $d = '';
+
+ while (length $data < $desired_len) {
+ $d = md5($d . $pass . $salt);
+ $data .= $d;
+ }
+ return (substr($data,0,$key_len),substr($data,$key_len,$iv_len));
+}
+
+sub random_bytes {
+ my $self = shift;
+ my $bytes = shift or croak "usage: random_bytes(\$byte_length)";
+ $self->_get_random_bytes($bytes);
+}
+
+sub _get_random_bytes {
+ my $self = shift;
+ my $length = shift;
+ my $result;
+
+ if (-r RANDOM_DEVICE && open(F,RANDOM_DEVICE)) {
+ read(F,$result,$length);
+ close F;
+ } else {
+ $result = pack("C*",map {rand(256)} 1..$length);
+ }
+ # Clear taint and check length
+ $result =~ /^(.+)$/s;
+ length($1) == $length or croak "Invalid length while gathering $length random bytes";
+ return $1;
+}
+
+sub _standard_padding ($$$) {
+ my ($b,$bs,$decrypt) = @_;
+ $b = length $b ? $b : '';
+ if ($decrypt eq 'd') {
+ my $pad_length = unpack("C",substr($b,-1));
+
+ # sanity check for implementations that don't pad correctly
+ return $b unless $pad_length >= 0 && $pad_length <= $bs;
+ my @pad_chars = unpack("C*",substr($b,-$pad_length));
+ return $b if grep {$pad_length != $_} @pad_chars;
+
+ return substr($b,0,$bs-$pad_length);
+ }
+ my $pad = $bs - length($b) % $bs;
+ return $b . pack("C*",($pad)x$pad);
+}
+
+sub _space_padding ($$$) {
+ my ($b,$bs,$decrypt) = @_;
+ return unless length $b;
+ $b = length $b ? $b : '';
+ if ($decrypt eq 'd') {
+ $b=~ s/ *\z//s;
+ return $b;
+ }
+ return $b . pack("C*", (32) x ($bs - length($b) % $bs));
+}
+
+sub _no_padding ($$$) {
+ my ($b,$bs,$decrypt) = @_;
+ return $b;
+}
+
+sub _null_padding ($$$) {
+ my ($b,$bs,$decrypt) = @_;
+ return unless length $b;
+ $b = length $b ? $b : '';
+ if ($decrypt eq 'd') {
+ $b=~ s/\0*\z//s;
+ return $b;
+ }
+ return $b . pack("C*", (0) x ($bs - length($b) % $bs));
+}
+
+sub _oneandzeroes_padding ($$$) {
+ my ($b,$bs,$decrypt) = @_;
+ $b = length $b ? $b : '';
+ if ($decrypt eq 'd') {
+ $b=~ s/\x80\0*\z//s;
+ return $b;
+ }
+ return $b . pack("C*", 128, (0) x ($bs - length($b) % $bs - 1) );
+}
+
+sub _rijndael_compat ($$$) {
+ my ($b,$bs,$decrypt) = @_;
+ return unless length $b;
+ if ($decrypt eq 'd') {
+ $b=~ s/\x80\0*\z//s;
+ return $b;
+ }
+ return $b . pack("C*", 128, (0) x ($bs - length($b) % $bs - 1) );
+}
+
+sub get_initialization_vector (\$) {
+ my $self = shift;
+ $self->iv();
+}
+
+sub set_initialization_vector (\$$) {
+ my $self = shift;
+ my $iv = shift;
+ my $bs = $self->blocksize;
+ croak "Initialization vector must be $bs bytes in length" unless length($iv) == $bs;
+ $self->iv($iv);
+}
+
+sub salt {
+ my $self = shift;
+ my $d = $self->{salt};
+ $self->{salt} = shift if @_;
+ $d;
+}
+
+sub iv {
+ my $self = shift;
+ my $d = $self->{iv};
+ $self->{iv} = shift if @_;
+ $d;
+}
+
+sub key {
+ my $self = shift;
+ my $d = $self->{key};
+ $self->{key} = shift if @_;
+ $d;
+}
+
+sub passphrase {
+ my $self = shift;
+ my $d = $self->{passphrase};
+ if (@_) {
+ undef $self->{key};
+ undef $self->{iv};
+ $self->{passphrase} = shift;
+ }
+ $d;
+}
+
+sub cipher { shift->{cipher} }
+sub padding { shift->{padding} }
+sub keysize { shift->{keysize} }
+sub blocksize { shift->{blocksize} }
+sub pcbc { shift->{pcbc} }
+sub header_mode {shift->{header_mode} }
+sub legacy_hack { shift->{legacy_hack} }
+
+1;
+__END__
+
+=head1 NAME
+
+Crypt::CBC - Encrypt Data with Cipher Block Chaining Mode
+
+=head1 SYNOPSIS
+
+ use Crypt::CBC;
+ $cipher = Crypt::CBC->new( -key => 'my secret key',
+ -cipher => 'Blowfish'
+ );
+
+ $ciphertext = $cipher->encrypt("This data is hush hush");
+ $plaintext = $cipher->decrypt($ciphertext);
+
+ $cipher->start('encrypting');
+ open(F,"./BIG_FILE");
+ while (read(F,$buffer,1024)) {
+ print $cipher->crypt($buffer);
+ }
+ print $cipher->finish;
+
+ # do-it-yourself mode -- specify key, initialization vector yourself
+ $key = Crypt::CBC->random_bytes(8); # assuming a 8-byte block cipher
+ $iv = Crypt::CBC->random_bytes(8);
+ $cipher = Crypt::CBC->new(-literal_key => 1,
+ -key => $key,
+ -iv => $iv,
+ -header => 'none');
+
+ $ciphertext = $cipher->encrypt("This data is hush hush");
+ $plaintext = $cipher->decrypt($ciphertext);
+
+ # RANDOMIV-compatible mode
+ $cipher = Crypt::CBC->new(-key => 'Super Secret!'
+ -header => 'randomiv');
+
+
+=head1 DESCRIPTION
+
+This module is a Perl-only implementation of the cryptographic cipher
+block chaining mode (CBC). In combination with a block cipher such as
+DES or IDEA, you can encrypt and decrypt messages of arbitrarily long
+length. The encrypted messages are compatible with the encryption
+format used by the B package.
+
+To use this module, you will first create a Crypt::CBC cipher object
+with new(). At the time of cipher creation, you specify an encryption
+key to use and, optionally, a block encryption algorithm. You will
+then call the start() method to initialize the encryption or
+decryption process, crypt() to encrypt or decrypt one or more blocks
+of data, and lastly finish(), to pad and encrypt the final block. For
+your convenience, you can call the encrypt() and decrypt() methods to
+operate on a whole data value at once.
+
+=head2 new()
+
+ $cipher = Crypt::CBC->new( -key => 'my secret key',
+ -cipher => 'Blowfish',
+ );
+
+ # or (for compatibility with versions prior to 2.13)
+ $cipher = Crypt::CBC->new( {
+ key => 'my secret key',
+ cipher => 'Blowfish'
+ }
+ );
+
+
+ # or (for compatibility with versions prior to 2.0)
+ $cipher = new Crypt::CBC('my secret key' => 'Blowfish');
+
+The new() method creates a new Crypt::CBC object. It accepts a list of
+-argument => value pairs selected from the following list:
+
+ Argument Description
+ -------- -----------
+
+ -key The encryption/decryption key (required)
+
+ -cipher The cipher algorithm (defaults to Crypt::DES), or
+ a preexisting cipher object.
+
+ -salt Enables OpenSSL-compatibility. If equal to a value
+ of "1" then causes a random salt to be generated
+ and used to derive the encryption key and IV. Other
+ true values are taken to be the literal salt.
+
+ -iv The initialization vector (IV)
+
+ -header What type of header to prepend to ciphertext. One of
+ 'salt' -- use OpenSSL-compatible salted header
+ 'randomiv' -- Randomiv-compatible "RandomIV" header
+ 'none' -- prepend no header at all
+
+ -padding The padding method, one of "standard" (default),
+ "space", "oneandzeroes", "rijndael_compat",
+ "null", or "none" (default "standard").
+
+ -literal_key If true, the key provided by "key" is used directly
+ for encryption/decryption. Otherwise the actual
+ key used will be a hash of the provided key.
+ (default false)
+
+ -pcbc Whether to use the PCBC chaining algorithm rather than
+ the standard CBC algorithm (default false).
+
+ -keysize Force the cipher keysize to the indicated number of bytes.
+
+ -blocksize Force the cipher blocksize to the indicated number of bytes.
+
+ -insecure_legacy_decrypt
+ Allow decryption of data encrypted using the "RandomIV" header
+ produced by pre-2.17 versions of Crypt::CBC.
+
+ -add_header [deprecated; use -header instread]
+ Whether to add the salt and IV to the header of the output
+ cipher text.
+
+ -regenerate_key [deprecated; use literal_key instead]
+ Whether to use a hash of the provided key to generate
+ the actual encryption key (default true)
+
+ -prepend_iv [deprecated; use add_header instead]
+ Whether to prepend the IV to the beginning of the
+ encrypted stream (default true)
+
+Crypt::CBC requires three pieces of information to do its job. First
+it needs the name of the block cipher algorithm that will encrypt or
+decrypt the data in blocks of fixed length known as the cipher's
+"blocksize." Second, it needs an encryption/decryption key to pass to
+the block cipher. Third, it needs an initialization vector (IV) that
+will be used to propagate information from one encrypted block to the
+next. Both the key and the IV must be exactly the same length as the
+chosen cipher's blocksize.
+
+Crypt::CBC can derive the key and the IV from a passphrase that you
+provide, or can let you specify the true key and IV manually. In
+addition, you have the option of embedding enough information to
+regenerate the IV in a short header that is emitted at the start of
+the encrypted stream, or outputting a headerless encryption stream. In
+the first case, Crypt::CBC will be able to decrypt the stream given
+just the original key or passphrase. In the second case, you will have
+to provide the original IV as well as the key/passphrase.
+
+The B<-cipher> option specifies which block cipher algorithm to use to
+encode each section of the message. This argument is optional and
+will default to the quick-but-not-very-secure DES algorithm unless
+specified otherwise. You may use any compatible block encryption
+algorithm that you have installed. Currently, this includes
+Crypt::DES, Crypt::DES_EDE3, Crypt::IDEA, Crypt::Blowfish,
+Crypt::CAST5 and Crypt::Rijndael. You may refer to them using their
+full names ("Crypt::IDEA") or in abbreviated form ("IDEA").
+
+Instead of passing the name of a cipher class, you may pass an
+already-created block cipher object. This allows you to take advantage
+of cipher algorithms that have parameterized new() methods, such as
+Crypt::Eksblowfish:
+
+ my $eksblowfish = Crypt::Eksblowfish->new(8,$salt,$key);
+ my $cbc = Crypt::CBC->new(-cipher=>$eksblowfish);
+
+The B<-key> argument provides either a passphrase to use to generate
+the encryption key, or the literal value of the block cipher key. If
+used in passphrase mode (which is the default), B<-key> can be any
+number of characters; the actual key will be derived by passing the
+passphrase through a series of MD5 hash operations. To take full
+advantage of a given block cipher, the length of the passphrase should
+be at least equal to the cipher's blocksize. To skip this hashing
+operation and specify the key directly, pass a true value to the
+B<-literal_key> option. In this case, you should choose a key of
+length exactly equal to the cipher's key length. You should also
+specify the IV yourself and a -header mode of 'none'.
+
+If you pass an existing Crypt::* object to new(), then the -key
+argument is ignored and the module will generate a warning.
+
+The B<-header> argument specifies what type of header, if any, to
+prepend to the beginning of the encrypted data stream. The header
+allows Crypt::CBC to regenerate the original IV and correctly decrypt
+the data without your having to provide the same IV used to encrypt
+the data. Valid values for the B<-header> are:
+
+ "salt" -- Combine the passphrase with an 8-byte random value to
+ generate both the block cipher key and the IV from the
+ provided passphrase. The salt will be appended to the
+ beginning of the data stream allowing decryption to
+ regenerate both the key and IV given the correct passphrase.
+ This method is compatible with current versions of OpenSSL.
+
+ "randomiv" -- Generate the block cipher key from the passphrase, and
+ choose a random 8-byte value to use as the IV. The IV will
+ be prepended to the data stream. This method is compatible
+ with ciphertext produced by versions of the library prior to
+ 2.17, but is incompatible with block ciphers that have non
+ 8-byte block sizes, such as Rijndael. Crypt::CBC will exit
+ with a fatal error if you try to use this header mode with a
+ non 8-byte cipher.
+
+ "none" -- Do not generate a header. To decrypt a stream encrypted
+ in this way, you will have to provide the original IV
+ manually.
+
+B
+
+When using a "salt" header, you may specify your own value of the
+salt, by passing the desired 8-byte salt to the B<-salt>
+argument. Otherwise, the module will generate a random salt for
+you. Crypt::CBC will generate a fatal error if you specify a salt
+value that isn't exactly 8 bytes long. For backward compatibility
+reasons, passing a value of "1" will generate a random salt, the same
+as if no B<-salt> argument was provided.
+
+The B<-padding> argument controls how the last few bytes of the
+encrypted stream are dealt with when they not an exact multiple of the
+cipher block length. The default is "standard", the method specified
+in PKCS#5.
+
+The B<-pcbc> argument, if true, activates a modified chaining mode
+known as PCBC. It provides better error propagation characteristics
+than the default CBC encryption and is required for authenticating to
+Kerberos4 systems (see RFC 2222).
+
+The B<-keysize> and B<-blocksize> arguments can be used to force the
+cipher's keysize and/or blocksize. This is only currently useful for
+the Crypt::Blowfish module, which accepts a variable length
+keysize. If -keysize is not specified, then Crypt::CBC will use the
+maximum length Blowfish key size of 56 bytes (448 bits). The Openssl
+library defaults to 16 byte Blowfish key sizes, so for compatibility
+with Openssl you may wish to set -keysize=>16. There are currently no
+Crypt::* modules that have variable block sizes, but an option to
+change the block size is provided just in case.
+
+For compatibility with earlier versions of this module, you can
+provide new() with a hashref containing key/value pairs. The key names
+are the same as the arguments described earlier, but without the
+initial hyphen. You may also call new() with one or two positional
+arguments, in which case the first argument is taken to be the key and
+the second to be the optional block cipher algorithm.
+
+B Versions of this module prior to 2.17 were
+incorrectly using 8-byte IVs when generating the "randomiv" style of
+header, even when the chosen cipher's blocksize was greater than 8
+bytes. This primarily affects the Rijndael algorithm. Such encrypted
+data streams were B. From versions 2.17 onward, Crypt::CBC
+will refuse to encrypt or decrypt using the "randomiv" header and non-8
+byte block ciphers. To decrypt legacy data encrypted with earlier
+versions of the module, you can override the check using the
+B<-insecure_legacy_decrypt> option. It is not possible to override
+encryption. Please use the default "salt" header style, or no headers
+at all.
+
+=head2 start()
+
+ $cipher->start('encrypting');
+ $cipher->start('decrypting');
+
+The start() method prepares the cipher for a series of encryption or
+decryption steps, resetting the internal state of the cipher if
+necessary. You must provide a string indicating whether you wish to
+encrypt or decrypt. "E" or any word that begins with an "e" indicates
+encryption. "D" or any word that begins with a "d" indicates
+decryption.
+
+=head2 crypt()
+
+ $ciphertext = $cipher->crypt($plaintext);
+
+After calling start(), you should call crypt() as many times as
+necessary to encrypt the desired data.
+
+=head2 finish()
+
+ $ciphertext = $cipher->finish();
+
+The CBC algorithm must buffer data blocks internally until they are
+even multiples of the encryption algorithm's blocksize (typically 8
+bytes). After the last call to crypt() you should call finish().
+This flushes the internal buffer and returns any leftover ciphertext.
+
+In a typical application you will read the plaintext from a file or
+input stream and write the result to standard output in a loop that
+might look like this:
+
+ $cipher = new Crypt::CBC('hey jude!');
+ $cipher->start('encrypting');
+ print $cipher->crypt($_) while <>;
+ print $cipher->finish();
+
+=head2 encrypt()
+
+ $ciphertext = $cipher->encrypt($plaintext)
+
+This convenience function runs the entire sequence of start(), crypt()
+and finish() for you, processing the provided plaintext and returning
+the corresponding ciphertext.
+
+=head2 decrypt()
+
+ $plaintext = $cipher->decrypt($ciphertext)
+
+This convenience function runs the entire sequence of start(), crypt()
+and finish() for you, processing the provided ciphertext and returning
+the corresponding plaintext.
+
+=head2 encrypt_hex(), decrypt_hex()
+
+ $ciphertext = $cipher->encrypt_hex($plaintext)
+ $plaintext = $cipher->decrypt_hex($ciphertext)
+
+These are convenience functions that operate on ciphertext in a
+hexadecimal representation. B is exactly
+equivalent to B. These functions
+can be useful if, for example, you wish to place the encrypted in an
+email message.
+
+=head2 get_initialization_vector()
+
+ $iv = $cipher->get_initialization_vector()
+
+This function will return the IV used in encryption and or decryption.
+The IV is not guaranteed to be set when encrypting until start() is
+called, and when decrypting until crypt() is called the first
+time. Unless the IV was manually specified in the new() call, the IV
+will change with every complete encryption operation.
+
+=head2 set_initialization_vector()
+
+ $cipher->set_initialization_vector('76543210')
+
+This function sets the IV used in encryption and/or decryption. This
+function may be useful if the IV is not contained within the
+ciphertext string being decrypted, or if a particular IV is desired
+for encryption. Note that the IV must match the chosen cipher's
+blocksize bytes in length.
+
+=head2 iv()
+
+ $iv = $cipher->iv();
+ $cipher->iv($new_iv);
+
+As above, but using a single method call.
+
+=head2 key()
+
+ $key = $cipher->key();
+ $cipher->key($new_key);
+
+Get or set the block cipher key used for encryption/decryption. When
+encrypting, the key is not guaranteed to exist until start() is
+called, and when decrypting, the key is not guaranteed to exist until
+after the first call to crypt(). The key must match the length
+required by the underlying block cipher.
+
+When salted headers are used, the block cipher key will change after
+each complete sequence of encryption operations.
+
+=head2 salt()
+
+ $salt = $cipher->salt();
+ $cipher->salt($new_salt);
+
+Get or set the salt used for deriving the encryption key and IV when
+in OpenSSL compatibility mode.
+
+=head2 passphrase()
+
+ $passphrase = $cipher->passphrase();
+ $cipher->passphrase($new_passphrase);
+
+This gets or sets the value of the B passed to new() when
+B is false.
+
+=head2 $data = random_bytes($numbytes)
+
+Return $numbytes worth of random data. On systems that support the
+"/dev/urandom" device file, this data will be read from the
+device. Otherwise, it will be generated by repeated calls to the Perl
+rand() function.
+
+=head2 cipher(), padding(), keysize(), blocksize(), pcbc()
+
+These read-only methods return the identity of the chosen block cipher
+algorithm, padding method, key and block size of the chosen block
+cipher, and whether PCBC chaining is in effect.
+
+=head2 Padding methods
+
+Use the 'padding' option to change the padding method.
+
+When the last block of plaintext is shorter than the block size,
+it must be padded. Padding methods include: "standard" (i.e., PKCS#5),
+"oneandzeroes", "space", "rijndael_compat", "null", and "none".
+
+ standard: (default) Binary safe
+ pads with the number of bytes that should be truncated. So, if
+ blocksize is 8, then "0A0B0C" will be padded with "05", resulting
+ in "0A0B0C0505050505". If the final block is a full block of 8
+ bytes, then a whole block of "0808080808080808" is appended.
+
+ oneandzeroes: Binary safe
+ pads with "80" followed by as many "00" necessary to fill the
+ block. If the last block is a full block and blocksize is 8, a
+ block of "8000000000000000" will be appended.
+
+ rijndael_compat: Binary safe, with caveats
+ similar to oneandzeroes, except that no padding is performed if
+ the last block is a full block. This is provided for
+ compatibility with Crypt::Rijndael only and can only be used
+ with messages that are a multiple of the Rijndael blocksize
+ of 16 bytes.
+
+ null: text only
+ pads with as many "00" necessary to fill the block. If the last
+ block is a full block and blocksize is 8, a block of
+ "0000000000000000" will be appended.
+
+ space: text only
+ same as "null", but with "20".
+
+ none:
+ no padding added. Useful for special-purpose applications where
+ you wish to add custom padding to the message.
+
+Both the standard and oneandzeroes paddings are binary safe. The
+space and null paddings are recommended only for text data. Which
+type of padding you use depends on whether you wish to communicate
+with an external (non Crypt::CBC library). If this is the case, use
+whatever padding method is compatible.
+
+You can also pass in a custom padding function. To do this, create a
+function that takes the arguments:
+
+ $padded_block = function($block,$blocksize,$direction);
+
+where $block is the current block of data, $blocksize is the size to
+pad it to, $direction is "e" for encrypting and "d" for decrypting,
+and $padded_block is the result after padding or depadding.
+
+When encrypting, the function should always return a string of
+ length, and when decrypting, can expect the string coming
+in to always be that length. See _standard_padding(), _space_padding(),
+_null_padding(), or _oneandzeroes_padding() in the source for examples.
+
+Standard and oneandzeroes padding are recommended, as both space and
+null padding can potentially truncate more characters than they should.
+
+=head1 EXAMPLES
+
+Two examples, des.pl and idea.pl can be found in the eg/ subdirectory
+of the Crypt-CBC distribution. These implement command-line DES and
+IDEA encryption algorithms.
+
+=head1 LIMITATIONS
+
+The encryption and decryption process is about a tenth the speed of
+the equivalent SSLeay programs (compiled C). This could be improved
+by implementing this module in C. It may also be worthwhile to
+optimize the DES and IDEA block algorithms further.
+
+=head1 BUGS
+
+Please report them.
+
+=head1 AUTHOR
+
+Lincoln Stein, lstein@cshl.org
+
+This module is distributed under the ARTISTIC LICENSE using the same
+terms as Perl itself.
+
+=head1 SEE ALSO
+
+perl(1), Crypt::DES(3), Crypt::IDEA(3), rfc2898 (PKCS#5)
+
+=cut
diff --git a/src/redux/HTTP/Tiny.pm b/src/redux/HTTP/Tiny.pm
new file mode 100644
index 000000000..541befe90
--- /dev/null
+++ b/src/redux/HTTP/Tiny.pm
@@ -0,0 +1,2425 @@
+# vim: ts=4 sts=4 sw=4 et:
+package HTTP::Tiny;
+use strict;
+use warnings;
+# ABSTRACT: A small, simple, correct HTTP/1.1 client
+
+our $VERSION = '0.070';
+
+sub _croak { require Carp; Carp::croak(@_) }
+
+#pod =method new
+#pod
+#pod $http = HTTP::Tiny->new( %attributes );
+#pod
+#pod This constructor returns a new HTTP::Tiny object. Valid attributes include:
+#pod
+#pod =for :list
+#pod * C — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If
+#pod C — ends in a space character, the default user-agent string is
+#pod appended.
+#pod * C — An instance of L — or equivalent class
+#pod that supports the C and C methods
+#pod * C — A hashref of default headers to apply to requests
+#pod * C — The local IP address to bind to
+#pod * C — Whether to reuse the last connection (if for the same
+#pod scheme, host and port) (defaults to 1)
+#pod * C — Maximum number of redirects allowed (defaults to 5)
+#pod * C — Maximum response size in bytes (only when not using a data
+#pod callback). If defined, responses larger than this will return an
+#pod exception.
+#pod * C — URL of a proxy server to use for HTTP connections
+#pod (default is C<$ENV{http_proxy}> — if set)
+#pod * C — URL of a proxy server to use for HTTPS connections
+#pod (default is C<$ENV{https_proxy}> — if set)
+#pod * C — URL of a generic proxy server for both HTTP and HTTPS
+#pod connections (default is C<$ENV{all_proxy}> — if set)
+#pod * C — List of domain suffixes that should not be proxied. Must
+#pod be a comma-separated string or an array reference. (default is
+#pod C<$ENV{no_proxy}> —)
+#pod * C — Request timeout in seconds (default is 60) If a socket open,
+#pod read or write takes longer than the timeout, an exception is thrown.
+#pod * C — A boolean that indicates whether to validate the SSL
+#pod certificate of an C — connection (default is false)
+#pod * C — A hashref of C — options to pass through to
+#pod L
+#pod
+#pod Passing an explicit C for C, C or C will
+#pod prevent getting the corresponding proxies from the environment.
+#pod
+#pod Exceptions from C, C or other errors will result in a
+#pod pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
+#pod content field in the response will contain the text of the exception.
+#pod
+#pod The C parameter enables a persistent connection, but only to a
+#pod single destination scheme, host and port. Also, if any connection-relevant
+#pod attributes are modified, or if the process ID or thread ID change, the
+#pod persistent connection will be dropped. If you want persistent connections
+#pod across multiple destinations, use multiple HTTP::Tiny objects.
+#pod
+#pod See L for more on the C and C attributes.
+#pod
+#pod =cut
+
+my @attributes;
+BEGIN {
+ @attributes = qw(
+ cookie_jar default_headers http_proxy https_proxy keep_alive
+ local_address max_redirect max_size proxy no_proxy
+ SSL_options verify_SSL
+ );
+ my %persist_ok = map {; $_ => 1 } qw(
+ cookie_jar default_headers max_redirect max_size
+ );
+ no strict 'refs';
+ no warnings 'uninitialized';
+ for my $accessor ( @attributes ) {
+ *{$accessor} = sub {
+ @_ > 1
+ ? do {
+ delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor};
+ $_[0]->{$accessor} = $_[1]
+ }
+ : $_[0]->{$accessor};
+ };
+ }
+}
+
+sub agent {
+ my($self, $agent) = @_;
+ if( @_ > 1 ){
+ $self->{agent} =
+ (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent;
+ }
+ return $self->{agent};
+}
+
+sub timeout {
+ my ($self, $timeout) = @_;
+ if ( @_ > 1 ) {
+ $self->{timeout} = $timeout;
+ if ($self->{handle}) {
+ $self->{handle}->timeout($timeout);
+ }
+ }
+ return $self->{timeout};
+}
+
+sub new {
+ my($class, %args) = @_;
+
+ my $self = {
+ max_redirect => 5,
+ timeout => defined $args{timeout} ? $args{timeout} : 60,
+ keep_alive => 1,
+ verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
+ no_proxy => $ENV{no_proxy},
+ };
+
+ bless $self, $class;
+
+ $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};
+
+ for my $key ( @attributes ) {
+ $self->{$key} = $args{$key} if exists $args{$key}
+ }
+
+ $self->agent( exists $args{agent} ? $args{agent} : $class->_agent );
+
+ $self->_set_proxies;
+
+ return $self;
+}
+
+sub _set_proxies {
+ my ($self) = @_;
+
+ # get proxies from %ENV only if not provided; explicit undef will disable
+ # getting proxies from the environment
+
+ # generic proxy
+ if (! exists $self->{proxy} ) {
+ $self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY};
+ }
+
+ if ( defined $self->{proxy} ) {
+ $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate
+ }
+ else {
+ delete $self->{proxy};
+ }
+
+ # http proxy
+ if (! exists $self->{http_proxy} ) {
+ # under CGI, bypass HTTP_PROXY as request sets it from Proxy header
+ local $ENV{HTTP_PROXY} if $ENV{REQUEST_METHOD};
+ $self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy};
+ }
+
+ if ( defined $self->{http_proxy} ) {
+ $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate
+ $self->{_has_proxy}{http} = 1;
+ }
+ else {
+ delete $self->{http_proxy};
+ }
+
+ # https proxy
+ if (! exists $self->{https_proxy} ) {
+ $self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy};
+ }
+
+ if ( $self->{https_proxy} ) {
+ $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate
+ $self->{_has_proxy}{https} = 1;
+ }
+ else {
+ delete $self->{https_proxy};
+ }
+
+ # Split no_proxy to array reference if not provided as such
+ unless ( ref $self->{no_proxy} eq 'ARRAY' ) {
+ $self->{no_proxy} =
+ (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : [];
+ }
+
+ return;
+}
+
+#pod =method get|head|put|post|delete
+#pod
+#pod $response = $http->get($url);
+#pod $response = $http->get($url, \%options);
+#pod $response = $http->head($url);
+#pod
+#pod These methods are shorthand for calling C for the given method. The
+#pod URL must have unsafe characters escaped and international domain names encoded.
+#pod See C for valid options and a description of the response.
+#pod
+#pod The C field of the response will be true if the status code is 2XX.
+#pod
+#pod =cut
+
+for my $sub_name ( qw/get head put post delete/ ) {
+ my $req_method = uc $sub_name;
+ no strict 'refs';
+ eval <<"HERE"; ## no critic
+ sub $sub_name {
+ my (\$self, \$url, \$args) = \@_;
+ \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
+ or _croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
+ return \$self->request('$req_method', \$url, \$args || {});
+ }
+HERE
+}
+
+#pod =method post_form
+#pod
+#pod $response = $http->post_form($url, $form_data);
+#pod $response = $http->post_form($url, $form_data, \%options);
+#pod
+#pod This method executes a C request and sends the key/value pairs from a
+#pod form data hash or array reference to the given URL with a C of
+#pod C. If data is provided as an array
+#pod reference, the order is preserved; if provided as a hash reference, the terms
+#pod are sorted on key and value for consistency. See documentation for the
+#pod C method for details on the encoding.
+#pod
+#pod The URL must have unsafe characters escaped and international domain names
+#pod encoded. See C for valid options and a description of the response.
+#pod Any C header or content in the options hashref will be ignored.
+#pod
+#pod The C field of the response will be true if the status code is 2XX.
+#pod
+#pod =cut
+
+sub post_form {
+ my ($self, $url, $data, $args) = @_;
+ (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
+ or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
+
+ my $headers = {};
+ while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
+ $headers->{lc $key} = $value;
+ }
+ delete $args->{headers};
+
+ return $self->request('POST', $url, {
+ %$args,
+ content => $self->www_form_urlencode($data),
+ headers => {
+ %$headers,
+ 'content-type' => 'application/x-www-form-urlencoded'
+ },
+ }
+ );
+}
+
+#pod =method mirror
+#pod
+#pod $response = $http->mirror($url, $file, \%options)
+#pod if ( $response->{success} ) {
+#pod print "$file is up to date\n";
+#pod }
+#pod
+#pod Executes a C request for the URL and saves the response body to the file
+#pod name provided. The URL must have unsafe characters escaped and international
+#pod domain names encoded. If the file already exists, the request will include an
+#pod C header with the modification timestamp of the file. You
+#pod may specify a different C header yourself in the C<<
+#pod $options->{headers} >> hash.
+#pod
+#pod The C field of the response will be true if the status code is 2XX
+#pod or if the status code is 304 (unmodified).
+#pod
+#pod If the file was modified and the server response includes a properly
+#pod formatted C header, the file modification time will
+#pod be updated accordingly.
+#pod
+#pod =cut
+
+sub mirror {
+ my ($self, $url, $file, $args) = @_;
+ @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
+ or _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
+
+ if ( exists $args->{headers} ) {
+ my $headers = {};
+ while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
+ $headers->{lc $key} = $value;
+ }
+ $args->{headers} = $headers;
+ }
+
+ if ( -e $file and my $mtime = (stat($file))[9] ) {
+ $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
+ }
+ my $tempfile = $file . int(rand(2**31));
+
+ require Fcntl;
+ sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
+ or _croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
+ binmode $fh;
+ $args->{data_callback} = sub { print {$fh} $_[0] };
+ my $response = $self->request('GET', $url, $args);
+ close $fh
+ or _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
+
+ if ( $response->{success} ) {
+ rename $tempfile, $file
+ or _croak(qq/Error replacing $file with $tempfile: $!\n/);
+ my $lm = $response->{headers}{'last-modified'};
+ if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
+ utime $mtime, $mtime, $file;
+ }
+ }
+ $response->{success} ||= $response->{status} eq '304';
+ unlink $tempfile;
+ return $response;
+}
+
+#pod =method request
+#pod
+#pod $response = $http->request($method, $url);
+#pod $response = $http->request($method, $url, \%options);
+#pod
+#pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
+#pod 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and
+#pod international domain names encoded.
+#pod
+#pod If the URL includes a "user:password" stanza, they will be used for Basic-style
+#pod authorization headers. (Authorization headers will not be included in a
+#pod redirected request.) For example:
+#pod
+#pod $http->request('GET', 'http://Aladdin:open sesame@example.com/');
+#pod
+#pod If the "user:password" stanza contains reserved characters, they must
+#pod be percent-escaped:
+#pod
+#pod $http->request('GET', 'http://john%40example.com:password@example.com/');
+#pod
+#pod A hashref of options may be appended to modify the request.
+#pod
+#pod Valid options are:
+#pod
+#pod =for :list
+#pod * C —
+#pod A hashref containing headers to include with the request. If the value for
+#pod a header is an array reference, the header will be output multiple times with
+#pod each value in the array. These headers over-write any default headers.
+#pod * C —
+#pod A scalar to include as the body of the request OR a code reference
+#pod that will be called iteratively to produce the body of the request
+#pod * C —
+#pod A code reference that will be called if it exists to provide a hashref
+#pod of trailing headers (only used with chunked transfer-encoding)
+#pod * C —
+#pod A code reference that will be called for each chunks of the response
+#pod body received.
+#pod * C —
+#pod Override host resolution and force all connections to go only to a
+#pod specific peer address, regardless of the URL of the request. This will
+#pod include any redirections! This options should be used with extreme
+#pod caution (e.g. debugging or very special circumstances).
+#pod
+#pod The C header is generated from the URL in accordance with RFC 2616. It
+#pod is a fatal error to specify C in the C option. Other headers
+#pod may be ignored or overwritten if necessary for transport compliance.
+#pod
+#pod If the C option is a code reference, it will be called iteratively
+#pod to provide the content body of the request. It should return the empty
+#pod string or undef when the iterator is exhausted.
+#pod
+#pod If the C option is the empty string, no C or
+#pod C headers will be generated.
+#pod
+#pod If the C option is provided, it will be called iteratively until
+#pod the entire response body is received. The first argument will be a string
+#pod containing a chunk of the response body, the second argument will be the
+#pod in-progress response hash reference, as described below. (This allows
+#pod customizing the action of the callback based on the C or C
+#pod received prior to the content body.)
+#pod
+#pod The C method returns a hashref containing the response. The hashref
+#pod will have the following keys:
+#pod
+#pod =for :list
+#pod * C —
+#pod Boolean indicating whether the operation returned a 2XX status code
+#pod * C —
+#pod URL that provided the response. This is the URL of the request unless
+#pod there were redirections, in which case it is the last URL queried
+#pod in a redirection chain
+#pod * C —
+#pod The HTTP status code of the response
+#pod * C —
+#pod The response phrase returned by the server
+#pod * C —
+#pod The body of the response. If the response does not have any content
+#pod or if a data callback is provided to consume the response body,
+#pod this will be the empty string
+#pod * C —
+#pod A hashref of header fields. All header field names will be normalized
+#pod to be lower case. If a header is repeated, the value will be an arrayref;
+#pod it will otherwise be a scalar string containing the value
+#pod * C
+#pod If this field exists, it is an arrayref of response hash references from
+#pod redirects in the same order that redirections occurred. If it does
+#pod not exist, then no redirections occurred.
+#pod
+#pod On an exception during the execution of the request, the C field will
+#pod contain 599, and the C field will contain the text of the exception.
+#pod
+#pod =cut
+
+my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
+
+sub request {
+ my ($self, $method, $url, $args) = @_;
+ @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
+ or _croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
+ $args ||= {}; # we keep some state in this during _request
+
+ # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
+ my $response;
+ for ( 0 .. 1 ) {
+ $response = eval { $self->_request($method, $url, $args) };
+ last unless $@ && $idempotent{$method}
+ && $@ =~ m{^(?:Socket closed|Unexpected end)};
+ }
+
+ if (my $e = $@) {
+ # maybe we got a response hash thrown from somewhere deep
+ if ( ref $e eq 'HASH' && exists $e->{status} ) {
+ $e->{redirects} = delete $args->{_redirects} if @{ $args->{_redirects} || []};
+ return $e;
+ }
+
+ # otherwise, stringify it
+ $e = "$e";
+ $response = {
+ url => $url,
+ success => q{},
+ status => 599,
+ reason => 'Internal Exception',
+ content => $e,
+ headers => {
+ 'content-type' => 'text/plain',
+ 'content-length' => length $e,
+ },
+ ( @{$args->{_redirects} || []} ? (redirects => delete $args->{_redirects}) : () ),
+ };
+ }
+ return $response;
+}
+
+#pod =method www_form_urlencode
+#pod
+#pod $params = $http->www_form_urlencode( $data );
+#pod $response = $http->get("http://example.com/query?$params");
+#pod
+#pod This method converts the key/value pairs from a data hash or array reference
+#pod into a C string. The keys and values from the data
+#pod reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
+#pod array reference, the key will be repeated with each of the values of the array
+#pod reference. If data is provided as a hash reference, the key/value pairs in the
+#pod resulting string will be sorted by key and value for consistent ordering.
+#pod
+#pod =cut
+
+sub www_form_urlencode {
+ my ($self, $data) = @_;
+ (@_ == 2 && ref $data)
+ or _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
+ (ref $data eq 'HASH' || ref $data eq 'ARRAY')
+ or _croak("form data must be a hash or array reference\n");
+
+ my @params = ref $data eq 'HASH' ? %$data : @$data;
+ @params % 2 == 0
+ or _croak("form data reference must have an even number of terms\n");
+
+ my @terms;
+ while( @params ) {
+ my ($key, $value) = splice(@params, 0, 2);
+ if ( ref $value eq 'ARRAY' ) {
+ unshift @params, map { $key => $_ } @$value;
+ }
+ else {
+ push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
+ }
+ }
+
+ return join("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) );
+}
+
+#pod =method can_ssl
+#pod
+#pod $ok = HTTP::Tiny->can_ssl;
+#pod ($ok, $why) = HTTP::Tiny->can_ssl;
+#pod ($ok, $why) = $http->can_ssl;
+#pod
+#pod Indicates if SSL support is available. When called as a class object, it
+#pod checks for the correct version of L and L.
+#pod When called as an object methods, if C is true or if C
+#pod is set in C, it checks that a CA file is available.
+#pod
+#pod In scalar context, returns a boolean indicating if SSL is available.
+#pod In list context, returns the boolean and a (possibly multi-line) string of
+#pod errors indicating why SSL isn't available.
+#pod
+#pod =cut
+
+sub can_ssl {
+ my ($self) = @_;
+
+ my($ok, $reason) = (1, '');
+
+ # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ unless (eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}) {
+ $ok = 0;
+ $reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/;
+ }
+
+ # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY
+ unless (eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}) {
+ $ok = 0;
+ $reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/;
+ }
+
+ # If an object, check that SSL config lets us get a CA if necessary
+ if ( ref($self) && ( $self->{verify_SSL} || $self->{SSL_options}{SSL_verify_mode} ) ) {
+ my $handle = HTTP::Tiny::Handle->new(
+ SSL_options => $self->{SSL_options},
+ verify_SSL => $self->{verify_SSL},
+ );
+ unless ( eval { $handle->_find_CA_file; 1 } ) {
+ $ok = 0;
+ $reason .= "$@";
+ }
+ }
+
+ wantarray ? ($ok, $reason) : $ok;
+}
+
+#pod =method connected
+#pod
+#pod $host = $http->connected;
+#pod ($host, $port) = $http->connected;
+#pod
+#pod Indicates if a connection to a peer is being kept alive, per the C
+#pod option.
+#pod
+#pod In scalar context, returns the peer host and port, joined with a colon, or
+#pod C (if no peer is connected).
+#pod In list context, returns the peer host and port or an empty list (if no peer
+#pod is connected).
+#pod
+#pod B: This method cannot reliably be used to discover whether the remote
+#pod host has closed its end of the socket.
+#pod
+#pod =cut
+
+sub connected {
+ my ($self) = @_;
+
+ # If a socket exists...
+ if ($self->{handle} && $self->{handle}{fh}) {
+ my $socket = $self->{handle}{fh};
+
+ # ...and is connected, return the peer host and port.
+ if ($socket->connected) {
+ return wantarray
+ ? ($socket->peerhost, $socket->peerport)
+ : join(':', $socket->peerhost, $socket->peerport);
+ }
+ }
+ return;
+}
+
+#--------------------------------------------------------------------------#
+# private methods
+#--------------------------------------------------------------------------#
+
+my %DefaultPort = (
+ http => 80,
+ https => 443,
+);
+
+sub _agent {
+ my $class = ref($_[0]) || $_[0];
+ (my $default_agent = $class) =~ s{::}{-}g;
+ return $default_agent . "/" . $class->VERSION;
+}
+
+sub _request {
+ my ($self, $method, $url, $args) = @_;
+
+ my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url);
+
+ my $request = {
+ method => $method,
+ scheme => $scheme,
+ host => $host,
+ port => $port,
+ host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
+ uri => $path_query,
+ headers => {},
+ };
+
+ my $peer = $args->{peer} || $host;
+
+ # We remove the cached handle so it is not reused in the case of redirect.
+ # If all is well, it will be recached at the end of _request. We only
+ # reuse for the same scheme, host and port
+ my $handle = delete $self->{handle};
+ if ( $handle ) {
+ unless ( $handle->can_reuse( $scheme, $host, $port, $peer ) ) {
+ $handle->close;
+ undef $handle;
+ }
+ }
+ $handle ||= $self->_open_handle( $request, $scheme, $host, $port, $peer );
+
+ $self->_prepare_headers_and_cb($request, $args, $url, $auth);
+ $handle->write_request($request);
+
+ my $response;
+ do { $response = $handle->read_response_header }
+ until (substr($response->{status},0,1) ne '1');
+
+ $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
+ my @redir_args = $self->_maybe_redirect($request, $response, $args);
+
+ my $known_message_length;
+ if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
+ # response has no message body
+ $known_message_length = 1;
+ }
+ else {
+ # Ignore any data callbacks during redirection.
+ my $cb_args = @redir_args ? +{} : $args;
+ my $data_cb = $self->_prepare_data_cb($response, $cb_args);
+ $known_message_length = $handle->read_body($data_cb, $response);
+ }
+
+ if ( $self->{keep_alive}
+ && $known_message_length
+ && $response->{protocol} eq 'HTTP/1.1'
+ && ($response->{headers}{connection} || '') ne 'close'
+ ) {
+ $self->{handle} = $handle;
+ }
+ else {
+ $handle->close;
+ }
+
+ $response->{success} = substr( $response->{status}, 0, 1 ) eq '2';
+ $response->{url} = $url;
+
+ # Push the current response onto the stack of redirects if redirecting.
+ if (@redir_args) {
+ push @{$args->{_redirects}}, $response;
+ return $self->_request(@redir_args, $args);
+ }
+
+ # Copy the stack of redirects into the response before returning.
+ $response->{redirects} = delete $args->{_redirects}
+ if @{$args->{_redirects}};
+ return $response;
+}
+
+sub _open_handle {
+ my ($self, $request, $scheme, $host, $port, $peer) = @_;
+
+ my $handle = HTTP::Tiny::Handle->new(
+ timeout => $self->{timeout},
+ SSL_options => $self->{SSL_options},
+ verify_SSL => $self->{verify_SSL},
+ local_address => $self->{local_address},
+ keep_alive => $self->{keep_alive}
+ );
+
+ if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) {
+ return $self->_proxy_connect( $request, $handle );
+ }
+ else {
+ return $handle->connect($scheme, $host, $port, $peer);
+ }
+}
+
+sub _proxy_connect {
+ my ($self, $request, $handle) = @_;
+
+ my @proxy_vars;
+ if ( $request->{scheme} eq 'https' ) {
+ _croak(qq{No https_proxy defined}) unless $self->{https_proxy};
+ @proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} );
+ if ( $proxy_vars[0] eq 'https' ) {
+ _croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
+ }
+ }
+ else {
+ _croak(qq{No http_proxy defined}) unless $self->{http_proxy};
+ @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} );
+ }
+
+ my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars;
+
+ if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) {
+ $self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth );
+ }
+
+ $handle->connect($p_scheme, $p_host, $p_port, $p_host);
+
+ if ($request->{scheme} eq 'https') {
+ $self->_create_proxy_tunnel( $request, $handle );
+ }
+ else {
+ # non-tunneled proxy requires absolute URI
+ $request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}";
+ }
+
+ return $handle;
+}
+
+sub _split_proxy {
+ my ($self, $type, $proxy) = @_;
+
+ my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) };
+
+ unless(
+ defined($scheme) && length($scheme) && length($host) && length($port)
+ && $path_query eq '/'
+ ) {
+ _croak(qq{$type URL must be in format http[s]://[auth@]:/\n});
+ }
+
+ return ($scheme, $host, $port, $auth);
+}
+
+sub _create_proxy_tunnel {
+ my ($self, $request, $handle) = @_;
+
+ $handle->_assert_ssl;
+
+ my $agent = exists($request->{headers}{'user-agent'})
+ ? $request->{headers}{'user-agent'} : $self->{agent};
+
+ my $connect_request = {
+ method => 'CONNECT',
+ uri => "$request->{host}:$request->{port}",
+ headers => {
+ host => "$request->{host}:$request->{port}",
+ 'user-agent' => $agent,
+ }
+ };
+
+ if ( $request->{headers}{'proxy-authorization'} ) {
+ $connect_request->{headers}{'proxy-authorization'} =
+ delete $request->{headers}{'proxy-authorization'};
+ }
+
+ $handle->write_request($connect_request);
+ my $response;
+ do { $response = $handle->read_response_header }
+ until (substr($response->{status},0,1) ne '1');
+
+ # if CONNECT failed, throw the response so it will be
+ # returned from the original request() method;
+ unless (substr($response->{status},0,1) eq '2') {
+ die $response;
+ }
+
+ # tunnel established, so start SSL handshake
+ $handle->start_ssl( $request->{host} );
+
+ return;
+}
+
+sub _prepare_headers_and_cb {
+ my ($self, $request, $args, $url, $auth) = @_;
+
+ for ($self->{default_headers}, $args->{headers}) {
+ next unless defined;
+ while (my ($k, $v) = each %$_) {
+ $request->{headers}{lc $k} = $v;
+ $request->{header_case}{lc $k} = $k;
+ }
+ }
+
+ if (exists $request->{headers}{'host'}) {
+ die(qq/The 'Host' header must not be provided as header option\n/);
+ }
+
+ $request->{headers}{'host'} = $request->{host_port};
+ $request->{headers}{'user-agent'} ||= $self->{agent};
+ $request->{headers}{'connection'} = "close"
+ unless $self->{keep_alive};
+
+ if ( defined $args->{content} ) {
+ if (ref $args->{content} eq 'CODE') {
+ $request->{headers}{'content-type'} ||= "application/octet-stream";
+ $request->{headers}{'transfer-encoding'} = 'chunked'
+ unless $request->{headers}{'content-length'}
+ || $request->{headers}{'transfer-encoding'};
+ $request->{cb} = $args->{content};
+ }
+ elsif ( length $args->{content} ) {
+ my $content = $args->{content};
+ if ( $] ge '5.008' ) {
+ utf8::downgrade($content, 1)
+ or die(qq/Wide character in request message body\n/);
+ }
+ $request->{headers}{'content-type'} ||= "application/octet-stream";
+ $request->{headers}{'content-length'} = length $content
+ unless $request->{headers}{'content-length'}
+ || $request->{headers}{'transfer-encoding'};
+ $request->{cb} = sub { substr $content, 0, length $content, '' };
+ }
+ $request->{trailer_cb} = $args->{trailer_callback}
+ if ref $args->{trailer_callback} eq 'CODE';
+ }
+
+ ### If we have a cookie jar, then maybe add relevant cookies
+ if ( $self->{cookie_jar} ) {
+ my $cookies = $self->cookie_jar->cookie_header( $url );
+ $request->{headers}{cookie} = $cookies if length $cookies;
+ }
+
+ # if we have Basic auth parameters, add them
+ if ( length $auth && ! defined $request->{headers}{authorization} ) {
+ $self->_add_basic_auth_header( $request, 'authorization' => $auth );
+ }
+
+ return;
+}
+
+sub _add_basic_auth_header {
+ my ($self, $request, $header, $auth) = @_;
+ require MIME::Base64;
+ $request->{headers}{$header} =
+ "Basic " . MIME::Base64::encode_base64($auth, "");
+ return;
+}
+
+sub _prepare_data_cb {
+ my ($self, $response, $args) = @_;
+ my $data_cb = $args->{data_callback};
+ $response->{content} = '';
+
+ if (!$data_cb || $response->{status} !~ /^2/) {
+ if (defined $self->{max_size}) {
+ $data_cb = sub {
+ $_[1]->{content} .= $_[0];
+ die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
+ if length $_[1]->{content} > $self->{max_size};
+ };
+ }
+ else {
+ $data_cb = sub { $_[1]->{content} .= $_[0] };
+ }
+ }
+ return $data_cb;
+}
+
+sub _update_cookie_jar {
+ my ($self, $url, $response) = @_;
+
+ my $cookies = $response->{headers}->{'set-cookie'};
+ return unless defined $cookies;
+
+ my @cookies = ref $cookies ? @$cookies : $cookies;
+
+ $self->cookie_jar->add( $url, $_ ) for @cookies;
+
+ return;
+}
+
+sub _validate_cookie_jar {
+ my ($class, $jar) = @_;
+
+ # duck typing
+ for my $method ( qw/add cookie_header/ ) {
+ _croak(qq/Cookie jar must provide the '$method' method\n/)
+ unless ref($jar) && ref($jar)->can($method);
+ }
+
+ return;
+}
+
+sub _maybe_redirect {
+ my ($self, $request, $response, $args) = @_;
+ my $headers = $response->{headers};
+ my ($status, $method) = ($response->{status}, $request->{method});
+ $args->{_redirects} ||= [];
+
+ if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))
+ and $headers->{location}
+ and @{$args->{_redirects}} < $self->{max_redirect}
+ ) {
+ my $location = ($headers->{location} =~ /^\//)
+ ? "$request->{scheme}://$request->{host_port}$headers->{location}"
+ : $headers->{location} ;
+ return (($status eq '303' ? 'GET' : $method), $location);
+ }
+ return;
+}
+
+sub _split_url {
+ my $url = pop;
+
+ # URI regex adapted from the URI module
+ my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
+ or die(qq/Cannot parse URL: '$url'\n/);
+
+ $scheme = lc $scheme;
+ $path_query = "/$path_query" unless $path_query =~ m<\A/>;
+
+ my $auth = '';
+ if ( (my $i = index $host, '@') != -1 ) {
+ # user:pass@host
+ $auth = substr $host, 0, $i, ''; # take up to the @ for auth
+ substr $host, 0, 1, ''; # knock the @ off the host
+
+ # userinfo might be percent escaped, so recover real auth info
+ $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ }
+ my $port = $host =~ s/:(\d*)\z// && length $1 ? $1
+ : $scheme eq 'http' ? 80
+ : $scheme eq 'https' ? 443
+ : undef;
+
+ return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth);
+}
+
+# Date conversions adapted from HTTP::Date
+my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
+my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
+sub _http_date {
+ my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
+ return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
+ substr($DoW,$wday*4,3),
+ $mday, substr($MoY,$mon*4,3), $year+1900,
+ $hour, $min, $sec
+ );
+}
+
+sub _parse_http_date {
+ my ($self, $str) = @_;
+ require Time::Local;
+ my @tl_parts;
+ if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
+ @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
+ }
+ elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
+ @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
+ }
+ elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
+ @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
+ }
+ return eval {
+ my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
+ $t < 0 ? undef : $t;
+ };
+}
+
+# URI escaping adapted from URI::Escape
+# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
+# perl 5.6 ready UTF-8 encoding adapted from JSON::PP
+my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
+$escapes{' '}="+";
+my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
+
+sub _uri_escape {
+ my ($self, $str) = @_;
+ if ( $] ge '5.008' ) {
+ utf8::encode($str);
+ }
+ else {
+ $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
+ if ( length $str == do { use bytes; length $str } );
+ $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
+ }
+ $str =~ s/($unsafe_char)/$escapes{$1}/ge;
+ return $str;
+}
+
+package
+ HTTP::Tiny::Handle; # hide from PAUSE/indexers
+use strict;
+use warnings;
+
+use Errno qw[EINTR EPIPE];
+use IO::Socket qw[SOCK_STREAM];
+use Socket qw[SOL_SOCKET SO_KEEPALIVE];
+
+# PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old
+# behavior if someone is unable to boostrap CPAN from a new perl install; it is
+# not intended for general, per-client use and may be removed in the future
+my $SOCKET_CLASS =
+ $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' :
+ eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.25) } ? 'IO::Socket::IP' :
+ 'IO::Socket::INET';
+
+sub BUFSIZE () { 32768 } ## no critic
+
+my $Printable = sub {
+ local $_ = shift;
+ s/\r/\\r/g;
+ s/\n/\\n/g;
+ s/\t/\\t/g;
+ s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
+ $_;
+};
+
+my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
+my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x;
+
+sub new {
+ my ($class, %args) = @_;
+ return bless {
+ rbuf => '',
+ timeout => 60,
+ max_line_size => 16384,
+ max_header_lines => 64,
+ verify_SSL => 0,
+ SSL_options => {},
+ %args
+ }, $class;
+}
+
+sub timeout {
+ my ($self, $timeout) = @_;
+ if ( @_ > 1 ) {
+ $self->{timeout} = $timeout;
+ if ( $self->{fh} && $self->{fh}->can('timeout') ) {
+ $self->{fh}->timeout($timeout);
+ }
+ }
+ return $self->{timeout};
+}
+
+sub connect {
+ @_ == 5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ . "\n");
+ my ($self, $scheme, $host, $port, $peer) = @_;
+
+ if ( $scheme eq 'https' ) {
+ $self->_assert_ssl;
+ }
+ elsif ( $scheme ne 'http' ) {
+ die(qq/Unsupported URL scheme '$scheme'\n/);
+ }
+ $self->{fh} = $SOCKET_CLASS->new(
+ PeerHost => $peer,
+ PeerPort => $port,
+ $self->{local_address} ?
+ ( LocalAddr => $self->{local_address} ) : (),
+ Proto => 'tcp',
+ Type => SOCK_STREAM,
+ Timeout => $self->{timeout},
+ ) or die(qq/Could not connect to '$host:$port': $@\n/);
+
+ binmode($self->{fh})
+ or die(qq/Could not binmode() socket: '$!'\n/);
+
+ if ( $self->{keep_alive} ) {
+ unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) {
+ CORE::close($self->{fh});
+ die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/);
+ }
+ }
+
+ $self->start_ssl($host) if $scheme eq 'https';
+
+ $self->{scheme} = $scheme;
+ $self->{host} = $host;
+ $self->{peer} = $peer;
+ $self->{port} = $port;
+ $self->{pid} = $$;
+ $self->{tid} = _get_tid();
+
+ return $self;
+}
+
+sub start_ssl {
+ my ($self, $host) = @_;
+
+ # As this might be used via CONNECT after an SSL session
+ # to a proxy, we shut down any existing SSL before attempting
+ # the handshake
+ if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
+ unless ( $self->{fh}->stop_SSL ) {
+ my $ssl_err = IO::Socket::SSL->errstr;
+ die(qq/Error halting prior SSL connection: $ssl_err/);
+ }
+ }
+
+ my $ssl_args = $self->_ssl_args($host);
+ IO::Socket::SSL->start_SSL(
+ $self->{fh},
+ %$ssl_args,
+ SSL_create_ctx_callback => sub {
+ my $ctx = shift;
+ Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
+ },
+ );
+
+ unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
+ my $ssl_err = IO::Socket::SSL->errstr;
+ die(qq/SSL connection failed for $host: $ssl_err\n/);
+ }
+}
+
+sub close {
+ @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
+ my ($self) = @_;
+ CORE::close($self->{fh})
+ or die(qq/Could not close socket: '$!'\n/);
+}
+
+sub write {
+ @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
+ my ($self, $buf) = @_;
+
+ if ( $] ge '5.008' ) {
+ utf8::downgrade($buf, 1)
+ or die(qq/Wide character in write()\n/);
+ }
+
+ my $len = length $buf;
+ my $off = 0;
+
+ local $SIG{PIPE} = 'IGNORE';
+
+ while () {
+ $self->can_write
+ or die(qq/Timed out while waiting for socket to become ready for writing\n/);
+ my $r = syswrite($self->{fh}, $buf, $len, $off);
+ if (defined $r) {
+ $len -= $r;
+ $off += $r;
+ last unless $len > 0;
+ }
+ elsif ($! == EPIPE) {
+ die(qq/Socket closed by remote server: $!\n/);
+ }
+ elsif ($! != EINTR) {
+ if ($self->{fh}->can('errstr')){
+ my $err = $self->{fh}->errstr();
+ die (qq/Could not write to SSL socket: '$err'\n /);
+ }
+ else {
+ die(qq/Could not write to socket: '$!'\n/);
+ }
+
+ }
+ }
+ return $off;
+}
+
+sub read {
+ @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
+ my ($self, $len, $allow_partial) = @_;
+
+ my $buf = '';
+ my $got = length $self->{rbuf};
+
+ if ($got) {
+ my $take = ($got < $len) ? $got : $len;
+ $buf = substr($self->{rbuf}, 0, $take, '');
+ $len -= $take;
+ }
+
+ while ($len > 0) {
+ $self->can_read
+ or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
+ my $r = sysread($self->{fh}, $buf, $len, length $buf);
+ if (defined $r) {
+ last unless $r;
+ $len -= $r;
+ }
+ elsif ($! != EINTR) {
+ if ($self->{fh}->can('errstr')){
+ my $err = $self->{fh}->errstr();
+ die (qq/Could not read from SSL socket: '$err'\n /);
+ }
+ else {
+ die(qq/Could not read from socket: '$!'\n/);
+ }
+ }
+ }
+ if ($len && !$allow_partial) {
+ die(qq/Unexpected end of stream\n/);
+ }
+ return $buf;
+}
+
+sub readline {
+ @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
+ my ($self) = @_;
+
+ while () {
+ if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
+ return $1;
+ }
+ if (length $self->{rbuf} >= $self->{max_line_size}) {
+ die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
+ }
+ $self->can_read
+ or die(qq/Timed out while waiting for socket to become ready for reading\n/);
+ my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
+ if (defined $r) {
+ last unless $r;
+ }
+ elsif ($! != EINTR) {
+ if ($self->{fh}->can('errstr')){
+ my $err = $self->{fh}->errstr();
+ die (qq/Could not read from SSL socket: '$err'\n /);
+ }
+ else {
+ die(qq/Could not read from socket: '$!'\n/);
+ }
+ }
+ }
+ die(qq/Unexpected end of stream while looking for line\n/);
+}
+
+sub read_header_lines {
+ @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
+ my ($self, $headers) = @_;
+ $headers ||= {};
+ my $lines = 0;
+ my $val;
+
+ while () {
+ my $line = $self->readline;
+
+ if (++$lines >= $self->{max_header_lines}) {
+ die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
+ }
+ elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
+ my ($field_name) = lc $1;
+ if (exists $headers->{$field_name}) {
+ for ($headers->{$field_name}) {
+ $_ = [$_] unless ref $_ eq "ARRAY";
+ push @$_, $2;
+ $val = \$_->[-1];
+ }
+ }
+ else {
+ $val = \($headers->{$field_name} = $2);
+ }
+ }
+ elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
+ $val
+ or die(qq/Unexpected header continuation line\n/);
+ next unless length $1;
+ $$val .= ' ' if length $$val;
+ $$val .= $1;
+ }
+ elsif ($line =~ /\A \x0D?\x0A \z/x) {
+ last;
+ }
+ else {
+ die(q/Malformed header line: / . $Printable->($line) . "\n");
+ }
+ }
+ return $headers;
+}
+
+sub write_request {
+ @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
+ my($self, $request) = @_;
+ $self->write_request_header(@{$request}{qw/method uri headers header_case/});
+ $self->write_body($request) if $request->{cb};
+ return;
+}
+
+# Standard request header names/case from HTTP/1.1 RFCs
+my @rfc_request_headers = qw(
+ Accept Accept-Charset Accept-Encoding Accept-Language Authorization
+ Cache-Control Connection Content-Length Expect From Host
+ If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
+ Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer
+ Transfer-Encoding Upgrade User-Agent Via
+);
+
+my @other_request_headers = qw(
+ Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin
+ X-XSS-Protection
+);
+
+my %HeaderCase = map { lc($_) => $_ } @rfc_request_headers, @other_request_headers;
+
+# to avoid multiple small writes and hence nagle, you can pass the method line or anything else to
+# combine writes.
+sub write_header_lines {
+ (@_ >= 2 && @_ <= 4 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ . "\n");
+ my($self, $headers, $header_case, $prefix_data) = @_;
+ $header_case ||= {};
+
+ my $buf = (defined $prefix_data ? $prefix_data : '');
+
+ # Per RFC, control fields should be listed first
+ my %seen;
+ for my $k ( qw/host cache-control expect max-forwards pragma range te/ ) {
+ next unless exists $headers->{$k};
+ $seen{$k}++;
+ my $field_name = $HeaderCase{$k};
+ my $v = $headers->{$k};
+ for (ref $v eq 'ARRAY' ? @$v : $v) {
+ $_ = '' unless defined $_;
+ $buf .= "$field_name: $_\x0D\x0A";
+ }
+ }
+
+ # Other headers sent in arbitrary order
+ while (my ($k, $v) = each %$headers) {
+ my $field_name = lc $k;
+ next if $seen{$field_name};
+ if (exists $HeaderCase{$field_name}) {
+ $field_name = $HeaderCase{$field_name};
+ }
+ else {
+ if (exists $header_case->{$field_name}) {
+ $field_name = $header_case->{$field_name};
+ }
+ else {
+ $field_name =~ s/\b(\w)/\u$1/g;
+ }
+ $field_name =~ /\A $Token+ \z/xo
+ or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
+ $HeaderCase{lc $field_name} = $field_name;
+ }
+ for (ref $v eq 'ARRAY' ? @$v : $v) {
+ # unwrap a field value if pre-wrapped by user
+ s/\x0D?\x0A\s+/ /g;
+ die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n")
+ unless $_ eq '' || /\A $Field_Content \z/xo;
+ $_ = '' unless defined $_;
+ $buf .= "$field_name: $_\x0D\x0A";
+ }
+ }
+ $buf .= "\x0D\x0A";
+ return $self->write($buf);
+}
+
+# return value indicates whether message length was defined; this is generally
+# true unless there was no content-length header and we just read until EOF.
+# Other message length errors are thrown as exceptions
+sub read_body {
+ @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
+ my ($self, $cb, $response) = @_;
+ my $te = $response->{headers}{'transfer-encoding'} || '';
+ my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ;
+ return $chunked
+ ? $self->read_chunked_body($cb, $response)
+ : $self->read_content_body($cb, $response);
+}
+
+sub write_body {
+ @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
+ my ($self, $request) = @_;
+ if ($request->{headers}{'content-length'}) {
+ return $self->write_content_body($request);
+ }
+ else {
+ return $self->write_chunked_body($request);
+ }
+}
+
+sub read_content_body {
+ @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
+ my ($self, $cb, $response, $content_length) = @_;
+ $content_length ||= $response->{headers}{'content-length'};
+
+ if ( defined $content_length ) {
+ my $len = $content_length;
+ while ($len > 0) {
+ my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
+ $cb->($self->read($read, 0), $response);
+ $len -= $read;
+ }
+ return length($self->{rbuf}) == 0;
+ }
+
+ my $chunk;
+ $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
+
+ return;
+}
+
+sub write_content_body {
+ @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
+ my ($self, $request) = @_;
+
+ my ($len, $content_length) = (0, $request->{headers}{'content-length'});
+ while () {
+ my $data = $request->{cb}->();
+
+ defined $data && length $data
+ or last;
+
+ if ( $] ge '5.008' ) {
+ utf8::downgrade($data, 1)
+ or die(qq/Wide character in write_content()\n/);
+ }
+
+ $len += $self->write($data);
+ }
+
+ $len == $content_length
+ or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);
+
+ return $len;
+}
+
+sub read_chunked_body {
+ @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
+ my ($self, $cb, $response) = @_;
+
+ while () {
+ my $head = $self->readline;
+
+ $head =~ /\A ([A-Fa-f0-9]+)/x
+ or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
+
+ my $len = hex($1)
+ or last;
+
+ $self->read_content_body($cb, $response, $len);
+
+ $self->read(2) eq "\x0D\x0A"
+ or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
+ }
+ $self->read_header_lines($response->{headers});
+ return 1;
+}
+
+sub write_chunked_body {
+ @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
+ my ($self, $request) = @_;
+
+ my $len = 0;
+ while () {
+ my $data = $request->{cb}->();
+
+ defined $data && length $data
+ or last;
+
+ if ( $] ge '5.008' ) {
+ utf8::downgrade($data, 1)
+ or die(qq/Wide character in write_chunked_body()\n/);
+ }
+
+ $len += length $data;
+
+ my $chunk = sprintf '%X', length $data;
+ $chunk .= "\x0D\x0A";
+ $chunk .= $data;
+ $chunk .= "\x0D\x0A";
+
+ $self->write($chunk);
+ }
+ $self->write("0\x0D\x0A");
+ if ( ref $request->{trailer_cb} eq 'CODE' ) {
+ $self->write_header_lines($request->{trailer_cb}->())
+ }
+ else {
+ $self->write("\x0D\x0A");
+ }
+ return $len;
+}
+
+sub read_response_header {
+ @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
+ my ($self) = @_;
+
+ my $line = $self->readline;
+
+ $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
+ or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
+
+ my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
+
+ die (qq/Unsupported HTTP protocol: $protocol\n/)
+ unless $version =~ /0*1\.0*[01]/;
+
+ return {
+ status => $status,
+ reason => $reason,
+ headers => $self->read_header_lines,
+ protocol => $protocol,
+ };
+}
+
+sub write_request_header {
+ @_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n");
+ my ($self, $method, $request_uri, $headers, $header_case) = @_;
+
+ return $self->write_header_lines($headers, $header_case, "$method $request_uri HTTP/1.1\x0D\x0A");
+}
+
+sub _do_timeout {
+ my ($self, $type, $timeout) = @_;
+ $timeout = $self->{timeout}
+ unless defined $timeout && $timeout >= 0;
+
+ my $fd = fileno $self->{fh};
+ defined $fd && $fd >= 0
+ or die(qq/select(2): 'Bad file descriptor'\n/);
+
+ my $initial = time;
+ my $pending = $timeout;
+ my $nfound;
+
+ vec(my $fdset = '', $fd, 1) = 1;
+
+ while () {
+ $nfound = ($type eq 'read')
+ ? select($fdset, undef, undef, $pending)
+ : select(undef, $fdset, undef, $pending) ;
+ if ($nfound == -1) {
+ $! == EINTR
+ or die(qq/select(2): '$!'\n/);
+ redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
+ $nfound = 0;
+ }
+ last;
+ }
+ $! = 0;
+ return $nfound;
+}
+
+sub can_read {
+ @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
+ my $self = shift;
+ if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
+ return 1 if $self->{fh}->pending;
+ }
+ return $self->_do_timeout('read', @_)
+}
+
+sub can_write {
+ @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
+ my $self = shift;
+ return $self->_do_timeout('write', @_)
+}
+
+sub _assert_ssl {
+ my($ok, $reason) = HTTP::Tiny->can_ssl();
+ die $reason unless $ok;
+}
+
+sub can_reuse {
+ my ($self,$scheme,$host,$port,$peer) = @_;
+ return 0 if
+ $self->{pid} != $$
+ || $self->{tid} != _get_tid()
+ || length($self->{rbuf})
+ || $scheme ne $self->{scheme}
+ || $host ne $self->{host}
+ || $port ne $self->{port}
+ || $peer ne $self->{peer}
+ || eval { $self->can_read(0) }
+ || $@ ;
+ return 1;
+}
+
+# Try to find a CA bundle to validate the SSL cert,
+# prefer Mozilla::CA or fallback to a system file
+sub _find_CA_file {
+ my $self = shift();
+
+ my $ca_file =
+ defined( $self->{SSL_options}->{SSL_ca_file} )
+ ? $self->{SSL_options}->{SSL_ca_file}
+ : $ENV{SSL_CERT_FILE};
+
+ if ( defined $ca_file ) {
+ unless ( -r $ca_file ) {
+ die qq/SSL_ca_file '$ca_file' not found or not readable\n/;
+ }
+ return $ca_file;
+ }
+
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ return Mozilla::CA::SSL_ca_file()
+ if eval { require Mozilla::CA; 1 };
+
+ # cert list copied from golang src/crypto/x509/root_unix.go
+ foreach my $ca_bundle (
+ "/etc/ssl/certs/ca-certificates.crt", # Debian/Ubuntu/Gentoo etc.
+ "/etc/pki/tls/certs/ca-bundle.crt", # Fedora/RHEL
+ "/etc/ssl/ca-bundle.pem", # OpenSUSE
+ "/etc/openssl/certs/ca-certificates.crt", # NetBSD
+ "/etc/ssl/cert.pem", # OpenBSD
+ "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly
+ "/etc/pki/tls/cacert.pem", # OpenELEC
+ "/etc/certs/ca-certificates.crt", # Solaris 11.2+
+ ) {
+ return $ca_bundle if -e $ca_bundle;
+ }
+
+ die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
+ . qq/Try installing Mozilla::CA from CPAN\n/;
+}
+
+# for thread safety, we need to know thread id if threads are loaded
+sub _get_tid {
+ no warnings 'reserved'; # for 'threads'
+ return threads->can("tid") ? threads->tid : 0;
+}
+
+sub _ssl_args {
+ my ($self, $host) = @_;
+
+ my %ssl_args;
+
+ # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't
+ # added until IO::Socket::SSL 1.84
+ if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) {
+ $ssl_args{SSL_hostname} = $host, # Sane SNI support
+ }
+
+ if ($self->{verify_SSL}) {
+ $ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation
+ $ssl_args{SSL_verifycn_name} = $host; # set validation hostname
+ $ssl_args{SSL_verify_mode} = 0x01; # enable cert validation
+ $ssl_args{SSL_ca_file} = $self->_find_CA_file;
+ }
+ else {
+ $ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation
+ $ssl_args{SSL_verify_mode} = 0x00; # disable cert validation
+ }
+
+ # user options override settings from verify_SSL
+ for my $k ( keys %{$self->{SSL_options}} ) {
+ $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
+ }
+
+ return \%ssl_args;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+HTTP::Tiny - A small, simple, correct HTTP/1.1 client
+
+=head1 VERSION
+
+version 0.070
+
+=head1 SYNOPSIS
+
+ use HTTP::Tiny;
+
+ my $response = HTTP::Tiny->new->get('http://example.com/');
+
+ die "Failed!\n" unless $response->{success};
+
+ print "$response->{status} $response->{reason}\n";
+
+ while (my ($k, $v) = each %{$response->{headers}}) {
+ for (ref $v eq 'ARRAY' ? @$v : $v) {
+ print "$k: $_\n";
+ }
+ }
+
+ print $response->{content} if length $response->{content};
+
+=head1 DESCRIPTION
+
+This is a very simple HTTP/1.1 client, designed for doing simple
+requests without the overhead of a large framework like L.
+
+It is more correct and more complete than L. It supports
+proxies and redirection. It also correctly resumes after EINTR.
+
+If L 0.25 or later is installed, HTTP::Tiny will use it instead
+of L for transparent support for both IPv4 and IPv6.
+
+Cookie support requires L or an equivalent class.
+
+=head1 METHODS
+
+=head2 new
+
+ $http = HTTP::Tiny->new( %attributes );
+
+This constructor returns a new HTTP::Tiny object. Valid attributes include:
+
+=over 4
+
+=item *
+
+C — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C — ends in a space character, the default user-agent string is appended.
+
+=item *
+
+C — An instance of L — or equivalent class that supports the C and C methods
+
+=item *
+
+C — A hashref of default headers to apply to requests
+
+=item *
+
+C — The local IP address to bind to
+
+=item *
+
+C — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
+
+=item *
+
+C — Maximum number of redirects allowed (defaults to 5)
+
+=item *
+
+C — Maximum response size in bytes (only when not using a data callback). If defined, responses larger than this will return an exception.
+
+=item *
+
+C — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
+
+=item *
+
+C — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
+
+=item *
+
+C — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
+
+=item *
+
+C — List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —)
+
+=item *
+
+C — Request timeout in seconds (default is 60) If a socket open, read or write takes longer than the timeout, an exception is thrown.
+
+=item *
+
+C — A boolean that indicates whether to validate the SSL certificate of an C — connection (default is false)
+
+=item *
+
+C — A hashref of C — options to pass through to L
+
+=back
+
+Passing an explicit C for C, C or C will
+prevent getting the corresponding proxies from the environment.
+
+Exceptions from C, C or other errors will result in a
+pseudo-HTTP status code of 599 and a reason of "Internal Exception". The
+content field in the response will contain the text of the exception.
+
+The C parameter enables a persistent connection, but only to a
+single destination scheme, host and port. Also, if any connection-relevant
+attributes are modified, or if the process ID or thread ID change, the
+persistent connection will be dropped. If you want persistent connections
+across multiple destinations, use multiple HTTP::Tiny objects.
+
+See L for more on the C and C attributes.
+
+=head2 get|head|put|post|delete
+
+ $response = $http->get($url);
+ $response = $http->get($url, \%options);
+ $response = $http->head($url);
+
+These methods are shorthand for calling C for the given method. The
+URL must have unsafe characters escaped and international domain names encoded.
+See C for valid options and a description of the response.
+
+The C field of the response will be true if the status code is 2XX.
+
+=head2 post_form
+
+ $response = $http->post_form($url, $form_data);
+ $response = $http->post_form($url, $form_data, \%options);
+
+This method executes a C request and sends the key/value pairs from a
+form data hash or array reference to the given URL with a C of
+C. If data is provided as an array
+reference, the order is preserved; if provided as a hash reference, the terms
+are sorted on key and value for consistency. See documentation for the
+C method for details on the encoding.
+
+The URL must have unsafe characters escaped and international domain names
+encoded. See C for valid options and a description of the response.
+Any C header or content in the options hashref will be ignored.
+
+The C field of the response will be true if the status code is 2XX.
+
+=head2 mirror
+
+ $response = $http->mirror($url, $file, \%options)
+ if ( $response->{success} ) {
+ print "$file is up to date\n";
+ }
+
+Executes a C request for the URL and saves the response body to the file
+name provided. The URL must have unsafe characters escaped and international
+domain names encoded. If the file already exists, the request will include an
+C header with the modification timestamp of the file. You
+may specify a different C header yourself in the C<<
+$options->{headers} >> hash.
+
+The C field of the response will be true if the status code is 2XX
+or if the status code is 304 (unmodified).
+
+If the file was modified and the server response includes a properly
+formatted C header, the file modification time will
+be updated accordingly.
+
+=head2 request
+
+ $response = $http->request($method, $url);
+ $response = $http->request($method, $url, \%options);
+
+Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
+'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and
+international domain names encoded.
+
+If the URL includes a "user:password" stanza, they will be used for Basic-style
+authorization headers. (Authorization headers will not be included in a
+redirected request.) For example:
+
+ $http->request('GET', 'http://Aladdin:open sesame@example.com/');
+
+If the "user:password" stanza contains reserved characters, they must
+be percent-escaped:
+
+ $http->request('GET', 'http://john%40example.com:password@example.com/');
+
+A hashref of options may be appended to modify the request.
+
+Valid options are:
+
+=over 4
+
+=item *
+
+C — A hashref containing headers to include with the request. If the value for a header is an array reference, the header will be output multiple times with each value in the array. These headers over-write any default headers.
+
+=item *
+
+C — A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the request
+
+=item *
+
+C — A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding)
+
+=item *
+
+C — A code reference that will be called for each chunks of the response body received.
+
+=item *
+
+C — Override host resolution and force all connections to go only to a specific peer address, regardless of the URL of the request. This will include any redirections! This options should be used with extreme caution (e.g. debugging or very special circumstances).
+
+=back
+
+The C header is generated from the URL in accordance with RFC 2616. It
+is a fatal error to specify C in the C option. Other headers
+may be ignored or overwritten if necessary for transport compliance.
+
+If the C option is a code reference, it will be called iteratively
+to provide the content body of the request. It should return the empty
+string or undef when the iterator is exhausted.
+
+If the C option is the empty string, no C or
+C headers will be generated.
+
+If the C option is provided, it will be called iteratively until
+the entire response body is received. The first argument will be a string
+containing a chunk of the response body, the second argument will be the
+in-progress response hash reference, as described below. (This allows
+customizing the action of the callback based on the C or C
+received prior to the content body.)
+
+The C method returns a hashref containing the response. The hashref
+will have the following keys:
+
+=over 4
+
+=item *
+
+C — Boolean indicating whether the operation returned a 2XX status code
+
+=item *
+
+C — URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain
+
+=item *
+
+C — The HTTP status code of the response
+
+=item *
+
+C — The response phrase returned by the server
+
+=item *
+
+C — The body of the response. If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string
+
+=item *
+
+C — A hashref of header fields. All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value
+
+=item *
+
+C If this field exists, it is an arrayref of response hash references from redirects in the same order that redirections occurred. If it does not exist, then no redirections occurred.
+
+=back
+
+On an exception during the execution of the request, the C field will
+contain 599, and the C field will contain the text of the exception.
+
+=head2 www_form_urlencode
+
+ $params = $http->www_form_urlencode( $data );
+ $response = $http->get("http://example.com/query?$params");
+
+This method converts the key/value pairs from a data hash or array reference
+into a C string. The keys and values from the data
+reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
+array reference, the key will be repeated with each of the values of the array
+reference. If data is provided as a hash reference, the key/value pairs in the
+resulting string will be sorted by key and value for consistent ordering.
+
+=head2 can_ssl
+
+ $ok = HTTP::Tiny->can_ssl;
+ ($ok, $why) = HTTP::Tiny->can_ssl;
+ ($ok, $why) = $http->can_ssl;
+
+Indicates if SSL support is available. When called as a class object, it
+checks for the correct version of L and L.
+When called as an object methods, if C is true or if C
+is set in C, it checks that a CA file is available.
+
+In scalar context, returns a boolean indicating if SSL is available.
+In list context, returns the boolean and a (possibly multi-line) string of
+errors indicating why SSL isn't available.
+
+=head2 connected
+
+ $host = $http->connected;
+ ($host, $port) = $http->connected;
+
+Indicates if a connection to a peer is being kept alive, per the C
+option.
+
+In scalar context, returns the peer host and port, joined with a colon, or
+C (if no peer is connected).
+In list context, returns the peer host and port or an empty list (if no peer
+is connected).
+
+B: This method cannot reliably be used to discover whether the remote
+host has closed its end of the socket.
+
+=for Pod::Coverage SSL_options
+agent
+cookie_jar
+default_headers
+http_proxy
+https_proxy
+keep_alive
+local_address
+max_redirect
+max_size
+no_proxy
+proxy
+timeout
+verify_SSL
+
+=head1 SSL SUPPORT
+
+Direct C connections are supported only if L 1.56 or
+greater and L 1.49 or greater are installed. An exception will be
+thrown if new enough versions of these modules are not installed or if the SSL
+encryption fails. You can also use C utility function
+that returns boolean to see if the required modules are installed.
+
+An C connection may be made via an C proxy that supports the CONNECT
+command (i.e. RFC 2817). You may not proxy C via a proxy that itself
+requires C to communicate.
+
+SSL provides two distinct capabilities:
+
+=over 4
+
+=item *
+
+Encrypted communication channel
+
+=item *
+
+Verification of server identity
+
+=back
+
+B.
+
+Server identity verification is controversial and potentially tricky because it
+depends on a (usually paid) third-party Certificate Authority (CA) trust model
+to validate a certificate as legitimate. This discriminates against servers
+with self-signed certificates or certificates signed by free, community-driven
+CA's such as L.
+
+By default, HTTP::Tiny does not make any assumptions about your trust model,
+threat level or risk tolerance. It just aims to give you an encrypted channel
+when you need one.
+
+Setting the C attribute to a true value will make HTTP::Tiny verify
+that an SSL connection has a valid SSL certificate corresponding to the host
+name of the connection and that the SSL certificate has been verified by a CA.
+Assuming you trust the CA, this will protect against a L. If you are
+concerned about security, you should enable this option.
+
+Certificate verification requires a file containing trusted CA certificates.
+
+If the environment variable C is present, HTTP::Tiny
+will try to find a CA certificate file in that location.
+
+If the L module is installed, HTTP::Tiny will use the CA file
+included with it as a source of trusted CA's. (This means you trust Mozilla,
+the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the
+toolchain used to install it, and your operating system security, right?)
+
+If that module is not available, then HTTP::Tiny will search several
+system-specific default locations for a CA certificate file:
+
+=over 4
+
+=item *
+
+/etc/ssl/certs/ca-certificates.crt
+
+=item *
+
+/etc/pki/tls/certs/ca-bundle.crt
+
+=item *
+
+/etc/ssl/ca-bundle.pem
+
+=back
+
+An exception will be raised if C is true and no CA certificate file
+is available.
+
+If you desire complete control over SSL connections, the C attribute
+lets you provide a hash reference that will be passed through to
+C, overriding any options set by HTTP::Tiny. For
+example, to provide your own trusted CA file:
+
+ SSL_options => {
+ SSL_ca_file => $file_path,
+ }
+
+The C attribute could also be used for such things as providing a
+client certificate for authentication to a server or controlling the choice of
+cipher used for the SSL connection. See L documentation for
+details.
+
+=head1 PROXY SUPPORT
+
+HTTP::Tiny can proxy both C and C requests. Only Basic proxy
+authorization is supported and it must be provided as part of the proxy URL:
+C .
+
+HTTP::Tiny supports the following proxy environment variables:
+
+=over 4
+
+=item *
+
+http_proxy or HTTP_PROXY
+
+=item *
+
+https_proxy or HTTPS_PROXY
+
+=item *
+
+all_proxy or ALL_PROXY
+
+=back
+
+If the C environment variable is set, then this might be a CGI
+process and C would be set from the C header, which is a
+security risk. If C is set, C (the upper case
+variant only) is ignored.
+
+Tunnelling C over an C proxy using the CONNECT method is
+supported. If your proxy uses C itself, you can not tunnel C
+over it.
+
+Be warned that proxying an C connection opens you to the risk of a
+man-in-the-middle attack by the proxy server.
+
+The C environment variable is supported in the format of a
+comma-separated list of domain extensions proxy should not be used for.
+
+Proxy arguments passed to C will override their corresponding
+environment variables.
+
+=head1 LIMITATIONS
+
+HTTP::Tiny is I with the
+L :
+
+=over 4
+
+=item *
+
+"Message Syntax and Routing" [RFC7230]
+
+=item *
+
+"Semantics and Content" [RFC7231]
+
+=item *
+
+"Conditional Requests" [RFC7232]
+
+=item *
+
+"Range Requests" [RFC7233]
+
+=item *
+
+"Caching" [RFC7234]
+
+=item *
+
+"Authentication" [RFC7235]
+
+=back
+
+It attempts to meet all "MUST" requirements of the specification, but does not
+implement all "SHOULD" requirements. (Note: it was developed against the
+earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235
+spec.)
+
+Some particular limitations of note include:
+
+=over
+
+=item *
+
+HTTP::Tiny focuses on correct transport. Users are responsible for ensuring
+that user-defined headers and content are compliant with the HTTP/1.1
+specification.
+
+=item *
+
+Users must ensure that URLs are properly escaped for unsafe characters and that
+international domain names are properly encoded to ASCII. See L,
+L and L.
+
+=item *
+
+Redirection is very strict against the specification. Redirection is only
+automatic for response codes 301, 302, 307 and 308 if the request method is
+'GET' or 'HEAD'. Response code 303 is always converted into a 'GET'
+redirection, as mandated by the specification. There is no automatic support
+for status 305 ("Use proxy") redirections.
+
+=item *
+
+There is no provision for delaying a request body using an C header.
+Unexpected C<1XX> responses are silently ignored as per the specification.
+
+=item *
+
+Only 'chunked' C is supported.
+
+=item *
+
+There is no support for a Request-URI of '*' for the 'OPTIONS' request.
+
+=item *
+
+Headers mentioned in the RFCs and some other, well-known headers are
+generated with their canonical case. Other headers are sent in the
+case provided by the user. Except for control headers (which are sent first),
+headers are sent in arbitrary order.
+
+=back
+
+Despite the limitations listed above, HTTP::Tiny is considered
+feature-complete. New feature requests should be directed to
+L.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item *
+
+L - Higher level UA features for HTTP::Tiny
+
+=item *
+
+L - HTTP::Tiny wrapper with L/L compatibility
+
+=item *
+
+L - Wrap L instance in HTTP::Tiny compatible interface
+
+=item *
+
+L - Required for IPv6 support
+
+=item *
+
+L - Required for SSL support
+
+=item *
+
+L
\n/g; + print "$line
\n"; + } + } + print "