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