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 When you import this module you may use C<-logger> as a shortcut for
 386 L<set_logger>, for example:
 387
 388  use Log::Contextual::SimpleLogger;
 389  use Log::Contextual qw( :dlog ),
 390    -logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )] });
 391
 392 sometimes you might want to have the logger handy for other stuff, in which
 393 case you might try something like the following:
 394
 395  my $var_log;
 396  BEGIN { $var_log = VarLogger->new }
 397  use Log::Contextual qw( :dlog ), -logger => $var_log;
 398
 399 =head1 A WORK IN PROGRESS
 400
 401 This module is certainly not complete, but we will not break the interface
 402 lightly, so I would say it's safe to use in production code.  The main result
 403 from that at this point is that doing:
 404
 405  use Log::Contextual;
 406
 407 will die as we do not yet know what the defaults should be.  If it turns out
 408 that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll
 409 probably make C<:log> the default.  But only time and usage will tell.
 410
 411 =head1 FUNCTIONS
 412
 413 =head2 set_logger
 414
 415  my $logger = WarnLogger->new;
 416  set_logger $logger;
 417
 418 Arguments: C<Ref|CodeRef $returning_logger>
 419
 420 C<set_logger> will just set the current logger to whatever you pass it.  It
 421 expects a C<CodeRef>, but if you pass it something else it will wrap it in a
 422 C<CodeRef> for you.  C<set_logger> is really meant only to be called from a
 423 top-level script.  To avoid foot-shooting the function will warn if you call it
 424 more than once.
 425
 426 =head2 with_logger
 427
 428  my $logger = WarnLogger->new;
 429  with_logger $logger => sub {
 430     if (1 == 0) {
 431        log_fatal { 'Non Logical Universe Detected' };
 432     } else {
 433        log_info  { 'All is good' };
 434     }
 435  };
 436
 437 Arguments: C<Ref|CodeRef $returning_logger, CodeRef $to_execute>
 438
 439 C<with_logger> sets the logger for the scope of the C<CodeRef> C<$to_execute>.
 440 As with L</set_logger>, C<with_logger> will wrap C<$returning_logger> with a
 441 C<CodeRef> if needed.
 442
 443 =head2 log_$level
 444
 445 Import Tag: C<:log>
 446
 447 Arguments: C<CodeRef $returning_message, @args>
 448
 449 All of the following six functions work the same except that a different method
 450 is called on the underlying C<$logger> object.  The basic pattern is:
 451
 452  sub log_$level (&@) {
 453    if ($logger->is_$level) {
 454      $logger->$level(shift->(@_));
 455    }
 456    @_
 457  }
 458
 459 Note that the function returns it's arguments.  This can be used in a number of
 460 ways, but often it's convenient just for partial inspection of passthrough data
 461
 462  my @friends = log_trace {
 463    'friends list being generated, data from first friend: ' .
 464      Dumper($_[0]->TO_JSON)
 465  } generate_friend_list();
 466
 467 If you want complete inspection of passthrough data, take a look at the
 468 L</Dlog_$level> functions.
 469
 470 =head3 log_trace
 471
 472  log_trace { 'entered method foo with args ' join q{,}, @args };
 473
 474 =head3 log_debug
 475
 476  log_debug { 'entered method foo' };
 477
 478 =head3 log_info
 479
 480  log_info { 'started process foo' };
 481
 482 =head3 log_warn
 483
 484  log_warn { 'possible misconfiguration at line 10' };
 485
 486 =head3 log_error
 487
 488  log_error { 'non-numeric user input!' };
 489
 490 =head3 log_fatal
 491
 492  log_fatal { '1 is never equal to 0!' };
 493
 494 =head2 logS_$level
 495
 496 Import Tag: C<:log>
 497
 498 Arguments: C<CodeRef $returning_message, Item $arg>
 499
 500 This is really just a special case of the L</log_$level> functions.  It forces
 501 scalar context when that is what you need.  Other than that it works exactly
 502 same:
 503
 504  my $friend = logS_trace {
 505    'I only have one friend: ' .  Dumper($_[0]->TO_JSON)
 506  } friend();
 507
 508 See also: L</DlogS_$level>.
 509
 510 =head2 Dlog_$level
 511
 512 Import Tag: C<:dlog>
 513
 514 Arguments: C<CodeRef $returning_message, @args>
 515
 516 All of the following six functions work the same as their L</log_$level>
 517 brethren, except they return what is passed into them and put the stringified
 518 (with L<Data::Dumper::Concise>) version of their args into C<$_>.  This means
 519 you can do cool things like the following:
 520
 521  my @nicks = Dlog_debug { "names: $_" } map $_->value, $frew->names->all;
 522
 523 and the output might look something like:
 524
 525  names: "fREW"
 526  "fRIOUX"
 527  "fROOH"
 528  "fRUE"
 529  "fiSMBoC"
 530
 531 =head3 Dlog_trace
 532
 533  my ($foo, $bar) = Dlog_trace { "entered method foo with args: $_" } @_;
 534
 535 =head3 Dlog_debug
 536
 537  Dlog_debug { "random data structure: $_" } { foo => $bar };
 538
 539 =head3 Dlog_info
 540
 541  return Dlog_info { "html from method returned: $_" } "<html>...</html>";
 542
 543 =head3 Dlog_warn
 544
 545  Dlog_warn { "probably invalid value: $_" } $foo;
 546
 547 =head3 Dlog_error
 548
 549  Dlog_error { "non-numeric user input! ($_)" } $port;
 550
 551 =head3 Dlog_fatal
 552
 553  Dlog_fatal { '1 is never equal to 0!' } 'ZOMG ZOMG' if 1 == 0;
 554
 555 =head2 DlogS_$level
 556
 557 Import Tag: C<:dlog>
 558
 559 Arguments: C<CodeRef $returning_message, Item $arg>
 560
 561 Like L</logS_$level>, these functions are a special case of L</Dlog_$level>.
 562 They only take a single scalar after the C<$returning_message> instead of
 563 slurping up (and also setting C<wantarray>) all the C<@args>
 564
 565  my $pals_rs = DlogS_debug { "pals resultset: $_" }
 566    $schema->resultset('Pals')->search({ perlers => 1 });
 567
 568 =head1 LOGGER INTERFACE
 569
 570 Because this module is ultimately pretty looking glue (glittery?) with the
 571 awesome benefit of the Contextual part, users will often want to make their
 572 favorite logger work with it.  The following are the methods that should be
 573 implemented in the logger:
 574
 575  is_trace
 576  is_debug
 577  is_info
 578  is_warn
 579  is_error
 580  is_fatal
 581  trace
 582  debug
 583  info
 584  warn
 585  error
 586  fatal
 587
 588 The first six merely need to return true if that level is enabled.  The latter
 589 six take the results of whatever the user returned from their coderef and log
 590 them.  For a basic example see L<Log::Contextual::SimpleLogger>.
 591
 592 =head1 AUTHOR
 593
 594 frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
 595
 596 =head1 DESIGNER
 597
 598 mst - Matt S. Trout <mst@shadowcat.co.uk>
 599
 600 =head1 COPYRIGHT
 601
 602 Copyright (c) 2010 the Log::Contextual L</AUTHOR> and L</DESIGNER> as listed
 603 above.
 604
 605 =head1 LICENSE
 606
 607 This library is free software and may be distributed under the same terms as
 608 Perl 5 itself.
 609
 610 =cut
 611