File Coverage

blib/lib/Config/Manager/Report.pm

Criterion	Covered	Total	%
statement	203	328	61.8
branch	50	136	36.7
condition	17	61	27.8
subroutine	17	26	65.3
pod	0	14	0.0
total	287	565	50.8

###############################################################################
##                                                                           ##
##    Copyright (c) 2003 by Steffen Beyer & Gerhard Albers.                  ##
##    All rights reserved.                                                   ##
##                                                                           ##
##    This package is free software; you can redistribute it                 ##
##    and/or modify it under the same terms as Perl itself.                  ##
##                                                                           ##
###############################################################################

package Config::Manager::Report;

use strict;
use vars qw( @ISA @EXPORT @ALL @AUX @EXPORT_OK %EXPORT_TAGS $VERSION %SIG
             $SHOW_ALL $USE_LEADIN $STACKTRACE
             $LEVEL_TRACE $LEVEL_INFO $LEVEL_WARN $LEVEL_ERROR $LEVEL_FATAL
             $FROM_HOLD $TO_HLD $TO_OUT $TO_ERR $TO_LOG
             @TRACE @INFO @WARN @ERROR @FATAL );

require Exporter;

@ISA = qw(Exporter);

@EXPORT = qw();

@ALL = qw( $SHOW_ALL $USE_LEADIN $STACKTRACE
           $LEVEL_TRACE $LEVEL_INFO $LEVEL_WARN $LEVEL_ERROR $LEVEL_FATAL
           $FROM_HOLD $TO_HLD $TO_OUT $TO_ERR $TO_LOG
           @TRACE @INFO @WARN @ERROR @FATAL
           end abort );

@AUX = qw( Normalize MakeDir );

@EXPORT_OK = (@ALL,@AUX);

%EXPORT_TAGS =
(
    all => [@ALL],
    aux => [@AUX],
    ALL => [@EXPORT_OK]
);

$VERSION = '1.7';

use Config::Manager::Conf qw( whoami );
use Symbol;

#######################
## Public constants: ##
#######################

$TO_HLD      = 0x01;
$TO_OUT      = 0x02;
$TO_ERR      = 0x04;
$TO_LOG      = 0x08;
$FROM_HOLD   = 0x10;

$USE_LEADIN  = 0x01;
$STACKTRACE  = 0x02;

$LEVEL_TRACE = 0x00;
$LEVEL_INFO  = 0x04;
$LEVEL_WARN  = 0x08;
$LEVEL_ERROR = 0x0C;
$LEVEL_FATAL = 0x10;

$SHOW_ALL    = 0x00;

@TRACE = ( $TO_LOG          , $LEVEL_TRACE + $USE_LEADIN );
@INFO  = ( $TO_LOG + $TO_OUT, $LEVEL_INFO  + $USE_LEADIN );
@WARN  = ( $TO_LOG + $TO_ERR, $LEVEL_WARN  + $USE_LEADIN );
@ERROR = ( $TO_LOG + $TO_HLD, $LEVEL_ERROR + $USE_LEADIN );
@FATAL = ( $TO_LOG + $TO_HLD, $LEVEL_FATAL + $USE_LEADIN );

#######################################
## Internal configuration constants: ##
#######################################

my $LOGSUFFIX = 'log';

my @LOGFILEPATH  = ('DEFAULT', 'LOGFILEPATH');
my @FULLNAME     = ('Person',  'Name');

my $RULER   = '_' x 78 . "\n";
my $HEADER  = 'STARTED';
my $CMDLINE = 'COMMAND';
my $LOGFILE = 'LOGFILE';
my $FOOTER  = 'ENDED';

my @LEADIN =
(
    [ 'TRACE',  'HINT',  'WARNING',  'ERROR',  'EXCEPTION'  ], # Singular
    [ 'TRACES', 'HINTS', 'WARNINGS', 'ERRORS', 'EXCEPTIONS' ]  # Plural
);

my $LINE0 = 'line on hold';
my $LINE1 = 'lines on hold';

my $STAT_MIN = 1;
my $STAT_MAX = 4;

my $STARTDEPTH = 0;
my $MAXEVALLEN = 0; # 0 = no limit

#######################
## Global variables: ##
#######################

my $Singleton = 0;

my @Inventory = ();

my $User = (&whoami())[0] || '';

my $Count = 0;

########################
## Private functions: ##
########################

sub _warn_
{
    my($text) = @_;
    $text =~ s!\s+$!!;
    Config::Manager::Report->report
    (
        $TO_LOG+$TO_ERR, $LEVEL_WARN+$USE_LEADIN, $text
    )
}

sub _die_
{
    my($text) = @_;
    $text =~ s!\s+$!!;
    Config::Manager::Report->report
    (
        $TO_LOG+$TO_ERR, $LEVEL_FATAL+$USE_LEADIN, $text
    )
    if (defined $^S); # no logging during startup
}

sub _adjust # code "stolen" from Carp.pm:
{
    my($pack,$file,$line,$sub,$hargs,$warray,$eval,$require) = @_;

    if (defined $eval)
    {
        if ($require)
        {
            $sub = "require $eval";
        }
        else
        {
            if ($MAXEVALLEN && length($eval) > $MAXEVALLEN)
            {
                substr($eval,$MAXEVALLEN) = '...';
            }
            $eval =~ s!([\\\'])!\\$1!g;
            $sub = "eval '$eval'";
        }
    }
    elsif ($sub eq '(eval)')
    {
        $sub = 'eval {...}';
    }
    return $sub;
}

sub _ShortTime
{
    my($s,$m,$h,$dd,$mm,$yy) = localtime(time);
    $yy %= 100;
    $mm++;
    return sprintf("%02d%02d%02d-%02d%02d%02d", $yy,$mm,$dd,$h,$m,$s);
}

sub _LongTime
{
    my($s,$m,$h,$dd,$mm,$yy) = localtime(time);
    $yy += 1900;
    $mm = (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mm];
    return sprintf("%02d-%s-%d %02d:%02d:%02d", $dd,$mm,$yy,$h,$m,$s);
}

sub _which
{
    my($self) = shift;

    if (ref $self) { return $self; }
    else
    {
        unless (ref $Singleton)
        {
            if (ref ($Singleton = Config::Manager::Report->new(@_)))
            {
                ${$Singleton}{'singleton'} = 1;
                $SIG{'__WARN__'} = \&_warn_;
                $SIG{'__DIE__'}  = \&_die_;
            }
        }
        return $Singleton;
    }
}

sub DESTROY
{
    my($self,$close) = @_;
    my($text,$item,$count,$file,$handle);

    return unless (ref $self and keys %{$self});
    $text = "\n" . $RULER . "\n $FOOTER: " . _LongTime();
    for ( $item = $STAT_MIN; $item <= $STAT_MAX; $item++ )
    {
        if ((defined ($count = ${${$self}{'stat'}}[$item])) && ($count > 0))
        {
            $text .= " - $count ";
            if ($count == 1) { $text .= ucfirst(lc($LEADIN[0][$item])); }
            else             { $text .= ucfirst(lc($LEADIN[1][$item])); }
        }
    }
    if (($count = scalar(@{${$self}{'hold'}})) > 0)
    {
        $text .= " - $count ";
        if ($count == 1) { $text .= $LINE0; }
        else             { $text .= $LINE1; }
    }
    $text .= "\n" . $RULER;
    $file   = ${$self}{'file'};
    $handle = ${$self}{'hand'};
    ${$self}{'level'} = $SHOW_ALL;
    if (${$self}{'flag'})
    {
        $self->report($TO_LOG+$TO_OUT,$LEVEL_INFO,"$LOGFILE = '$file'");
    }
    $self->report($TO_LOG,$LEVEL_INFO,$text);
    # Enable creation of new singleton object if necessary:
    $Singleton = 0 if (${$self}{'singleton'});
    # Prevent closing it again at global destruction time:
    %{$self} = ();
    $text = '';
    unless (close($handle))
    {
        if ($close)
        {
            $text = __PACKAGE__ . "::close(): Can't close logfile '$file': $!";
        }
        else
        {
            $text = __PACKAGE__ . "::DESTROY(): Can't close logfile '$file': $!";
            print STDERR "$text\n";
        }
    }
    return $text;
}

END { &end(); }

#######################
## Public functions: ##
#######################

sub end
{
    $SIG{'__WARN__'} = 'DEFAULT';
    $SIG{'__DIE__'}  = 'DEFAULT';
    while (@Inventory)
    {
        pop(@Inventory)->DESTROY();
    }
}

sub abort
{
    &end();
    print STDERR @_ if @_;
    print STDERR "\n";
    exit 1;
}

sub Normalize
{
    my $dir = defined $_[0] ? $_[0] : '';
    my $drv = '';

    if    ($dir =~ s!^([a-zA-Z]:)!!) { $drv = $1;  }
    elsif ($dir !~ m!^[/\\]!)        { $drv = '.'; }
    $dir = "/$dir/";
    $dir =~ s!\\!/!g;
    $dir =~ s!//+!/!g;
    while ($dir =~ s!/(?:\./)+!/!g) {};
    while ($dir =~ s,/(?!\.\./)[^/]+/\.\./,/,g) {};
    $dir =~ s!^/(?:\.\./)+!/!g;
    $dir =~ s!^/!!;
    $dir =~ s!/$!!;

    return wantarray ? ($drv,$dir) : "$drv/$dir";
}

sub MakeDir
{
    my($drv,$dir) = Normalize($_[0]);
    my(@dir);
    local($!);

    return '' if (-d "$drv/$dir");
    @dir = split(/\//, $dir);
    $dir = $drv;
    while (@dir)
    {
        $dir .= '/' . shift(@dir);
        unless (-d $dir)
        {
            unless (mkdir($dir,0777))
            {
                return "Can't mkdir '$dir': $!";
            }
        }
    }
    return '';
}

#####################
## Public methods: ##
#####################

sub singleton
{
    shift;                        # discard class name
    return _which($Singleton,@_); # trigger creation if necessary
}

sub new
{
    my($class) = shift || __PACKAGE__;
    my($tool)  = shift || '';
    my($path)  = shift || '';
    my($file)  = shift || '';
    my($err,$name,$user,$handle,$self,$time,$text);
    local($_); # because of map()

    $class = ref($class) || $class;
    $name = Config::Manager::Conf->get(@FULLNAME) || '';
    if ($tool =~ /^\s*$/)
    {
        $tool = $0;
        $tool =~ s!^.*[/\\]!!;
        $tool =~ s!\.+[^\.]*$!!;
    }
    if ($path =~ /^\s*$/)
    {
        unless (defined ($path = Config::Manager::Conf->get(@LOGFILEPATH)))
        {
            $err = Config::Manager::Conf->error();
            $err =~ s!\s+$!!;
            return(__PACKAGE__ .
                "::new(): Can't find log directory in configuration data: $err");
        }
    }
    $file =~ s!^.*[/\\]!!;
    if ($file =~ /^\s*$/)
    {
        $user = $User || $name || 'unknown';
        $user =~ s!\s+!!g;
        $path .= "/$tool/$user";
        $file = join('-', $tool, $user, _ShortTime(), $$, ++$Count) . '.' . $LOGSUFFIX;
    }
    if ($err = MakeDir($path))
    {
        return(__PACKAGE__ .
            "::new(): Can't create log directory '$path': $err");
    }
    $file = Normalize("$path/$file");
    $handle = gensym();
    unless (open($handle, ">$file"))
    {
        return(__PACKAGE__ .
            "::new(): Can't open logfile '$file': $!");
    }
    select( ( select($handle), $| = 1 )[0] );
    $self = { };
    bless($self, $class);
#   ${$self}{'user'} = $User;
#   ${$self}{'name'} = $name;
#   ${$self}{'tool'} = $tool;
#   ${$self}{'path'} = $path;
    ${$self}{'file'} = $file;   # logfile name
    ${$self}{'hand'} = $handle; # logfile handle
    ${$self}{'hold'} = [ ];     # for putting lines on hold
    ${$self}{'stat'} = [ ];     # for statistics
    ${$self}{'flag'} = 0;       # for automatic dump of logfile name
    ${$self}{'level'} = $SHOW_ALL;
    # (for suppressing messages below the indicated level)
    $user = $User;
    if (($user !~ /^\s*$/) && ($name !~ /^\s*$/))
    {
        $user = "$name ($user)";
    }
    else
    {
        if ($user =~ /^\s*$/)
        {
            if ($name =~ /^\s*$/) { $user = ""; }
            else                  { $user = $name; }
        }
    }
    $time = _LongTime();
    $text =
        $RULER .
        "\n $HEADER: $tool - $time - $user\n" .
        $RULER .
        "\n $CMDLINE: " .
        join(' ', map("'$_'", $^X, $0, @ARGV)) .
        "\n";
    $self->report($TO_LOG,$LEVEL_INFO,$text); # increments stat counters
    ${$self}{'stat'} = [ ];                   # reset stat counters to zero
    push( @Inventory, $self );
    return $self;
}

sub close
{
    my($self) = _which(shift);

    return __PACKAGE__ . "::close(): invalid logfile object!"
        unless (ref $self and keys %{$self});
    return $self->DESTROY(1);
}

sub report
{
    my($self)    = _which(shift);
    my($command) = shift || 0;
    my($level)   = shift || 0;
    my($text,$leadin,$indent,$item,$depth,$sub,$file,$handle);
    my(@stack,@trace);

    return unless (ref $self and keys %{$self});
    if ($command & $FROM_HOLD)
    {
        return if ($command == $FROM_HOLD + $TO_HLD);
        return unless (@{${$self}{'hold'}} > 0);
        $text = ${$self}{'hold'};
    }
    else
    {
        return if ($level < ${$self}{'level'});
        $leadin = '';
        $indent = '';
        if ($level & $USE_LEADIN)
        {
            $leadin = $LEADIN[0][$level >> 2] . ': ';
            $indent = ' ' x length($leadin);
        }
        $text = [ ];
        foreach $item (@_)
        {
            push( @{$text}, split(/\n/, $item, -1) );
        }
        foreach $item (@{$text})
        {
            $item = $leadin . $item;
            $item =~ s!\s+$!!;
            $item .= "\n";
            $leadin = $indent;
        }
        @trace = ();
        if ($level & $STACKTRACE)
        {
            $depth = $STARTDEPTH;
            while (@stack = caller($depth++))
            {
                $sub = _adjust(@stack);
                push
                (
                    @trace,
                    $indent . "in $sub\n",
                    $indent . "called at $stack[1] line $stack[2]\n"
                );
            }
            # Comment out next line if stack traces in logfile ONLY:
####        push( @{$text}, @trace );
        }
    }
    if ($command & $TO_LOG)
    {
        $file   = ${$self}{'file'};
        $handle = ${$self}{'hand'};
####    unless (print $handle join('', @{$text}))         # use this if push above is enabled
        unless (print $handle join('', @{$text}, @trace)) # use this if push above is disabled
        {
            unshift( @{$text}, __PACKAGE__ . "::report(): Can't print logfile '$file': $!\n" );
            $command |= $TO_HLD;
            $command |= $TO_ERR;
        }
    }
    if ($command & $TO_ERR)
    {
        unless (print STDERR join('', @{$text}))
        {
            $command |= $TO_OUT;
        }
    }
    if ($command & $TO_OUT)
    {
        unless (print STDOUT join('', @{$text}))
        {
            $command |= $TO_HLD;
        }
    }
    if ($command & $TO_HLD)
    {
        unless ($command & $FROM_HOLD)
        {
####        push( @{${$self}{'hold'}}, @{$text} );         # use this if push above is enabled
            push( @{${$self}{'hold'}}, @{$text}, @trace ); # use this if push above is disabled
        }
    }
    if ($command & $FROM_HOLD)
    {
        ${$self}{'hold'} = [ ] unless ($command & $TO_HLD);
    }
    else
    {
        ${${$self}{'stat'}}[$level >> 2]++;
    }
}

sub trace
{
    my($self) = _which(shift);
    my($first,$depth,$sub,$item);
    my(@stack,@trace,@args);

    return unless (ref $self and keys %{$self});
    # Do nothing if trace unwanted:
    return if ($LEVEL_TRACE < ${$self}{'level'});
    $first = 1;
    $depth = 1;
    @trace = (); # code "borrowed" from Carp.pm:
    while ( do {{ package DB; @stack = caller($depth++) }} )
    {
        $sub = _adjust(@stack);
        if ($first)
        {
            if ($stack[4]) # $hargs
            {
                @args = @DB::args;
                foreach $item (@args)
                {
                    if (defined $item)
                    {
                        $item = "$item";
                        $item =~ s!([\\\'])!\\$1!g;
                        $item = "'$item'"
                            unless ($item =~ /^-?(?:[1-9]\d*|0)(?:\.\d+)?$/);
#                       $item =~ s!([\x80-\xFF])!'M-'.chr(ord($1)&0x7F)!eg;
                        $item =~ s!([\x00-\x1F\x7F])!'^'.chr(ord($1)^0x40)!eg;
                    }
                    else { $item = "undef"; }
                }
                $sub .= '(' . join(',', @args) . ')';
            }
            else { $sub .= '()'; }
        }
        else { $sub = "in $sub"; }
        push
        (
            @trace,
            $sub,
            "called at $stack[1] line $stack[2]"
        );
        $first = 0;
    }
    $self->report(@TRACE,@trace);
}

sub level
{
    my($self) = _which(shift);
    my($level);

    return undef unless (ref $self and keys %{$self});
    $level = ${$self}{'level'};
    if (@_ > 0)
    {
        ${$self}{'level'} = $_[0] + 0;
    }
    return $level;
}

sub logfile
{
    my($self) = _which(shift);

    return undef unless (ref $self and keys %{$self});
    return ${$self}{'file'};
}

sub notify # set flag for notifying user at exit about where logfile lies
{
    my($self) = _which(shift);
    my($flag);

    return undef unless (ref $self and keys %{$self});
    $flag = ${$self}{'flag'};
    if (@_ > 0)
    {
        ${$self}{'flag'} = ($_[0] ? 1 : 0);
    }
    return $flag;
}

sub ret_hold
{
    my($self) = _which(shift);

    if (defined wantarray && wantarray)
    {
        return () unless (ref $self and keys %{$self});
        return (@{${$self}{'hold'}});
    }
    else
    {
        return undef unless (ref $self and keys %{$self});
        return scalar(@{${$self}{'hold'}});
    }
}

sub clr_hold
{
    my($self) = _which(shift);

    return unless (ref $self and keys %{$self});
    ${$self}{'hold'} = [ ];
}

1;

__END__