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