package ActivePerl::PPM::Logger;

use strict;
use base qw(Exporter);

our @EXPORT = qw(LOG_EMERG LOG_ALERT LOG_CRIT LOG_ERR LOG_WARNING LOG_NOTICE LOG_INFO LOG_DEBUG
                 ppm_logger
		 ppm_log ppm_debug ppm_status);
our @EXPORT_OK = qw();

use Carp qw(croak);
use HTTP::Date qw(time2iso);
use File::Basename qw(basename);

# syslog inspired constants
sub LOG_EMERG   () { 0 }
sub LOG_ALERT   () { 1 }
sub LOG_CRIT    () { 2 }
sub LOG_ERR     () { 3 }
sub LOG_WARNING () { 4 }
sub LOG_WARN    () { 4 }  # unofficial
sub LOG_NOTICE  () { 5 }
sub LOG_INFO    () { 6 }
sub LOG_DEBUG   () { 7 }

my $logger;
my $status;

sub ppm_logger {
    return $logger ||= ActivePerl::PPM::Logger->new;
}

sub ppm_log {
    ($logger || ppm_logger())->log(@_);
}

sub ppm_debug {
    ppm_log(LOG_DEBUG, @_);
}

sub ppm_status {
    unless ($status) {
	if (exists &ActivePerl::PPM::GUI::Status::begin) {
	    $status = ActivePerl::PPM::GUI::Status->new;
	}
	elsif (-t *STDOUT) {
	    require ActivePerl::PPM::Status::Term;
	    $status = ActivePerl::PPM::Status::Term->new;
	    $| = 1;
	}
	else {
	    require ActivePerl::PPM::Status;
	    $status = ActivePerl::PPM::Status->new;
	}
    }
    return $status unless @_;

    my $method = shift;
    return $status->$method(@_);
}

#
#  Objects
#

sub new {
    my($class, %opt) = shift;

    my $logfile = $opt{file} || $ENV{ACTIVEPERL_PPM_LOG_FILE} ||
	($ENV{ACTIVEPERL_PPM_HOME} ? "$ENV{ACTIVEPERL_PPM_HOME}/ppm4.log" :
	 ($^O eq "MSWin32" ? "$ENV{TEMP}\\ppm4.log" : "$ENV{HOME}/ppm4.log"));
    my $fh;
    if ($ENV{HARNESS_ACTIVE}) {
	# suppress logging when running under Test::Harness
	$opt{level} ||= 1;
    }
    elsif (open($fh, ">>", $logfile)) {
	require IO::Handle;  # adds methods to $fh
	$fh->autoflush;
    }
    else {
	warn "Can't log to '$logfile': $!";
	$opt{cons}++;
	undef($fh);
    }

    return bless {
        level => _num_prio($opt{level} || $ENV{ACTIVEPERL_PPM_LOG_LEVEL} || LOG_DEBUG()),
        cons => ($opt{cons} || $ENV{ACTIVEPERL_PPM_LOG_CONS}),
        callinfo => 1, #($opt{callinfo} || $ENV{ACTIVEPERL_PPM_LOG_CALLINFO}),
	logfile => $logfile,
	fh => $fh,
    }, $class;
}

sub log {
    my $self = shift;
    my $prio = _num_prio(shift);
    my $msg = shift;

    return if $prio > ($self->{level} || LOG_INFO);

    if ($self->{callinfo}) {
	# fill in caller info
	my $i = 0;
	CALLER: {
	    my($pkg, $file, $line) = caller($i++);
	    redo CALLER if $pkg eq __PACKAGE__;
	    $file = basename($file);
	    substr($msg, 0, 0) = "[$file:$line] ";
	};
    }

    # clean up message
    $msg =~ s/^\s+//;
    $msg =~ s/\s+\z//;
    $msg =~ s/\s+/ /g;
    $msg .= "\n";

    if ($self->{cons}) {
	print STDERR $msg;
    }

    if (my $fh = $self->{fh}) {
	my @t = (localtime)[reverse 0..5];
	$t[0] += 1900; # year
	$t[1] ++;      # month
	$fh->print(sprintf "%04d-%02d-%02dT%02d:%02d:%02d <%d> %s", @t, $prio, $msg);
    }
}

sub logfile {
    my $self = shift;
    return $self->{logfile};
}

sub _num_prio {
    my $prio = shift;
    unless ($prio =~ /^\d+$/) {
	no strict 'refs';
	if (defined &{"LOG_$prio"}) {
	    $prio = &{"LOG_$prio"};
	}
	else {
	    croak("Unrecognized log priority '$prio'");
	}
    }
    return $prio;
}

1;