File Coverage

blib/lib/Log/ProgramInfo.pm

Criterion	Covered	Total	%
statement	174	192	90.6
branch	42	82	51.2
condition	16	24	66.6
subroutine	19	21	90.4
pod	0	9	0.0
total	251	328	76.5

package Log::ProgramInfo;

=head1 NAME

Log::ProgramInfo - log global info from a perl programs.

=cut

### HISTORY ###################################################################
# Version               Date            Developer        Comments
# 0.1.1                 2015-04-02      John Macdonald   Initial release to CPAN
# 0.1.2                 2015-04-04      John Macdonald   Minor cleanups to initial release
# 0.1.3                 2015-04-09      John Macdonald   Rename s/JobInof/ProgramInfo/
# 0.1.4                 2015-04-09      John Macdonald   Add README
# 0.1.5                 2015-04-10      John Macdonald   Change log extension and env
#                                                        variable names to reflect
#                                                        the ProgramInfo name.
# 0.1.6                 2015-04-23      John Macdonald   Fix env name ..._FILE -> ..._NAME
#                                                        Fix env handling - capture at start
#                                                                         - apply at end
#                                                        Log username(s) groupname(s)
#                                                        Include identifying info in separator line
#                                                        Make output more easily parsable
# 0.1.7                 2015-05-20      John Macdonald   Add user-pluggable log routines
#                                                        Move log parser from test to module.
# 0.1.8                 2015-06-12      John Macdonald   Catch most signals (not just HUP)
#

=head1 VERSION

Version 0.1.8

=cut

our $VERSION = '0.1.8';

use feature qw(say);
use Data::Dumper;
use FindBin;
use Time::HiRes qw(time);
use DateTime;
use DateTime::Duration;
use Carp qw(carp croak cluck);
use Fcntl qw(:flock);


=head1 SYNOPSIS

        use Log::ProgramInfo qw(
            [ -logname LOGNAME                 ]
            [ -logdir  LOGDIR                  ]
            [ -logext  LOGEXT                  ]
            [ -logdate none|date|time|datetime ]
            [ -stdout                          ]
            [ -suppress                        ]
            );

        # main program does lots of stuff...
        exit 0;

    After the program has run, this module will automatically
    log information about this run into a log file.  It will
    list such things as:
      - program
        - name
        - version
      - command line arguments
      - version of perl
      - modules loaded
        - source code location
        - Version
      - run time

    The log is appended to the file:
        LOGDIR/LOGDATE-LOGNAME.LOGEXT
    where
        LOGDIR        defaults to . (the current directory when the program terminates)
        LOGDATE       defaults to the date that the program was started
        LOGNAME       defaults to the basename of the program
        LOGEXT        defaults to ".programinfo"

    The -ARG specifiers in the "import" list can be used to over-ride these defaults.  Specifying:

    -logname LOGNAME  will use LOGNAME instead of the program name
    -logdir  LOGDIR   will use LOGDIR instead of the current directory
                        - if it is a relative path, it will be based on the
                              current directory at termination of execution
    -logext  EXT      will add .EXT to the log filename
    -logext  .EXT     will add .EXT to the log filename
    -logext  ""       will add no extension to the log filename
    -logdate STRING
                      will specify the LOGDATE portion of the filename.  The STRING can be:
                  none      LOGNAME (and no dash)
                  date      YYYYMMDD-LOGNAME   (this is the default)
                  time      HHMMSS-LOGNAME
                  datetime  YYYYMMDDHHMMSS-LOGNAME

    -stdout           will cause the log to be sent to stdout instead of a file
    -suppress         will suppress logging (unless environment variable
                              LOGPROGRAMINFO_SUPPRESS is explcitly set to 0 or null)

                              Normally, neither -suppress nor -stdout will be set in the
                              use statement, and the environment variables can then be
                              used to disable the logging completely or to send it to
                              stdout instead of to the selected file.

                              For some programs, however, it may be desired to not normally
                              provide any logging.  Specifying -suppress will accomplish
                              this.  In such a case, setting the environment variable
                              LOGPROGRAMINFO_SUPPRESS=0 will over-ride that choice, causing
                              the log to be written (as specified by the other options
                              and environment variables).

    Environment variables can over-ride these parameters:
        LOGPROGRAMINFO_SUPPRESS=x  boolean suppresses all logging if true
        LOGPROGRAMINFO_STDOUT=x    boolean sets -stdout
        LOGPROGRAMINFO_DIR=DIR     string  sets the target directory name
        LOGPROGRAMINFO_NAME=NAME   string  sets the target filename LOGNAME
        LOGPROGRAMINFO_EXT=EXT     string  sets the target extension
        LOGPROGRAMINFO_DATE=DATE   string  sets the target filename LOGDATE selector

    Adding extra loggable information:
        If you want to add your own classes of loggable info, there are a
        few restrictions.

        You define a logging extension routine using:

            Log::ProgramInfo::add_extra_logger( \&my_logger );

        Your logger routine should be defined as:

            sub my_logger {
                my $write_entry = shift;
                $write_entry->( $key1, $value );
                $write_entry->( $key1, $key2, $value );
            }

        The $write_entry function passed to my_logger must be called with
        2 or 3 arguments.  The leading arguments are major (and minor if
        desired) keys, the final one os the value for the key(s).

        Try to keep the first key to 7 characters, and the second to 8 to
        keep the log readable by humans.  (It will be parseable even if you
        use longer keys.)

    Parsing the log file:
        The log file is designed to be easily parsed.

        A log always starts with a line beginning with 8 hash marks in column
        one (########) plus some identifying info.

        The value lines are of the form:

        key     : value
        key1    : key2    : value

        The first key is extended to at least 7 characters with blanks, the
        second key (if any) is extended to at least 8 characters.  There is
        always a separator of (space(colon)(space) between a key and the
        following field.  (A key can be provided with leading spaces for making
        the log more readable by humans - the readlog function in the test suite
        will remove such spaces.)

        Two subroutines are available to do this parsing for you:

            my $firstonly = 0;
            @logs = readlog( $filepath    [, $acceptsub] [, $firstonly] );
            @logs = parselog( $filehandle [, $acceptsub] [, $firstonly] );

            $logs = readlog( $filepath    [, $acceptsub ], 1 );
            $logs = parselog( $filehandle [, $acceptsub ] ,1 );

        The first parameter to each is either a string pathname (for readlog)
        or an already opened readable file handle (for parselog).

        If a subroutine reference arg $acceptsub is provided, each log that is
        read will be passed to that sub reference.  If the acceptsub returns
        true the log is retained, otherwise it is discarded.  If a trailing
        (non-sub-ref) value is provided, it selects whether only the first
        (acceptable) log found will be returned as a single hash reference, or
        whether all of the (accepted) logs in the file will be returned as a
        list of hash references.`

        The hash reference for each accepted log contains the key/value (or
        key1 => { key2/value pairs }) from that log.

        Whenever a key (or key1/key2 pair) is seen multiple times, the value
        is an array ref instead of a scalar.  This only happens with the
        MODULE pairs (MODULE/NAME, MODULE/LOC, MODULE/VERSION), and the INC
        key.  (User-provided keys are not currently permitted to use the same
        key set multiple times.)

=cut

# preserve command line info
my @args      = @ARGV;
my $progbase;
my $starttime;

my %option;

my %valid_dates;

my %_omap;
my %env_options;

my $kill_caught;

my ($uid, $gid);
my %cache;
my %modkeys = ( NAME => 1, VERSION => 1, LOC => 1 );

sub readlog {
    my $file = shift;
    open my $fh, '<', $file or die "Cannot open $file: $!";
    return parselog( $fh, @_ );
}

sub parselog {
    my $fh = shift;
    my $accept;
    $accept = shift if ref($_[0]) eq 'CODE';
    my $firstonly = shift;
    my @logs;
    while (my $log = parse1log( $fh )) {
        next if $accept && ! $accept->($log);
        return $log if $firstonly;
        push @logs, $log;
    }
    return @logs;
}

sub parse1log {
    my $fh = shift;
    my $log;
    while (my $line = <$fh>) {
        return $log if $line =~ /^$/;
        next if $line =~ /^########/;
        chomp $line;
        $log ||= {};
        my @keys = split ': ', $line;
        s/^\s*// for @keys;
        s/\s*$// for @keys;
        die "Unexpected syntax in log line: $line\n" unless scalar(@keys) >= 2;
        my $val = pop @keys;
        my $key = shift @keys;
        if (scalar(@keys) == 0) {
            if ($key eq 'INC') {
                my $list = $log->{$key} ||= [];
                push @$list, $val;
            }
            else {
                die "repeated key: $key" if exists $log->{$key};
                $log->{$key} = $val;
            }
        }
        else {
            my $key2 = shift @keys;
            die "invalid nested key: {" . join( '}{', $key, $key2, @keys, $val ) . "}"
                if scalar(@keys);
            if ($key eq 'MODULE') {
                die "Unknown MODULE key ($key2)" unless $modkeys{$key2};
                my $list = $log->{$key}{$key2} ||= [];
                push @$list, $val;
            }
            else {
                die "repeated key: $key $key2" if exists $log->{$key}{$key2};
                $log->{$key}{$key2} = $val;
            }
        }
    }
    return $log;
}

my @extra_loggers = ();

sub add_extra_logger {
    for my $logger (@_) {
        croak "arg to extra_loggers is not a code ref: " . Dumper($logger)
            unless ref $logger eq 'CODE';
        push @extra_loggers, $logger;
    }
}

sub groupmap {
    my $list = shift;
    my @res;
    my %unique;
    push @res, ($cache{$_} //= getgrgid $_) for grep { ! $unique{$_}++ } split ' ', $list;
    my $g1 = shift @res;
    return join( '+', $g1, join( ',', @res ) );
}

BEGIN {
    $progbase        = $FindBin::Script;
    $starttime       = DateTime->from_epoch(epoch => time);
    $valid_dates{$_} = 1 for qw( date time datetime none );
    $uid             = getpwuid $<;
    my $euid         = getpwuid $>;
    $gid             = groupmap $(;
    my $egid         = groupmap $);
    $uid             = "$euid($uid)"   if $uid ne $euid;
    $gid             = "$egid // $gid" if $egid ne $gid;

    %option = (
        suppress  => 0,
        stdout    => 0,
        logdir    => ".",
        logdate   => "date",
        logname   => $progbase,
        logext    => ".programinfo",
    );

    %_omap = (
        LOGPROGRAMINFO_SUPPRESS => 'suppress',
        LOGPROGRAMINFO_STDOUT   => 'stdout',
        LOGPROGRAMINFO_DIR      => 'logdir',
        LOGPROGRAMINFO_DATE     => 'logdate',
        LOGPROGRAMINFO_NAME     => 'logname',
        LOGPROGRAMINFO_EXT      => 'logext',
    );

    while( my($k,$v) = each %_omap ) {
        $env_options{$v} = $ENV{$k} if exists $ENV{$k};
    }
    $SIG{HUP}  = \&catch_sig;
    $SIG{INT}  = \&catch_sig;
    $SIG{PIPE} = \&catch_sig;
    $SIG{TERM} = \&catch_sig;
    $SIG{USR1} = \&catch_sig;
    $SIG{USR2} = \&catch_sig;
}

sub import {
    my $mod = shift;

    while (scalar(@_)) {
        if ($_[0] =~ /^-(logname|logdir|logext|logdate)$/) {
            my $key = $1;
            croak "Option to Log::ProgramInfo requires a value: $_[0]" if scalar(@_) == 1;
            shift;
            my $val = shift;
            $option{$key} = $val;
        }
        elsif ($_[0] =~ /^-(stdout|suppress)$/) {
            my $key = $1;
            shift;
            $option{$key} = 1;
        }
        else {
            last;
        }
    }

    croak "Unknown option to Log::ProgramInfo: $_[0]" if (@_ and $_[0] =~ /^-/);
    croak "Import arguments not supported from Log::ProgramInfo: " . join( ',', @_ ) if @_;
    croak "Unknown logdate option: $option{logdate}"
        unless exists $valid_dates{ $option{logdate} };

    say STDERR "resolved option hash: ", Dumper(\%option) if $ENV{DUMP_LOG_IMPORTS};
}

END {
    my $exit_status = $?;
    local $?;    # protect program exit code from END actions
    finish_log($exit_status);
}

sub catch_sig {
    my $signame = shift;
    local $?;    # protect program exit code from END actions
    finish_log("Killed with signal: $signame");
}

sub log_entry {
    my $logfh = shift;
    if (@_ == 2 ) {
        printf $logfh "%-7s : %s\n", @_;
    } elsif (@_ == 3 ) {
        printf $logfh "%-7s : %-8s : %s\n", @_;
    } else {
        my $msg = "log_entry needs 2 or 3 arguments, got "
            . scalar(@_);
        $msg .= ': (' . join( '), (', @_ ) . ')' if @_;
        cluck $msg;
    }
}

sub finish_log {
    return if $kill_caught++; # only write log once - first kill, or termination
    my $exit_status = shift;
    unless ($option{suppress}) {
        # pull ENV var over-rides
        while (my ($k, $v) = each %env_options) {
            $option{$k} = $v;
        }
        my $logfh;
        my $endtime = DateTime->from_epoch(epoch => time);

        if ($option{stdout}) {
            open $logfh, ">>&STDOUT";
        }
        else {
            my $dopt = $option{logdate};
            my $date =
                ( "none" eq $dopt )   ? ''
                : ( "date" eq $dopt ) ? $starttime->ymd('')
                : ( "time" eq $dopt ) ? $starttime->hms('')

                # : ("datetime" eq $dopt) # validated, so must be 'datetime '
                : ( $starttime->ymd('') . $starttime->hms('') );
            $date .= '-' if $date;
            $option{logext} = ".$option{logext}" if $option{logext} =~ m(^[^.]);
            my $log_path = "$option{logdir}/$date$option{logname}$option{logext}";
            open( $logfh, ">>", $log_path )
                or carp "cannot open log file $log_path: $!";
            say STDERR "Appending log info to $log_path";
            my $lock_cnt = 0;
            while (1) {
                flock $logfh, LOCK_EX and last;
                croak "$0 [$$]: flock failed on $log_path: $!" if $lock_cnt > 30;
                say STDERR "Waiting for lock on $log_path" unless $lock_cnt++;
                print STDERR ".";
                sleep(2);
            }
            say "" if $lock_cnt;
        }

        say $logfh join( ' ', "########", $uid, '(', $gid, ') :', $progbase, @args );

        my $mod = show_modules();
        for my $key ( sort keys %$mod ) {
            my ( $ver, $loc ) = @{ $mod->{$key} };
            log_entry( $logfh, MODULE => NAME    => $key );
            log_entry( $logfh, MODULE => VERSION => $ver );
            log_entry( $logfh, MODULE => LOC     => $loc );
        }
        for my $inc (@INC) {
            log_entry( $logfh, INC => $inc );
        }

        log_entry( $logfh, UNAME => $_->[1], do { my $out = qx( uname $_->[0] ); chomp $out; $out } )
            for (
            [ -s => "System" ],
            [ -n => "Name" ],
            [ -r => "OSRel" ],
            [ -v => "OSVer" ],
            [ -m => "Machine" ]
        );
        log_entry( $logfh, PERL    => $^X );
        log_entry( $logfh, PERLVer => $] );
        log_entry( $logfh, User    => $uid );
        log_entry( $logfh, Group   => $gid );
        log_entry( $logfh, ProgDir => $FindBin::Bin );
        log_entry( $logfh, Program => $progbase );
        log_entry( $logfh, Version => ( $::VERSION // "(No VERSION)" ) );
        log_entry( $logfh, Args    => scalar(@args) );
        my $acnt = 0;
        log_entry( $logfh, "  arg" => sprintf("%8d", ++$acnt), $args[$acnt-1] ) for @args;
        log_entry( $logfh, Start   => $starttime->datetime() . "." . sprintf( "%03d", $starttime->millisecond ) );
        log_entry( $logfh, End     => $endtime->datetime()   . "." . sprintf( "%03d", $endtime->millisecond ) );
        my $dur = $endtime->subtract_datetime_absolute($starttime);
        log_entry( $logfh, Elapsed => $dur->delta_seconds . "." .
                                    sprintf( "%03d", $dur->delta_nanoseconds/1_000_000) );
        log_entry( $logfh, EndStat => $exit_status );

        $_->(sub { log_entry( $logfh, @_ ) }) for @extra_loggers;

        say $logfh "";

        close($logfh);
    }
}

# Print version and loading path information for modules
sub show_modules {
    my $module_infos = {};

    # %INC looks like this:
    # {
    #    ...
    #    "Data/Dump.pm"
    #        => "/whatever/perl/lib/site_perl/5.18.1/Data/Dump.pm",
    #    ...
    # }
    # So let's convert it to this:
    # {
    #    ...
    #    "Data::Dump"
    #        => [ "1.4.2",
    #             "/whatever/perl/lib/site_perl/5.18.1/Data/Dump.pm",
    #           ],
    #    ...
    # }
    foreach my $module_inc_name ( keys(%INC) ) {
        my $real_name = $module_inc_name;
        $real_name =~ s|/|::|g;
        $real_name =~ s|\.pm$||;

        my $version = eval { $real_name->VERSION }
            // eval { ${"${real_name}::VERSION"} }
            // 'unknown';
        # stringify, in case it is a weird format
        # - I don't think the 'invalid' alternative can be hit, but safer to have it in
        $version = eval { $version . ''  } // 'invalid';

        $module_infos->{$real_name} = [ $version, $INC{$module_inc_name} ];
    }

    return $module_infos;
}

1;