File Coverage

blib/lib/Log/Contextual.pm

Criterion	Covered	Total	%
statement	121	131	92.3
branch	34	48	70.8
condition	19	27	70.3
subroutine	34	36	94.4
pod	0	9	0.0
total	208	251	82.8

package Log::Contextual;
$Log::Contextual::VERSION = '0.008001';
# ABSTRACT: Simple logging interface with a contextual log

use strict;
use warnings;

my @levels = qw(debug trace warn info error fatal);

use Exporter::Declare;
use Exporter::Declare::Export::Generator;
use Data::Dumper::Concise;
use Scalar::Util 'blessed';

use B qw(svref_2object);

sub stash_name {
   my ($coderef) = @_;
   ref $coderef or return;
   my $cv = B::svref_2object($coderef);
   $cv->isa('B::CV') or return;

   # bail out if GV is undefined
   $cv->GV->isa('B::SPECIAL') and return;

   return $cv->GV->STASH->NAME;
}

my @dlog = (
   (map "Dlog_$_", @levels),
   (map "DlogS_$_",  @levels),
   (map "Dslog_$_",  @levels),
   (map "DslogS_$_", @levels));

my @log = (
   (map "log_$_", @levels),
   (map "logS_$_",  @levels),
   (map "slog_$_",  @levels),
   (map "slogS_$_", @levels));

sub _maybe_export {
   my ($spec, $target, $name, $new_code) = @_;

   no strict 'refs';
   if (defined &{"${target}::${name}"}) {
      my $code = \&{"${target}::${name}"};

      # this will warn
      $spec->add_export("&$name", $new_code)
        unless (stash_name($code) eq __PACKAGE__);
   } else {
      $spec->add_export("&$name", $new_code)
   }
}

eval {
   require Log::Log4perl;
   die if $Log::Log4perl::VERSION < 1.29;
   Log::Log4perl->wrapper_register(__PACKAGE__)
};

# ____ is because tags must have at least one export and we don't want to
# export anything but the levels selected
sub ____ { }

exports('____', @dlog, @log, qw( set_logger with_logger has_logger ));

export_tag dlog => ('____');
export_tag log  => ('____');
import_arguments qw(logger package_logger default_logger);

sub router {
   our $Router_Instance ||= do {
      require Log::Contextual::Router;
      Log::Contextual::Router->new
     }
}

sub default_import {
   my ($class) = shift;

   die 'Log::Contextual does not have a default import list';

   ()
}

sub arg_logger         { $_[1] }
sub arg_levels         { $_[1] || [qw(debug trace warn info error fatal)] }
sub arg_package_logger { $_[1] }
sub arg_default_logger { $_[1] }

sub before_import {
   my ($class, $importer, $spec) = @_;
   my $router      = $class->router;
   my $exports     = $spec->exports;
   my %router_args = (
      exporter  => $class,
      target    => $importer,
      arguments => $spec->argument_info
   );

   my @tags = $class->default_import($spec)
     if $spec->config->{default};

   for (@tags) {
      die "only tags are supported for defaults at this time"
        unless $_ =~ /^:(.*)$/;

      $spec->config->{$1} = 1;
   }

   $router->before_import(%router_args);

   if ($exports->{'&set_logger'}) {
      die ref($router) . " does not support set_logger()"
        unless $router->does('Log::Contextual::Role::Router::SetLogger');

      _maybe_export($spec, $importer, 'set_logger',
         sub { $router->set_logger(@_) },
      );
   }

   if ($exports->{'&with_logger'}) {
      die ref($router) . " does not support with_logger()"
        unless $router->does('Log::Contextual::Role::Router::WithLogger');

      _maybe_export($spec, $importer, 'with_logger',
         sub { $router->with_logger(@_) },
      );
   }

   if ($exports->{'&has_logger'}) {
      die ref($router) . " does not support has_logger()"
        unless $router->does('Log::Contextual::Role::Router::HasLogger');

      _maybe_export($spec, $importer, 'has_logger',
         sub { $router->has_logger(@_) },
      );
   }

   my @levels = @{$class->arg_levels($spec->config->{levels})};
   for my $level (@levels) {
      my %base =
        (exporter => $class, caller_level => 1, message_level => $level);
      my %exports;
      if ($spec->config->{log} || $exports->{"&log_$level"}) {
         $exports{log_} = sub (&@) {
            my ($code, @args) = @_;
            $router->handle_log_request(
               %base,
               caller_package => scalar(caller),
               message_sub    => $code,
               message_args   => \@args,
            );
            return @args;
         };
      }
      if ($spec->config->{log} || $exports->{"&slog_$level"}) {
         $exports{slog_} = sub {
            my ($text, @args) = @_;
            $router->handle_log_request(
               %base,
               caller_package => scalar(caller),
               message_text   => $text,
               message_args   => \@args,
            );
            return @args;
         };
      }
      if ($spec->config->{log} || $exports->{"&logS_$level"}) {
         $exports{logS_} = sub (&@) {
            my ($code, @args) = @_;
            $router->handle_log_request(
               %base,
               caller_package => scalar(caller),
               message_sub    => $code,
               message_args   => \@args,
            );
            return $args[0];
         };
      }
      if ($spec->config->{log} || $exports->{"&slogS_$level"}) {
         $exports{slogS_} = sub {
            my ($text, @args) = @_;
            $router->handle_log_request(
               %base,
               caller_package => scalar(caller),
               message_text   => $text,
               message_args   => \@args,
            );
            return $args[0];
         };
      }
      if ($spec->config->{dlog} || $exports->{"&Dlog_$level"}) {
         $exports{Dlog_} = sub (&@) {
            my ($code, @args) = @_;
            my $wrapped = sub {
               local $_ = (@_ ? Data::Dumper::Concise::Dumper @_ : '()');
               &$code;
            };
            $router->handle_log_request(
               %base,
               caller_package => scalar(caller),
               message_sub    => $wrapped,
               message_args   => \@args,
            );
            return @args;
         };
      }
      if ($spec->config->{dlog} || $exports->{"&Dslog_$level"}) {
         $exports{Dslog_} = sub {
            my ($text, @args) = @_;
            my $wrapped = sub {
               $text . (@_ ? Data::Dumper::Concise::Dumper @_ : '()');
            };
            $router->handle_log_request(
               %base,
               caller_package => scalar(caller),
               message_sub    => $wrapped,
               message_args   => \@args,
            );
            return @args;
         };
      }
      if ($spec->config->{dlog} || $exports->{"&DlogS_$level"}) {
         $exports{DlogS_} = sub (&$) {
            my ($code, $ref) = @_;
            my $wrapped = sub {
               local $_ = Data::Dumper::Concise::Dumper($_[0]);
               &$code;
            };
            $router->handle_log_request(
               %base,
               caller_package => scalar(caller),
               message_sub    => $wrapped,
               message_args   => [$ref],
            );
            return $ref;
         };
      }
      if ($spec->config->{dlog} || $exports->{"&DslogS_$level"}) {
         $exports{DslogS_} = sub {
            my ($text, $ref) = @_;
            my $wrapped = sub {
               $text . Data::Dumper::Concise::Dumper($_[0]);
            };
            $router->handle_log_request(
               %base,
               caller_package => scalar(caller),
               message_sub    => $wrapped,
               message_args   => [$ref],
            );
            return $ref;
         };
      }
      _maybe_export($spec, $importer, $_ . $level, $exports{$_})
        for keys %exports;
   }
}

sub after_import {
   my ($class, $importer, $spec) = @_;
   my %router_args = (
      exporter  => $class,
      target    => $importer,
      arguments => $spec->argument_info
   );
   $class->router->after_import(%router_args);
}

for (qw(set with)) {
   no strict 'refs';
   my $sub = "${_}_logger";
   *{"Log::Contextual::$sub"} = sub {
      die "$sub is no longer a direct sub in Log::Contextual.  "
        . 'Note that this feature was never tested nor documented.  '
        . "Please fix your code to import $sub instead of trying to use it directly"
     }
}

1;

__END__