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