File Coverage

blib/lib/Log/Any/Plugin/History.pm

Criterion	Covered	Total	%
statement	50	52	96.1
branch	6	10	60.0
condition	4	10	40.0
subroutine	10	10	100.0
pod	0	1	0.0
total	70	83	84.3

package Log::Any::Plugin::History;
# ABSTRACT: Add a message history to a Log::Any adapter

our $VERSION = '0.01';

use strict;
use warnings;

use Log::Any::Adapter::Util qw( log_level_aliases logging_methods );
use Class::Method::Modifiers qw( install_modifier );

sub install {
    my ($class, $adapter_class, %args) = @_;

    my $history = [];
    my $history_size = $args{size} // 10;
    my $timestamp = $args{timestamp} // sub { time };

    my $aliases = { log_level_aliases() };

    # Create history attribute if it doesn't exist
    unless ($adapter_class->can('history')) {
        install_modifier( $adapter_class, 'fresh', history => sub {
            my ($self, $arg) = @_;
            $history = $arg if defined $arg and ref $arg eq 'ARRAY';
            return $history;
        });
    }

    # Create max_history_size attribute if it doesn't exist
    unless ($adapter_class->can('max_history_size')) {
        install_modifier( $adapter_class, 'fresh', max_history_size => sub {
            my ($self, $arg) = @_;

            return $history_size unless $arg;

            $history_size = $arg;
            return $self;
        });
    }

    # Push to history from logging methods
    for my $method ( logging_methods() ) {
        install_modifier( $adapter_class, 'around', $method => sub {
            my $orig = shift;
            my $self = shift;

            my $level   = $aliases->{$method} // $method;
            my $check   = "is_$level";

            return unless $self->$check;

            my $history = $self->history;
            my $max     = $self->max_history_size;

            my $msg = $self->$orig( @_ );

            push @{$history}, [ $timestamp->(), $level, $msg ];
            shift @{$history} while scalar @{$history} > $max;

            return $msg;
        });
    }

    # Make aliases call their counterparts
    for my $alias ( keys %{$aliases} ) {
        install_modifier( $adapter_class, 'around', $alias => sub {
            my $orig = shift;
            my $self = shift;

            my $method = $aliases->{$alias};
            return $self->$method(@_);
        });
    }
}

1;

__END__