lib/Log/Contextual.pm

   1 package Log::Contextual;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.00201';
   7
   8 require Exporter;
   9 use Data::Dumper::Concise;
  10 use Scalar::Util 'blessed';
  11
  12 BEGIN { our @ISA = qw(Exporter) }
  13
  14 my @dlog = (qw(
  15    Dlog_debug DlogS_debug
  16    Dlog_trace DlogS_trace
  17    Dlog_warn DlogS_warn
  18    Dlog_info DlogS_info
  19    Dlog_error DlogS_error
  20    Dlog_fatal DlogS_fatal
  21  ));
  22
  23 my @log = (qw(
  24    log_debug logS_debug
  25    log_trace logS_trace
  26    log_warn logS_warn
  27    log_info logS_info
  28    log_error logS_error
  29    log_fatal logS_fatal
  30  ));
  31
  32 our @EXPORT_OK = (
  33    @dlog, @log,
  34    qw( set_logger with_logger )
  35 );
  36
  37 our %EXPORT_TAGS = (
  38    dlog => \@dlog,
  39    log  => \@log,
  40    all  => [@dlog, @log],
  41 );
  42
  43 sub import {
  44    my $package = shift;
  45    die 'Log::Contextual does not have a default import list'
  46       unless @_;
  47
  48    for my $idx ( 0 .. $#_ ) {
  49       my $val = $_[$idx];
  50       if ( defined $val && $val eq '-logger' ) {
  51          set_logger($_[$idx + 1]);
  52          splice @_, $idx, 2;
  53       } elsif ( defined $val && $val eq '-default_logger' ) {
  54          _set_default_logger_for(scalar caller, $_[$idx + 1]);
  55          splice @_, $idx, 2;
  56       }
  57    }
  58    $package->export_to_level(1, $package, @_);
  59 }
  60
  61 our $Get_Logger;
  62 our %Default_Logger;
  63
  64 sub _set_default_logger_for {
  65    my $logger = $_[1];
  66    if(ref $logger ne 'CODE') {
  67       die 'logger was not a CodeRef or a logger object.  Please try again.'
  68          unless blessed($logger);
  69       $logger = do { my $l = $logger; sub { $l } }
  70    }
  71    $Default_Logger{$_[0]} = $logger
  72 }
  73
  74 sub _get_logger($) {
  75    my $package = shift;
  76    (
  77       $Get_Logger ||
  78       $Default_Logger{$package} ||
  79       die q( no logger set!  you can't try to log something without a logger! )
  80    )->($package);
  81 }
  82
  83 sub set_logger {
  84    my $logger = $_[0];
  85    if(ref $logger ne 'CODE') {
  86       die 'logger was not a CodeRef or a logger object.  Please try again.'
  87          unless blessed($logger);
  88       $logger = do { my $l = $logger; sub { $l } }
  89    }
  90
  91    warn 'set_logger (or -logger) called more than once!  This is a bad idea!'
  92       if $Get_Logger;
  93    $Get_Logger = $logger;
  94 }
  95
  96 sub with_logger {
  97    my $logger = $_[0];
  98    if(ref $logger ne 'CODE') {
  99       die 'logger was not a CodeRef or a logger object.  Please try again.'
 100          unless blessed($logger);
 101       $logger = do { my $l = $logger; sub { $l } }
 102    }
 103    local $Get_Logger = $logger;
 104    $_[1]->();
 105 }
 106
 107 sub _do_log {
 108    my $level  = shift;
 109    my $logger = shift;
 110    my $code   = shift;
 111    my @values = @_;
 112
 113    local $Log::Log4perl::caller_depth = ($Log::Log4perl::caller_depth || 0 ) + 2;
 114    $logger->$level($code->(@_))
 115       if $logger->${\"is_$level"};
 116    @values
 117 }
 118
 119 sub _do_logS {
 120    my $level  = shift;
 121    my $logger = shift;
 122    my $code   = shift;
 123    my $value  = shift;
 124
 125    local $Log::Log4perl::caller_depth = ($Log::Log4perl::caller_depth || 0 ) + 2;
 126    $logger->$level($code->($value))
 127       if $logger->${\"is_$level"};
 128    $value
 129 }
 130
 131 sub log_trace (&@) { _do_log( trace => _get_logger( caller ), shift @_, @_) }
 132 sub log_debug (&@) { _do_log( debug => _get_logger( caller ), shift @_, @_) }
 133 sub log_info  (&@) { _do_log( info  => _get_logger( caller ), shift @_, @_) }
 134 sub log_warn  (&@) { _do_log( warn  => _get_logger( caller ), shift @_, @_) }
 135 sub log_error (&@) { _do_log( error => _get_logger( caller ), shift @_, @_) }
 136 sub log_fatal (&@) { _do_log( fatal => _get_logger( caller ), shift @_, @_) }
 137
 138 sub logS_trace (&$) { _do_logS( trace => _get_logger( caller ), $_[0], $_[1]) }
 139 sub logS_debug (&$) { _do_logS( debug => _get_logger( caller ), $_[0], $_[1]) }
 140 sub logS_info  (&$) { _do_logS( info  => _get_logger( caller ), $_[0], $_[1]) }
 141 sub logS_warn  (&$) { _do_logS( warn  => _get_logger( caller ), $_[0], $_[1]) }
 142 sub logS_error (&$) { _do_logS( error => _get_logger( caller ), $_[0], $_[1]) }
 143 sub logS_fatal (&$) { _do_logS( fatal => _get_logger( caller ), $_[0], $_[1]) }
 144
 145
 146 sub Dlog_trace (&@) {
 147   my $code = shift;
 148   local $_ = (@_?Data::Dumper::Concise::Dumper @_:'()');
 149   return _do_log( trace => _get_logger( caller ), $code, @_ );
 150 }
 151
 152 sub Dlog_debug (&@) {
 153   my $code = shift;
 154   local $_ = (@_?Data::Dumper::Concise::Dumper @_:'()');
 155   return _do_log( debug => _get_logger( caller ), $code, @_ );
 156 }
 157
 158 sub Dlog_info (&@) {
 159   my $code = shift;
 160   local $_ = (@_?Data::Dumper::Concise::Dumper @_:'()');
 161   return _do_log( info => _get_logger( caller ), $code, @_ );
 162 }
 163
 164 sub Dlog_warn (&@) {
 165   my $code = shift;
 166   local $_ = (@_?Data::Dumper::Concise::Dumper @_:'()');
 167   return _do_log( warn => _get_logger( caller ), $code, @_ );
 168 }
 169
 170 sub Dlog_error (&@) {
 171   my $code = shift;
 172   local $_ = (@_?Data::Dumper::Concise::Dumper @_:'()');
 173   return _do_log( error => _get_logger( caller ), $code, @_ );
 174 }
 175
 176 sub Dlog_fatal (&@) {
 177   my $code = shift;
 178   local $_ = (@_?Data::Dumper::Concise::Dumper @_:'()');
 179   return _do_log( fatal => _get_logger( caller ), $code, @_ );
 180 }
 181
 182
 183 sub DlogS_trace (&$) {
 184   local $_ = Data::Dumper::Concise::Dumper $_[1];
 185   _do_logS( trace => _get_logger( caller ), $_[0], $_[1] )
 186 }
 187
 188 sub DlogS_debug (&$) {
 189   local $_ = Data::Dumper::Concise::Dumper $_[1];
 190   _do_logS( debug => _get_logger( caller ), $_[0], $_[1] )
 191 }
 192
 193 sub DlogS_info (&$) {
 194   local $_ = Data::Dumper::Concise::Dumper $_[1];
 195   _do_logS( info => _get_logger( caller ), $_[0], $_[1] )
 196 }
 197
 198 sub DlogS_warn (&$) {
 199   local $_ = Data::Dumper::Concise::Dumper $_[1];
 200   _do_logS( warn => _get_logger( caller ), $_[0], $_[1] )
 201 }
 202
 203 sub DlogS_error (&$) {
 204   local $_ = Data::Dumper::Concise::Dumper $_[1];
 205   _do_logS( error => _get_logger( caller ), $_[0], $_[1] )
 206 }
 207
 208 sub DlogS_fatal (&$) {
 209   local $_ = Data::Dumper::Concise::Dumper $_[1];
 210   _do_logS( fatal => _get_logger( caller ), $_[0], $_[1] )
 211 }
 212
 213 1;
 214
 215 __END__
 216
 217 =head1 NAME
 218
 219 Log::Contextual - Simple logging interface with a contextual log
 220
 221 =head1 SYNOPSIS
 222
 223  use Log::Contextual qw( :log :dlog set_logger with_logger );
 224  use Log::Contextual::SimpleLogger;
 225  use Log::Log4perl ':easy';
 226  Log::Log4perl->easy_init($DEBUG);
 227
 228
 229  my $logger  = Log::Log4perl->get_logger;
 230
 231  set_logger $logger;
 232
 233  log_debug { 'program started' };
 234
 235  sub foo {
 236    with_logger(Log::Contextual::SimpleLogger->new({
 237        levels => [qw( trace debug )]
 238      }) => sub {
 239      log_trace { 'foo entered' };
 240      my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @_;
 241      # ...
 242      log_trace { 'foo left' };
 243    });
 244  }
 245
 246  foo();
 247
 248 Beginning with version 1.008 L<Log::Dispatchouli> also works out of the box
 249 with C<Log::Contextual>:
 250
 251  use Log::Contextual qw( :log :dlog set_logger );
 252  use Log::Dispatchouli;
 253  my $ld = Log::Dispatchouli->new({
 254     ident     => 'slrtbrfst',
 255     to_stderr => 1,
 256     debug     => 1,
 257  });
 258
 259  set_logger $ld;
 260
 261  log_debug { 'program started' };
 262
 263 =head1 DESCRIPTION
 264
 265 This module is a simple interface to extensible logging.  It is bundled with a
 266 really basic logger, L<Log::Contextual::SimpleLogger>, but in general you
 267 should use a real logger instead of that.  For something more serious but not
 268 overly complicated, try L<Log::Dispatchouli> (see L</SYNOPSIS> for example.)
 269
 270 =head1 OPTIONS
 271
 272 =head2 -logger
 273
 274 When you import this module you may use C<-logger> as a shortcut for
 275 L<set_logger>, for example:
 276
 277  use Log::Contextual::SimpleLogger;
 278  use Log::Contextual qw( :dlog ),
 279    -logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )] });
 280
 281 sometimes you might want to have the logger handy for other stuff, in which
 282 case you might try something like the following:
 283
 284  my $var_log;
 285  BEGIN { $var_log = VarLogger->new }
 286  use Log::Contextual qw( :dlog ), -logger => $var_log;
 287
 288 =head2 -default_logger
 289
 290 The C<-default_logger> import option is similar to the C<-logger> import option
 291 except C<-default_logger> sets the the default logger for the current package.
 292
 293 Basically it sets the logger to be used if C<set_logger> is never called; so
 294
 295  package My::Package;
 296  use Log::Contextual::SimpleLogger;
 297  use Log::Contextual qw( :log ),
 298    -default_logger => Log::Contextual::WarnLogger->new({
 299       env_prefix => 'MY_PACKAGE'
 300    });
 301
 302 If you are interested in using this package for a module you are putting on
 303 CPAN we recommend L<Log::Contextual::WarnLogger> for your default logger.
 304
 305 =head1 A WORK IN PROGRESS
 306
 307 This module is certainly not complete, but we will not break the interface
 308 lightly, so I would say it's safe to use in production code.  The main result
 309 from that at this point is that doing:
 310
 311  use Log::Contextual;
 312
 313 will die as we do not yet know what the defaults should be.  If it turns out
 314 that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll
 315 probably make C<:log> the default.  But only time and usage will tell.
 316
 317 =head1 FUNCTIONS
 318
 319 =head2 set_logger
 320
 321  my $logger = WarnLogger->new;
 322  set_logger $logger;
 323
 324 Arguments: C<Ref|CodeRef $returning_logger>
 325
 326 C<set_logger> will just set the current logger to whatever you pass it.  It
 327 expects a C<CodeRef>, but if you pass it something else it will wrap it in a
 328 C<CodeRef> for you.  C<set_logger> is really meant only to be called from a
 329 top-level script.  To avoid foot-shooting the function will warn if you call it
 330 more than once.
 331
 332 =head2 with_logger
 333
 334  my $logger = WarnLogger->new;
 335  with_logger $logger => sub {
 336     if (1 == 0) {
 337        log_fatal { 'Non Logical Universe Detected' };
 338     } else {
 339        log_info  { 'All is good' };
 340     }
 341  };
 342
 343 Arguments: C<Ref|CodeRef $returning_logger, CodeRef $to_execute>
 344
 345 C<with_logger> sets the logger for the scope of the C<CodeRef> C<$to_execute>.
 346 As with L</set_logger>, C<with_logger> will wrap C<$returning_logger> with a
 347 C<CodeRef> if needed.
 348
 349 =head2 log_$level
 350
 351 Import Tag: C<:log>
 352
 353 Arguments: C<CodeRef $returning_message, @args>
 354
 355 All of the following six functions work the same except that a different method
 356 is called on the underlying C<$logger> object.  The basic pattern is:
 357
 358  sub log_$level (&@) {
 359    if ($logger->is_$level) {
 360      $logger->$level(shift->(@_));
 361    }
 362    @_
 363  }
 364
 365 Note that the function returns it's arguments.  This can be used in a number of
 366 ways, but often it's convenient just for partial inspection of passthrough data
 367
 368  my @friends = log_trace {
 369    'friends list being generated, data from first friend: ' .
 370      Dumper($_[0]->TO_JSON)
 371  } generate_friend_list();
 372
 373 If you want complete inspection of passthrough data, take a look at the
 374 L</Dlog_$level> functions.
 375
 376 =head3 log_trace
 377
 378  log_trace { 'entered method foo with args ' join q{,}, @args };
 379
 380 =head3 log_debug
 381
 382  log_debug { 'entered method foo' };
 383
 384 =head3 log_info
 385
 386  log_info { 'started process foo' };
 387
 388 =head3 log_warn
 389
 390  log_warn { 'possible misconfiguration at line 10' };
 391
 392 =head3 log_error
 393
 394  log_error { 'non-numeric user input!' };
 395
 396 =head3 log_fatal
 397
 398  log_fatal { '1 is never equal to 0!' };
 399
 400 =head2 logS_$level
 401
 402 Import Tag: C<:log>
 403
 404 Arguments: C<CodeRef $returning_message, Item $arg>
 405
 406 This is really just a special case of the L</log_$level> functions.  It forces
 407 scalar context when that is what you need.  Other than that it works exactly
 408 same:
 409
 410  my $friend = logS_trace {
 411    'I only have one friend: ' .  Dumper($_[0]->TO_JSON)
 412  } friend();
 413
 414 See also: L</DlogS_$level>.
 415
 416 =head2 Dlog_$level
 417
 418 Import Tag: C<:dlog>
 419
 420 Arguments: C<CodeRef $returning_message, @args>
 421
 422 All of the following six functions work the same as their L</log_$level>
 423 brethren, except they return what is passed into them and put the stringified
 424 (with L<Data::Dumper::Concise>) version of their args into C<$_>.  This means
 425 you can do cool things like the following:
 426
 427  my @nicks = Dlog_debug { "names: $_" } map $_->value, $frew->names->all;
 428
 429 and the output might look something like:
 430
 431  names: "fREW"
 432  "fRIOUX"
 433  "fROOH"
 434  "fRUE"
 435  "fiSMBoC"
 436
 437 =head3 Dlog_trace
 438
 439  my ($foo, $bar) = Dlog_trace { "entered method foo with args: $_" } @_;
 440
 441 =head3 Dlog_debug
 442
 443  Dlog_debug { "random data structure: $_" } { foo => $bar };
 444
 445 =head3 Dlog_info
 446
 447  return Dlog_info { "html from method returned: $_" } "<html>...</html>";
 448
 449 =head3 Dlog_warn
 450
 451  Dlog_warn { "probably invalid value: $_" } $foo;
 452
 453 =head3 Dlog_error
 454
 455  Dlog_error { "non-numeric user input! ($_)" } $port;
 456
 457 =head3 Dlog_fatal
 458
 459  Dlog_fatal { '1 is never equal to 0!' } 'ZOMG ZOMG' if 1 == 0;
 460
 461 =head2 DlogS_$level
 462
 463 Import Tag: C<:dlog>
 464
 465 Arguments: C<CodeRef $returning_message, Item $arg>
 466
 467 Like L</logS_$level>, these functions are a special case of L</Dlog_$level>.
 468 They only take a single scalar after the C<$returning_message> instead of
 469 slurping up (and also setting C<wantarray>) all the C<@args>
 470
 471  my $pals_rs = DlogS_debug { "pals resultset: $_" }
 472    $schema->resultset('Pals')->search({ perlers => 1 });
 473
 474 =head1 LOGGER INTERFACE
 475
 476 Because this module is ultimately pretty looking glue (glittery?) with the
 477 awesome benefit of the Contextual part, users will often want to make their
 478 favorite logger work with it.  The following are the methods that should be
 479 implemented in the logger:
 480
 481  is_trace
 482  is_debug
 483  is_info
 484  is_warn
 485  is_error
 486  is_fatal
 487  trace
 488  debug
 489  info
 490  warn
 491  error
 492  fatal
 493
 494 The first six merely need to return true if that level is enabled.  The latter
 495 six take the results of whatever the user returned from their coderef and log
 496 them.  For a basic example see L<Log::Contextual::SimpleLogger>.
 497
 498 =head1 AUTHOR
 499
 500 frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
 501
 502 =head1 DESIGNER
 503
 504 mst - Matt S. Trout <mst@shadowcat.co.uk>
 505
 506 =head1 COPYRIGHT
 507
 508 Copyright (c) 2010 the Log::Contextual L</AUTHOR> and L</DESIGNER> as listed
 509 above.
 510
 511 =head1 LICENSE
 512
 513 This library is free software and may be distributed under the same terms as
 514 Perl 5 itself.
 515
 516 =cut
 517