lib/Log/Contextual.pm

   1 package Log::Contextual;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.005001';
   7 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
   8
   9 my @levels = qw(debug trace warn info error fatal);
  10
  11 use Exporter::Declare;
  12 use Exporter::Declare::Export::Generator;
  13 use Data::Dumper::Concise;
  14 use Scalar::Util 'blessed';
  15
  16 my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels));
  17
  18 my @log = ((map "log_$_", @levels), (map "logS_$_", @levels));
  19
  20 eval {
  21    require Log::Log4perl;
  22    die if $Log::Log4perl::VERSION < 1.29;
  23    Log::Log4perl->wrapper_register(__PACKAGE__)
  24 };
  25
  26 # ____ is because tags must have at least one export and we don't want to
  27 # export anything but the levels selected
  28 sub ____ { }
  29
  30 exports ('____',
  31    @dlog, @log,
  32    qw( set_logger with_logger )
  33 );
  34
  35 export_tag dlog => ('____');
  36 export_tag log  => ('____');
  37 import_arguments qw(logger package_logger default_logger);
  38
  39 sub router {
  40    our $Router_Instance ||= do {
  41       require Log::Contextual::Router;
  42       Log::Contextual::Router->new
  43      }
  44 }
  45
  46 sub default_import {
  47    my ($class) = shift;
  48
  49    die 'Log::Contextual does not have a default import list';
  50
  51    ()
  52 }
  53
  54 sub arg_logger         { $_[1] }
  55 sub arg_levels         { $_[1] || [qw(debug trace warn info error fatal)] }
  56 sub arg_package_logger { $_[1] }
  57 sub arg_default_logger { $_[1] }
  58
  59 sub before_import {
  60    my ($class, $importer, $spec) = @_;
  61    my $router      = $class->router;
  62    my $exports     = $spec->exports;
  63    my %router_args = (
  64       exporter  => $class,
  65       target    => $importer,
  66       arguments => $spec->argument_info
  67    );
  68
  69    my @tags = $class->default_import($spec)
  70      if $spec->config->{default};
  71
  72    for (@tags) {
  73       die "only tags are supported for defaults at this time"
  74         unless $_ =~ /^:(.*)$/;
  75
  76       $spec->config->{$1} = 1;
  77    }
  78
  79    $router->before_import(%router_args);
  80
  81    if ($exports->{'&set_logger'}) {
  82       die ref($router) . " does not support set_logger()"
  83         unless $router->does('Log::Contextual::Role::Router::SetLogger');
  84
  85       $spec->add_export('&set_logger', sub { $router->set_logger(@_) })
  86    }
  87
  88    if ($exports->{'&with_logger'}) {
  89       die ref($router) . " does not support with_logger()"
  90         unless $router->does('Log::Contextual::Role::Router::WithLogger');
  91
  92       $spec->add_export('&with_logger', sub { $router->with_logger(@_) })
  93    }
  94
  95    my @levels = @{$class->arg_levels($spec->config->{levels})};
  96    for my $level (@levels) {
  97       if ($spec->config->{log} || $exports->{"&log_$level"}) {
  98          $spec->add_export(
  99             "&log_$level",
 100             sub (&@) {
 101                my ($code, @args) = @_;
 102                $router->handle_log_request(
 103                   exporter       => $class,
 104                   caller_package => scalar(caller),
 105                   caller_level   => 1,
 106                   message_level  => $level,
 107                   message_sub    => $code,
 108                   message_args   => \@args,
 109                );
 110                return @args;
 111             });
 112       }
 113       if ($spec->config->{log} || $exports->{"&logS_$level"}) {
 114          $spec->add_export(
 115             "&logS_$level",
 116             sub (&@) {
 117                my ($code, @args) = @_;
 118                $router->handle_log_request(
 119                   exporter       => $class,
 120                   caller_package => scalar(caller),
 121                   caller_level   => 1,
 122                   message_level  => $level,
 123                   message_sub    => $code,
 124                   message_args   => \@args,
 125                );
 126                return $args[0];
 127             });
 128       }
 129       if ($spec->config->{dlog} || $exports->{"&Dlog_$level"}) {
 130          $spec->add_export(
 131             "&Dlog_$level",
 132             sub (&@) {
 133                my ($code, @args) = @_;
 134                my $wrapped = sub {
 135                   local $_ = (@_ ? Data::Dumper::Concise::Dumper @_ : '()');
 136                   &$code;
 137                };
 138                $router->handle_log_request(
 139                   exporter       => $class,
 140                   caller_package => scalar(caller),
 141                   caller_level   => 1,
 142                   message_level  => $level,
 143                   message_sub    => $wrapped,
 144                   message_args   => \@args,
 145                );
 146                return @args;
 147             });
 148       }
 149       if ($spec->config->{dlog} || $exports->{"&DlogS_$level"}) {
 150          $spec->add_export(
 151             "&DlogS_$level",
 152             sub (&$) {
 153                my ($code, $ref) = @_;
 154                my $wrapped = sub {
 155                   local $_ = Data::Dumper::Concise::Dumper($_[0]);
 156                   &$code;
 157                };
 158                $router->handle_log_request(
 159                   exporter       => $class,
 160                   caller_package => scalar(caller),
 161                   caller_level   => 1,
 162                   message_level  => $level,
 163                   message_sub    => $wrapped,
 164                   message_args   => [$ref],
 165                );
 166                return $ref;
 167             });
 168       }
 169    }
 170 }
 171
 172 sub after_import {
 173    my ($class, $importer, $spec) = @_;
 174    my %router_args = (
 175       exporter  => $class,
 176       target    => $importer,
 177       arguments => $spec->argument_info
 178    );
 179    $class->router->after_import(%router_args);
 180 }
 181
 182 1;
 183
 184 __END__
 185
 186 =head1 NAME
 187
 188 Log::Contextual - Simple logging interface with a contextual log
 189
 190 =head1 SYNOPSIS
 191
 192  use Log::Contextual qw( :log :dlog set_logger with_logger );
 193  use Log::Contextual::SimpleLogger;
 194  use Log::Log4perl ':easy';
 195  Log::Log4perl->easy_init($DEBUG);
 196
 197  my $logger  = Log::Log4perl->get_logger;
 198
 199  set_logger $logger;
 200
 201  log_debug { 'program started' };
 202
 203  sub foo {
 204
 205    my $minilogger = Log::Contextual::SimpleLogger->new({
 206      levels => [qw( trace debug )]
 207    });
 208
 209    my @args = @_;
 210
 211    with_logger $minilogger => sub {
 212      log_trace { 'foo entered' };
 213      my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @args;
 214      # ...
 215      log_trace { 'foo left' };
 216    };
 217  }
 218
 219  foo();
 220
 221 Beginning with version 1.008 L<Log::Dispatchouli> also works out of the box
 222 with C<Log::Contextual>:
 223
 224  use Log::Contextual qw( :log :dlog set_logger );
 225  use Log::Dispatchouli;
 226  my $ld = Log::Dispatchouli->new({
 227     ident     => 'slrtbrfst',
 228     to_stderr => 1,
 229     debug     => 1,
 230  });
 231
 232  set_logger $ld;
 233
 234  log_debug { 'program started' };
 235
 236 =head1 DESCRIPTION
 237
 238 Major benefits:
 239
 240 =over 2
 241
 242 =item * Efficient
 243
 244 The logging functions take blocks, so if a log level is disabled, the
 245 block will not run:
 246
 247  # the following won't run if debug is off
 248  log_debug { "the new count in the database is " . $rs->count };
 249
 250 Similarly, the C<D> prefixed methods only C<Dumper> the input if the level is
 251 enabled.
 252
 253 =item * Handy
 254
 255 The logging functions return their arguments, so you can stick them in
 256 the middle of expressions:
 257
 258  for (log_debug { "downloading:\n" . join qq(\n), @_ } @urls) { ... }
 259
 260 =item * Generic
 261
 262 C<Log::Contextual> is an interface for all major loggers.  If you log through
 263 C<Log::Contextual> you will be able to swap underlying loggers later.
 264
 265 =item * Powerful
 266
 267 C<Log::Contextual> chooses which logger to use based on L<< user defined C<CodeRef>s|/LOGGER CODEREF >>.
 268 Normally you don't need to know this, but you can take advantage of it when you
 269 need to later
 270
 271 =item * Scalable
 272
 273 If you just want to add logging to your extremely basic application, start with
 274 L<Log::Contextual::SimpleLogger> and then as your needs grow you can switch to
 275 L<Log::Dispatchouli> or L<Log::Dispatch> or L<Log::Log4perl> or whatever else.
 276
 277 =back
 278
 279 This module is a simple interface to extensible logging.  It exists to
 280 abstract your logging interface so that logging is as painless as possible,
 281 while still allowing you to switch from one logger to another.
 282
 283 It is bundled with a really basic logger, L<Log::Contextual::SimpleLogger>,
 284 but in general you should use a real logger instead of that.  For something
 285 more serious but not overly complicated, try L<Log::Dispatchouli> (see
 286 L</SYNOPSIS> for example.)
 287
 288 =head1 A WORK IN PROGRESS
 289
 290 This module is certainly not complete, but we will not break the interface
 291 lightly, so I would say it's safe to use in production code.  The main result
 292 from that at this point is that doing:
 293
 294  use Log::Contextual;
 295
 296 will die as we do not yet know what the defaults should be.  If it turns out
 297 that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll
 298 probably make C<:log> the default.  But only time and usage will tell.
 299
 300 =head1 IMPORT OPTIONS
 301
 302 See L</SETTING DEFAULT IMPORT OPTIONS> for information on setting these project
 303 wide.
 304
 305 =head2 -logger
 306
 307 When you import this module you may use C<-logger> as a shortcut for
 308 L<set_logger>, for example:
 309
 310  use Log::Contextual::SimpleLogger;
 311  use Log::Contextual qw( :dlog ),
 312    -logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )] });
 313
 314 sometimes you might want to have the logger handy for other stuff, in which
 315 case you might try something like the following:
 316
 317  my $var_log;
 318  BEGIN { $var_log = VarLogger->new }
 319  use Log::Contextual qw( :dlog ), -logger => $var_log;
 320
 321 =head2 -levels
 322
 323 The C<-levels> import option allows you to define exactly which levels your
 324 logger supports.  So the default,
 325 C<< [qw(debug trace warn info error fatal)] >>, works great for
 326 L<Log::Log4perl>, but it doesn't support the levels for L<Log::Dispatch>.  But
 327 supporting those levels is as easy as doing
 328
 329  use Log::Contextual
 330    -levels => [qw( debug info notice warning error critical alert emergency )];
 331
 332 =head2 -package_logger
 333
 334 The C<-package_logger> import option is similar to the C<-logger> import option
 335 except C<-package_logger> sets the the logger for the current package.
 336
 337 Unlike L</-default_logger>, C<-package_logger> cannot be overridden with
 338 L</set_logger>.
 339
 340  package My::Package;
 341  use Log::Contextual::SimpleLogger;
 342  use Log::Contextual qw( :log ),
 343    -package_logger => Log::Contextual::WarnLogger->new({
 344       env_prefix => 'MY_PACKAGE'
 345    });
 346
 347 If you are interested in using this package for a module you are putting on
 348 CPAN we recommend L<Log::Contextual::WarnLogger> for your package logger.
 349
 350 =head2 -default_logger
 351
 352 The C<-default_logger> import option is similar to the C<-logger> import option
 353 except C<-default_logger> sets the the B<default> logger for the current package.
 354
 355 Basically it sets the logger to be used if C<set_logger> is never called; so
 356
 357  package My::Package;
 358  use Log::Contextual::SimpleLogger;
 359  use Log::Contextual qw( :log ),
 360    -default_logger => Log::Contextual::WarnLogger->new({
 361       env_prefix => 'MY_PACKAGE'
 362    });
 363
 364 =head1 SETTING DEFAULT IMPORT OPTIONS
 365
 366 Eventually you will get tired of writing the following in every single one of
 367 your packages:
 368
 369  use Log::Log4perl;
 370  use Log::Log4perl ':easy';
 371  BEGIN { Log::Log4perl->easy_init($DEBUG) }
 372
 373  use Log::Contextual -logger => Log::Log4perl->get_logger;
 374
 375 You can set any of the import options for your whole project if you define your
 376 own C<Log::Contextual> subclass as follows:
 377
 378  package MyApp::Log::Contextual;
 379
 380  use base 'Log::Contextual';
 381
 382  use Log::Log4perl ':easy';
 383  Log::Log4perl->easy_init($DEBUG)
 384
 385  sub arg_default_logger { $_[1] || Log::Log4perl->get_logger }
 386  sub arg_levels { [qw(debug trace warn info error fatal custom_level)] }
 387  sub default_import { ':log' }
 388
 389  # or maybe instead of default_logger
 390  sub arg_package_logger { $_[1] }
 391
 392  # and almost definitely not this, which is only here for completeness
 393  sub arg_logger { $_[1] }
 394
 395 Note the C<< $_[1] || >> in C<arg_default_logger>.  All of these methods are
 396 passed the values passed in from the arguments to the subclass, so you can
 397 either throw them away, honor them, die on usage, or whatever.  To be clear,
 398 if you define your subclass, and someone uses it as follows:
 399
 400  use MyApp::Log::Contextual -default_logger => $foo,
 401                             -levels => [qw(bar baz biff)];
 402
 403 Your C<arg_default_logger> method will get C<$foo> and your C<arg_levels>
 404 will get C<[qw(bar baz biff)]>;
 405
 406 Additionally, the C<default_import> method is what happens if a user tries to
 407 use your subclass with no arguments.  The default just dies, but if you'd like
 408 to change the default to import a tag merely return the tags you'd like to
 409 import.  So the following will all work:
 410
 411  sub default_import { ':log' }
 412
 413  sub default_import { ':dlog' }
 414
 415  sub default_import { qw(:dlog :log ) }
 416
 417 =head1 FUNCTIONS
 418
 419 =head2 set_logger
 420
 421  my $logger = WarnLogger->new;
 422  set_logger $logger;
 423
 424 Arguments: L</LOGGER CODEREF>
 425
 426 C<set_logger> will just set the current logger to whatever you pass it.  It
 427 expects a C<CodeRef>, but if you pass it something else it will wrap it in a
 428 C<CodeRef> for you.  C<set_logger> is really meant only to be called from a
 429 top-level script.  To avoid foot-shooting the function will warn if you call it
 430 more than once.
 431
 432 =head2 with_logger
 433
 434  my $logger = WarnLogger->new;
 435  with_logger $logger => sub {
 436     if (1 == 0) {
 437        log_fatal { 'Non Logical Universe Detected' };
 438     } else {
 439        log_info  { 'All is good' };
 440     }
 441  };
 442
 443 Arguments: L</LOGGER CODEREF>, C<CodeRef $to_execute>
 444
 445 C<with_logger> sets the logger for the scope of the C<CodeRef> C<$to_execute>.
 446 As with L</set_logger>, C<with_logger> will wrap C<$returning_logger> with a
 447 C<CodeRef> if needed.
 448
 449 =head2 log_$level
 450
 451 Import Tag: C<:log>
 452
 453 Arguments: C<CodeRef $returning_message, @args>
 454
 455 C<log_$level> functions all work the same except that a different method
 456 is called on the underlying C<$logger> object.  The basic pattern is:
 457
 458  sub log_$level (&@) {
 459    if ($logger->is_$level) {
 460      $logger->$level(shift->(@_));
 461    }
 462    @_
 463  }
 464
 465 Note that the function returns it's arguments.  This can be used in a number of
 466 ways, but often it's convenient just for partial inspection of passthrough data
 467
 468  my @friends = log_trace {
 469    'friends list being generated, data from first friend: ' .
 470      Dumper($_[0]->TO_JSON)
 471  } generate_friend_list();
 472
 473 If you want complete inspection of passthrough data, take a look at the
 474 L</Dlog_$level> functions.
 475
 476 Which functions are exported depends on what was passed to L</-levels>.  The
 477 default (no C<-levels> option passed) would export:
 478
 479 =over 2
 480
 481 =item log_trace
 482
 483 =item log_debug
 484
 485 =item log_info
 486
 487 =item log_warn
 488
 489 =item log_error
 490
 491 =item log_fatal
 492
 493 =back
 494
 495 =head2 logS_$level
 496
 497 Import Tag: C<:log>
 498
 499 Arguments: C<CodeRef $returning_message, Item $arg>
 500
 501 This is really just a special case of the L</log_$level> functions.  It forces
 502 scalar context when that is what you need.  Other than that it works exactly
 503 same:
 504
 505  my $friend = logS_trace {
 506    'I only have one friend: ' .  Dumper($_[0]->TO_JSON)
 507  } friend();
 508
 509 See also: L</DlogS_$level>.
 510
 511 =head2 Dlog_$level
 512
 513 Import Tag: C<:dlog>
 514
 515 Arguments: C<CodeRef $returning_message, @args>
 516
 517 All of the following six functions work the same as their L</log_$level>
 518 brethren, except they return what is passed into them and put the stringified
 519 (with L<Data::Dumper::Concise>) version of their args into C<$_>.  This means
 520 you can do cool things like the following:
 521
 522  my @nicks = Dlog_debug { "names: $_" } map $_->value, $frew->names->all;
 523
 524 and the output might look something like:
 525
 526  names: "fREW"
 527  "fRIOUX"
 528  "fROOH"
 529  "fRUE"
 530  "fiSMBoC"
 531
 532 Which functions are exported depends on what was passed to L</-levels>.  The
 533 default (no C<-levels> option passed) would export:
 534
 535 =over 2
 536
 537 =item Dlog_trace
 538
 539 =item Dlog_debug
 540
 541 =item Dlog_info
 542
 543 =item Dlog_warn
 544
 545 =item Dlog_error
 546
 547 =item Dlog_fatal
 548
 549 =back
 550
 551 =head2 DlogS_$level
 552
 553 Import Tag: C<:dlog>
 554
 555 Arguments: C<CodeRef $returning_message, Item $arg>
 556
 557 Like L</logS_$level>, these functions are a special case of L</Dlog_$level>.
 558 They only take a single scalar after the C<$returning_message> instead of
 559 slurping up (and also setting C<wantarray>) all the C<@args>
 560
 561  my $pals_rs = DlogS_debug { "pals resultset: $_" }
 562    $schema->resultset('Pals')->search({ perlers => 1 });
 563
 564 =head1 LOGGER CODEREF
 565
 566 Anywhere a logger object can be passed, a coderef is accepted.  This is so
 567 that the user can use different logger objects based on runtime information.
 568 The logger coderef is passed the package of the caller the caller level the
 569 coderef needs to use if it wants more caller information.  The latter is in
 570 a hashref to allow for more options in the future.
 571
 572 Here is a basic example of a logger that exploits C<caller> to reproduce the
 573 output of C<warn> with a logger:
 574
 575  my @caller_info;
 576  my $var_log = Log::Contextual::SimpleLogger->new({
 577     levels  => [qw(trace debug info warn error fatal)],
 578     coderef => sub { chomp($_[0]); warn "$_[0] at $caller_info[1] line $caller_info[2].\n" }
 579  });
 580  my $warn_faker = sub {
 581     my ($package, $args) = @_;
 582     @caller_info = caller($args->{caller_level});
 583     $var_log
 584  };
 585  set_logger($warn_faker);
 586  log_debug { 'test' };
 587
 588 The following is an example that uses the information passed to the logger
 589 coderef.  It sets the global logger to C<$l3>, the logger for the C<A1>
 590 package to C<$l1>, except the C<lol> method in C<A1> which uses the C<$l2>
 591 logger and lastly the logger for the C<A2> package to C<$l2>.
 592
 593 Note that it increases the caller level as it dispatches based on where
 594 the caller of the log function, not the log function itself.
 595
 596  my $complex_dispatcher = do {
 597
 598     my $l1 = ...;
 599     my $l2 = ...;
 600     my $l3 = ...;
 601
 602     my %registry = (
 603        -logger => $l3,
 604        A1 => {
 605           -logger => $l1,
 606           lol     => $l2,
 607        },
 608        A2 => { -logger => $l2 },
 609     );
 610
 611     sub {
 612        my ( $package, $info ) = @_;
 613
 614        my $logger = $registry{'-logger'};
 615        if (my $r = $registry{$package}) {
 616           $logger = $r->{'-logger'} if $r->{'-logger'};
 617           my (undef, undef, undef, $sub) = caller($info->{caller_level} + 1);
 618           $sub =~ s/^\Q$package\E:://g;
 619           $logger = $r->{$sub} if $r->{$sub};
 620        }
 621        return $logger;
 622     }
 623  };
 624
 625  set_logger $complex_dispatcher;
 626
 627 =head1 LOGGER INTERFACE
 628
 629 Because this module is ultimately pretty looking glue (glittery?) with the
 630 awesome benefit of the Contextual part, users will often want to make their
 631 favorite logger work with it.  The following are the methods that should be
 632 implemented in the logger:
 633
 634  is_trace
 635  is_debug
 636  is_info
 637  is_warn
 638  is_error
 639  is_fatal
 640  trace
 641  debug
 642  info
 643  warn
 644  error
 645  fatal
 646
 647 The first six merely need to return true if that level is enabled.  The latter
 648 six take the results of whatever the user returned from their coderef and log
 649 them.  For a basic example see L<Log::Contextual::SimpleLogger>.
 650
 651 =head1 LOG ROUTING
 652
 653 In between the loggers and the log functions is a log router that is responsible for
 654 finding a logger to handle the log event and passing the log information to the
 655 logger. This relationship is described in the documentation for C<Log::Contextual::Role::Router>.
 656
 657 C<Log::Contextual> and packages that extend it will by default share a router singleton that
 658 implements the with_logger() and set_logger() functions and also respects the -logger,
 659 -package_logger, and -default_logger import options with their associated default value
 660 functions. The router singleton is available as the return value of the router() function. Users
 661 of Log::Contextual may overload router() to return instances of custom log routers that
 662 could for example work with loggers that use a different interface.
 663
 664 =head1 AUTHOR
 665
 666 frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
 667
 668 =head1 CONTRIBUTORS
 669
 670 triddle - Tyler Riddle <t.riddle@shadowcat.co.uk>
 671
 672 =head1 DESIGNER
 673
 674 mst - Matt S. Trout <mst@shadowcat.co.uk>
 675
 676 =head1 COPYRIGHT
 677
 678 Copyright (c) 2012 the Log::Contextual L</AUTHOR> and L</DESIGNER> as listed
 679 above.
 680
 681 =head1 LICENSE
 682
 683 This library is free software and may be distributed under the same terms as
 684 Perl 5 itself.
 685
 686 =cut
 687