X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FLog%2FContextual.pm;h=1d0a1dca966de1903ba032dd5c71811c41d98f46;hb=0c180ced3d15f9851c4ae1cf4ea984c026f67b3f;hp=b472e916ce958a66061dffa5420627b82de0eed7;hpb=a4273dbf7cfc7c98377278358bdb18df9e4a06de;p=p5sagit%2FLog-Contextual.git diff --git a/lib/Log/Contextual.pm b/lib/Log/Contextual.pm index b472e91..1d0a1dc 100644 --- a/lib/Log/Contextual.pm +++ b/lib/Log/Contextual.pm @@ -3,268 +3,296 @@ package Log::Contextual; use strict; use warnings; -our $VERSION = '0.00100'; +our $VERSION = '0.004202'; -require Exporter; +my @levels = qw(debug trace warn info error fatal); + +use Exporter::Declare; +use Exporter::Declare::Export::Generator; use Data::Dumper::Concise; +use Scalar::Util 'blessed'; + +my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels)); + +my @log = ((map "log_$_", @levels), (map "logS_$_", @levels)); -BEGIN { our @ISA = qw(Exporter) } - -my @dlog = (qw( - Dlog_debug DlogS_debug - Dlog_trace DlogS_trace - Dlog_warn DlogS_warn - Dlog_info DlogS_info - Dlog_error DlogS_error - Dlog_fatal DlogS_fatal - )); - -my @log = (qw( - log_debug - log_trace - log_warn - log_info - log_error - log_fatal - )); - -our @EXPORT_OK = ( +eval { + require Log::Log4perl; + die if $Log::Log4perl::VERSION < 1.29; + Log::Log4perl->wrapper_register(__PACKAGE__) +}; + +# ____ is because tags must have at least one export and we don't want to +# export anything but the levels selected +sub ____ {} + +exports ('____', @dlog, @log, qw( set_logger with_logger ) ); -our %EXPORT_TAGS = ( - dlog => \@dlog, - log => \@log, - all => [@dlog, @log], -); +export_tag dlog => ('____'); +export_tag log => ('____'); +import_arguments qw(logger package_logger default_logger); -sub import { - my $package = shift; - die 'Log::Contextual does not have a default import list' - unless @_; +sub before_import { + my ($class, $importer, $spec) = @_; - for my $idx ( 0 .. $#_ ) { - if ( $_[$idx] eq '-logger' ) { - set_logger($_[$idx + 1]); - splice @_, $idx, 2; - last; + die 'Log::Contextual does not have a default import list' + if $spec->config->{default}; + + my @levels = @{$class->arg_levels($spec->config->{levels})}; + for my $level (@levels) { + if ($spec->config->{log}) { + $spec->add_export("&log_$level", sub (&@) { + _do_log( $level => _get_logger( caller ), shift @_, @_) + }); + $spec->add_export("&logS_$level", sub (&@) { + _do_logS( $level => _get_logger( caller ), $_[0], $_[1]) + }); + } + if ($spec->config->{dlog}) { + $spec->add_export("&Dlog_$level", sub (&@) { + my ($code, @args) = @_; + return _do_log( $level => _get_logger( caller ), sub { + local $_ = (@args?Data::Dumper::Concise::Dumper @args:'()'); + $code->(@_) + }, @args ); + }); + $spec->add_export("&DlogS_$level", sub (&$) { + my ($code, $ref) = @_; + _do_logS( $level => _get_logger( caller ), sub { + local $_ = Data::Dumper::Concise::Dumper $ref; + $code->($ref) + }, $ref ) + }); } } - $package->export_to_level(1, $package, @_); +} + +sub arg_logger { $_[1] } +sub arg_levels { $_[1] || [qw(debug trace warn info error fatal)] } +sub arg_package_logger { $_[1] } +sub arg_default_logger { $_[1] } + +sub after_import { + my ($class, $importer, $specs) = @_; + + if (my $l = $class->arg_logger($specs->config->{logger})) { + set_logger($l) + } + + if (my $l = $class->arg_package_logger($specs->config->{package_logger})) { + _set_package_logger_for($importer, $l) + } + + if (my $l = $class->arg_default_logger($specs->config->{default_logger})) { + _set_default_logger_for($importer, $l) + } } our $Get_Logger; +our %Default_Logger; +our %Package_Logger; + +sub _set_default_logger_for { + my $logger = $_[1]; + if(ref $logger ne 'CODE') { + die 'logger was not a CodeRef or a logger object. Please try again.' + unless blessed($logger); + $logger = do { my $l = $logger; sub { $l } } + } + $Default_Logger{$_[0]} = $logger +} + +sub _set_package_logger_for { + my $logger = $_[1]; + if(ref $logger ne 'CODE') { + die 'logger was not a CodeRef or a logger object. Please try again.' + unless blessed($logger); + $logger = do { my $l = $logger; sub { $l } } + } + $Package_Logger{$_[0]} = $logger +} + +sub _get_logger($) { + my $package = shift; + ( + $Package_Logger{$package} || + $Get_Logger || + $Default_Logger{$package} || + die q( no logger set! you can't try to log something without a logger! ) + )->($package, { caller_level => 2 }); +} sub set_logger { my $logger = $_[0]; - $logger = do { my $l = $logger; sub { $l } } - if ref $logger ne 'CODE'; + if(ref $logger ne 'CODE') { + die 'logger was not a CodeRef or a logger object. Please try again.' + unless blessed($logger); + $logger = do { my $l = $logger; sub { $l } } + } + + warn 'set_logger (or -logger) called more than once! This is a bad idea!' + if $Get_Logger; $Get_Logger = $logger; } sub with_logger { my $logger = $_[0]; - $logger = do { my $l = $logger; sub { $l } } - if ref $logger ne 'CODE'; + if(ref $logger ne 'CODE') { + die 'logger was not a CodeRef or a logger object. Please try again.' + unless blessed($logger); + $logger = do { my $l = $logger; sub { $l } } + } local $Get_Logger = $logger; $_[1]->(); } +sub _do_log { + my $level = shift; + my $logger = shift; + my $code = shift; + my @values = @_; - -sub log_trace (&@) { - my $log = $Get_Logger->(); - my $code = shift; - $log->trace($code->(@_)) - if $log->is_trace; - @_ + $logger->$level($code->(@_)) + if $logger->${\"is_$level"}; + @values } -sub log_debug (&@) { - my $log = $Get_Logger->(); - my $code = shift; - $log->debug($code->(@_)) - if $log->is_debug; - @_ -} +sub _do_logS { + my $level = shift; + my $logger = shift; + my $code = shift; + my $value = shift; -sub log_info (&@) { - my $log = $Get_Logger->(); - my $code = shift; - $log->info($code->(@_)) - if $log->is_info; - @_ + $logger->$level($code->($value)) + if $logger->${\"is_$level"}; + $value } -sub log_warn (&@) { - my $log = $Get_Logger->(); - my $code = shift; - $log->warn($code->(@_)) - if $log->is_warn; - @_ -} +1; -sub log_error (&@) { - my $log = $Get_Logger->(); - my $code = shift; - $log->error($code->(@_)) - if $log->is_error; - @_ -} +__END__ -sub log_fatal (&@) { - my $log = $Get_Logger->(); - my $code = shift; - $log->fatal($code->(@_)) - if $log->is_fatal; - @_ -} +=head1 NAME +Log::Contextual - Simple logging interface with a contextual log +=head1 SYNOPSIS -sub Dlog_trace (&@) { - my $code = shift; - my @values = @_; - return log_trace { - do { local $_ = Data::Dumper::Concise::Dumper @values; $code->() }; - } @values -} + use Log::Contextual qw( :log :dlog set_logger with_logger ); + use Log::Contextual::SimpleLogger; + use Log::Log4perl ':easy'; + Log::Log4perl->easy_init($DEBUG); -sub Dlog_debug (&@) { - my $code = shift; - my @values = @_; - log_debug { - do { local $_ = Data::Dumper::Concise::Dumper @values; $code->() }; - } @values -} + my $logger = Log::Log4perl->get_logger; -sub Dlog_info (&@) { - my $code = shift; - my @values = @_; - log_info { - do { local $_ = Data::Dumper::Concise::Dumper @values; $code->() }; - } @values -} + set_logger $logger; -sub Dlog_warn (&@) { - my $code = shift; - my @values = @_; - log_warn { - do { local $_ = Data::Dumper::Concise::Dumper @values; $code->() }; - } @values -} + log_debug { 'program started' }; -sub Dlog_error (&@) { - my $code = shift; - my @values = @_; - log_error { - do { local $_ = Data::Dumper::Concise::Dumper @values; $code->() }; - } @values -} + sub foo { -sub Dlog_fatal (&@) { - my $code = shift; - my @values = @_; - log_fatal { - do { local $_ = Data::Dumper::Concise::Dumper @values; $code->() }; - } @values -} + my $minilogger = Log::Contextual::SimpleLogger->new({ + levels => [qw( trace debug )] + }); + with_logger $minilogger => sub { + log_trace { 'foo entered' }; + my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @_; + # ... + log_trace { 'foo left' }; + }; + } + foo(); -sub DlogS_trace (&$) { - my $code = $_[0]; - my $value = $_[1]; - log_trace { - do { local $_ = Data::Dumper::Concise::Dumper $value; $code->() }; - }; - $value -} +Beginning with version 1.008 L also works out of the box +with C: -sub DlogS_debug (&$) { - my $code = $_[0]; - my $value = $_[1]; - log_debug { - do { local $_ = Data::Dumper::Concise::Dumper $value; $code->() }; - }; - $value -} + use Log::Contextual qw( :log :dlog set_logger ); + use Log::Dispatchouli; + my $ld = Log::Dispatchouli->new({ + ident => 'slrtbrfst', + to_stderr => 1, + debug => 1, + }); -sub DlogS_info (&$) { - my $code = $_[0]; - my $value = $_[1]; - log_info { - do { local $_ = Data::Dumper::Concise::Dumper $value; $code->() }; - }; - $value -} + set_logger $ld; -sub DlogS_warn (&$) { - my $code = $_[0]; - my $value = $_[1]; - log_warn { - do { local $_ = Data::Dumper::Concise::Dumper $value; $code->() }; - }; - $value -} + log_debug { 'program started' }; -sub DlogS_error (&$) { - my $code = $_[0]; - my $value = $_[1]; - log_error { - do { local $_ = Data::Dumper::Concise::Dumper $value; $code->() }; - }; - $value -} +=head1 DESCRIPTION -sub DlogS_fatal (&$) { - my $code = $_[0]; - my $value = $_[1]; - log_fatal { - do { local $_ = Data::Dumper::Concise::Dumper $value; $code->() }; - }; - $value -} +Major benefits: -1; +=over 2 -__END__ +=item * Efficient -=head1 NAME +The logging functions take blocks, so if a log level is disabled, the +block will not run: -Log::Contextual - Simple logging interface with a contextual log + # the following won't run if debug is off + log_debug { "the new count in the database is " . $rs->count }; -=head1 SYNOPSIS +Similarly, the C prefixed methods only C the input if the level is +enabled. - use Log::Log4perl; - use Log::Contextual qw( :log :dlog set_logger with_logger ); +=item * Handy - my $logger = sub { Log::Log4perl->get_logger }; +The logging functions return their arguments, so you can stick them in +the middle of expressions: - set_logger { $logger }; + for (log_debug { "downloading:\n" . join qq(\n), @_ } @urls) { ... } - log_debug { 'program started' }; +=item * Generic - sub foo { - with_logger(Log::Contextual::SimpleLogger->new({ - levels => [qw( trace debug )] - }) => sub { - log_trace { 'foo entered' }; - my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @_; - # ... - log_trace { 'foo left' }; - }); - } +C is an interface for all major loggers. If you log through +C you will be able to swap underlying loggers later. -=head1 DESCRIPTION +=item * Powerful + +C chooses which logger to use based on L<< user defined Cs|/LOGGER CODEREF >>. +Normally you don't need to know this, but you can take advantage of it when you +need to later -This module is a simple interface to extensible logging. It is bundled with a -really basic logger, L, but in general you -should use a real logger instead of that. For something more serious but not -overly complicated, take a look at L. +=item * Scalable -=head1 OPTIONS +If you just want to add logging to your extremely basic application, start with +L and then as your needs grow you can switch to +L or L or L or whatever else. + +=back + +This module is a simple interface to extensible logging. It exists to +abstract your logging interface so that logging is as painless as possible, +while still allowing you to switch from one logger to another. + +It is bundled with a really basic logger, L, +but in general you should use a real logger instead of that. For something +more serious but not overly complicated, try L (see +L for example.) + +=head1 A WORK IN PROGRESS + +This module is certainly not complete, but we will not break the interface +lightly, so I would say it's safe to use in production code. The main result +from that at this point is that doing: + + use Log::Contextual; + +will die as we do not yet know what the defaults should be. If it turns out +that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll +probably make C<:log> the default. But only time and usage will tell. + +=head1 IMPORT OPTIONS + +See L for information on setting these project +wide. + +=head2 -logger When you import this module you may use C<-logger> as a shortcut for L, for example: @@ -280,17 +308,89 @@ case you might try something like the following: BEGIN { $var_log = VarLogger->new } use Log::Contextual qw( :dlog ), -logger => $var_log; -=head1 A WORK IN PROGRESS +=head2 -levels -This module is certainly not complete, but we will not break the interface -lightly, so I would say it's safe to use in production code. The main result -from that at this point is that doing: +The C<-levels> import option allows you to define exactly which levels your +logger supports. So the default, +C<< [qw(debug trace warn info error fatal)] >>, works great for +L, but it doesn't support the levels for L. But +supporting those levels is as easy as doing - use Log::Contextual; + use Log::Contextual + -levels => [qw( debug info notice warning error critical alert emergency )]; -will die as we do not yet know what the defaults should be. If it turns out -that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll -probably make C<:log> the default. But only time and usage will tell. +=head2 -package_logger + +The C<-package_logger> import option is similar to the C<-logger> import option +except C<-package_logger> sets the the logger for the current package. + +Unlike L, C<-package_logger> cannot be overridden with +L. + + package My::Package; + use Log::Contextual::SimpleLogger; + use Log::Contextual qw( :log ), + -package_logger => Log::Contextual::WarnLogger->new({ + env_prefix => 'MY_PACKAGE' + }); + +If you are interested in using this package for a module you are putting on +CPAN we recommend L for your package logger. + +=head2 -default_logger + +The C<-default_logger> import option is similar to the C<-logger> import option +except C<-default_logger> sets the the B logger for the current package. + +Basically it sets the logger to be used if C is never called; so + + package My::Package; + use Log::Contextual::SimpleLogger; + use Log::Contextual qw( :log ), + -default_logger => Log::Contextual::WarnLogger->new({ + env_prefix => 'MY_PACKAGE' + }); + +=head1 SETTING DEFAULT IMPORT OPTIONS + +Eventually you will get tired of writing the following in every single one of +your packages: + + use Log::Log4perl; + use Log::Log4perl ':easy'; + BEGIN { Log::Log4perl->easy_init($DEBUG) } + + use Log::Contextual -logger => Log::Log4perl->get_logger; + +You can set any of the import options for your whole project if you define your +own C subclass as follows: + + package MyApp::Log::Contextual; + + use base 'Log::Contextual'; + + use Log::Log4perl ':easy'; + Log::Log4perl->easy_init($DEBUG) + + sub arg_default_logger { $_[1] || Log::Log4perl->get_logger } + sub arg_levels { [qw(debug trace warn info error fatal custom_level)] } + + # or maybe instead of default_logger + sub arg_package_logger { $_[1] } + + # and almost definitely not this, which is only here for completeness + sub arg_logger { $_[1] } + +Note the C<< $_[1] || >> in C. All of these methods are +passed the values passed in from the arguments to the subclass, so you can +either throw them away, honor them, die on usage, or whatever. To be clear, +if you define your subclass, and someone uses it as follows: + + use MyApp::Log::Contextual -default_logger => $foo, + -levels => [qw(bar baz biff)]; + +Your C method will get C<$foo> and your C +will get C<[qw(bar baz biff)]>; =head1 FUNCTIONS @@ -299,11 +399,13 @@ probably make C<:log> the default. But only time and usage will tell. my $logger = WarnLogger->new; set_logger $logger; -Arguments: Ref|CodeRef $returning_logger +Arguments: L C will just set the current logger to whatever you pass it. It expects a C, but if you pass it something else it will wrap it in a -C for you. +C for you. C is really meant only to be called from a +top-level script. To avoid foot-shooting the function will warn if you call it +more than once. =head2 with_logger @@ -316,58 +418,81 @@ C for you. } }; -Arguments: Ref|CodeRef $returning_logger, CodeRef $to_execute +Arguments: L, C C sets the logger for the scope of the C C<$to_execute>. -As with L, C will wrap C<$returning_logger> with a +As with L, C will wrap C<$returning_logger> with a C if needed. =head2 log_$level -Import Tag: ":log" +Import Tag: C<:log> -Arguments: CodeRef $returning_message +Arguments: C -All of the following six functions work the same except that a different method +C functions all work the same except that a different method is called on the underlying C<$logger> object. The basic pattern is: - sub log_$level (&) { + sub log_$level (&@) { if ($logger->is_$level) { - $logger->$level(shift->()); + $logger->$level(shift->(@_)); } + @_ } -=head3 log_trace +Note that the function returns it's arguments. This can be used in a number of +ways, but often it's convenient just for partial inspection of passthrough data + + my @friends = log_trace { + 'friends list being generated, data from first friend: ' . + Dumper($_[0]->TO_JSON) + } generate_friend_list(); + +If you want complete inspection of passthrough data, take a look at the +L functions. - log_trace { 'entered method foo with args ' join q{,}, @args }; +Which functions are exported depends on what was passed to L. The +default (no C<-levels> option passed) would export: -=head3 log_debug +=over 2 - log_debug { 'entered method foo' }; +=item log_trace -=head3 log_info +=item log_debug - log_info { 'started process foo' }; +=item log_info -=head3 log_warn +=item log_warn - log_warn { 'possible misconfiguration at line 10' }; +=item log_error -=head3 log_error +=item log_fatal - log_error { 'non-numeric user input!' }; +=back -=head3 log_fatal +=head2 logS_$level - log_fatal { '1 is never equal to 0!' }; +Import Tag: C<:log> + +Arguments: C + +This is really just a special case of the L functions. It forces +scalar context when that is what you need. Other than that it works exactly +same: + + my $friend = logS_trace { + 'I only have one friend: ' . Dumper($_[0]->TO_JSON) + } friend(); + +See also: L. =head2 Dlog_$level -Import Tag: ":dlog" +Import Tag: C<:dlog> -Arguments: CodeRef $returning_message, @args +Arguments: C -All of the following six functions work the same as their L +All of the following six functions work the same as their L brethren, except they return what is passed into them and put the stringified (with L) version of their args into C<$_>. This means you can do cool things like the following: @@ -382,68 +507,100 @@ and the output might look something like: "fRUE" "fiSMBoC" -=head3 Dlog_trace - - my ($foo, $bar) = Dlog_trace { "entered method foo with args: $_" } @_; +Which functions are exported depends on what was passed to L. The +default (no C<-levels> option passed) would export: -=head3 Dlog_debug +=over 2 - Dlog_debug { "random data structure: $_" } { foo => $bar }; +=item Dlog_trace -=head3 Dlog_info +=item Dlog_debug - return Dlog_info { "html from method returned: $_" } "..."; +=item Dlog_info -=head3 Dlog_warn +=item Dlog_warn - Dlog_warn { "probably invalid value: $_" } $foo; +=item Dlog_error -=head3 Dlog_error +=item Dlog_fatal - Dlog_error { "non-numeric user input! ($_)" } $port; - -=head3 Dlog_fatal - - Dlog_fatal { '1 is never equal to 0!' } 'ZOMG ZOMG' if 1 == 0; +=back =head2 DlogS_$level -Import Tag: ":dlog" +Import Tag: C<:dlog> -Arguments: CodeRef $returning_message, Item $arg +Arguments: C -All of the following six functions work the same as the related L -functions, except they only take a single scalar after the -C<$returning_message> instead of slurping up (and also setting C) -all the C<@args> +Like L, these functions are a special case of L. +They only take a single scalar after the C<$returning_message> instead of +slurping up (and also setting C) all the C<@args> my $pals_rs = DlogS_debug { "pals resultset: $_" } $schema->resultset('Pals')->search({ perlers => 1 }); -=head3 DlogS_trace - - my ($foo, $bar) = - DlogS_trace { "entered method foo with first arg $_" } $_[0], $_[1]; - -=head3 DlogS_debug - - DlogS_debug { "random data structure: $_" } { foo => $bar }; - -=head3 DlogS_info - - return DlogS_info { "html from method returned: $_" } "..."; - -=head3 DlogS_warn - - DlogS_warn { "probably invalid value: $_" } $foo; - -=head3 DlogS_error - - DlogS_error { "non-numeric user input! ($_)" } $port; - -=head3 DlogS_fatal +=head1 LOGGER CODEREF + +Anywhere a logger object can be passed, a coderef is accepted. This is so +that the user can use different logger objects based on runtime information. +The logger coderef is passed the package of the caller the caller level the +coderef needs to use if it wants more caller information. The latter is in +a hashref to allow for more options in the future. + +Here is a basic example of a logger that exploits C to reproduce the +output of C with a logger: + + my @caller_info; + my $var_log = Log::Contextual::SimpleLogger->new({ + levels => [qw(trace debug info warn error fatal)], + coderef => sub { chomp($_[0]); warn "$_[0] at $caller_info[1] line $caller_info[2].\n" } + }); + my $warn_faker = sub { + my ($package, $args) = @_; + @caller_info = caller($args->{caller_level}); + $var_log + }; + set_logger($warn_faker); + log_debug { 'test' }; + +The following is an example that uses the information passed to the logger +coderef. It sets the global logger to C<$l3>, the logger for the C +package to C<$l1>, except the C method in C which uses the C<$l2> +logger and lastly the logger for the C package to C<$l2>. + +Note that it increases the caller level as it dispatches based on where +the caller of the log function, not the log function itself. + + my $complex_dispatcher = do { + + my $l1 = ...; + my $l2 = ...; + my $l3 = ...; + + my %registry = ( + -logger => $l3, + A1 => { + -logger => $l1, + lol => $l2, + }, + A2 => { -logger => $l2 }, + ); + + sub { + my ( $package, $info ) = @_; + + my $logger = $registry{'-logger'}; + if (my $r = $registry{$package}) { + $logger = $r->{'-logger'} if $r->{'-logger'}; + my (undef, undef, undef, $sub) = caller($info->{caller_level} + 1); + $sub =~ s/^\Q$package\E:://g; + $logger = $r->{$sub} if $r->{$sub}; + } + return $logger; + } + }; - DlogS_fatal { '1 is never equal to 0!' } 'ZOMG ZOMG' if 1 == 0; + set_logger $complex_dispatcher; =head1 LOGGER INTERFACE @@ -479,7 +636,7 @@ mst - Matt S. Trout =head1 COPYRIGHT -Copyright (c) 2010 the Log::Contextual L and L as listed +Copyright (c) 2012 the Log::Contextual L and L as listed above. =head1 LICENSE