652 lines
14 KiB
Perl
652 lines
14 KiB
Perl
package logging;
|
|
|
|
use strict;
|
|
|
|
require Exporter;
|
|
@logging::ISA = qw(Exporter);
|
|
@logging::EXPORT = qw(
|
|
VARIABLE
|
|
FATAL
|
|
ERROR
|
|
WARNING
|
|
INFO
|
|
DEBUG1
|
|
DEBUG2
|
|
DEBUG3
|
|
DEBUG4
|
|
DEBUG5
|
|
DEBUG
|
|
set_pkgtool_dir
|
|
set_verbose_flag
|
|
set_log_level
|
|
set_log_base_dir
|
|
set_current_pkg_name
|
|
get_win_major
|
|
get_win_version
|
|
get_default_vars
|
|
set_datetime_vars
|
|
compare_versions
|
|
substitute_variables
|
|
close_all_log_files
|
|
print_log
|
|
set_log_defs
|
|
);
|
|
|
|
use POSIX;
|
|
use File::Spec;
|
|
require Win32;
|
|
|
|
sub print_stderr_log ($$);
|
|
sub print_to_log_file ($$);
|
|
|
|
my $orig_stdout;
|
|
my $orig_stderr;
|
|
|
|
if (! open($orig_stdout, '>&STDOUT')) {
|
|
print STDERR 'Cannot dup STDOUT: '.$!."\n";
|
|
exit(1);
|
|
}
|
|
if (! open($orig_stderr, '>&', \*STDERR)) {
|
|
print STDERR 'Cannot dup STDERR: '.$!."\n";
|
|
exit(1);
|
|
}
|
|
|
|
sub VARIABLE { return -99; }
|
|
sub FATAL { return -3; }
|
|
sub ERROR { return -2; }
|
|
sub WARNING { return -1; }
|
|
sub INFO { return 0; }
|
|
sub DEBUG1 { return 1; }
|
|
sub DEBUG2 { return 2; }
|
|
sub DEBUG3 { return 3; }
|
|
sub DEBUG4 { return 4; }
|
|
sub DEBUG5 { return 5; }
|
|
sub DEBUG { return 99; }
|
|
|
|
my $pkgtool_dir;
|
|
my $verbose_flag;
|
|
my $log_level;
|
|
my $log_base_dir;
|
|
my $fallback_log_def = {
|
|
type => 'stderr',
|
|
channel => {
|
|
global => 'variable'
|
|
}
|
|
};
|
|
my $fallback_log_file = {
|
|
Definition => $fallback_log_def,
|
|
LogFunc => \&print_stderr_log,
|
|
Channels => {
|
|
global => VARIABLE,
|
|
config => VARIABLE,
|
|
pkg => VARIABLE
|
|
}
|
|
};
|
|
my $log_defs = [];
|
|
my $current_pkg_name;
|
|
my $global_log_files = {};
|
|
my $package_log_files = {};
|
|
|
|
sub set_pkgtool_dir ($)
|
|
{
|
|
my ($dir) = @_;
|
|
|
|
$pkgtool_dir = $dir;
|
|
}
|
|
|
|
sub set_verbose_flag ($)
|
|
{
|
|
my ($verbose) = @_;
|
|
|
|
$verbose_flag = $verbose;
|
|
}
|
|
|
|
sub set_log_level ($)
|
|
{
|
|
my ($level) = @_;
|
|
|
|
$log_level = $level;
|
|
}
|
|
|
|
sub set_log_base_dir ($)
|
|
{
|
|
my ($dir) = @_;
|
|
|
|
$log_base_dir = $dir;
|
|
}
|
|
|
|
sub level2str ($)
|
|
{
|
|
my ($level) = @_;
|
|
|
|
return 'VARIABLE' if ($level == VARIABLE);
|
|
return 'FATAL' if ($level == FATAL);
|
|
return 'ERROR' if ($level == ERROR);
|
|
return 'WARNING' if ($level == WARNING);
|
|
return 'INFO' if ($level == INFO);
|
|
return 'DEBUG1' if ($level == DEBUG1);
|
|
return 'DEBUG2' if ($level == DEBUG2);
|
|
return 'DEBUG3' if ($level == DEBUG3);
|
|
return 'DEBUG4' if ($level == DEBUG4);
|
|
return 'DEBUG5' if ($level == DEBUG5);
|
|
return 'DEBUG' if ($level == DEBUG);
|
|
return $level;
|
|
}
|
|
|
|
sub str2level ($)
|
|
{
|
|
my ($level) = @_;
|
|
|
|
return $level if $level =~ /^-?\d+$/o;
|
|
return VARIABLE if $level =~ /^variable$/io;
|
|
return FATAL if $level =~ /^fatal$/io;
|
|
return ERROR if $level =~ /^error$/io;
|
|
return WARNING if $level =~ /^warning$/io;
|
|
return INFO if $level =~ /^info$/io;
|
|
return DEBUG1 if $level =~ /^debug1$/io;
|
|
return DEBUG2 if $level =~ /^debug2$/io;
|
|
return DEBUG3 if $level =~ /^debug3$/io;
|
|
return DEBUG4 if $level =~ /^debug4$/io;
|
|
return DEBUG5 if $level =~ /^debug5$/io;
|
|
return DEBUG if $level =~ /^debug$/io;
|
|
return VARIABLE;
|
|
}
|
|
|
|
sub compare_levels ($$)
|
|
{
|
|
my ($reference, $level) = @_;
|
|
|
|
if ($reference == VARIABLE) {
|
|
$reference = defined $log_level && $log_level > 0 ? $log_level :
|
|
defined $verbose_flag && $verbose_flag ? INFO : WARNING;
|
|
}
|
|
elsif ($reference == DEBUG) {
|
|
$reference = defined $log_level && $log_level > 0 ? $log_level : INFO;
|
|
}
|
|
return $level <=> $reference;
|
|
}
|
|
|
|
sub compare_versions ($$)
|
|
{
|
|
my ($a, $b) = @_;
|
|
|
|
my $alist = [split(/\./, $a)];
|
|
my $blist = [split(/\./, $b)];
|
|
while (1) {
|
|
my $acomponent = shift @$alist;
|
|
my $bcomponent = shift @$blist;
|
|
if (defined $acomponent) {
|
|
return 1 unless defined $acomponent;
|
|
my $rc;
|
|
if ($acomponent =~ /^\d+$/o && $bcomponent =~ /^\d+$/o) {
|
|
$rc = $acomponent <=> $bcomponent;
|
|
}
|
|
else {
|
|
$rc = $acomponent cmp $bcomponent;
|
|
}
|
|
return $rc if $rc;
|
|
}
|
|
else {
|
|
return 0 unless defined $bcomponent;
|
|
return -1;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub get_win_major ()
|
|
{
|
|
my ($osver, $osmajor, $osminor, $osbuild) = Win32::GetOSVersion();
|
|
|
|
return $osmajor;
|
|
}
|
|
|
|
sub get_win_version ()
|
|
{
|
|
my ($osver, $osmajor, $osminor, $osbuild) = Win32::GetOSVersion();
|
|
|
|
return $osmajor.'.'.$osminor;
|
|
}
|
|
|
|
sub get_default_vars (;$)
|
|
{
|
|
my ($config) = @_;
|
|
|
|
my $genericvars = defined $config ? $$config{'generic-variables'} : undef;
|
|
my $globals = defined $config ? $$config{'global-variables'} : undef;
|
|
|
|
my $arch = $ENV{'PROCESSOR_ARCHITECTURE'} =~ /AMD64/io ? 'x64' : '';
|
|
my $xarch = $ENV{'PROCESSOR_ARCHITECTURE'} =~ /AMD64/io ? 'x64' : 'x86';
|
|
my $programfiles = $ENV{'ProgramFiles'};
|
|
my $programfiles32 = $ENV{'ProgramFiles(x86)'};
|
|
$programfiles32 = $programfiles unless defined $programfiles32;
|
|
|
|
my $vars = {};
|
|
foreach my $key (keys %ENV) {
|
|
$$vars{lc($key)} = $ENV{$key};
|
|
}
|
|
$$vars{arch} = $arch;
|
|
$$vars{xarch} = $xarch;
|
|
my ($osver, $osmajor, $osminor, $osbuild) = Win32::GetOSVersion();
|
|
if ($osmajor == 5 && $$osminor == 1) {
|
|
$$vars{os} = 'xp';
|
|
}
|
|
elsif ($osmajor == 6 && $$osminor == 1) {
|
|
$$vars{os} = '7';
|
|
}
|
|
elsif ($osmajor == 10) {
|
|
$$vars{os} = '10';
|
|
}
|
|
else {
|
|
$$vars{os} = 'unknown';
|
|
}
|
|
$$vars{osversion} = $osmajor.'.'.$osminor;
|
|
$$vars{osmajor} = $osmajor;
|
|
$$vars{osminor} = $osminor;
|
|
$$vars{osbuild} = $osbuild;
|
|
$$vars{programfiles32} = $programfiles32;
|
|
$$vars{pkgtooldir} = $pkgtool_dir;
|
|
$$vars{logdir} = $log_base_dir if defined $log_base_dir;
|
|
|
|
if (defined $genericvars) {
|
|
foreach my $genvar (@$genericvars) {
|
|
my $varname = $$genvar{variable};
|
|
my $expression = $$genvar{expression};
|
|
|
|
my $value = eval $expression;
|
|
my $error = $@;
|
|
next if defined $error && $error ne '';
|
|
$$vars{$varname} = $value;
|
|
}
|
|
}
|
|
if (defined $globals) {
|
|
foreach my $varname (keys %$globals) {
|
|
my $value = $$globals{$varname};
|
|
$$vars{$varname} = $value;
|
|
}
|
|
}
|
|
|
|
return $vars;
|
|
}
|
|
|
|
sub set_datetime_vars ($;$)
|
|
{
|
|
my ($vars, $now) = @_;
|
|
|
|
$now = time() unless defined $now;
|
|
my $date = strftime('%Y%m%d', localtime($now));
|
|
my $time = strftime('%H%M%S', localtime($now));
|
|
my $datetime = $date.'-'.$time;
|
|
$$vars{date} = $date;
|
|
$$vars{time} = $time;
|
|
$$vars{datetime} = $datetime;
|
|
}
|
|
|
|
sub substitute_variables ($$$;$$)
|
|
{
|
|
my ($vars, $expr, $ispath, $basedir, $channel) = @_;
|
|
|
|
print_log($channel, DEBUG3, 'Substitute_variables for: %s', $expr) if defined $channel;
|
|
|
|
$expr =~ s/\//\\/go if $ispath;
|
|
$expr =~ s/%([^%]+)%/defined $$vars{lc($1)} ? $$vars{lc($1)} : ''/ge;
|
|
$expr =~ s/%%/%/go;
|
|
if ($ispath && defined $basedir && $expr !~ /^[^:]:/o) {
|
|
print_log($channel, DEBUG3, 'Basedir: %s expr: %s', $basedir, $expr) if defined $channel;
|
|
if ($expr =~ /^\\/o) {
|
|
if ($basedir =~ /^([^:]:)/o) {
|
|
my $drive = $1;
|
|
$expr = $drive.$expr;
|
|
}
|
|
}
|
|
else {
|
|
$basedir .= '\\' unless $basedir =~ /\\$/o;
|
|
$expr = $basedir.$expr;
|
|
}
|
|
}
|
|
print_log($channel, DEBUG3, 'Result: %s', $expr) if defined $channel;
|
|
return $expr;
|
|
}
|
|
|
|
sub init_log_file ($)
|
|
{
|
|
my ($logdef) = @_;
|
|
|
|
my $ispkg = 0;
|
|
my $spec;
|
|
my $func;
|
|
my $type = $$logdef{type};
|
|
if ($type eq 'stderr') {
|
|
$spec = '<STDERR>';
|
|
$func = \&print_stderr_log;
|
|
}
|
|
elsif ($type eq 'file') {
|
|
$spec = $$logdef{path};
|
|
$func = \&print_to_log_file;
|
|
$ispkg = is_pkg_only_path($spec);
|
|
}
|
|
else {
|
|
print_log('global', ERROR, 'Unknown log type %s', $type);
|
|
return undef;
|
|
}
|
|
|
|
if ($ispkg) {
|
|
return undef unless defined $current_pkg_name;
|
|
}
|
|
|
|
my $log_file_registry;
|
|
if ($ispkg) {
|
|
$log_file_registry = $package_log_files;
|
|
}
|
|
else {
|
|
$log_file_registry = $global_log_files;
|
|
}
|
|
|
|
my $lfchan = {};
|
|
my $channels = $$logdef{channel};
|
|
foreach my $ch (keys %$channels) {
|
|
$$lfchan{$ch} = str2level($$channels{$ch});
|
|
}
|
|
|
|
if (defined $$log_file_registry{$spec}) {
|
|
print_log('global', ERROR, 'Trying to reinitialize %s log type %s%s',
|
|
$type, (defined $ispkg ? 'application '.$current_pkg_name : 'global'),
|
|
($type eq 'file' ? ' path '.$$logdef{path} : ''));
|
|
return undef;
|
|
}
|
|
my $lf = {
|
|
Definition => $logdef,
|
|
LogFunc => $func,
|
|
Channels => $lfchan
|
|
};
|
|
$$lf{PackageName} = $current_pkg_name if defined $current_pkg_name;
|
|
$$log_file_registry{$spec} = $lf;
|
|
$$logdef{Initialized} = 1;
|
|
return $lf;
|
|
}
|
|
|
|
sub close_all_log_files ($)
|
|
{
|
|
my ($pkgonly) = @_;
|
|
|
|
my $speclist = [keys %$package_log_files];
|
|
foreach my $spec (@$speclist) {
|
|
my $lf = $$package_log_files{$spec};
|
|
delete $$package_log_files{$spec};
|
|
my $def = $$lf{Definition};
|
|
delete $$def{Initialized} if defined $def;
|
|
close_log_file($lf);
|
|
}
|
|
return if $pkgonly;
|
|
$speclist = [keys %$global_log_files];
|
|
foreach my $spec (@$speclist) {
|
|
my $lf = $$global_log_files{$spec};
|
|
delete $$global_log_files{$spec};
|
|
my $def = $$lf{Definition};
|
|
delete $$def{Initialized} if defined $def;
|
|
close_log_file($lf);
|
|
}
|
|
}
|
|
|
|
sub init_log_files ()
|
|
{
|
|
foreach my $def (@$log_defs) {
|
|
next if defined $$def{Initialized};
|
|
init_log_file($def);
|
|
}
|
|
}
|
|
|
|
sub is_pkg_only_path ($)
|
|
{
|
|
my ($path) = @_;
|
|
|
|
return $path =~ /%(pkgname)%/io;
|
|
}
|
|
|
|
sub is_timebased_path ($)
|
|
{
|
|
my ($path) = @_;
|
|
|
|
return $path =~ /%(date|time|datetime)%/io;
|
|
}
|
|
|
|
sub set_current_pkg_name ($)
|
|
{
|
|
my ($pkgname) = @_;
|
|
|
|
if (defined $current_pkg_name) {
|
|
return if defined $pkgname && $current_pkg_name eq $pkgname;
|
|
close_all_log_files(1);
|
|
}
|
|
$current_pkg_name = $pkgname;
|
|
init_log_files();
|
|
}
|
|
|
|
sub get_log_file_name ($$)
|
|
{
|
|
my ($pkgname, $path) = @_;
|
|
|
|
my $vars = get_default_vars();
|
|
set_datetime_vars($vars);
|
|
$$vars{pkgname} = $pkgname if defined $pkgname;
|
|
return substitute_variables($vars, $path, 1, $log_base_dir);
|
|
}
|
|
|
|
sub get_log_template_name ($$)
|
|
{
|
|
my ($pkgname, $path) = @_;
|
|
|
|
my $vars = get_default_vars();
|
|
$$vars{date} = '????????';
|
|
$$vars{time} = '??????';
|
|
$$vars{datetime} = '????????-??????';
|
|
$$vars{pkgname} = $pkgname if defined $pkgname;
|
|
return substitute_variables($vars, $path, 1, $log_base_dir);
|
|
}
|
|
|
|
sub generate_log_file_name ($)
|
|
{
|
|
my ($lf) = @_;
|
|
|
|
if (! defined $$lf{CurrentFileName}) {
|
|
my $def = $$lf{Definition};
|
|
$$lf{CurrentFileName} = get_log_file_name($$lf{PackageName}, $$def{path});
|
|
}
|
|
return $$lf{CurrentFileName};
|
|
}
|
|
|
|
sub open_log_file ($)
|
|
{
|
|
my ($lf) = @_;
|
|
|
|
return 1 if defined $$lf{Handle};
|
|
my $path = generate_log_file_name($lf);
|
|
local *LH;
|
|
return 0 unless open(LH, '>>', $path);
|
|
LH->autoflush(1);
|
|
$$lf{Handle} = *LH;
|
|
return 1;
|
|
}
|
|
|
|
sub close_log_file ($)
|
|
{
|
|
my ($lf) = @_;
|
|
|
|
if (defined $$lf{Handle}) {
|
|
close($$lf{Handle});
|
|
delete $$lf{Handle};
|
|
}
|
|
}
|
|
|
|
sub rotate_log_file ($)
|
|
{
|
|
my ($lf) = @_;
|
|
|
|
return unless defined $$lf{Handle};
|
|
my $def = $$lf{Definition};
|
|
return unless defined $def && defined $$def{type} && $$def{type} eq 'file';
|
|
|
|
my $rotate = $$def{rotate};
|
|
return unless defined $rotate;
|
|
my $template = $$rotate{name};
|
|
next unless defined $template;
|
|
$template = File::Spec->canonpath($template);
|
|
my $maxsize = $$rotate{'max-kb'};
|
|
return unless defined $maxsize && $maxsize > 0;
|
|
$maxsize *= 1024;
|
|
my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size) =
|
|
stat($$lf{Handle});
|
|
return unless defined $size && $size >= $maxsize;
|
|
close_log_file($lf);
|
|
|
|
if (! is_timebased_path($$def{path})) {
|
|
my $newname = get_log_file_name($$lf{PackageName}, $template);
|
|
my $oldname = $$lf{CurrentFileName};
|
|
rename($oldname, $newname);
|
|
}
|
|
delete $$lf{CurrentFileName};
|
|
|
|
my $maxhist = $$rotate{'max-num'};
|
|
if (defined $maxhist && $maxhist > 0) {
|
|
my ($vol, $dir, $file) = File::Spec->splitpath(get_log_template_name($$lf{PackageName}, $template));
|
|
$dir = $vol.$dir;
|
|
return if $dir =~ /\?/o;
|
|
if (opendir(DIR, $dir)) {
|
|
$dir .= '\\' unless $dir =~ /\\$/o;
|
|
$file =~ s/\./\\./go;
|
|
$file =~ s/\?/[0-9]/go;
|
|
my $list = [];
|
|
while (1) {
|
|
my $entry = readdir(DIR);
|
|
last unless defined $entry;
|
|
next if $entry eq '.' || $entry eq '..';
|
|
next unless $entry =~ /^$file$/;
|
|
push @$list, $entry;
|
|
}
|
|
closedir(DIR);
|
|
if (scalar @$list > $maxhist) {
|
|
$list = [sort @$list];
|
|
while (1) {
|
|
my $filename = $dir;
|
|
$filename .= shift @$list;
|
|
unlink($filename);
|
|
last if scalar @$list <= $maxhist;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
open_log_file($lf);
|
|
}
|
|
|
|
sub setup_log_msg_prefix ($)
|
|
{
|
|
my ($msg) = @_;
|
|
|
|
return if defined $$msg{Prefix};
|
|
my $levelstr = $$msg{LevelStr};
|
|
$levelstr = $$msg{LevelStr} = level2str($$msg{Level}) unless defined $levelstr;
|
|
$$msg{Prefix} = strftime('%Y-%m-%d %H:%M:%S', localtime($$msg{TimeStamp})).
|
|
' ['.$$msg{Channel}.'/'.$levelstr.'] ';
|
|
}
|
|
|
|
sub process_log_msg ($)
|
|
{
|
|
my ($msg) = @_;
|
|
|
|
return if defined $$msg{Output};
|
|
$$msg{Output} = sprintf($$msg{Message}, @{$$msg{Parameters}});
|
|
}
|
|
|
|
sub print_to_log_file ($$)
|
|
{
|
|
my ($lf, $msg) = @_;
|
|
|
|
return 0 unless open_log_file($lf);
|
|
rotate_log_file($lf);
|
|
setup_log_msg_prefix($msg);
|
|
process_log_msg($msg);
|
|
print { $$lf{Handle} } $$msg{Prefix}.$$msg{Output}."\n";
|
|
return 1;
|
|
}
|
|
|
|
sub print_stderr_log ($$)
|
|
{
|
|
my ($lf, $msg) = @_;
|
|
|
|
process_log_msg($msg);
|
|
print $orig_stderr $$msg{Output}."\n";
|
|
return 1;
|
|
}
|
|
|
|
sub print_log_into_logfile ($$)
|
|
{
|
|
my ($lf, $msg) = @_;
|
|
|
|
my $func = $$lf{LogFunc};
|
|
return 0 unless defined $func;
|
|
my $channels = $$lf{Channels};
|
|
return 0 unless defined $channels;
|
|
my $minlevel = $$channels{$$msg{Channel}};
|
|
return 0 unless defined $minlevel;
|
|
return 1 unless compare_levels($minlevel, $$msg{Level}) <= 0;
|
|
return &{$func}($lf, $msg);
|
|
}
|
|
|
|
sub print_log ($$$@)
|
|
{
|
|
my ($channel, $level, $message, @params) = @_;
|
|
|
|
my $msg = {
|
|
TimeStamp => time(),
|
|
Channel => $channel,
|
|
Level => $level,
|
|
Message => $message,
|
|
Parameters => [@params]
|
|
};
|
|
|
|
my $list = [values %$global_log_files];
|
|
push @$list, values %$package_log_files if $channel eq 'pkg';
|
|
my $ok = 0;
|
|
foreach my $lf (@$list) {
|
|
$ok = 1 if print_log_into_logfile($lf, $msg);
|
|
}
|
|
return if $ok;
|
|
print_log_into_logfile($fallback_log_file, $msg);
|
|
}
|
|
|
|
sub set_log_defs ($)
|
|
{
|
|
my ($defs) = @_;
|
|
|
|
$log_defs = $defs;
|
|
init_log_files();
|
|
}
|
|
|
|
use Carp;
|
|
|
|
$SIG{__DIE__} = sub {
|
|
die @_ unless defined $^S && $^S == 0 && defined Carp::longmess;
|
|
print_log('global', FATAL, '%s',
|
|
join(', ', map {
|
|
my $x = $_;
|
|
$x =~ s/\r?\n[ \t]*$//os;
|
|
$x =~ s/\.\r?\n[ \t]*/. /gos;
|
|
$x =~ s/\r?\n[ \t]*/, /gos;
|
|
$x =~ s/^ +//o;
|
|
$x
|
|
} Carp::longmess(@_)));
|
|
die 'Fatal error: exiting'."\n";
|
|
};
|
|
$SIG{__WARN__} = sub {
|
|
print_log('global', WARNING, '%s',
|
|
join(', ', map {
|
|
my $x = $_;
|
|
$x =~ s/\r?\n[ \t]*$//os;
|
|
$x =~ s/\.\r?\n[ \t]*/. /gos;
|
|
$x =~ s/\r?\n[ \t]*/, /gos;
|
|
$x =~ s/^ +//o;
|
|
$x
|
|
} @_));
|
|
};
|
|
|
|
1;
|