lib/Log/Contextual.pm

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