MMAgic/Log.pm

Go to the documentation of this file.

package MMAgic::Log;
#
# MMAgic/Log.pm
#
#   Object representing an output log stream.
#   Output is formatted with type tags and timestamps.
#

use     strict;
use     warnings;

use     Exporter;
use     POSIX;
use     UNIVERSAL   qw(isa);

use     MMAgic::Log::Indent;
use     MMAgic::Output;
use     MMAgic::Trace;

our     @ISA    = qw(Exporter MMAgic::Output);
our     @EXPORT = qw(Log);

our     $hashkey;
our     $signals;
our     $special;
our     @stack;

###########################################################################
###########################################################################
sub new ($;%)   #
#
    {
    my ($class, %parms) = @_;
    my  $self = new MMAgic::Output(%parms);
    
    return undef
        unless isa($self, 'MMAgic::Output');
    
    bless $self, $class;
    
    $self->{code} = 'T';
    $self->{dGMT} = $parms{GMT}      || $ENV{MMAgic_Log_GMT};
    $self->{dFmt} = $parms{timeOnly} || $ENV{MMAgic_Log_timeOnly}
                  ? '%H:%M:%S' : '%Y/%m/%d %H:%M:%S';
    
    if ($self->{handle} && ! $self->{noFlush})
        {
        # suceeded, turn on auto-flushing:
        my  $oldFH = select($self->{handle});
        
        $| = 1;
        select($oldFH);
        }
        
    $self
    }

###########################################################################
sub Log         # [ $class ]
#
    {
    unshift @stack, new MMAgic::Log(output => \*STDERR)
        unless @stack;

    $stack[0]
    }

###########################################################################
sub pushLog     # [ $class, ] $log | %init
#
    {
    my  $log = shift;

    # Get rid of optional class argument:
    $log = shift if isa($log, __PACKAGE__) && ! ref $log;
    
    # See which argument form we have:
    unless (isa($log, __PACKAGE__))
        {
        # Must create Log object from parameters:
        my  %init = ( $log, @_ );
        my  $type = $init{logType};
        
        if ($type)
            {
            $type = "MMAgic::Log::$type";
            
            eval "use $type";
            
            die "Unable to load $type:\n  $@\n"
                if $@;
            }
        
        $type = __PACKAGE__
            unless $type;
        
        $log = $type->new(%init);
        }

    unshift @stack, $log
        if isa($log, __PACKAGE__);

    $stack[0]
    }

###########################################################################
sub popLog      # [ $class ]
#
    {
    shift @stack
    }

###########################################################################
###########################################################################
sub handle      # [ $class ] [ @which ]
# Capture warn and/or die handlers and redirect to current log.
#   This would be a permanent fix, the user being responsible for
#   backing the out if necessary.
#
    {
    shift if isa($_[0], __PACKAGE__);
    
#!# my  $auto = Log->method(@_)->block;
    
    map {
#!#     Log->trace('Which:  ', $_);
        
        if (/^warn/i)
            {
            $SIG{__WARN__} = \&handleWarn;
            }
        
        elsif (/^die/i)
            {
            $SIG{__DIE__} = \&handleDie;
            }
        
        else
            {
            Log->warn('Unable to Log ', $_, ' messages');
            }
        } @_ ? @_ : qw(warn die);
    }

###########################################################################
sub handleWarn  #
# Redirect warnings to log file.
#
    {
    Log->warning(shift);
    }

###########################################################################
sub handleDie   #
# Redirect die messages to log file.
#
    {
    # Unfortunately, the $SIG{__DIE__} handler is somewhat broken,
    #   we don't want to fire if we're wrapped in an eval somewhere:
    my  $up = 0;
    
    while (1)
        {
        my ($pkg, $file, $line, $sub) = caller($up++);
        
        last unless $pkg;
        
        return if $file eq '(eval)' || $sub eq '(eval)';
        }
    
    Log->critical(shift);
    
#   die "DIE:  Final error message in MMAgic::Log repository!\n"
    die "\n"
    }

###########################################################################
###########################################################################
sub starter         # $self
#
    {
    my  $self = shift;
    my  $now  = $self->timestamp($self->{msgT});
    
    $self->SUPER::starter;
    $self->process("$now [$self->{msgC}] ");
    $self->{msgC} = '+';
    $self
    }

###########################################################################
sub timestamp   # [ $clasSelf ] [ $when ]
#
    {
    my ($self, $when) = @_;
    
    if (! isa($self, __PACKAGE__))
        {
        $when = $self;
        $self = Log;
        }
    
    unless ($when && int($when))
        {
        $when = $self->{msgT};
        $when = time unless $when && int($when);
        }
    
    return strftime
        ($self->{dFmt},
         $self->{dGMT} ? gmtime($when) : localtime($when));
    }

###########################################################################
###########################################################################
sub block   # [ $clasSelf, ] [ $incr ]
# Returns 'auto-indent' object.
#   Indent is started and then removed when the object is destroyed.
#
    {
    my  $target = shift;
    
    $target = Log unless isa($target, __PACKAGE__);

    new MMAgic::Log::Indent($target, @_)
    }

###########################################################################
sub push        # $clasSelf [, $incr]
#
    {
    my  $target = shift;

    $target = Log unless isa($target, __PACKAGE__);
    $target->pushIndent(shift);
    }

###########################################################################
sub pop         # $clasSelf
#
    {
    my  $target = shift;

    $target = Log unless isa($target, __PACKAGE__);
    $target->popIndent;
    }

###########################################################################
sub withIndent  # $clasSelf, $sub, @args
#
    {
    my  $target = shift;
    my  $sub    = shift;
    
    $target = Log unless isa($target, __PACKAGE__);
    $target->push;
    
    my  $result = eval { &$sub(@_); };
    my  $error  = $@;

    $target->pop;

    die $error if $error;

    $result
    }

###########################################################################
###########################################################################
sub flush   # $self
# Flush pending output.
#   Override the basic MMAgic::Output method which prints nasty messages.
#
    {
    # Still can't actually do anything...
    shift
    }

###########################################################################
sub message     # $self, [ timestamp, ] $code, ...
#
    {
    my  $self = shift;
    
    $self = Log unless ref($self) eq __PACKAGE__;
    
    my  $strt = $self->{msgT};
    
    $self->{msgC} = '?';
    $self->{msgT} = shift;
    
    if ($self->{msgT} !~ /\D/)  # check for integer
        {
        # Timestamp was actually provided:
        $self->{msgC} = shift || $self->{code};
        }
    
    else
        {
        # No timestamp, was flag instead:
        $self->{msgC} = $self->{msgT};
        $self->{msgT} = time;
        }

    $self->newLine;
    
    my  @args = @_; # don't know why this is necessary,
                    #   but can't just use @_ inside of eval
    eval
        {
        $self->print(@args);
        $self->newLine;
        };

    $self->{msgT} = $strt;
    $self->flush;
    $self
    }

###########################################################################
sub append      # [ $clasSelf, ] ...
#
    {
    my  $target = shift;
    
    $target = Log unless isa($target, __PACKAGE__);
    $target->message('+', @_);
    }

###########################################################################
sub critical    # [ $clasSelf, ] ...
#
    {
    my  $target = shift;
    
    $target = Log unless isa($target, __PACKAGE__);
    $target->message('C', @_);
    }

###########################################################################
sub error       # [ $clasSelf, ] ...
#
    {
    my  $target = shift;
    
    $target = Log unless isa($target, __PACKAGE__);
    $target->message('E', @_);
    }

###########################################################################
sub info        # [ $clasSelf, ] ...
#
    {
    my  $target = shift;

    $target = Log unless isa($target, __PACKAGE__);
    $target->message('I', @_);
    }

###########################################################################
sub trace       # [ $clasSelf, ] ...
#
    {
    my  $target = shift;
    
    $target = Log unless isa($target, __PACKAGE__);
    $target->message('T', @_);
    }

###########################################################################
sub unknown     # [ $clasSelf, ] ...
#
    {
    my  $target = shift;
    
    $target = Log unless isa($target, __PACKAGE__);
    $target->message('?', @_);
    }

###########################################################################
sub warning     # [ $clasSelf, ] ...
#
    {
    my  $target = shift;
    
    $target = Log unless isa($target, __PACKAGE__);
    $target->message('W', @_);
    }

###########################################################################
###########################################################################
sub crash       # [ $clasSelf, ] ...
#
    {
    my  $target = shift;

    $target = Log unless isa($target, __PACKAGE__);
    $target->message('C', @_);
    
    my ($pkg, $file, $line) = caller;
    
    die "Crashed at $file line $line\n"
    }

###########################################################################
sub bail        # [ $clasSelf, ] ...
#
    {
    warn 'Log::bail() deprecated, use Log::crash() instead';

    crash(@_)
    }

###########################################################################
sub method      # [ $clasSelf, ] ...
#
{
    my  $target = shift;
    
    $target = Log unless isa($target, __PACKAGE__);

    my ($pkg, undef, undef, $sub) = caller(1);
    my  $flag = 'T';
    my  $indt = '';
    
    if ($_[0] && $_[0] =~ /^\[(.)\](.*)$/)
        {
        # Special first argument to specify message flag and indent:
        $flag = $1;
        $indt = $2;
        shift;
        }

    shift if isa($_[0], $pkg);
    
    local   $special = undef;
    local   $hashkey = undef;
    
    $target->message
        ($flag, $indt, $sub, '(',
         join(', ', map
            {
            my  $result = defined($_) ? $_ : '<undef>';
            
            if ($special)
                {
                if ($hashkey)
                    {
                    $result = "$hashkey => $result";
                    undef $hashkey;
                    }
                
                else
                    {
                    $hashkey = $_;
                    undef $result;
                    }
                }
            
            elsif ($result eq '%')
                {
                $special = 1;
                undef $result;
                }
            
            defined($result) ? $result : ( )
            } @_), ')'
        );
    }

###########################################################################
sub where       # [ $line ]
#
    {
    shift if isa $_[0], __PACKAGE__;
    
    my ($func, $pkg, $stack) = ('eval', undef, 1);
    
    ($pkg, undef, undef, $func) = caller($stack++)
        while $func =~ /\b(?:eval|where)\b/;
    
    my  $where = "${pkg}::${func}()";
    
    $where .=  "\n  file @{[ shift ]}" if @_;
    $where .=  "\n  line @{[ shift ]}" if @_;
    $where  =~ s/^main:://i;
    $where
    }

###########################################################################
###########################################################################
sub signals     # [ $clasSelf, ] $flag
# Turn signal capture and redirection on and off.
#   Don't know if this actually works.
#   And then there's the __DIE__ over-zealous problem.
#
    {
    my  $flag = shift;
    
    $flag = shift if isa($flag, __PACKAGE__);
    
    return if $flag == $signals;
    
    if ($flag)
        {
        $SIG{__WARN__} = sub { Log->Error   (@_) };
        $SIG{__DIE__}  = sub { Log->Critical(@_) };
        }
    
    else
        {
        delete $SIG{__DIE__};
        delete $SIG{__WARN__};
        }
    
    $signals = $flag;
    }

###########################################################################
sub display     # $self, $item, %param
# Dump an object to a Log.
#
    {
    my  $self = shift;
    my  $item = shift;
    my  %param;
    
    if (@_ == 1) {
        # Support old-style shortcut which I keep doing...
        #   it just makes sense most of the time.
        $param{prefix} = shift;
        $param{prefix} =~ s/\s*$/ => /
            unless $param{prefix} =~ /=>\s*/;
    } elsif (@_) {
        %param = @_;
    }
    
    $self->{msgC} = $param{code} || $self->{code};
    
    delete $param{code}
        if exists $param{code};
    
    $self->newLine;
    $self->SUPER::display($item, %param);
    $self->flush;
    $self
    }

###########################################################################
###########################################################################
my  $deprecated;

sub reference   # $self, $target, %param
# Dump a reference-based object to Log.
#
    {
    my  $self = shift;
    my  $targ = shift;
    
    Log->warning(__PACKAGE__, '::reference() deprecated in favor of ',
                 __PACKAGE__, '::display()')
        unless $deprecated++;
    
    # Cover for ancient calling convention
    #   ($self, $target [, $code]):
    $self->{msgC} = shift
        if @_ == 1;
    
    $self->display(@_, $targ, @_)
    }

1