test of CatLogger idiom

[p5sagit/Log-Contextual.git] / lib / Log / Contextual.pm

package Log::Contextual;

use strict;
use warnings;

our $VERSION = '0.00304';

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

require Exporter;
use Data::Dumper::Concise;
use Scalar::Util 'blessed';

BEGIN { our @ISA = qw(Exporter) }

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

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

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

our @EXPORT_OK = (
   @dlog, @log,
   qw( set_logger with_logger )
);

our %EXPORT_TAGS = (
   dlog => \@dlog,
   log  => \@log,
   all  => [@dlog, @log],
);

sub import {
   my $package = shift;

   my $skipnext;
   my @rest;
   for my $idx ( 0 .. $#_ ) {
      if ($skipnext) {
         $skipnext--;
         next;
      }

      my $val = $_[$idx];
      if (!defined $val) {
         next;
      } elsif ( $val eq '-logger' ) {
         set_logger($_[$idx + 1]);
         $skipnext = 1;
      } elsif ( $val eq '-args' ) {
         _set_package_logger_args_for(scalar caller, $_[$idx + 1]);
         $skipnext = 1;
      } elsif ( $val eq '-package_logger' ) {
         _set_package_logger_for(scalar caller, $_[$idx + 1]);
         $skipnext = 1;
      } elsif ( $val eq '-default_logger' ) {
         _set_default_logger_for(scalar caller, $_[$idx + 1]);
         $skipnext = 1;
      } else {
         push @rest, $val;
      }
   }

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

   $package->export_to_level(1, $package, @rest);
}

our $Get_Logger;
our %Default_Logger;
our %Package_Logger;
our %Package_Logger_Args;

sub _set_default_logger_for {
   my $logger = $_[1];
   if(ref $logger ne 'CODE') {
      die 'logger was not a CodeRef or a logger object.  Please try again.'
         unless blessed($logger);
      $logger = do { my $l = $logger; sub { $l } }
   }
   $Default_Logger{$_[0]} = $logger
}

sub _set_package_logger_args_for {
   my $args = $_[1];
   die 'args are not an arrayref.  Please try again.'
      unless ref $args eq 'ARRAY';
   $Package_Logger_Args{$_[0]} = $args
}

sub _set_package_logger_for {
   my $logger = $_[1];
   if(ref $logger ne 'CODE') {
      die 'logger was not a CodeRef or a logger object.  Please try again.'
         unless blessed($logger);
      $logger = do { my $l = $logger; sub { $l } }
   }
   $Package_Logger{$_[0]} = $logger
}

sub _get_logger($) {
   my $package = shift;
   (
      $Package_Logger{$package} ||
      $Get_Logger ||
      $Default_Logger{$package} ||
      die q( no logger set!  you can't try to log something without a logger! )
   )->({
      package => $package,
      args    => $Package_Logger_Args{$package},
   });
}

sub set_logger {
   my $logger = $_[0];
   if(ref $logger ne 'CODE') {
      die 'logger was not a CodeRef or a logger object.  Please try again.'
         unless blessed($logger);
      $logger = do { my $l = $logger; sub { $l } }
   }

   warn 'set_logger (or -logger) called more than once!  This is a bad idea!'
      if $Get_Logger;
   $Get_Logger = $logger;
}

sub with_logger {
   my $logger = $_[0];
   if(ref $logger ne 'CODE') {
      die 'logger was not a CodeRef or a logger object.  Please try again.'
         unless blessed($logger);
      $logger = do { my $l = $logger; sub { $l } }
   }
   local $Get_Logger = $logger;
   $_[1]->();
}

sub _do_log {
   my $level  = shift;
   my $logger = shift;
   my $code   = shift;
   my @values = @_;

   $logger->$level($code->(@_))
      if $logger->${\"is_$level"};
   @values
}

sub _do_logS {
   my $level  = shift;
   my $logger = shift;
   my $code   = shift;
   my $value  = shift;

   $logger->$level($code->($value))
      if $logger->${\"is_$level"};
   $value
}

for my $level (@levels) {
   no strict 'refs';

   *{"log_$level"} = sub (&@) {
      _do_log( $level => _get_logger( caller ), shift @_, @_)
   };

   *{"logS_$level"} = sub (&$) {
      _do_logS( $level => _get_logger( caller ), $_[0], $_[1])
   };

   *{"Dlog_$level"} = sub (&@) {
     my $code = shift;
     local $_ = (@_?Data::Dumper::Concise::Dumper @_:'()');
     return _do_log( $level => _get_logger( caller ), $code, @_ );
   };

   *{"DlogS_$level"} = sub (&$) {
     local $_ = Data::Dumper::Concise::Dumper $_[1];
     _do_logS( $level => _get_logger( caller ), $_[0], $_[1] )
   };
}

1;

__END__

=head1 NAME

Log::Contextual - Simple logging interface with a contextual log

=head1 SYNOPSIS

 use Log::Contextual qw( :log :dlog set_logger with_logger );
 use Log::Contextual::SimpleLogger;
 use Log::Log4perl ':easy';
 Log::Log4perl->easy_init($DEBUG);


 my $logger  = Log::Log4perl->get_logger;

 set_logger $logger;

 log_debug { 'program started' };

 sub foo {
   with_logger(Log::Contextual::SimpleLogger->new({
       levels => [qw( trace debug )]
     }) => sub {
     log_trace { 'foo entered' };
     my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @_;
     # ...
     log_trace { 'foo left' };
   });
 }

 foo();

Beginning with version 1.008 L<Log::Dispatchouli> also works out of the box
with C<Log::Contextual>:

 use Log::Contextual qw( :log :dlog set_logger );
 use Log::Dispatchouli;
 my $ld = Log::Dispatchouli->new({
    ident     => 'slrtbrfst',
    to_stderr => 1,
    debug     => 1,
 });

 set_logger $ld;

 log_debug { 'program started' };

=head1 DESCRIPTION

This module is a simple interface to extensible logging.  It is bundled with a
really basic logger, L<Log::Contextual::SimpleLogger>, but in general you
should use a real logger instead of that.  For something more serious but not
overly complicated, try L<Log::Dispatchouli> (see L</SYNOPSIS> for example.)

=head1 OPTIONS

=head2 -logger

When you import this module you may use C<-logger> as a shortcut for
L<set_logger>, for example:

 use Log::Contextual::SimpleLogger;
 use Log::Contextual qw( :dlog ),
   -logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )] });

sometimes you might want to have the logger handy for other stuff, in which
case you might try something like the following:

 my $var_log;
 BEGIN { $var_log = VarLogger->new }
 use Log::Contextual qw( :dlog ), -logger => $var_log;

=head2 -package_logger

The C<-package_logger> import option is similar to the C<-logger> import option
except C<-package_logger> sets the the logger for the current package.

Unlike L</-default_logger>, C<-package_logger> cannot be overridden with
L</set_logger>.

 package My::Package;
 use Log::Contextual::SimpleLogger;
 use Log::Contextual qw( :log ),
   -package_logger => Log::Contextual::WarnLogger->new({
      env_prefix => 'MY_PACKAGE'
   });

If you are interested in using this package for a module you are putting on
CPAN we recommend L<Log::Contextual::WarnLogger> for your package logger.

=head2 -default_logger

The C<-default_logger> import option is similar to the C<-logger> import option
except C<-default_logger> sets the the B<default> logger for the current package.

Basically it sets the logger to be used if C<set_logger> is never called; so

 package My::Package;
 use Log::Contextual::SimpleLogger;
 use Log::Contextual qw( :log ),
   -default_logger => Log::Contextual::WarnLogger->new({
      env_prefix => 'MY_PACKAGE'
   });

=head1 A WORK IN PROGRESS

This module is certainly not complete, but we will not break the interface
lightly, so I would say it's safe to use in production code.  The main result
from that at this point is that doing:

 use Log::Contextual;

will die as we do not yet know what the defaults should be.  If it turns out
that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll
probably make C<:log> the default.  But only time and usage will tell.

=head1 FUNCTIONS

=head2 set_logger

 my $logger = WarnLogger->new;
 set_logger $logger;

Arguments: C<Ref|CodeRef $returning_logger>

C<set_logger> will just set the current logger to whatever you pass it.  It
expects a C<CodeRef>, but if you pass it something else it will wrap it in a
C<CodeRef> for you.  C<set_logger> is really meant only to be called from a
top-level script.  To avoid foot-shooting the function will warn if you call it
more than once.

=head2 with_logger

 my $logger = WarnLogger->new;
 with_logger $logger => sub {
    if (1 == 0) {
       log_fatal { 'Non Logical Universe Detected' };
    } else {
       log_info  { 'All is good' };
    }
 };

Arguments: C<Ref|CodeRef $returning_logger, CodeRef $to_execute>

C<with_logger> sets the logger for the scope of the C<CodeRef> C<$to_execute>.
As with L</set_logger>, C<with_logger> will wrap C<$returning_logger> with a
C<CodeRef> if needed.

=head2 log_$level

Import Tag: C<:log>

Arguments: C<CodeRef $returning_message, @args>

All of the following six functions work the same except that a different method
is called on the underlying C<$logger> object.  The basic pattern is:

 sub log_$level (&@) {
   if ($logger->is_$level) {
     $logger->$level(shift->(@_));
   }
   @_
 }

Note that the function returns it's arguments.  This can be used in a number of
ways, but often it's convenient just for partial inspection of passthrough data

 my @friends = log_trace {
   'friends list being generated, data from first friend: ' .
     Dumper($_[0]->TO_JSON)
 } generate_friend_list();

If you want complete inspection of passthrough data, take a look at the
L</Dlog_$level> functions.

=head3 log_trace

 log_trace { 'entered method foo with args ' join q{,}, @args };

=head3 log_debug

 log_debug { 'entered method foo' };

=head3 log_info

 log_info { 'started process foo' };

=head3 log_warn

 log_warn { 'possible misconfiguration at line 10' };

=head3 log_error

 log_error { 'non-numeric user input!' };

=head3 log_fatal

 log_fatal { '1 is never equal to 0!' };

=head2 logS_$level

Import Tag: C<:log>

Arguments: C<CodeRef $returning_message, Item $arg>

This is really just a special case of the L</log_$level> functions.  It forces
scalar context when that is what you need.  Other than that it works exactly
same:

 my $friend = logS_trace {
   'I only have one friend: ' .  Dumper($_[0]->TO_JSON)
 } friend();

See also: L</DlogS_$level>.

=head2 Dlog_$level

Import Tag: C<:dlog>

Arguments: C<CodeRef $returning_message, @args>

All of the following six functions work the same as their L</log_$level>
brethren, except they return what is passed into them and put the stringified
(with L<Data::Dumper::Concise>) version of their args into C<$_>.  This means
you can do cool things like the following:

 my @nicks = Dlog_debug { "names: $_" } map $_->value, $frew->names->all;

and the output might look something like:

 names: "fREW"
 "fRIOUX"
 "fROOH"
 "fRUE"
 "fiSMBoC"

=head3 Dlog_trace

 my ($foo, $bar) = Dlog_trace { "entered method foo with args: $_" } @_;

=head3 Dlog_debug

 Dlog_debug { "random data structure: $_" } { foo => $bar };

=head3 Dlog_info

 return Dlog_info { "html from method returned: $_" } "<html>...</html>";

=head3 Dlog_warn

 Dlog_warn { "probably invalid value: $_" } $foo;

=head3 Dlog_error

 Dlog_error { "non-numeric user input! ($_)" } $port;

=head3 Dlog_fatal

 Dlog_fatal { '1 is never equal to 0!' } 'ZOMG ZOMG' if 1 == 0;

=head2 DlogS_$level

Import Tag: C<:dlog>

Arguments: C<CodeRef $returning_message, Item $arg>

Like L</logS_$level>, these functions are a special case of L</Dlog_$level>.
They only take a single scalar after the C<$returning_message> instead of
slurping up (and also setting C<wantarray>) all the C<@args>

 my $pals_rs = DlogS_debug { "pals resultset: $_" }
   $schema->resultset('Pals')->search({ perlers => 1 });

=head1 LOGGER INTERFACE

Because this module is ultimately pretty looking glue (glittery?) with the
awesome benefit of the Contextual part, users will often want to make their
favorite logger work with it.  The following are the methods that should be
implemented in the logger:

 is_trace
 is_debug
 is_info
 is_warn
 is_error
 is_fatal
 trace
 debug
 info
 warn
 error
 fatal

The first six merely need to return true if that level is enabled.  The latter
six take the results of whatever the user returned from their coderef and log
them.  For a basic example see L<Log::Contextual::SimpleLogger>.

=head1 AUTHOR

frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>

=head1 DESIGNER

mst - Matt S. Trout <mst@shadowcat.co.uk>

=head1 COPYRIGHT

Copyright (c) 2010 the Log::Contextual L</AUTHOR> and L</DESIGNER> as listed
above.

=head1 LICENSE

This library is free software and may be distributed under the same terms as
Perl 5 itself.

=cut