Show util.pm syntax highlighted
# Utility routines that any module within PsychoStats will use. This is mostly
# utility code such as file handling, and other various routines...
#
package util;
use IO::File;
use FindBin;
use Time::Local;
use File::Spec::Functions qw( :ALL );
use IO::Socket;
use Carp;
our $LOGGING = 1; # enable/disable logging in the logerror() function
BEGIN {
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(
©hash
&gethostip
&gethostname
&calcpct
&calcratio
&calcavg
&list_sum
&list_avg
&list_max
&list_min
&setfilepath
&getfilename
&striplr
&prepare_regexp
&date
&diffdays_ymd
&echo
&compacttime
&loadconfig
&simple_interpolate
&logerror
&slurpfile
&getprogname
&getprogbasename
&getprogpath
&getrealtime
&yesno
&str2hash
&str2array
&myfuncname
&ip2int
&int2ip
&getnetmask
&getwildmask
&getbroadcast
&split_ip
&getnetmask
&abbrnum
&commify
&isleapyear
&dayofyear
&dayssince1bc
&datefrom1bc
&daysinmonth
&logcompare
);
}
use strict;
# -----------------------------------------------------------------------------------------------------------------------------
#
{
my @dim = (31,28,31,30,31,30,31,31,30,31,30,31); # static variables for dayssince1bc function ...
my @mdim = (31,29,31,30,31,30,31,31,30,31,30,31);
my $daysin4centuries = 146097; # static variables for datefrom1bc function ...
my $daysin1century = 36524;
my $daysin4years = 1461;
my $daysin1year = 365;
sub dayssince1bc {
my ($year, $month, $day) = @_;
my ($days, $ary);
return 0 if $year + $month + $day == 0;
$days = 0;
$year--;
$month--;
$day--;
$days += $year * 365;
$days += $year / 4;
$days -= $year / 100;
$days += $year / 400;
$ary = isleapyear($year+1) ? \@mdim : \@dim;
for (my $i=0; $i < $month; $i++) {
$days += $ary->[$i];
}
$days += $day;
return sprintf("%d",$days);
}
sub datefrom1bc {
my ($days) = @_;
my ($year,$month,$day) = (0,0,0);
my ($ary, $i);
while ($days >= $daysin4centuries) {
$days -= $daysin4centuries;
$year += 400;
}
if ($days == $daysin1century * 4) {
$days -= $daysin1century * 3;
$days -= $daysin4years * 24;
$days -= $daysin1year * 3;
$year += 399;
} else {
while ($days >= $daysin1century) {
$days -= $daysin1century;
$year += 100;
}
while ($days >= $daysin4years) {
$days -= $daysin4years;
$year += 4;
}
if ($days == $daysin1year * 4) {
$days -= $daysin1year * 3;
$year += 3;
} else {
while ($days >= $daysin1year) {
$days -= $daysin1year;
$year++;
}
}
}
$year++;
$ary = isleapyear($year) ? \@mdim : \@dim;
for (my $i=0; $days >= $$ary[$i]; $i++) {
$days -= $ary->[$i];
$month++;
}
$month++;
$day = $days+1;
return wantarray ? ($year,$month,$day) : sprintf("%04s-%02s-%02s", $year,$month,$day);
}
# returns the number of days in the given month (1..12) or epoch timestamp, or undef for current epoch time
sub daysinmonth {
my ($year, $month) = @_;
if (!defined $month) { # we assume $year is an epoch timestamp, since there's no month
($month, $year) = (localtime($year))[4,5];
$year += 1900;
} else {
$month--;
}
return isleapyear($year) ? $mdim[$month] : $dim[$month];
}
}
# -----------------------------------------------------------------------------------------------------------------------------
# Returns the day of the year (1 to 366)
sub dayofyear {
my ($year, $month, $day) = @_;
my @days = (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365); # total days at the end of each month
my $leapyear = 0;
$leapyear = 1 if $month > 2 and isleapyear($year);
return ($days[$month-1] + $day + $leapyear);
}
# -----------------------------------------------------------------------------------------------------------------------------
# Returns true if the year given is a leap year or false otherwise. the year MUST be a 4 digit year '2003'
sub isleapyear {
my ($year) = @_;
return 0 unless $year % 4 == 0;
return 1 unless $year % 100 == 0;
return 0 unless $year % 400 == 0;
return 1;
}
# -----------------------------------------------------------------------------------------------------------------------------
# Does an DNS lookup on the hostname given. Returns undef if the host is unknown
sub gethostip {
my ($host) = @_;
my $ip = undef;
my $packed = scalar gethostbyname($host);
return undef if !defined $packed;
return join(".", unpack("C4", $packed));
}
# -----------------------------------------------------------------------------------------------------------------------------
# Does an INVERSE DNS lookup on the IP given. Returns undef if the host is unknown
sub gethostname {
my ($ip) = @_;
my $host;
eval { $host = scalar(gethostbyaddr(pack("C4",split(/\./,$ip)),2)) };
return !$@ ? $host : undef;
}
# -----------------------------------------------------------------------------------------------------------------------------
# Returns the percentage of sum / total. $digits specifies how many right-side digits should be used (defaults to 2)
sub calcpct {
my ($sum, $total, $digits) = @_;
$digits = 2 if not defined $digits or $digits < 0;
my $pct = ($total and $sum)
? sprintf("%.${digits}f", $sum / $total * 100)
: ($digits)
? '0.' . ('0' x $digits)
: '0';
return $pct;
}
# -----------------------------------------------------------------------------------------------------------------------------
# Returns the ratio of two numbers (left / right). $digits specifies how many right-side digits should be used (defaults to 2)
sub calcratio {
my ($left, $right, $digits) = @_;
$digits = 2 if not defined $digits or $digits < 0;
my $ratio;
if ($right) {
$ratio = sprintf("%.${digits}f", $left / $right);
} else {
$ratio = ($digits)
? "${left}." . ('0' x $digits)
: $left;
}
return $ratio;
}
# -----------------------------------------------------------------------------------------------------------------------------
# note: the parameters for this are backwards compared to the other calcX() functions
# Returns the average of values given.
# params: digits, total, value[, value, ...]
# 'value' can be an array ref.
sub calcavg {
my $digits = shift;
my $total = shift;
my $sum = 0;
my $avg;
$digits = 2 if not defined $digits or $digits < 0;
foreach my $i (@_) { # add the remaining parameters for total sum
$sum += ref $i eq 'ARRAY' ? list_sum($i) : $i;
}
if ($total) {
$avg = sprintf("%.${digits}f", $sum / $total);
} else {
$avg = ($digits)
? "${sum}." . ('0' x $digits)
: $sum;
}
return $avg;
}
# -----------------------------------------------------------------------------------------------------------------------------
# returns the sum of all elements in an ARRAYREF. If the arrayref contains a list of HASHREF's you can specify a $key to
# use for the summarizing variable.
sub list_sum {
my $list = shift; # must be an ARRAY ref
my $key = shift;
my $total = 0;
$total += ($key and ref($_) eq 'HASH' and exists $_->{$key}) ? $_->{$key} || 0 : $_ || 0 foreach @$list;
return $total;
}
# -----------------------------------------------------------------------------------------------------------------------------
# returns the average of all elements in an ARRAYREF. If the arrayref contains a list of HASHREF's you can specify a $key to
# use for the summarizing variable.
sub list_avg {
my $list = shift; # must be an ARRAY ref
my $key = shift;
my $digits = shift || 0;
my $sum = 0;
$sum += ($key and ref($_) eq 'HASH' and exists $_->{$key}) ? $_->{$key} || 0 : $_ || 0 foreach @$list;
return calcavg($digits, scalar @$list, $sum);
}
# -----------------------------------------------------------------------------------------------------------------------------
# returns the max value in an ARRAYREF. If the arrayref contains a list of HASHREF's you can specify a $key to
# use for the variable check
sub list_max {
my $list = shift; # must be an ARRAY ref
my $key = shift;
my $value = undef;
foreach my $item (@$list) {
if ($key and ref($item) eq 'HASH' and exists $item->{$key}) {
$value = $item->{$key} if !defined $value or (defined $item->{$key} and $item->{$key} > $value);
} else {
$value = $item if !defined $value or $item > $value;
}
}
return $value;
}
# -----------------------------------------------------------------------------------------------------------------------------
# returns the min value in an ARRAYREF. If the arrayref contains a list of HASHREF's you can specify a $key to
# use for the variable check
sub list_min {
my $list = shift; # must be an ARRAY ref
my $key = shift;
my $value = undef;
foreach my $item (@$list) {
if ($key and ref($item) eq 'HASH' and exists $item->{$key}) {
$value = $item->{$key} if !defined $value or (defined $item->{$key} and $item->{$key} < $value);
} else {
$value = $item if !defined $value or $item < $value;
}
}
return $value;
}
# -----------------------------------------------------------------------------------------------------------------------------
# Sets the path to the relative filename given to include the working path of the perl script BIN unless the file given is
# already an absolute path or a DSN string reference
sub setfilepath {
my ($str) = @_;
my $test = $str;
$test =~ s#\\#/#; # for easier checks, replace all backslashes with forward slashes
if ($test =~ m#^\w\w+://#) { # DSN mysql://blah
return $str;
} elsif ($test !~ m#^((\w:)|/)#) { # c:/blah, /blah
return catfile(getprogpath(), $str);
}
return $str;
}
# -----------------------------------------------------------------------------------------------------------------------------
# Searches all paths given for an existing filename and returns the full path. On failure it returns an empty string ''
# If no paths are given then the current script path is used
sub getfilename {
my $file = shift;
my @paths = (defined @_) ? @_ : ();
push(@paths, $FindBin::Bin) if not scalar @paths;
foreach my $path (@paths) {
my $f = canonpath(catfile($path,$file));
return $f if -f $f; # if it exists and its a FILE
}
return '';
}
# -----------------------------------------------------------------
# removes the standard // chars from a regexp, if they're present
sub prepare_regexp {
my $str = shift;
if ($str =~ /^\/(.+?)\/$/) {
$str = $1;
}
return $str;
}
# -----------------------------------------------------------------
# echos a string to the screen using the supplied epoch date, or current date
sub echo {
my ($str, $epoch) = @_;
$epoch ||= time();
print &date('%Y/%m/%d - %H:%i:%s ', $epoch) . $str;
}
# -----------------------------------------------------------------
# removes a single char from the beginning and ending of the string
sub striplr {
my $str = shift;
return $str if length($str) < 3;
# $str =~ s/^.(.+?).$/$1/me;
$str = substr($str, 1, -1);
return $str;
}
# -----------------------------------------------------------------
# Loads a config file and returns a hash of all variables from the file.
# option section : [HEADER]
# Starts a section of options. All options under a section will be seperated from other options of the same name. This will
# allow you to have multiple sets of variables with the same name for different sections. If no sections are defined
# everything falls under the [GLOBAL] section. The global section, unlike all other sections, is not a sub-hash of the hash
# returned. The only thing that ENDS a section is another section or EOF.
# [MYSECTION] would create vars like: $conf{mysection}{var} = value
# [GLOBAL] would create vars like: $conf{var} = value
# include files : INCLUDE: filename
# Reads in the filename as if it were already part of the original file. This routine does not check for recursion.
# Including files always default to GLOBAL section. Any sections defined in the INCLUDE'd file will overwrite any sections
# already created from the first config file (*bug*).
# single options : var = value
# If the value is surrounded by double quotes (") then the string inside will be used (usefull for having leading or
# trailing spaces on a line)
# If var is in the form of "section.var" then the 'section' is stripped off and 'var' is stored under the section
# If the same var is used more then once, the value for that var is converted to an array of values. Each index of the array
# will hold a single value read from the config
# multi-line opts : var [ ... all lines treated as a single value... ] (var equals everything within the brackets)
# : var >> END ('END' can be anything and the block doesn't end until its seen again on a line by itself)
# code blocks : var { ...perl code... }
# Everything within the curly braces is EVAL'd as perl code and its result is returned. NOTE, you must watch out for
# nested curly braces within the block. If the braces become uneven the block will break.
# Note: code blocks are only executed once and are executed as soon as they're seen (during the config loading process). So
# assigning $conf{mycodeblock} doesn't execute the code each time.
# file blocks : *** BLOCKNAME ***
# Specifies the starting point of the file to start reading at.
sub loadconfig {
my %args = (
'filename' => '',
'oldconf' => undef,
'fatal' => 1,
'warning' => 1,
'commentstr' => '#',
'idx' => 0,
'section' => 'global',
'sectionname' => 'SECTION',
'idxname' => 'IDX',
'ignorequotes' => 0,
'preservecase' => 0,
'noarrays' => 0,
# 'data' => {}, # data to match interpolations on (in addition to the current file data)
'fileblock' => '', # what block to read from file ('' or false = read everything)
@_ # actual parameters passed into function override those above
);
my %newconf = ();
my ($var, $val, $begin, $end, $begintotal);
my %blockend = ( '{' => '}', '[' => ']' );
my $confptr = \%newconf;
my $fileblock = '1fd27eec2d4c64a93436dea3182f56a2'; # dummy data
my $F = IO::File->new(); # this makes it possible to recursively call ourself (from INCLUDE: lines)
local *FILE = $F;
%newconf = %{$args{oldconf}} if defined $args{oldconf};
$args{section} = lc $args{section}; # make sure section names are always lowercase
# this allows us to start at an alternate section from 'global'
unless (open(FILE, "<$args{filename}")) {
logerror("Error opening config file: $args{filename}: $!\n",$args{fatal},$args{warning}) if $args{fatal} or $args{warning};
return %newconf;
}
while (<FILE>) {
s/^\s+//; # remove whitespace from front
s/\s+$//; # remove whitespace from end
next if $args{commentstr} ne 'none' and /^\Q$args{commentstr}/; # skip comments
next if /^$/; # skip blank lines
next if not /^\*+|\[?\s*\S+\s*(\*+|>|\]|=|:|\{|\[)/; # skip 'invalid' lines
if ($args{fileblock}) {
if (/^\*+\s*([^\*]+?)\s*\*+/) { # *** BLOCKNAME ***
$fileblock = lc $1;
}
}
next if ($args{fileblock} and ($args{fileblock} ne $fileblock)); # skip everthing until a valid fileblock is seen
if (/^\[\s*(.+)\s*\]/) { # [SECTION] header
$args{section} = lc $1;
## create section if needed and create reference to new hash section, taking care of 'global'
if ($args{section} ne 'global') {
# keep order of sections as read from file
$newconf{ $args{section} }{ $args{idxname} } = ++$args{idx} unless exists $newconf{ $args{section} };
$confptr = \%{$newconf{ $args{section} }};
$confptr->{ $args{sectionname} } = $1 unless exists $confptr->{ $args{sectionname} }; # preserve the section header case
} else {
$confptr = \%newconf; # reset confptr to 'global' level of hash
}
} elsif (/^\s*(\S+?)\s*=\s*(.*)/) { # VAR = VALUE
($var, $val) = ($1,defined $2 ? $2 : '');
$var = lc $var unless $args{preservecase};
$val =~ s/\s*\Q$args{commentstr}\E.*// if $args{commentstr} ne 'none'; # remove comments from end
if (($var eq '$comments') and ($val ne '')) { # change the comment str if requested
$args{commentstr} = $val;
next;
}
$val =~ s/^"(.*)"$/$1/ unless $args{ignorequotes}; # remove double quotes if present
if ($var =~ /^([\w\d]+)\.([\w\d]+)/) { # dot notation to specify a different SECTION
if (lc $1 ne 'global') { # IGNORE 'global' sections
_assignvar(\%{$newconf{$1}}, $2, $val, $args{noarrays}); # NOTE: use %newconf and not $confptr !
} else {
_assignvar(\%newconf, $2, $val, $args{noarrays});
}
} else { # normal variable
_assignvar($confptr, $var, $val, $args{noarrays});
}
} elsif (/^\s*(\S+?)\s*>+\s*([\.\w\d]+)/) { # VAR >> END
($var, $val) = ($1,$2);
my $token = $val;
$var = lc $var unless $args{preservecase};
$val = '';
while (my $line = <FILE>) {
if ($line =~ /^\s*\Q$token\E\s*$/i) { # matched 'END' token
last;
} else {
$val .= $line;
}
}
if ($var =~ /^([\w\d]+)\.([\w\d]+)/) { # dot notation to specify a different SECTION
if ($1 ne 'global') { # IGNORE 'global' sections
_assignvar(\%{$newconf{$1}}, $2, $val, $args{noarrays}); # NOTE: use %newconf and not $confptr !
} else {
_assignvar(\%newconf, $2, $val, $args{noarrays});
}
} else { # normal variable
_assignvar($confptr, $var, $val, $args{noarrays});
}
} elsif (/^\s*(\S+?)\s*([{\[])\s*(.*)/) { # -- VAR {[ VALUE (multi-line) ]} --
($var, $begin, $val) = ($1,$2,defined $3 ? $3 : '');
$end = $blockend{$begin}; # get block ending character
$var = lc $var unless $args{preservecase};
my $block = '';
$begintotal = 1;
if ($val =~ /^(.*)(\Q$end\E\s*)/) { # var { $1 } ($2 = $end; line doesn't have to exist)
$block = $1;
if (defined $2) {
$val = $end; # set '}' so the while loop below will not run.
$begintotal = 0;
} else {
$block .= "\n";
}
}
while ( (($val ne $end) or ($begintotal>0)) and !eof(FILE)) { # This runs when an {} block has more than one line
$val = getc(FILE); # get next char
$begintotal-- if ($val eq $end); # must account for nested {} blocks
$begintotal++ if ($val eq $begin);
$block .= $val if ($val ne $end) or ($begintotal>0);
}
$block =~ s/^\s+//; # trim white space from value
$block =~ s/\s+$//;
if ($begin.$end eq '{}') { # CODE block { ... } needs to be run
my $code = $block;
my $this = eval $code;
if (!$@) {
$block = (defined $this) ? $this : '';
} else {
&logerror("Invalid code block '$var' specified in $args{filename} ($@)",1);
}
}
if ($var =~ /^([\w\d]+)\.([\w\d]+)/) { # dot notation to specify a different SECTION
if ($1 ne 'global') { # IGNORE 'global' sections
_assignvar(\%{$newconf{$1}}, $2, $block, $args{noarrays}); # NOTE: use %newconf and not $confptr !
} else {
_assignvar(\%newconf, $2, $block, $args{noarrays});
}
} else { # normal variable
_assignvar($confptr, $var, $block, $args{noarrays});
}
# _assignvar($confptr, $var, $block, $args{noarrays}); # assign final value to variable
} elsif (/^\s*(\S+?)\s*:\s*(.*)/) { # INCLUDE: filename
next unless lc $1 eq 'include';
next unless $2;
# my $inc = simple_interpolate($2, { %{$args{data}}, %newconf });
my $inc = $2;
$inc =~ s/\s+$//;
if ($^O ne 'MSWin32') {
$inc = getprogpath($args{filename}) . $inc if ($inc !~ /^\//); # doesn't start with slash "/"
} else {
$inc = getprogpath($args{filename}) . $inc if ($inc !~ /^(\w:|\\)/); # doesn't start with "\" or "x:"
}
my %newargs = %args;
$newargs{filename} = $inc;
my %incconf = loadconfig(%newargs); # pass the same args to itself, except filename
%newconf = (%newconf, %incconf);
} ## if..else..
} ## while(FILE) ...
close(FILE);
# convert all arrays in the config to scalar strings (if noarrays is specified)
if ($args{noarrays}) {
foreach my $k (keys %newconf) {
if (ref $newconf{$k} eq 'HASH') { # handle sub-hashes (there can be only 2 levels;
foreach my $k2 (keys %{$newconf{$k}}) { # so there is need for recursion)
next unless ref $newconf{$k}{$k2} eq 'ARRAY';
my $ary = $newconf{$k}{$k2};
$newconf{$k}{$k2} = join("\n", @$ary);
}
} else {
next unless ref $newconf{$k} eq 'ARRAY';
my $ary = $newconf{$k};
$newconf{$k} = join("\n", @$ary);
}
}
}
return wantarray ? %newconf : { %newconf };
}
# ---------
# internal function for loadconfig(). Assigns a value to the 'var'. Automatically converts var into an array if required
sub _assignvar {
my ($conf, $var, $val, $noary) = @_;
if (!$noary and exists $conf->{$var}) {
if (ref $conf->{$var} ne 'ARRAY') {
my $old = $conf->{$var};
$conf->{$var} = [ $old ]; # convert scalar into an array with its original value
}
push(@{$conf->{$var}}, $val); # add new value to the array
} else {
$conf->{$var} = $val; # single value, so we keep it as a scalar
}
return 1;
}
# --------------------------------------------------------------
# A /very/ simple version of an interpolating routine to do very simple variable substitution on a string.
# This allows for 2 levels of hash variables ONLY. ie: $key, or $key.var (but not $key.var.subvar) .. this is only meant to be
# a SIMPLE interpolator :-) ... If a code ref is found in a $token, it will be called and it's return value used.
sub simple_interpolate {
my ($str, $data, $fill) = @_;
my ($var1,$var2, $rep, $rightpos, $leftpos, $varlen);
$fill ||= 0;
while ($str =~ /\$([a-z][a-z\d_]+)(?:\.([a-z][a-z\d_]+))?/gsi) { # match $token or $key.token (but not $123token)
$var1 = lc $1;
$var2 = lc($2 || '');
$varlen = length($var1 . $var2);
if (exists $data->{$var1}) {
if ($var2 ne '') {
$rep = exists $data->{$var1}{$var2} ? $data->{$var1}{$var2} : ($fill) ? "$var1.$var2" : '';
$varlen++; # must account for the extra '.' in the $token.var
} else {
$rep = $data->{$var1};
}
if (ref $rep eq 'CODE') {
my $value = &$rep;
$rep = $value;
}
} else {
$rep = $fill ? "$var1" : '';
}
$rightpos = pos($str) - 1;
$leftpos = $rightpos - $varlen;
substr($str, $leftpos, $rightpos-$leftpos+1, $rep);
}
return $str;
}
# --------------------------------------------------------------
# Writes the error to a log file and screen if specified. Will die if $fatal is TRUE.
sub logerror {
my ($err, $fatal, $echo) = @_;
my $filename = getprogname() . ".log";
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
my $tag = ($fatal) ? "*FATAL*" : "WARNING";
my $time;
$year += 1900;
$mon++;
foreach my $i ($sec,$min,$hour,$mday,$mon) { $i = "0$i" if (length($i) < 2); }
$time = "$year-$mon-$mday $hour:$min:$sec";
$fatal = 0 if not defined $fatal;
$echo = 1 if not defined $echo;
$err ||= "UNKNOWN ERROR in " . (caller(0))[1] . " at line " . (caller(0))[2] . "\n";
chomp($err);
$err .= "\n" if ($err !~ /\n$/);
if ($LOGGING) {
if (open(ERRLOG, ">>$filename")) {
print ERRLOG "$tag $time: $err";
close(ERRLOG);
} else {
print STDERR "An error occured writting to the log file: '$filename': $!\n";
}
}
if ($echo and !$fatal) {
print STDERR "$tag: $err";
}
die("$tag: $err\n") if $fatal;
return 0;
}
# -----------------------------------------------------------------
# Converts military time to standard time
sub getrealtime {
my ($thetime) = @_;
my ($h,$m,$s) = split(/:/,$thetime);
my $ampm = "am";
if ($h == 12) { $ampm = "pm"; }
elsif ($h > 12) { $h = $h - 12; $ampm = "pm"; }
elsif ($h == 0) { $h = 12; }
$h = "0$h" if (length($h) < 2);
return "$h:$m:$s" . $ampm;
}
# -----------------------------------------------------------------
# returns the number of days between the two dates, format: "YYYY-MM-DD"
# $char specifies the seperator used in the date, defaults to '-'
sub diffdays_ymd {
my ($d1, $d2, $char) = @_;
my ($date1, $date2, $diff, @ary);
$char ||= '-';
@ary = reverse split($char, $d1);
$ary[1]--;
$ary[2] -= 1900;
$date1 = timelocal(0,0,12,@ary);
@ary = reverse split($char, $d2);
$ary[1]--;
$ary[2] -= 1900;
$date2 = timelocal(0,0,12,@ary);
$diff = $date1 - $date2;
return sprintf("%.0f", $diff / (60*60*24));
}
# -----------------------------------------------------------------
# Returns the date formated according to the format given (partially mimics PHPs date() function)
my @weekdays = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday');
my @weekabbr = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
my @months = ('January','February','March','April','May','June','July','August','September','October','November','December');
my @monthabbr= ('Jan','Feb','Mar','Apr','May','June','July','Aug','Sept','Oct','Nov','Dec');
sub date {
my $format = shift;
my $now = shift || time();
# print STDERR caller,"\n";
my ($sec,$min,$hour,$day,$mon,$year,$weekday,$yearday,$isdst) = localtime($now);
my $ampm = '';
$mon++;
$year += 1900;
$yearday++;
my $year2k = sprintf("%02d", $year % 100);
foreach my $val ($sec,$min,$hour,$day,$mon) { $val = '0'.$val if length($val) < 2; }
my $tmptime = &getrealtime("$hour:00:00");
my $hour12 = substr($tmptime, 0, 2);
$ampm = substr($tmptime, 8, 2);
$format =~ s/%a/lc $ampm/ge; # am/pm
$format =~ s/%A/uc $ampm/ge; # AM/PM
$format =~ s/%d/$day/ge; # 01..31 day
$format =~ s/%D/$weekabbr[$weekday]/ge; # Sun..Sat
$format =~ s/%F/$months[$mon-1]/ge; # Janurary..December
$format =~ s/%h/$hour12/ge; # 00..12 hour
$format =~ s/%H/$hour/ge; # 00..24 hour
$format =~ s/%i/$min/ge; # 00..59 minutes
$format =~ s/%I/$isdst/ge; # DST=0/1
$format =~ s/%l/$weekdays[$weekday]/ge; # Sunday..Saturday
$format =~ s/%m/$mon/ge; # 01..12 month
$format =~ s/%M/$monthabbr[$mon-1]/ge; # Jan..Dec
$format =~ s/%r/gmtime($now)/ge; # RFC 822 formatted date; i.e. "Thu, 21 Dec 2000 16:01:07" (no gmt diff: +0200)
$format =~ s/%s/$sec/ge; # 00..59 seconds
$format =~ s/%w/$weekday/ge; # 0..6 weekday number (0=sunday .. 6=saturday)
$format =~ s/%Y/$year/ge; # 2001 year
$format =~ s/%y/$year2k/ge; # 01 year
$format =~ s/%z/$yearday/ge; # 0 .. 365 day of the year
return $format;
}
# -----------------------------------------------------------------
# returns the seconds into total hours, minutes and seconds
sub compacttime {
my ($seconds, $format) = @_;
my ($d,$h,$m,$s) = ('00','00','00','00');
my $str = $format || 'hh:mm:ss';
$seconds ||= 0;
my $old = $seconds;
if ( ($str =~ /dd/) and ($seconds / (60*60*24)) >= 1) { $d = sprintf("%d", $seconds / (60*60*24)); $seconds -= $d * (60*60*24)}
if ( ($str =~ /hh/) and ($seconds / (60*60)) >= 1) { $h = sprintf("%d", $seconds / (60*60)); $seconds -= $h * (60*60)}
if ( ($str =~ /mm/) and ($seconds / 60) >= 1) { $m = sprintf("%d", $seconds / 60); $seconds -= $m * (60)}
if ( ($str =~ /ss/) and ($seconds % 60) >= 1) { $s = sprintf("%d", $seconds % 60);}
$str =~ s/dd/sprintf("%02d",$d)/e;
$str =~ s/hh/sprintf("%02d",$h)/e;
$str =~ s/mm/sprintf("%02d",$m)/e;
$str =~ s/ss/sprintf("%02d",$s)/e;
return $str;
}
# -----------------------------------------------------------------
# Returns an entire file or NULL if it couldn't be loaded.
sub slurpfile {
my ($filename) = @_;
if (open(F, "<$filename")) {
my @file = <F>;
close(F);
return wantarray ? @file : [ @file ];
}
return wantarray ? () : [];
}
# -----------------------------------------------------------------
# Get a yes or no response from STDIN
sub yesno {
my $default = shift || 0;
my $doyn = shift || 0;
my $prompt = shift || "Please enter 'yes' or 'no': ";
my $result = 0;
printf(" [%s]: ", $default ? "Y,n" : "y,N") if $doyn;
while (<STDIN>) {
if (/^\s*(yes|ye|y|no|n|\n)\s*$/i) {
if ($1 eq "\n") {
$result = $default;
# print $result ? "yes\n" : "no\n";
} else {
$result = (/y/i) ? 1 : 0;
}
last;
} else {
print $prompt;
}
}
return $result;
}
# --------------------------------------------------------------
# returns the full path name of the script, EXCEPT for the trailing ".pl".
# Uses $0 if nothing is passed.
sub getprogname {
my $path = shift || catfile($FindBin::Bin, $FindBin::Script);
return (($path =~ /(.+)(\.pl*)$/i)[0] || $path);
}
# --------------------------------------------------------------
# returns the name of the script, EXCEPT for the trailing ".pl".
# Uses $0 if nothing is passed.
sub getprogbasename {
my $path = shift || catfile($FindBin::Bin, $FindBin::Script);
my @parts = splitpath($path);
$parts[2] = ($parts[2] =~ /(.+)(\.pl*)$/i)[0] || '';
return $parts[2]; #catfile(@parts);
}
# --------------------------------------------------------------
# returns the path the script is running in, including trailing slash.
# Uses $0 if nothing is passed.
sub getprogpath {
my $path = shift || return $FindBin::Bin;
my @parts = (splitpath($path))[0,1];
return $parts[0] ? catfile(@parts) : $parts[1];
# my $os_slash = ($^O ne 'MSWin32') ? '/' : '\\';
# my @ary = split(/\Q$os_slash/, $path);
# $ary[$#ary] = ""; # removes the program name from the end.
# return join($os_slash, @ary);
}
# --------------------------------------------------------------
# takes a comma or space seperated string: val1,val2,val3 val4 val5,... and converts all vals into a hash (val => 1)
sub str2hash {
my $str = shift;
my $opts = {};
$str =~ s/,/ /g; # convert commas to spaces
# $str =~ s/\s{2,}/ /g; # convert multiple spaces to a single space
foreach my $opt (split(/\s+/,$str)) {
$opts->{$opt} = 1;
}
return wantarray ? %$opts : $opts;
}
# --------------------------------------------------------------
# takes a comma or space seperated string and returns an array with each item
sub str2array {
my $str = shift;
$str =~ s/,/ /g; # convert commas to spaces
# $str =~ s/\s{2,}/ /g; # convert multiple spaces to a single space
return wantarray ? split(/\s+/, $str) : [ split(/\s+/, $str) ];
}
# -----------------------------------------------------------------
# Returns the name of the function that calls this function
sub myfuncname {
return (caller(1))[3];
}
# -----------------------------------------------------------------
# Converts an IP "1.2.3.4" into a 32bit integer. Ignores any :port on the IP
sub ip2int {
my ($ip, $port) = split(/:/, shift, 2); # strip off any port if it's present
my ($i1,$i2,$i3,$i4) = split(/\./, $ip);
return ($i4) | ($i3 << 8) | ($i2 << 16) | ($i1 << 24);
}
# -----------------------------------------------------------------
# Converts a 32bit integer into its IP "1.2.3.4" representation
sub int2ip {
my $num = shift;
my ($i1,$i2,$i3,$i4);
$i1 = ($num & 0xFF000000) >> 24;
$i2 = ($num & 0x00FF0000) >> 16;
$i3 = ($num & 0x0000FF00) >> 8;
$i4 = ($num & 0x000000FF);
return join(".",($i1,$i2,$i3,$i4));
}
# --------------------------------------------------------------
sub getnetmask {
my $bits = shift;
my $num = 0xFFFFFFFF;
my $mask = ($num >> (32 - $bits)) << (32 - $bits);
return int2ip($mask);
}
# --------------------------------------------------------------
sub getwildmask {
my $num = ip2int( getnetmask(shift) );
$num = $num ^ 0xFFFFFFFF;
return int2ip($num);
}
# --------------------------------------------------------------
sub getbroadcast {
my ($num, $bits) = @_;
my @ip = split(/\./, int2ip($num));
my @wc = split(/\./, getwildmask($bits));
my $bc = "";
for (my $i=0; $i < 4; $i++) { $ip[$i] += $wc[$i]; }
return join(".",@ip);
}
# --------------------------------------------------------------
sub split_ip {
my ($ipstr) = @_;
my (@octets,$bits,$net,$wild,$broad,$valid,$ipint,$ip);
my @info = ();
if ($ipstr =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})(?:\/(\d{1,2}))?$/) {
@octets = ($1, $2, $3, $4);
$bits = defined $5 ? $5 : 32;
$ip = join(".", @octets);
$ipint = ip2int($ip);
$net = int2ip( $ipint & ip2int(getnetmask($bits)) ); # determine the CIDR network address
$broad = getbroadcast($ipint, $bits);
@info = (
$ip, # 10.200.0.12
$bits, # 1 .. 32
$net, # 10.200.0.0
$broad, # 10.200.0.255
$ipint # 180879372
);
return wantarray ? @info : [ @info ];
}
return @info;
}
# --------------------------------------------------------------
# converts a large integer into KB,MB, etc totals (1024 = 1 K)
sub abbrnum {
my ($num, $digits) = @_;
my @size = (' B',' KB',' MB', ' GB', ' TB');
my $i = 0;
$digits = 0 if !defined $digits;
return "0" . $size[0] unless $num;
while (($num >= 1024) and ($i < 4)) {
$num /= 1024;
$i++;
}
return sprintf("%." . $digits . "f",$num) . $size[$i];
}
# -----------------------------------------------------------------
# returns the number, ie: 123456.00 as: 123,456.00. Leading non-numeric characters are ignored, ie: +12345.00. The '+' will not
# effect the outcome of the commified number.
sub commify {
my $num = reverse shift; # reversing the string first makes things a LOT easier
$num =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g; # insert the commas ...
return scalar reverse $num; # reverse it again to restore the actual number (with commas)
}
# -----------------------------------------------------------------
# Returns a copy of the hash reference passed in. This includes all sub hashes or arrays. The returned hash will be an exact
# copy of the original but all references within the hash will be their own and will not point to the same ref's of the original.
sub copyhash {
my $orig = ref $_[0] eq 'HASH' ? $_[0] : { @_ };
my $new = {};
foreach my $key (keys %$orig) {
if (ref $orig->{$key} eq 'HASH') {
$new->{$key} = { copyhash($orig->{$key}) };
} elsif (ref $orig->{$key} eq 'ARRAY') {
$new->{$key} = [ @{$orig->{$key}} ];
# } elsif (ref $orig->{$key} eq 'SCALAR') {
# $new->{$key} = $orig->{$key};
} else {
$new->{$key} = $orig->{$key};
}
}
return wantarray ? %$new : $new;
}
# -----------------------------------------------------------------
# Returns -1 ($x is higher), 1 ($y is higher) or 0 (equal) as needed
# by perl's sort function
sub logcompare {
my ($x, $y) = @_;
# Fast path -- $a and $b are in the same month
if ( substr($x, 0, 3) eq substr($y, 0, 3) ) {
return $x cmp $y;
}
# Slow path -- handle year wrapping
my $month = (localtime())[4] + 2;
return (
substr($x, 1, 2) <= $month <=> substr($y, 1, 2) <= $month
or
lc $x cmp lc $y );
}
# must return 1; since this is a module
return 1;
See more files for this project here