File Coverage

blib/lib/Log/Declare.pm

Criterion	Covered	Total	%
statement	147	161	91.3
branch	49	66	74.2
condition	36	45	80.0
subroutine	16	18	88.8
pod	0	6	0.0
total	248	296	83.7

package Log::Declare;
# ABSTRACT: A high performance Perl logging module.

use 5.10.0; # for //
use strict;
use warnings;

use Devel::Declare::Lexer;
use Devel::Declare::Lexer::Token::Raw;
use POSIX qw(strftime);
use Data::Dumper; # for d: statements

our $VERSION = '0.10';

my %LEVEL = (
    ALL     => -1,
    TRACE   =>  1,
    DEBUG   =>  2,
    INFO    =>  3,
    WARN    =>  4,
    ERROR   =>  5,
    AUDIT   =>  6,
    OFF     =>  7,
    DISABLE =>  7,
);

# XXX be careful about removing/renaming this: it's required by MojoX::Log::Declare
our @level_priority = qw(audit error warn info debug trace);

my ($LEVEL, $LEVEL_NAME);
__PACKAGE__->startup_level($ENV{'LOG_DECLARE_STARTUP_LEVEL'} || 'ERROR'); # sets $LEVEL and $LEVEL_NAME

my $log_statement = "Log::Declare->log('%s', [%s], %s)%s";

unless($ENV{LOG_DECLARE_NO_STARTUP_NOTICE}) {
    Log::Declare->log('INFO', ['LOGGER'], "Got logger startup level of $LEVEL_NAME");
}

# this provides a way to globally override the behaviour of the injected keywords.
# if replaced by e.g. a sub which returns 0, the level will be completely disabled and
# the log writer won't be called. The original implementations can be restored at any
# time by deleting the hooks.
# XXX be careful about removing/renaming this: it's required for namespace hooks (see
# the NAMESPACES section in the POD).
our %levels;

# define the exported trace, debug &c. subs. These delegate to the hooked implementations
# in %levels (if defined); otherwise they return true/false if the level is enabled/disabled
my %EXPORT;
for my $name (@level_priority) {
    my $hook;
    my $level = $LEVEL{uc $name};
    # goto &sub: make sure caller() works as expected in the hooked sub
    $EXPORT{$name} = sub { ($hook = $levels{$name}) ? goto &$hook : $level >= $LEVEL };
}

BEGIN {
    my $callback = sub {
        my ($stream_r) = @_;
        my @stream = @$stream_r;

        # Get the declarator
        my $decl = $stream[0];

        shift @stream; # remove the declarator
        while (ref($stream[0]) =~ /Devel::Declare::Lexer::Token::Whitespace/) {
            shift @stream; # remove the whitespace
        }

        if(ref($stream[$#stream]) =~ /Devel::Declare::Lexer::Token::Newline/) {
            pop @stream; # remove the newline
        }
        pop @stream; # remove the semicolon

        # Work backwards from the end looking for if statement
        my $nested = 0;
        my $ifStart = -1;
        for(my $i = $#stream; $i >= 0; $i--) {
            my $token = $stream[$i];

            if(ref($token) =~ /Devel::Declare::Lexer::Token::RightBracket/ &&
               $token->{value} =~ /\]/) {
                $nested++;
                next;
            }
            if(ref($token) =~ /Devel::Declare::Lexer::Token::LeftBracket/ &&
               $token->{value} =~ /\[/) {
                $nested--;
                next;
            }
            if($nested == 0 && ref($token) =~ /Devel::Declare::Lexer::Token::Bareword/ &&
                ($token->{value} eq 'if' || $token->{value} eq 'unless')) {
                $ifStart = $i;
                last;
            }
        }

        # Extract the conditional tokens
        my @condTokens;
        if($ifStart > -1) {
            my $soc = $ifStart;
            my $eoc = $#stream;
            @condTokens = @stream[$soc .. $eoc];
            @stream = @stream[0 .. $ifStart - 1];
        }

        # Work backwards from the end looking for categories
        $nested = 0;
        my $catStart = -1;
        for(my $i = $#stream; $i >= 0; $i--) {
            my $token = $stream[$i];

            if(ref($token) =~ /Devel::Declare::Lexer::Token::RightBracket/ &&
               $token->{value} =~ /\]/) {
                $nested++;
                next;
            }
            if(ref($token) =~ /Devel::Declare::Lexer::Token::LeftBracket/ &&
               $token->{value} =~ /\[/) {
                $nested--;
                if($nested == 0) {
                    if($stream[$i-1] && ref($stream[$i-1]) !~ /Devel::Declare::Lexer::Token::Whitespace/) {
                        next;
                    }
                    $catStart = $i;
                    last;
                }
                next;
            }
        }

        # Extract the category tokens
        my @catTokens;
        if($catStart > -1) {
            my $soc = $catStart + 1;
            my $eoc = $#stream - 1;
            @catTokens = @stream[$soc .. $eoc];
            @stream = @stream[0 .. $catStart - 1];
        }

        # Convert the tokens into a list of category names
        my @categories;
        if(scalar @catTokens) {
            my $buf = '';
            for my $token (@catTokens) {
                if(ref($token) =~ /Devel::Declare::Lexer::Token::Comma/) {
                    push @categories, (uc "\"$buf\"") if $buf;
                    $buf = '';
                    next;
                }
                next if $buf eq '' && ref($token) =~ /Devel::Declare::Lexer::Token::Whitespace/;
                $buf .= $token->{value};
            }
            push @categories, uc("\"$buf\"") if $buf;
        }
        push @categories, "\"GENERAL\"" if scalar @categories == 0;

        # Create a new stream from whats left
        my @ns = ();
        tie @ns, "Devel::Declare::Lexer::Stream";

        # See how many arguments we have
        my $nest = 0;
        my $bits = 0;

        for my $tok (@stream) {
            if(ref($tok) =~ /Devel::Declare::Lexer::Token::LeftBracket/) {
                $nest++;
                next;
            }
            if(ref($tok) =~ /Devel::Declare::Lexer::Token::RightBracket/) {
                $nest++;
                next;
            }
            if($nest == 0 && ref($tok) =~ /Devel::Declare::Lexer::Token::Operator/ &&
                $tok->{value} =~ /,/) {
                $bits++;
            }
        }

        # Reconstruct the log statement
        my $level = $decl->{value};
        my $cats = join ', ', @categories;
        my $inner = join '', map { $_->get } @stream;

        # Handle prefixes
        $inner =~ s/([\s,])d:([\\\$\@\%\&\*]+[^\s,]+)/$1Data::Dumper::Dumper($2)/g;
        $inner =~ s/([\s,])r:([\\\$\@\%\&\*]+[^\s,]+)/$1ref($2)/g;

        my $msg = '';
        if ($bits) {
            $msg = 'sprintf(' if $bits;
            $msg .= $inner;
            $msg .= ')' if $bits;
        } else {
            $msg = $inner;
        }
        my $cond = ' ' . join '', map { $_->get } @condTokens;

        my $output = Devel::Declare::Lexer::Token::Raw->new(
            value => sprintf($log_statement, $level, $cats, $msg, $cond)
        );

        return [
            $decl,
            Devel::Declare::Lexer::Token::Whitespace->new(value => ' '), $output,
            Devel::Declare::Lexer::Token::EndOfStatement->new,
            Devel::Declare::Lexer::Token::Newline->new
        ];
    };

    # Setup callbacks for each of the keywords
    Devel::Declare::Lexer::lexed(audit => $callback);
    Devel::Declare::Lexer::lexed(info  => $callback);
    Devel::Declare::Lexer::lexed(warn  => $callback);
    Devel::Declare::Lexer::lexed(error => $callback);
    Devel::Declare::Lexer::lexed(debug => $callback);
    Devel::Declare::Lexer::lexed(trace => $callback);
}

# -----------------------------------------------------------------------------

# set the global log level
# FIXME this should be called level
sub startup_level {
    my $self = shift;

    if (@_) {
        my $level = shift // '';
        $LEVEL_NAME = uc $level;
        # ALL: be forgiving if the name is invalid/mistyped (see below)
        $LEVEL = $LEVEL{$LEVEL_NAME} // $LEVEL{ALL};
    } else {
        return $LEVEL_NAME;
    }
}

# -----------------------------------------------------------------------------

sub log_statement {
    my ($self, $statement) = @_;

    return $log_statement unless $statement;
    $log_statement = $statement;
    return $log_statement;
}

# -----------------------------------------------------------------------------

sub log {
    my ($self, $level_name, $categories, $message) = @_;

    $level_name = uc($level_name // '');

    # be forgiving if the log level is mistyped/invalid: it's going
    # to be easier to remove an unwanted log message than to track
    # down a bug that isn't being logged because of a typo
    my $level = $LEVEL{$level_name} // $LEVEL;

    return unless $level >= $LEVEL;

    if($categories) {
        $categories = scalar @$categories > 0 ? (join ', ', @$categories) : '';
        $categories = " [$categories]";
    }

    my $ts = strftime $ENV{'LOG_DECLARE_DATE_FORMAT'} // "%a %b %e %H:%M:%S %Y",
                      ($ENV{'LOG_DECLARE_USE_LOCALTIME'} ? localtime : gmtime);

    $message .= "\n" if substr($message,-1) ne "\n";

    return CORE::print STDERR "$$ [$ts] [$level_name]$categories $message";
}

# -----------------------------------------------------------------------------

sub capture {
    my ($self, $capture, $coderef) = @_;

    {
        no strict 'refs';
        *{$capture} = sub {
            my $logger = shift;
            @_ = $coderef->(@_) if $coderef;
            $self->log('debug', [ref($logger)], @_);
        };
    }
}

# -----------------------------------------------------------------------------

sub import {
    my ($class, @tags) = @_;

    my $caller = caller;
    Log::Declare->do_import($caller, @tags);
}

# -----------------------------------------------------------------------------

sub export_to_level {
    my ($class, $level, @tags) = @_;

    my $caller = caller($level);
    Log::Declare->do_import($caller, @tags);
}

# -----------------------------------------------------------------------------

sub do_import {
    my ($class, $caller, @tags) = @_;

    my %t = map { $_ => 1 } @tags;
    return if $t{':nosyntax'};

    # Inject each of the keywords into the caller's namespace
    for my $name (@level_priority) {
        Devel::Declare::Lexer::import_for($caller, {
            $name => $EXPORT{$name}
        }) if !$t{":no$name"};
    }
}

# -----------------------------------------------------------------------------

=pod

=head1 NAME

Log::Declare - A high performance Perl logging module

=head1 OVERVIEW

Creates syntactic sugar for logging using categories with sprintf support.

Complex logging statements can be written without impacting on performance
when those log levels are disabled.

For example, using a typical logger, this would incur a penalty even if
the logging is disabled:

    $self->log(Dumper $myobject);

but with Log::Declare we incur almost no performance penalty if 'info' level is
disabled, since the following log statement:

    info Dumper $myobject [mycategory];

gets rewritten as:

    info && $Log::Declare::logger->log('info', ['mycategory'], Dumper $myobject);

which means if 'info' returns 0, nothing else gets evaluated.

=head1 SYNOPSIS

    use Log::Declare;
    use Log::Declare qw/ :nosyntax /; # disables syntactic sugar
    use Log::Declare qw/ :nowarn :noerror ... /; # disables specific sugar

    # with syntactic sugar
    debug "My debug message" [category];
    error "My error message: %s", $error [category1, category2];

    # auto-dump variables with Data::Dumper
    debug "Using sprintf format: %s", d:$error [category];

    # auto-ref variables with ref()
    debug "Using sprintf format: %s", r:$error [category];

    # capture other loggers (loses Log::Declare performance)
    Log::Declare->capture('Test::Logger::log');
    Log::Declare->capture('Test::Logger::log' => sub {
        my ($logger, @args) = @_;
        # manipulate logger args here
        return @args;
    });

=head1 NAMESPACES

If you're using a namespace-aware logger, Log::Declare can use your logger's
namespacing to determine log levels. For example:

    $Log::Declare::levels{'debug'} = sub {
        Log::Log4perl->get_logger(caller)->is_debug;
    };

=cut

1;