lib/Log/Contextual.pm

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