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