view release on metacpan or  search on metacpan

lib/Log/ProgramInfo.pm  view on Meta::CPAN

        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} : line {$line}" 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",
        log       => undef,
    );

    %_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} };