lib/Log/Contextual.pm

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