File Coverage

blib/lib/No/Worries/Log.pm

Criterion	Covered	Total	%
statement	302	352	85.8
branch	61	90	67.7
condition	23	36	63.8
subroutine	65	75	86.6
pod	14	14	100.0
total	465	567	82.0

#+##############################################################################
#                                                                              #
# File: No/Worries/Log.pm                                                      #
#                                                                              #
# Description: logging without worries                                         #
#                                                                              #
#-##############################################################################

#
# module definition
#

package No::Worries::Log;
use strict;
use warnings;
our $VERSION  = "1.5";
our $REVISION = sprintf("%d.%02d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/);

#
# used modules
#

use IO::Handle qw();
use No::Worries qw($HostName $ProgramName);
use No::Worries::Date qw(date_stamp);
use No::Worries::Export qw(export_control);
use No::Worries::File qw(file_read);
use No::Worries::Die qw(dief);

#
# constants
#

use constant _LEVEL_ERROR   => "error";
use constant _LEVEL_WARNING => "warning";
use constant _LEVEL_INFO    => "info";
use constant _LEVEL_DEBUG   => "debug";
use constant _LEVEL_TRACE   => "trace";

#
# global variables
#

our($Handler);

our(
    %_KnownLevel,           # hash with known levels
    %_InterestingLevel,     # hash with interesting levels
    %_Level2Char,           # hash mapping levels to chars for the output
    $_MaybeInterestingInfo, # filtering sub (partial)
    $_InterestingInfo,      # filtering sub (complete)
    $_ConfigTag,            # dev:ino:mtime of the last configuration file used
);

#+++############################################################################
#                                                                              #
# configuring                                                                  #
#                                                                              #
#---############################################################################

#
# configure the module from the given file (if needed)
#

sub log_configure ($) {
    my($path) = @_;
    my(@stat, $tag);

    @stat = stat($path) or dief("cannot stat(%s): %s", $path, $!);
    $tag = join(":", $stat[0], $stat[1], $stat[9]);
    return(0) if $_ConfigTag and $_ConfigTag eq $tag;
    log_filter(file_read($path));
    $_ConfigTag = $tag;
    return(1);
}

#+++############################################################################
#                                                                              #
# filtering                                                                    #
#                                                                              #
#---############################################################################

#
# return the Perl code to use for a given filtering expression
#

sub _expr_code ($@) {
    my($partial, $attr, $op, $value) = @_;

    # for partial filtering, we do not care about the message
    return("1") if $attr eq "message" and $partial;
    # for the attributes we know about, it is easy
    return("\$info->{$attr} $op $value")
        if $attr =~ /^(level|time|program|host|file|line|sub|message)$/;
    # for the other attributes, the test always fails if not defined
    return("(defined(\$info->{$attr}) and \$info->{$attr} $op $value)");
}

#
# compile the given filter
#

sub _compile_filter ($@) {
    my($partial, @filter) = @_;
    my(@code, $code, $sub);

    @code = (
        "package No::Worries::Log::Filter;",
        "use strict;",
        "use warnings;",
        "\$sub = sub {",
        "  my(\$info) = \@_;",
        "  return(1) if",
    );
    foreach my $expr (@filter) {
        if (ref($expr) eq "ARRAY") {
            push(@code, "    " . _expr_code($partial, @{ $expr }));
        } else {
            push(@code, "    $expr");
        }
    }
    $code[-1] .= ";";
    push(@code,
         "  return(0);",
         "}",
    );
    $code = join("\n", @code);
    eval($code); ## no critic 'BuiltinFunctions::ProhibitStringyEval'
    dief("invalid code built: %s", $@) if $@;
    return($sub);
}

#
# parse a single filtering expression
#

sub _parse_expr ($$$) {
    my($line, $level, $expr) = @_;
    my($attr, $op, $value);

    # we first parse the (attr, op, value) triplet
    if ($_KnownLevel{$expr}) {
        # there can be only one level per filter line and we keep track of it
        dief("invalid filter line: %s", $line) if ${ $level };
        ${ $level } = $expr;
        ($attr, $op, $value) = ("level", "==", $expr);
    } elsif ($expr =~ /^(\w+)(==|!=)$/ and $1 ne "level") {
        # special case for comparison with empty string
        ($attr, $op, $value) = ($1, $2, "");
    } elsif ($expr =~ /^(\w+)(==|!=|=~|!~|>=?|<=?)(\S+)$/ and $1 ne "level") {
        # normal case
        ($attr, $op, $value) = ($1, $2, $3);
    } else {
        dief("invalid filter expression: %s", $expr);
    }
    # we then check the value
    if ($op eq "=~" or $op eq "!~") {
        # match: check that the value is a valid regular expression
        eval { $expr =~ /$value/ };
        dief("invalid regexp: %s", $value) if $@;
        $value = "m\0$value\0";
    } elsif ($op eq "==" or $op eq "!=") {
        # equality: adjust according to type
        unless ($value =~ /^-?\d+$/) {
            $op = $op eq "==" ? "eq" : "ne";
            $value = "qq\0$value\0";
        }
    } else {
        # numerical: check that the value is a valid integer
        dief("invalid integer: %s", $value) unless $value =~ /^-?\d+$/;
    }
    # so far, so good
    return([ $attr, $op, $value ]);
}

#
# parse and compile the filter to use
#

sub log_filter ($) {
    my($filter) = @_;
    my($and_re, $or_re, $level, @list, @filter, %il, $ii, $mii);

    # strip comments and empty lines and extra spaces
    @list = ();
    foreach my $line (split(/\n/, $filter)) {
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        $line =~ s/\s+/ /g;
        next if $line eq "" or $line =~ /^\#/;
        push(@list, $line);
    }
    $filter = join("\n", @list);
    # find out how to split lines and expressions
    if ($filter =~ /\s(and|or)\s/) {
        # with syntactical sugar
        $and_re = qr/\s+and\s+/;
        $or_re = qr/\s+or\s+/;
    } else {
        # without syntactical sugar
        $and_re = qr/ /;
        $or_re = qr/\n/;
    }
    # parse line by line
    foreach my $line (split($or_re, $filter)) {
        $line =~ s/^\s+//;
        $line =~ s/\s+$//;
        next if $line eq "" or $line =~ /^\#/;
        $level = "";
        @list = ();
        foreach my $expr (split($and_re, $line)) {
            $expr = _parse_expr($line, \$level, $expr);
            # each expression within a line is AND'ed
            push(@list, $expr, "and");
        }
        if ($level) {
            # one level specified
            $il{$level}++;
        } else {
            # no level specified => all are potentially interesting
            foreach my $kl (keys(%_KnownLevel)) {
                $il{$kl}++;
            }
        }
        # remove the last "and"
        pop(@list);
        # each line within a filter is OR'ed
        push(@filter, @list, "or");
    }
    if (@filter) {
        # non-empty filter => remove the last "or"
        pop(@filter);
    } else {
        # empty filter => default behavior
        %il = (_LEVEL_INFO() => 1);
        @filter = ("1");
    }
    $ii  = _compile_filter(0, @filter);
    $mii = _compile_filter(1, @filter);
    # so far, so good...
    %_InterestingLevel = %il;
    $_InterestingInfo = $ii;
    $_MaybeInterestingInfo = $mii;
}

#+++############################################################################
#                                                                              #
# outputting                                                                   #
#                                                                              #
#---############################################################################

#
# default handler: print compact yet user friendly output to STDOUT or STDERR
#

sub log2std ($) {
    my($info) = @_;
    my($id, $string, $fh);

    $id = $INC{"threads.pm"} ? "$info->{pid}.$info->{tid}": $info->{pid};
    $string = sprintf("%s %s %s[%s]: %s\n",
                      $_Level2Char{$info->{level}}, date_stamp($info->{time}),
                      $info->{program}, $id, $info->{message});
    $fh = $info->{level} eq _LEVEL_INFO ? *STDOUT : *STDERR;
    $fh->print($string);
    $fh->flush();
    return(1);
}

#
# dump handler: print all attributes to STDERR
#

sub log2dump ($) {
    my($info) = @_;
    my(@list);

    foreach my $attr (sort(keys(%{ $info }))) {
        if ($info->{$attr} =~ /^[\w\.\-\/]*$/) {
            push(@list, "$attr=$info->{$attr}");
        } else {
            push(@list, "$attr=\'$info->{$attr}\'");
        }
    }
    STDERR->print("% @list\n");
    STDERR->flush();
    return(1);
}

#+++############################################################################
#                                                                              #
# formatting                                                                   #
#                                                                              #
#---############################################################################

#
# format the message
#

sub _message ($$) {
    my($message, $info) = @_;
    my(@list, $format, $pos);

    @list = @{ $message };
    unless (@list) {
        # no message given => empty string
        return("");
    }
    $format = shift(@list);
    if (ref($format) eq "CODE") {
        # code message => result of the call
        return($format->(@list));
    }
    if (ref($format)) {
        # unexpected first argument
        dief("unexpected argument: %s", $format);
    }
    unless (@list) {
        # plain message
        return($format);
    }
    # sprintf message => format it
    $pos = 0;
    foreach my $arg (@list) {
        if (ref($arg) eq "SCALAR") {
            # attribute argument
            dief("unknown attribute: %s", ${ $arg })
                unless defined($info->{${ $arg }});
            $arg = $info->{${ $arg }};
        } elsif (not ref($arg)) {
            # plain argument
            dief("undefined argument at position %d", $pos)
                unless defined($arg);
        } else {
            dief("unexpected argument: %s", $arg);
        }
        $pos++;
    }
    return(sprintf($format, @list));
}

#+++############################################################################
#                                                                              #
# handling                                                                     #
#                                                                              #
#---############################################################################

#
# handle information
#

sub _handle ($$) {
    my($message, $info) = @_;
    my(@list);

    # build the info to log with minimal (= cheap to get) information
    $info->{time} = time();
    $info->{program} = $ProgramName;
    $info->{host} = $HostName;
    $info->{pid} = $$;
    $info->{tid} = threads->tid() if $INC{"threads.pm"};
    @list = caller(1);
    $info->{file} = $list[1];
    $info->{line} = $list[2];
    @list = caller(2);
    $info->{caller} = defined($list[3]) ? $list[3] : "main";
    # check if we may care about this info
    return(0) unless $_MaybeInterestingInfo->($info);
    # format the message
    $info->{message} = _message($message, $info);
    # we always strip trailing spaces
    $info->{message} =~ s/\s+$//;
    # check if we really care about this info
    return(0) unless $_InterestingInfo->($info);
    # now send it to the right final handler
    return($Handler->($info));
}

#+++############################################################################
#                                                                              #
# public API                                                                   #
#                                                                              #
#---############################################################################

#
# check whether a level is "active"
#

sub log_wants_error   () { return($_InterestingLevel{_LEVEL_ERROR()})   }
sub log_wants_warning () { return($_InterestingLevel{_LEVEL_WARNING()}) }
sub log_wants_info    () { return($_InterestingLevel{_LEVEL_INFO()})    }
sub log_wants_debug   () { return($_InterestingLevel{_LEVEL_DEBUG()})   }
sub log_wants_trace   () { return($_InterestingLevel{_LEVEL_TRACE()})   }

#
# log error information
#

sub log_error (@) {
    my(@args) = @_;
    my($attrs);

    return(0) unless $_InterestingLevel{_LEVEL_ERROR()};
    if (@args and ref($args[-1]) eq "HASH") {
        $attrs = pop(@args);
    } else {
        $attrs = {};
    }
    return(_handle(\@args, { %{ $attrs }, level => _LEVEL_ERROR }));
}

#
# log warning information
#

sub log_warning (@) {
    my(@args) = @_;
    my($attrs);

    return(0) unless $_InterestingLevel{_LEVEL_WARNING()};
    if (@args and ref($args[-1]) eq "HASH") {
        $attrs = pop(@args);
    } else {
        $attrs = {};
    }
    return(_handle(\@args, { %{ $attrs }, level => _LEVEL_WARNING }));
}

#
# log informational information ;-)
#

sub log_info (@) {
    my(@args) = @_;
    my($attrs);

    return(0) unless $_InterestingLevel{_LEVEL_INFO()};
    if (@args and ref($args[-1]) eq "HASH") {
        $attrs = pop(@args);
    } else {
        $attrs = {};
    }
    return(_handle(\@args, { %{ $attrs }, level => _LEVEL_INFO }));
}

#
# log debugging information
#

sub log_debug (@) {
    my(@args) = @_;
    my($attrs);

    return(0) unless $_InterestingLevel{_LEVEL_DEBUG()};
    if (@args and ref($args[-1]) eq "HASH") {
        $attrs = pop(@args);
    } else {
        $attrs = {};
    }
    return(_handle(\@args, { %{ $attrs }, level => _LEVEL_DEBUG }));
}

#
# log tracing information (fixed message)
#

sub log_trace () {
    return(0) unless $_InterestingLevel{_LEVEL_TRACE()};
    return(_handle(
        [ "in %s at %s line %s", \ "caller", \ "file", \ "line" ],
        { level => _LEVEL_TRACE },
    ));
}

#+++############################################################################
#                                                                              #
# module initialization                                                        #
#                                                                              #
#---############################################################################

# we select the relevant handler to use
if ($ENV{NO_WORRIES} and $ENV{NO_WORRIES} =~ /\b(log2dump)\b/) {
    $Handler = \&log2dump;
} else {
    $Handler = \&log2std;
};

# here are all the known levels
%_Level2Char = (
    error   => "!",
    warning => "?",
    info    => ":",
    debug   => "#",
    trace   => "=",
);
foreach my $level (keys(%_Level2Char)) {
    $_KnownLevel{$level}++;
}

# by default we only care about informational level or higher
%_InterestingLevel = %_KnownLevel;
delete($_InterestingLevel{_LEVEL_DEBUG()});
delete($_InterestingLevel{_LEVEL_TRACE()});

# by default we do not filter anything out
$_MaybeInterestingInfo = $_InterestingInfo = sub { return(1) };

#
# export control
#

sub import : method {
    my($pkg, %exported);

    $pkg = shift(@_);
    grep($exported{$_}++,
         map("log_$_", qw(configure filter)),
         map("log_$_",       qw(error warning info debug trace)),
         map("log_wants_$_", qw(error warning info debug trace)),
    );
    $exported{"log2std"}  = sub { $Handler = \&log2std };
    $exported{"log2dump"} = sub { $Handler = \&log2dump };
    export_control(scalar(caller()), $pkg, \%exported, @_);
}

1;

__DATA__