tyler.durden
/
pandorafms
mirror of https://github.com/pandorafms/pandorafms.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
pandorafms/pandora_server/lib/PandoraFMS/Tools.pm

1822 lines
48 KiB
Perl
Executable File
Raw Blame History

package PandoraFMS::Tools;
########################################################################
# Tools Package
# Pandora FMS. the Flexible Monitoring System. http://www.pandorafms.org
########################################################################
# Copyright (c) 2005-2011 Artica Soluciones Tecnologicas S.L
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public License
# as published by the Free Software Foundation; version 2
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
##########################################################################
use warnings;
use Time::Local;
use POSIX qw(setsid strftime);
use POSIX;
use PandoraFMS::Sendmail;
use HTML::Entities;
use Encode;
use Socket qw(inet_ntoa inet_aton);
use Sys::Syslog;
use Scalar::Util qw(looks_like_number);
use LWP::UserAgent;
use threads;
# New in 3.2. Used to sendmail internally, without external scripts
# use Module::Loaded;
# Used to calculate the MD5 checksum of a string
use constant MOD232 => 2**32;
# UTF-8 flags deletion from multibyte characters when files are opened.
use open OUT => ":utf8";
use open ":std";
require Exporter;
our @ISA = ("Exporter");
our %EXPORT_TAGS = ( 'all' => [ qw( ) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw(
DATASERVER
NETWORKSERVER
SNMPCONSOLE
RECONSERVER
PLUGINSERVER
PREDICTIONSERVER
WMISERVER
EXPORTSERVER
INVENTORYSERVER
WEBSERVER
EVENTSERVER
ICMPSERVER
SNMPSERVER
SATELLITESERVER
MFSERVER
TRANSACTIONALSERVER
SYNCSERVER
SYSLOGSERVER
WUXSERVER
PROVISIONINGSERVER
MIGRATIONSERVER
METACONSOLE_LICENSE
OFFLINE_LICENSE
$DEVNULL
$OS
$OS_VERSION
RECOVERED_ALERT
FIRED_ALERT
MODULE_NORMAL
MODULE_CRITICAL
MODULE_WARNING
MODULE_UNKNOWN
MODULE_NOTINIT
$THRRUN
api_call_url
cron_get_closest_in_range
cron_next_execution
cron_next_execution_date
cron_check_syntax
pandora_daemonize
logger
pandora_rotate_logfile
limpia_cadena
md5check
float_equal
sqlWrap
is_numeric
is_metaconsole
is_offline
to_number
clean_blank
pandora_sendmail
pandora_trash_ascii
enterprise_hook
enterprise_load
print_message
get_tag_value
disk_free
load_average
free_mem
md5
md5_init
pandora_ping
pandora_ping_latency
resolve_hostname
ticks_totime
safe_input
safe_output
month_have_days
translate_obj
valid_regex
set_file_permissions
uri_encode
check_server_threads
start_server_thread
stop_server_threads
);
# ID of the different servers
use constant DATASERVER => 0;
use constant NETWORKSERVER => 1;
use constant SNMPCONSOLE => 2;
use constant RECONSERVER => 3;
use constant PLUGINSERVER => 4;
use constant PREDICTIONSERVER => 5;
use constant WMISERVER => 6;
use constant EXPORTSERVER => 7;
use constant INVENTORYSERVER => 8;
use constant WEBSERVER => 9;
use constant EVENTSERVER => 10;
use constant ICMPSERVER => 11;
use constant SNMPSERVER => 12;
use constant SATELLITESERVER => 13;
use constant TRANSACTIONALSERVER => 14;
use constant MFSERVER => 15;
use constant SYNCSERVER => 16;
use constant WUXSERVER => 17;
use constant SYSLOGSERVER => 18;
use constant PROVISIONINGSERVER => 19;
use constant MIGRATIONSERVER => 20;
# Module status
use constant MODULE_NORMAL => 0;
use constant MODULE_CRITICAL => 1;
use constant MODULE_WARNING => 2;
use constant MODULE_UNKNOWN => 3;
use constant MODULE_NOTINIT => 4;
# Mask for a metaconsole license type
use constant METACONSOLE_LICENSE => 0x01;
# Mask for an offline license type
use constant OFFLINE_LICENSE => 0x02;
# Alert modes
use constant RECOVERED_ALERT => 0;
use constant FIRED_ALERT => 1;
# Set OS, OS version and /dev/null
our $OS = $^O;
our $OS_VERSION = "unknown";
our $DEVNULL = '/dev/null';
if ($OS eq 'linux') {
$OS_VERSION = `lsb_release -sd 2>/dev/null`;
} elsif ($OS eq 'aix') {
$OS_VERSION = "$2.$1" if (`uname -rv` =~ /\s*(\d)\s+(\d)\s*/);
} elsif ($OS =~ /win/i) {
$OS = "windows";
$OS_VERSION = `ver`;
$OS_VERSION =~ s/[^[:ascii:]]//g;
$DEVNULL = '/Nul';
} elsif ($OS eq 'freebsd') {
$OS_VERSION = `uname -r`;
}
chomp($OS_VERSION);
# Entity to character mapping. Contains a few tweaks to make it backward compatible with the previous safe_input implementation.
my %ENT2CHR = (
'#x00' => chr(0),
'#x01' => chr(1),
'#x02' => chr(2),
'#x03' => chr(3),
'#x04' => chr(4),
'#x05' => chr(5),
'#x06' => chr(6),
'#x07' => chr(7),
'#x08' => chr(8),
'#x09' => chr(9),
'#x0a' => chr(10),
'#x0b' => chr(11),
'#x0c' => chr(12),
'#x0d' => chr(13),
'#x0e' => chr(14),
'#x0f' => chr(15),
'#x10' => chr(16),
'#x11' => chr(17),
'#x12' => chr(18),
'#x13' => chr(19),
'#x14' => chr(20),
'#x15' => chr(21),
'#x16' => chr(22),
'#x17' => chr(23),
'#x18' => chr(24),
'#x19' => chr(25),
'#x1a' => chr(26),
'#x1b' => chr(27),
'#x1c' => chr(28),
'#x1d' => chr(29),
'#x1e' => chr(30),
'#x1f' => chr(31),
'#x20' => chr(32),
'quot' => chr(34),
'amp' => chr(38),
'#039' => chr(39),
'#40' => chr(40),
'#41' => chr(41),
'lt' => chr(60),
'gt' => chr(62),
'#92' => chr(92),
'#x80' => chr(128),
'#x81' => chr(129),
'#x82' => chr(130),
'#x83' => chr(131),
'#x84' => chr(132),
'#x85' => chr(133),
'#x86' => chr(134),
'#x87' => chr(135),
'#x88' => chr(136),
'#x89' => chr(137),
'#x8a' => chr(138),
'#x8b' => chr(139),
'#x8c' => chr(140),
'#x8d' => chr(141),
'#x8e' => chr(142),
'#x8f' => chr(143),
'#x90' => chr(144),
'#x91' => chr(145),
'#x92' => chr(146),
'#x93' => chr(147),
'#x94' => chr(148),
'#x95' => chr(149),
'#x96' => chr(150),
'#x97' => chr(151),
'#x98' => chr(152),
'#x99' => chr(153),
'#x9a' => chr(154),
'#x9b' => chr(155),
'#x9c' => chr(156),
'#x9d' => chr(157),
'#x9e' => chr(158),
'#x9f' => chr(159),
'#xa0' => chr(160),
'#xa1' => chr(161),
'#xa2' => chr(162),
'#xa3' => chr(163),
'#xa4' => chr(164),
'#xa5' => chr(165),
'#xa6' => chr(166),
'#xa7' => chr(167),
'#xa8' => chr(168),
'#xa9' => chr(169),
'#xaa' => chr(170),
'#xab' => chr(171),
'#xac' => chr(172),
'#xad' => chr(173),
'#xae' => chr(174),
'#xaf' => chr(175),
'#xb0' => chr(176),
'#xb1' => chr(177),
'#xb2' => chr(178),
'#xb3' => chr(179),
'#xb4' => chr(180),
'#xb5' => chr(181),
'#xb6' => chr(182),
'#xb7' => chr(183),
'#xb8' => chr(184),
'#xb9' => chr(185),
'#xba' => chr(186),
'#xbb' => chr(187),
'#xbc' => chr(188),
'#xbd' => chr(189),
'#xbe' => chr(190),
'Aacute' => chr(193),
'Auml' => chr(196),
'Eacute' => chr(201),
'Euml' => chr(203),
'Iacute' => chr(205),
'Iuml' => chr(207),
'Ntilde' => chr(209),
'Oacute' => chr(211),
'Ouml' => chr(214),
'Uacute' => chr(218),
'Uuml' => chr(220),
'aacute' => chr(225),
'auml' => chr(228),
'eacute' => chr(233),
'euml' => chr(235),
'iacute' => chr(237),
'iuml' => chr(239),
'ntilde' => chr(241),
'oacute' => chr(243),
'ouml' => chr(246),
'uacute' => chr(250),
'uuml' => chr(252),
);
# Construct the character to entity mapping.
my %CHR2ENT;
while (my ($ent, $chr) = each(%ENT2CHR)) {
$CHR2ENT{$chr} = "&" . $ent . ";";
}
# Threads started by the Pandora FMS Server.
my @ServerThreads;
# Keep threads running.
our $THRRUN :shared = 1;
###############################################################################
# Sets user:group owner for the given file
###############################################################################
sub set_file_permissions($$;$) {
my ($pa_config, $file, $grants) = @_;
if ($^O !~ /win/i ) { # Only for Linux environments
eval {
if (defined ($grants)) {
$grants = oct($grants);
}
else {
$grants = oct("0777");
}
my $uid = getpwnam($pa_config->{'user'});
my $gid = getgrnam($pa_config->{'group'});
my $perm = $grants & (~oct($pa_config->{'umask'}));
chown $uid, $gid, $file;
chmod ( $perm, $file );
};
if ($@) {
# Ignore error
}
}
}
########################################################################
## SUB pandora_trash_ascii
# Generate random ascii strings with variable lenght
########################################################################
sub pandora_trash_ascii {
my $config_depth = $_[0];
my $a;
my $output;
for ($a=0;$a<$config_depth;$a++){
$output = $output.chr(int(rand(25)+97));
}
return $output
}
########################################################################
## Convert the $value encode in html entity to clear char string.
########################################################################
sub safe_input($) {
my $value = shift;
return "" unless defined($value);
$value =~ s/([\x00-\xFF])/$CHR2ENT{$1}||$1/ge;
return $value;
}
########################################################################
## Convert the html entities to value encode to rebuild char string.
########################################################################
sub safe_output($) {
my $value = shift;
return "" unless defined($value);
_decode_entities ($value, \%ENT2CHR);
return $value;
}
########################################################################
# Sub daemonize ()
# Put program in background (for daemon mode)
########################################################################
sub pandora_daemonize {
my $pa_config = $_[0];
open STDIN, "$DEVNULL" or die "Can't read $DEVNULL: $!";
open STDOUT, ">>$DEVNULL" or die "Can't write to $DEVNULL: $!";
open STDERR, ">>$DEVNULL" or die "Can't write to $DEVNULL: $!";
chdir '/tmp' or die "Can't chdir to /tmp: $!";
defined(my $pid = fork) or die "Can't fork: $!";
exit if $pid;
setsid or die "Can't start a new session: $!";
# Store PID of this process in file presented by config token
if ($pa_config->{'PID'} ne "") {
if ( -e $pa_config->{'PID'} && open (FILE, $pa_config->{'PID'})) {
$pid = <FILE> + 0;
close FILE;
# check if pandora_server is running
if (kill (0, $pid)) {
die "[FATAL] " . pandora_get_initial_product_name() . " Server already running, pid: $pid.";
}
logger ($pa_config, '[W] Stale PID file, overwriting.', 1);
}
umask 0022;
open (FILE, "> ".$pa_config->{'PID'}) or die "[FATAL] Cannot open PIDfile at ".$pa_config->{'PID'};
print FILE "$$";
close (FILE);
}
umask 0007;
}
# -------------------------------------------+
# Pandora other General functions |
# -------------------------------------------+
########################################################################
# SUB pandora_sendmail
# Send a mail, connecting directly to MTA
# param1 - config hash
# param2 - Destination email addres
# param3 - Email subject
# param4 - Email Message body
# param4 - Email content type
########################################################################
sub pandora_sendmail {
my $pa_config = $_[0];
my $to_address = $_[1];
my $subject = $_[2];
my $message = $_[3];
my $content_type = $_[4];
$subject = decode_entities ($subject);
# If content type is defined, the message will be custom
if (! defined($content_type)) {
$message = decode_entities ($message);
}
my %mail = ( To => $to_address,
Message => $message,
Subject => encode('MIME-Header', $subject),
'X-Mailer' => $pa_config->{"rb_product_name"},
Smtp => $pa_config->{"mta_address"},
Port => $pa_config->{"mta_port"},
From => $pa_config->{"mta_from"},
);
if (defined($content_type)) {
$mail{'Content-Type'} = $content_type;
}
# Check if message has non-ascii chars.
# non-ascii chars should be encoded in UTF-8.
if ($message =~ /[^[:ascii:]]/o && !defined($content_type)) {
$mail{Message} = encode("UTF-8", $mail{Message});
$mail{'Content-Type'} = 'text/plain; charset="UTF-8"';
}
if ($pa_config->{"mta_user"} ne ""){
$mail{auth} = {user=>$pa_config->{"mta_user"}, password=>$pa_config->{"mta_pass"}, method=>$pa_config->{"mta_auth"}, required=>1 };
}
if (sendmail %mail) {
return;
}
else {
logger ($pa_config, "[ERROR] Sending email to $to_address with subject $subject", 1);
if (defined($Mail::Sendmail::error)){
logger ($pa_config, "ERROR Code: $Mail::Sendmail::error", 5);
}
}
}
##########################################################################
# SUB is_numeric
# Return TRUE if given argument is numeric
##########################################################################
sub is_numeric {
my $val = $_[0];
if (!defined($val)){
return 0;
}
# Replace "," for "."
$val =~ s/\,/\./;
my $DIGITS = qr{ \d+ (?: [.] \d*)? | [.] \d+ }xms;
my $SIGN = qr{ [+-] }xms;
my $NUMBER = qr{ ($SIGN?) ($DIGITS) }xms;
if ( $val !~ /^${NUMBER}$/ ) {
return 0; #Non-numeric
}
else {
return 1; #Numeric
}
}
##########################################################################
# SUB md5check (param_1, param_2)
# Verify MD5 file .checksum
##########################################################################
# param_1 : Name of data file
# param_2 : Name of md5 file
sub md5check {
my $buf;
my $buf2;
my $file = $_[0];
my $md5file = $_[1];
open(FILE, $file) or return 0;
binmode(FILE);
my $md5 = Digest::MD5->new;
while (<FILE>) {
$md5->add($_);
}
close(FILE);
$buf2 = $md5->hexdigest;
open(FILE,$md5file) or return 0;
while (<FILE>) {
$buf = $_;
}
close (FILE);
$buf=uc($buf);
$buf2=uc($buf2);
if ($buf =~ /$buf2/ ) {
#print "MD5 Correct";
return 1;
}
else {
#print "MD5 Incorrect";
return 0;
}
}
########################################################################
# SUB logger (pa_config, message, level)
# Log to file
########################################################################
sub logger ($$;$) {
my ($pa_config, $message, $level) = @_;
# Clean any string and ready to be printed in screen/file
$message = safe_output ($message);
$level = 1 unless defined ($level);
return if ($level > $pa_config->{'verbosity'});
if (!defined($pa_config->{'log_file'})) {
print strftime ("%Y-%m-%d %H:%M:%S", localtime()) . " [V". $level ."] " . $message . "\n";
return;
}
# Get the log file (can be a regular file or 'syslog')
my $file = $pa_config->{'log_file'};
# Syslog
if ($file eq 'syslog') {
# Set the security level
my $security_level = 'info';
if ($level < 2) {
$security = 'crit';
} elsif ($level < 5) {
$security = 'warn';
}
openlog('pandora_server', 'ndelay', 'daemon');
syslog($security_level, $message);
closelog();
} else {
open (FILE, ">> $file") or die "[FATAL] Could not open logfile '$file'";
# Get an exclusive lock on the file (LOCK_EX)
flock (FILE, 2);
print FILE strftime ("%Y-%m-%d %H:%M:%S", localtime()) . " " . (defined($pa_config->{'servername'}) ? $pa_config->{'servername'} : '') . " [V". $level ."] " . $message . "\n";
close (FILE);
}
}
########################################################################
# SUB pandora_rotate_log (pa_config)
# Log to file
########################################################################
sub pandora_rotate_logfile ($) {
my ($pa_config) = @_;
my $file = $pa_config->{'log_file'};
# Log File Rotation
if ($file ne 'syslog' && -e $file && (stat($file))[7] > $pa_config->{'max_log_size'}) {
foreach my $i (reverse 1..$pa_config->{'max_log_generation'}) {
rename ($file . "." . ($i - 1), $file . "." . $i);
}
rename ($file, "$file.0");
}
}
########################################################################
# limpia_cadena (string) - Purge a string for any forbidden characters (esc, etc)
########################################################################
sub limpia_cadena {
my $micadena;
$micadena = $_[0];
if (defined($micadena)){
$micadena =~ s/[^\-\:\;\.\,\_\s\a\*\=\(\)a-zA-Z0-9]//g;
$micadena =~ s/[\n\l\f]//g;
return $micadena;
}
else {
return "";
}
}
########################################################################
# clean_blank (string) - Remove leading and trailing blanks
########################################################################
sub clean_blank {
my $input = $_[0];
$input =~ s/^\s+//g;
$input =~ s/\s+$//g;
return $input;
}
########################################################################################
# sub sqlWrap(texto)
# Elimina comillas y caracteres problematicos y los sustituye por equivalentes
########################################################################################
sub sqlWrap {
my $toBeWrapped = shift(@_);
if (defined $toBeWrapped){
$toBeWrapped =~ s/\'/\\\'/g;
$toBeWrapped =~ s/\"/\\\'/g; # " This is for highlighters that don't understand escaped quotes
return "'".$toBeWrapped."'";
}
}
##########################################################################
# sub float_equal (num1, num2, decimals)
# This function make possible to compare two float numbers, using only x decimals
# in comparation.
# Taken from Perl Cookbook, O'Reilly. Thanks, guys.
##########################################################################
sub float_equal {
my ($A, $B, $dp) = @_;
return sprintf("%.${dp}g", $A) eq sprintf("%.${dp}g", $B);
}
##########################################################################
# Tries to load the PandoraEnterprise module. Must be called once before
# enterprise_hook ().
##########################################################################
sub enterprise_load ($) {
my $pa_config = shift;
# Check dependencies
# Already loaded
#return 1 if (is_loaded ('PandoraFMS::Enterprise'));
# Try to load the module
if ($^O eq 'MSWin32') {
# If the Windows service dies the service is stopped, even inside an eval ($RUN is set to 0)!
eval 'local $SIG{__DIE__}; require PandoraFMS::Enterprise;';
}
else {
eval 'require PandoraFMS::Enterprise;';
}
# Ops
if ($@) {
# Enterprise.pm not found.
return 0 if ($@ =~ m/PandoraFMS\/Enterprise\.pm.*\@INC/);
open (STDERR, ">> " . $pa_config->{'errorlog_file'});
print STDERR $@;
close (STDERR);
return 0;
}
# Initialize the enterprise module.
PandoraFMS::Enterprise::init($pa_config);
return 1;
}
##########################################################################
# Tries to call a PandoraEnterprise function. Returns undef if unsuccessful.
##########################################################################
sub enterprise_hook ($$) {
my $func = shift;
my @args = @{shift ()};
# Temporarily disable strict refs
no strict 'refs';
# Prepend the package name
$func = 'PandoraFMS::Enterprise::' . $func;
# undef is returned only if the enterprise function was not found
return undef unless (defined (&$func));
# Try to call the function
my $output = eval { &$func (@args); };
# Check for errors
#return undef if ($@);
return '' unless defined ($output);
return $output;
}
########################################################################
# Prints a message to STDOUT at the given log level.
########################################################################
sub print_message ($$$) {
my ($pa_config, $message, $log_level) = @_;
print STDOUT $message . "\n" if ($pa_config->{'verbosity'} >= $log_level);
}
##########################################################################
# Returns the value of an XML tag from a hash returned by XMLin (one level
# depth).
##########################################################################
sub get_tag_value ($$$;$) {
my ($hash_ref, $tag, $def_value, $all_array) = @_;
$all_array = 0 unless defined ($all_array);
return $def_value unless defined ($hash_ref->{$tag}) and ref ($hash_ref->{$tag});
# If all array is required, returns the array
return $hash_ref->{$tag} if ($all_array == 1);
# Return the first found value
foreach my $value (@{$hash_ref->{$tag}}) {
# If the tag is defined but has no value a ref to an empty hash is returned by XML::Simple
return $value unless ref ($value);
}
return $def_value;
}
########################################################################
# Initialize some variables needed by the MD5 algorithm.
# See http://en.wikipedia.org/wiki/MD5#Pseudocode.
########################################################################
my (@R, @K);
sub md5_init () {
# R specifies the per-round shift amounts
@R = (7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22,
5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20,
4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23,
6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21);
# Use binary integer part of the sines of integers (radians) as constants
for (my $i = 0; $i < 64; $i++) {
$K[$i] = floor(abs(sin($i + 1)) * MOD232);
}
}
###############################################################################
# Return the MD5 checksum of the given string.
# Pseudocode from http://en.wikipedia.org/wiki/MD5#Pseudocode.
###############################################################################
sub md5 ($) {
my $str = shift;
if (!defined($str)){
return "";
}
# Initialize once.
md5_init() if (!defined($R[0]));
# Note: All variables are unsigned 32 bits and wrap modulo 2^32 when calculating
# Initialize variables
my $h0 = 0x67452301;
my $h1 = 0xEFCDAB89;
my $h2 = 0x98BADCFE;
my $h3 = 0x10325476;
# Pre-processing
my $msg = unpack ("B*", pack ("A*", $str));
my $bit_len = length ($msg);
# Append "1" bit to message
$msg .= '1';
# Append "0" bits until message length in bits ≡ 448 (mod 512)
$msg .= '0' while ((length ($msg) % 512) != 448);
# Append bit /* bit, not byte */ length of unpadded message as 64-bit little-endian integer to message
$msg .= unpack ("B64", pack ("VV", $bit_len));
# Process the message in successive 512-bit chunks
for (my $i = 0; $i < length ($msg); $i += 512) {
my @w;
my $chunk = substr ($msg, $i, 512);
# Break chunk into sixteen 32-bit little-endian words w[i], 0 <= i <= 15
for (my $j = 0; $j < length ($chunk); $j += 32) {
push (@w, unpack ("V", pack ("B32", substr ($chunk, $j, 32))));
}
# Initialize hash value for this chunk
my $a = $h0;
my $b = $h1;
my $c = $h2;
my $d = $h3;
my $f;
my $g;
# Main loop
for (my $y = 0; $y < 64; $y++) {
if ($y <= 15) {
$f = $d ^ ($b & ($c ^ $d));
$g = $y;
}
elsif ($y <= 31) {
$f = $c ^ ($d & ($b ^ $c));
$g = (5 * $y + 1) % 16;
}
elsif ($y <= 47) {
$f = $b ^ $c ^ $d;
$g = (3 * $y + 5) % 16;
}
else {
$f = $c ^ ($b | (0xFFFFFFFF & (~ $d)));
$g = (7 * $y) % 16;
}
my $temp = $d;
$d = $c;
$c = $b;
$b = ($b + leftrotate (($a + $f + $K[$y] + $w[$g]) % MOD232, $R[$y])) % MOD232;
$a = $temp;
}
# Add this chunk's hash to result so far
$h0 = ($h0 + $a) % MOD232;
$h1 = ($h1 + $b) % MOD232;
$h2 = ($h2 + $c) % MOD232;
$h3 = ($h3 + $d) % MOD232;
}
# Digest := h0 append h1 append h2 append h3 #(expressed as little-endian)
return unpack ("H*", pack ("V", $h0)) . unpack ("H*", pack ("V", $h1)) . unpack ("H*", pack ("V", $h2)) . unpack ("H*", pack ("V", $h3));
}
###############################################################################
# MD5 leftrotate function. See http://en.wikipedia.org/wiki/MD5#Pseudocode.
###############################################################################
sub leftrotate ($$) {
my ($x, $c) = @_;
return (0xFFFFFFFF & ($x << $c)) | ($x >> (32 - $c));
}
##########################################################################
## Convert a date (yyy-mm-ddThh:ii:ss) to Timestamp.
##########################################################################
sub dateTimeToTimestamp {
$_[0] =~ /(\d{4})-(\d{2})-(\d{2})([ |T])(\d{2}):(\d{2}):(\d{2})/;
my($year, $mon, $day, $GMT, $hour, $min, $sec) = ($1, $2, $3, $4, $5, $6, $7);
#UTC
return timegm($sec, $min, $hour, $day, $mon - 1, $year - 1900);
#BST
#print "BST\t" . mktime($sec, $min, $hour, $day, $mon - 1, $year - 1900, 0, 0) . "\n";
}
##############################################################################
# Below some "internal" functions for automonitoring feature
# TODO: Implement the same for other systems like Solaris or BSD
##############################################################################
sub disk_free ($) {
my $target = $_[0];
my $OSNAME = $^O;
# Get the free disk on data_in folder unit
if ($OSNAME eq "MSWin32") {
# Check relative path
my $unit;
if ($target =~ m/^([a-zA-Z]):/gi) {
$unit = $1;
} else {
return;
}
# Get the free space of unit found
my $all_disk_info = `wmic logicaldisk get caption, freespace`;
if ($all_disk_info =~ m/$unit:\D*(\d+)/gmi){
return $1/(1024*1024);
}
return;
}
# Try to use df command with Posix parameters...
my $command = "df -k -P ".$target." | tail -1 | awk '{ print \$4/1024}'";
my $output = `$command`;
return $output;
}
sub load_average {
my $load_average;
my $OSNAME = $^O;
if ($OSNAME eq "freebsd"){
$load_average = ((split(/\s+/, `/sbin/sysctl -n vm.loadavg`))[1]);
} elsif ($OSNAME eq "MSWin32") {
# Windows hasn't got load average.
$load_average = undef;
}
# by default LINUX calls
else {
$load_average = `cat /proc/loadavg | awk '{ print \$1 }'`;
}
return $load_average;
}
sub free_mem {
my $free_mem;
my $OSNAME = $^O;
if ($OSNAME eq "freebsd"){
my ($pages_free, $page_size) = `/sbin/sysctl -n vm.stats.vm.v_page_size vm.stats.vm.v_free_count`;
# in kilobytes
$free_mem = $pages_free * $page_size / 1024;
}
elsif ($OSNAME eq "netbsd"){
$free_mem = `cat /proc/meminfo | grep MemFree | awk '{ print \$2 }'`;
}
elsif ($OSNAME eq "MSWin32"){
$free_mem = `wmic OS get FreePhysicalMemory /Value`;
if ($free_mem =~ m/=(.*)$/gm) {
$free_mem = $1;
} else {
$free_mem = undef;
}
}
# by default LINUX calls
else {
$free_mem = `free | grep Mem | awk '{ print \$4 }'`;
}
return $free_mem;
}
##########################################################################
## SUB ticks_totime
# Transform a snmp timeticks count in a date
##########################################################################
sub ticks_totime ($){
# Calculate ticks per second, minute, hour, and day
my $TICKS_PER_SECOND = 100;
my $TICKS_PER_MINUTE = $TICKS_PER_SECOND * 60;
my $TICKS_PER_HOUR = $TICKS_PER_MINUTE * 60;
my $TICKS_PER_DAY = $TICKS_PER_HOUR * 24;
my $ticks = shift;
if (!defined($ticks)){
return "";
}
my $seconds = int($ticks / $TICKS_PER_SECOND) % 60;
my $minutes = int($ticks / $TICKS_PER_MINUTE) % 60;
my $hours = int($ticks / $TICKS_PER_HOUR) % 24;
my $days = int($ticks / $TICKS_PER_DAY);
return "$days days, $hours hours, $minutes minutes, $seconds seconds";
}
##############################################################################
=head2 C<< pandora_ping (I<$pa_config>, I<$host>) >>
Ping the given host.
Returns:
1 if the host is alive
0 otherwise.
=cut
##############################################################################
sub pandora_ping ($$$$) {
my ($pa_config, $host, $timeout, $retries) = @_;
# Adjust timeout and retry values
if ($timeout == 0) {
$timeout = $pa_config->{'networktimeout'};
}
if ($retries == 0) {
$retries = $pa_config->{'icmp_checks'};
}
my $packets = defined($pa_config->{'icmp_packets'}) ? $pa_config->{'icmp_packets'} : 1;
my $output = 0;
my $i;
# See codes on http://perldoc.perl.org/perlport.html#PLATFORMS
my $OSNAME = $^O;
# Windows XP .. Windows 7
if (($OSNAME eq "MSWin32") || ($OSNAME eq "MSWin32-x64") || ($OSNAME eq "cygwin")){
my $ms_timeout = $timeout * 1000;
for ($i=0; $i < $retries; $i++) {
$output = `ping -n $packets -w $ms_timeout $host`;
if ($output =~ /TTL/){
return 1;
}
sleep 1;
}
return 0;
}
elsif ($OSNAME eq "solaris"){
my $ping_command = "ping";
if ($host =~ /\d+:|:\d+/ ) {
$ping_command = "ping -A inet6"
}
# Note: timeout option is not implemented in ping.
# 'networktimeout' is not used by ping on Solaris.
# Ping the host
for ($i=0; $i < $retries; $i++) {
`$ping_command -s -n $host 56 $packets >$DEVNULL 2>&1`;
if ($? == 0) {
return 1;
}
sleep 1;
}
return 0;
}
elsif ($OSNAME eq "freebsd"){
my $ping_command = "ping -t $timeout";
if ($host =~ /\d+:|:\d+/ ) {
$ping_command = "ping6";
}
# Note: timeout(-t) option is not implemented in ping6.
# 'networktimeout' is not used by ping6 on FreeBSD.
# Ping the host
for ($i=0; $i < $retries; $i++) {
`$ping_command -q -n -c $packets $host >$DEVNULL 2>&1`;
if ($? == 0) {
return 1;
}
sleep 1;
}
return 0;
}
elsif ($OSNAME eq "netbsd"){
my $ping_command = "ping -w $timeout";
if ($host =~ /\d+:|:\d+/ ) {
$ping_command = "ping6";
}
# Note: timeout(-w) option is not implemented in ping6.
# 'networktimeout' is not used by ping6 on NetBSD.
# Ping the host
for ($i=0; $i < $retries; $i++) {
`$ping_command -q -n -c $packets $host >$DEVNULL 2>&1`;
if ($? == 0) {
return 1;
}
sleep 1;
}
return 0;
}
# by default LINUX calls
else {
my $ping_command = "ping";
if ($host =~ /\d+:|:\d+/ ) {
$ping_command = "ping6";
}
# Ping the host
for ($i=0; $i < $retries; $i++) {
`$ping_command -q -W $timeout -n -c $packets $host >$DEVNULL 2>&1`;
if ($? == 0) {
return 1;
}
sleep 1;
}
return 0;
}
return $output;
}
########################################################################
=head2 C<< pandora_ping_latency (I<$pa_config>, I<$host>) >>
Ping the given host. Returns the average round-trip time. Returns undef if fails.
=cut
########################################################################
sub pandora_ping_latency ($$$$) {
my ($pa_config, $host, $timeout, $retries) = @_;
# Adjust timeout and retry values
if ($timeout == 0) {
$timeout = $pa_config->{'networktimeout'};
}
if ($retries == 0) {
$retries = $pa_config->{'icmp_checks'};
}
my $output = 0;
# See codes on http://perldoc.perl.org/perlport.html#PLATFORMS
my $OSNAME = $^O;
# Windows XP .. Windows 2008, I assume Win7 is the same
if (($OSNAME eq "MSWin32") || ($OSNAME eq "MSWin32-x64") || ($OSNAME eq "cygwin")){
# System ping reports in different languages, but with the same format:
# Mínimo = xxms, Máximo = xxms, Media = XXms
# Minimun = xxms, Mamimun = xxms, Average = XXms
# If this fails, ping can be replaced by fping which also have the same format
# but always in english
my $ms_timeout = $timeout * 1000;
$output = `ping -n $retries -w $ms_timeout $host`;
if ($output =~ m/\=\s([0-9]+)ms$/){
return $1;
} else {
return undef;
}
}
elsif ($OSNAME eq "solaris"){
my $ping_command = "ping";
if ($host =~ /\d+:|:\d+/ ) {
$ping_command = "ping -A inet6";
}
# Note: timeout option is not implemented in ping.
# 'networktimeout' is not used by ping on Solaris.
# Ping the host
my @output = `$ping_command -s -n $host 56 $retries 2>$DEVNULL`;
# Something went wrong
return undef if ($? != 0);
# Parse the output
my $stats = pop (@output);
return undef unless ($stats =~ m/([\d\.]+)\/([\d\.]+)\/([\d\.]+)\/([\d\.]+) +ms/);
return $2;
}
elsif ($OSNAME eq "freebsd"){
my $ping_command = "ping -t $timeout";
if ($host =~ /\d+:|:\d+/ ) {
$ping_command = "ping6";
}
# Note: timeout(-t) option is not implemented in ping6.
# timeout(-t) and waittime(-W) options in ping are not the same as
# Linux. On latency, there are no way to set timeout.
# 'networktimeout' is not used on FreeBSD.
# Ping the host
my @output = `$ping_command -q -n -c $retries $host 2>$DEVNULL`;
# Something went wrong
return undef if ($? != 0);
# Parse the output
my $stats = pop (@output);
return undef unless ($stats =~ m/([\d\.]+)\/([\d\.]+)\/([\d\.]+)\/([\d\.]+) +ms/);
return $2;
}
elsif ($OSNAME eq "netbsd"){
my $ping_command = "ping -w $timeout";
if ($host =~ /\d+:|:\d+/ ) {
$ping_command = "ping6";
}
# Note: timeout(-w) option is not implemented in ping6.
# timeout(-w) and waittime(-W) options in ping are not the same as
# Linux. On latency, there are no way to set timeout.
# 'networktimeout' is not used on NetBSD.
# Ping the host
my @output = `$ping_command -q -n -c $retries $host >$DEVNULL 2>&1`;
# Something went wrong
return undef in ($? != 0);
# Parse the output
my $stats = pop (@output);
return undef unless ($stats =~ m/([\d\.]+)\/([\d\.]+)\/([\d\.]+)\/([\d\.]+) +ms/);
return $2;
}
# by default LINUX calls
else {
my $ping_command = "ping";
if ($host =~ /\d+:|:\d+/ ) {
$ping_command = "ping6";
}
# Ping the host
my @output = `$ping_command -q -W $timeout -n -c $retries $host 2>$DEVNULL`;
# Something went wrong
return undef if ($? != 0);
# Parse the output
my $stats = pop (@output);
return undef unless ($stats =~ m/([\d\.]+)\/([\d\.]+)\/([\d\.]+)\/([\d\.]+) +ms/);
return $2;
}
# If no valid get values until now, just return with empty value (not valid)
return $output;
}
########################################################################
=head2 C<< month_have_days (I<$month>, I<$year>) >>
Pass a $month (as january 0 number and each month with numbers) and the year
as number (for example 1981). And return the days of this month.
=cut
########################################################################
sub month_have_days($$) {
my $month= shift(@_);
my $year= @_ ? shift(@_) : (1900 + (localtime())[5]);
my @monthDays= qw( 31 28 31 30 31 30 31 31 30 31 30 31 );
if ( $year <= 1752 ) {
# Note: Although September 1752 only had 19 days,
# they were numbered 1,2,14..30!
if (1752 == $year && 8 == $month) {
return 19;
}
if (1 == $month && 0 == $year % 4) {
return 29;
}
}
else {
#Check if Leap year
if (1 == $month && 0 == $year % 4 && 0 == $year%100
|| 0 == $year%400) {
return 29;
}
}
return $monthDays[$month];
}
###############################################################################
# Convert a text obj tag to an OID and update the module configuration.
###############################################################################
sub translate_obj ($$$) {
my ($pa_config, $dbh, $obj) = @_;
# Pandora FMS's console MIB directory
my $mib_dir = $pa_config->{'attachment_dir'} . '/mibs';
# Translate!
my $oid = `snmptranslate -On -mALL -M+"$mib_dir" $obj 2>$DEVNULL`;
if ($? != 0) {
return undef;
}
chomp($oid);
return $oid;
}
###############################################################################
# Get the number of seconds left to the next execution of the given cron entry.
###############################################################################
sub cron_next_execution {
my ($cron, $interval) = @_;
# Check cron conf format
if ($cron !~ /^((\*|(\d+(-\d+){0,1}))\s*){5}$/) {
return $interval;
}
# Get day of the week and month from cron config
my ($mday, $wday) = (split (/\s/, $cron))[2, 4];
# Get current time and day of the week
my $cur_time = time();
my $cur_wday = (localtime ($cur_time))[6];
# Any day of the week
if ($wday eq '*') {
my $nex_time = cron_next_execution_date ($cron, $cur_time, $interval);
return $nex_time - time();
}
# A range?
else {
$wday = cron_get_closest_in_range ($cur_wday, $wday);
}
# A specific day of the week
my $count = 0;
my $nex_time = $cur_time;
do {
$nex_time = cron_next_execution_date ($cron, $nex_time, $interval);
my $nex_time_wd = $nex_time;
my ($nex_mon, $nex_wday) = (localtime ($nex_time_wd))[4, 6];
my $nex_mon_wd;
do {
# Check the day of the week
if ($nex_wday == $wday) {
return $nex_time_wd - time();
}
# Move to the next day of the month
$nex_time_wd += 86400;
($nex_mon_wd, $nex_wday) = (localtime ($nex_time_wd))[4, 6];
} while ($mday eq '*' && $nex_mon_wd == $nex_mon);
$count++;
} while ($count < 60);
# Something went wrong, default to 5 minutes
return $interval;
}
###############################################################################
# Get the number of seconds left to the next execution of the given cron entry.
###############################################################################
sub cron_check_syntax ($) {
my ($cron) = @_;
return 0 if !defined ($cron);
return ($cron =~ m/^(\d|\*|-)+ (\d|\*|-)+ (\d|\*|-)+ (\d|\*|-)+ (\d|\*|-)+$/);
}
###############################################################################
# Get the next execution date for the given cron entry in seconds since epoch.
###############################################################################
sub cron_next_execution_date {
my ($cron, $cur_time, $interval) = @_;
# Get cron configuration
my ($min, $hour, $mday, $mon, $wday) = split (/\s/, $cron);
# Months start from 0
if($mon ne '*') {
my ($mon_down, $mon_up) = cron_get_interval ($mon);
if (defined($mon_up)) {
$mon = ($mon_down - 1) . "-" . ($mon_up - 1);
} else {
$mon = $mon_down - 1;
}
}
# Get current time
if (! defined ($cur_time)) {
$cur_time = time();
}
# Check if current time + interval is on cron too
my $nex_time = $cur_time + $interval;
my ($cur_min, $cur_hour, $cur_mday, $cur_mon, $cur_year)
= (localtime ($nex_time))[1, 2, 3, 4, 5];
my @cron_array = ($min, $hour, $mday, $mon);
my @curr_time_array = ($cur_min, $cur_hour, $cur_mday, $cur_mon);
return ($nex_time) if cron_is_in_cron(\@cron_array, \@curr_time_array) == 1;
# Get first next date candidate from next cron configuration
# Initialize some vars
my @nex_time_array = @curr_time_array;
# Update minutes
my ($min_down, undef) = cron_get_interval ($min);
$nex_time_array[0] = ($min_down eq '*') ? 0 : $min_down;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time >= $cur_time) {
return $nex_time if cron_is_in_cron(\@cron_array, \@nex_time_array);
}
# Check if next hour is in cron
$nex_time_array[1]++;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time == 0) {
#Update the month day if overflow
$nex_time_array[1] = 0;
$nex_time_array[2]++;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time == 0) {
#Update the month if overflow
$nex_time_array[2] = 1;
$nex_time_array[3]++;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time == 0) {
#Update the year if overflow
$cur_year++;
$nex_time_array[3] = 0;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
}
}
}
#Check the hour
return $nex_time if cron_is_in_cron(\@cron_array, \@nex_time_array);
#Update the hour if fails
my ($hour_down, undef) = cron_get_interval ($hour);
$nex_time_array[1] = ($hour_down eq '*') ? 0 : $hour_down;
# When an overflow is passed check the hour update again
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time >= $cur_time) {
return $nex_time if cron_is_in_cron(\@cron_array, \@nex_time_array);
}
# Check if next day is in cron
$nex_time_array[2]++;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time == 0) {
#Update the month if overflow
$nex_time_array[2] = 1;
$nex_time_array[3]++;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time == 0) {
#Update the year if overflow
$nex_time_array[3] = 0;
$cur_year++;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
}
}
#Check the day
return $nex_time if cron_is_in_cron(\@cron_array, \@nex_time_array);
#Update the day if fails
my ($mday_down, undef) = cron_get_interval ($mday);
$nex_time_array[2] = ($mday_down eq '*') ? 1 : $mday_down;
# When an overflow is passed check the hour update in the next execution
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time >= $cur_time) {
return $nex_time if cron_is_in_cron(\@cron_array, \@nex_time_array);
}
# Check if next month is in cron
$nex_time_array[3]++;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time == 0) {
#Update the year if overflow
$nex_time_array[3] = 0;
$cur_year++;
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
}
#Check the month
return $nex_time if cron_is_in_cron(\@cron_array, \@nex_time_array);
#Update the month if fails
my ($mon_down, undef) = cron_get_interval ($mon);
$nex_time_array[3] = ($mon_down eq '*') ? 0 : $mon_down;
# When an overflow is passed check the hour update in the next execution
$nex_time = cron_valid_date(@nex_time_array, $cur_year);
if ($nex_time >= $cur_time) {
return $nex_time if cron_is_in_cron(\@cron_array, \@nex_time_array);
}
$nex_time = cron_valid_date(@nex_time_array, $cur_year + 1);
return $nex_time;
}
###############################################################################
# Returns if a date is in a cron. Recursive.
# Needs the cron like an array reference and
# current time in cron format to works properly
###############################################################################
sub cron_is_in_cron {
my ($elems_cron, $elems_curr_time) = @_;
my @deref_elems_cron = @$elems_cron;
my @deref_elems_curr_time = @$elems_curr_time;
my $elem_cron = shift(@deref_elems_cron);
my $elem_curr_time = shift (@deref_elems_curr_time);
#If there is no elements means that is in cron
return 1 unless (defined($elem_cron) || defined($elem_curr_time));
# Go to last element if current is a wild card
if ($elem_cron ne '*') {
my ($down, $up) = cron_get_interval($elem_cron);
# Check if there is no a range
return 0 if (!defined($up) && ($down != $elem_curr_time));
# Check if there is on the range
if (defined($up)) {
if ($down < $up) {
return 0 if ($elem_curr_time < $down || $elem_curr_time > $up);
} else {
return 0 if ($elem_curr_time > $down || $elem_curr_time < $up);
}
}
}
return cron_is_in_cron(\@deref_elems_cron, \@deref_elems_curr_time);
}
###############################################################################
# Returns the interval of a cron element. If there is not a range,
# returns an array with the first element in the first place of array
# and the second place undefined.
###############################################################################
sub cron_get_interval {
my ($element) = @_;
# Not a range
if ($element !~ /(\d+)\-(\d+)/) {
return ($element, undef);
}
return ($1, $2);
}
###############################################################################
# Returns the closest number to the target inside the given range (including
# the target itself).
###############################################################################
sub cron_get_closest_in_range ($$) {
my ($target, $range) = @_;
# Not a range
if ($range !~ /(\d+)\-(\d+)/) {
return $range;
}
# Search the closes number to the target in the given range
my $range_start = $1;
my $range_end = $2;
# Outside the range
if ($target <= $range_start || $target > $range_end) {
return $range_start;
}
# Inside the range
return $target;
}
###############################################################################
# Check if a date is valid to get timelocal
###############################################################################
sub cron_valid_date {
my ($min, $hour, $mday, $month, $year) = @_;
my $utime;
eval {
local $SIG{__DIE__} = sub {};
$utime = timelocal(0, $min, $hour, $mday, $month, $year);
};
if ($@) {
return 0;
}
return $utime;
}
###############################################################################
# Attempt to resolve the given hostname.
###############################################################################
sub resolve_hostname ($) {
my ($hostname) = @_;
$resolved_hostname = inet_aton($hostname);
return $hostname if (! defined ($resolved_hostname));
return inet_ntoa($resolved_hostname);
}
###############################################################################
# Returns 1 if the given regular expression is valid, 0 otherwise.
###############################################################################
sub valid_regex ($) {
my $regex = shift;
eval {
local $SIG{'__DIE__'};
qr/$regex/
};
# Invalid regex
return 0 if ($@);
# Valid regex
return 1;
}
###############################################################################
# Returns 1 if a valid metaconsole license is configured, 0 otherwise.
###############################################################################
sub is_metaconsole ($) {
my ($pa_config) = @_;
if (defined($pa_config->{"license_type"}) &&
($pa_config->{"license_type"} & METACONSOLE_LICENSE) &&
$pa_config->{"node_metaconsole"} == 0) {
return 1;
}
return 0;
}
###############################################################################
# Returns 1 if a valid offline license is configured, 0 otherwise.
###############################################################################
sub is_offline ($) {
my ($pa_config) = @_;
if (defined($pa_config->{"license_type"}) &&
($pa_config->{"license_type"} & OFFLINE_LICENSE)) {
return 1;
}
return 0;
}
###############################################################################
# Check if a given variable contents a number
###############################################################################
sub to_number($) {
my $n = shift;
if ($n =~ /[\d+,]*\d+\.\d+/) {
# American notation
$n =~ s/,//g;
}
elsif ($n =~ /[\d+\.]*\d+,\d+/) {
# Spanish notation
$n =~ s/\.//g;
$n =~ s/,/./g;
}
if(looks_like_number($n)) {
return $n;
}
return undef;
}
#######################
# ENCODE
#######################
sub uri_encode {
# Un-reserved characters
my $unreserved_re = qr{ ([^a-zA-Z0-9\Q-_.~\E\%]) }x;
my $enc_map = { ( map { chr($_) => sprintf( "%%%02X", $_ ) } ( 0 ... 255 ) ) };
my $dec_map = { ( map { sprintf( "%02X", $_ ) => chr($_) } ( 0 ... 255 ) ) };
my ($data) = @_;
# Check for data
# Allow to be '0'
return unless defined $data;
# UTF-8 encode
$data = Encode::encode( 'utf-8-strict', $data );
# Encode a literal '%'
$data =~ s{(\%)(.*)}{uri_encode_literal_percent($1, $2, $enc_map, $dec_map)}gex;
# Percent Encode
$data =~ s{$unreserved_re}{uri_encode_get_encoded_char($1, $enc_map)}gex;
# Done
return $data;
} ## end sub encode
#######################
# INTERNAL
#######################
sub uri_encode_get_encoded_char($$) {
my ( $char, $enc_map ) = @_;
return $enc_map->{$char} if exists $enc_map->{$char};
return $char;
} ## end sub uri_encode_get_encoded_char
sub uri_encode_literal_percent {
my ( $char, $post, $enc_map, $dec_map ) = @_;
return uri_encode_get_encoded_char($char, $enc_map) if not defined $post;
my $return_char;
if ( $post =~ m{^([a-fA-F0-9]{2})}x ) {
if ( exists $dec_map->{$1} ) {
$return_char = join( '', $char, $post );
}
} ## end if ( $post =~ m{^([a-fA-F0-9]{2})}x)
$return_char ||= join( '', uri_encode_get_encoded_char($char, $enc_map), $post );
return $return_char;
} ## end sub uri_encode_literal_percent
################################################################################
# Launch API call
################################################################################
sub api_call_url {
my ($pa_config, $server_url, $api_params, @options) = @_;
my $ua = LWP::UserAgent->new();
$ua->timeout($options->{lwp_timeout});
# Enable environmental proxy settings
$ua->env_proxy;
# Enable in-memory cookie management
$ua->cookie_jar( {} );
# Disable verify host certificate (only needed for self-signed cert)
$ua->ssl_opts( 'verify_hostname' => 0 );
$ua->ssl_opts( 'SSL_verify_mode' => 0x00 );
my $response;
eval {
$response = $ua->post($server_url, $api_params, @options);
};
if ((!$@) && $response->is_success) {
return $response->decoded_content;
}
return undef;
}
################################################################################
# Start a server thread and keep track of it.
################################################################################
sub start_server_thread {
my ($fn, $args) = @_;
# Signal the threads to run.
$THRRUN = 1;
my $thr = threads->create($fn, @{$args});
push(@ServerThreads, $thr);
}
################################################################################
# Check the status of server threads. Returns 1 if all all running, 0 otherwise.
################################################################################
sub check_server_threads {
my ($fn, $args) = @_;
foreach my $thr (@ServerThreads) {
return 0 unless $thr->is_running();
}
return 1;
}
################################################################################
# Stop all server threads.
################################################################################
sub stop_server_threads {
my ($fn, $args) = @_;
# Signal the threads to exits.
$THRRUN = 0;
foreach my $thr (@ServerThreads) {
$thr->detach();
}
@ServerThreads = ();
}
# End of function declaration
# End of defined Code
1;
__END__
Reference in New Issue View Git Blame Copy Permalink