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();
	$$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;