From: Karen Etheridge Date: Mon, 19 Mar 2012 20:51:22 +0000 (+0000) Subject: WarnLogger now supports custom log levels via levels constructor argument X-Git-Tag: v0.004100~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e7b182828c58ebc7f661fc7cd99e96bc69922228;p=p5sagit%2FLog-Contextual.git WarnLogger now supports custom log levels via levels constructor argument --- diff --git a/Changes b/Changes index e98a28b..37addc3 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ ChangeLog for Log-Contextual + - Log::Contextual::WarnLogger now supports customized log levels via the + 'levels' constructor argument (Karen Etheridge) + 0.004001 2011-08-15 - Fix version of Exporter::Declare that we dep on diff --git a/Makefile.PL b/Makefile.PL index 78e4c4f..192dd02 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -7,5 +7,9 @@ perl_version '5.006'; all_from 'lib/Log/Contextual.pm'; requires 'Data::Dumper::Concise'; requires 'Exporter::Declare' => 0.105; +requires 'Carp'; +requires 'Scalar::Util'; + +test_requires 'Test::Fatal'; WriteAll; diff --git a/lib/Log/Contextual/WarnLogger.pm b/lib/Log/Contextual/WarnLogger.pm index 7f37390..0a7b921 100644 --- a/lib/Log/Contextual/WarnLogger.pm +++ b/lib/Log/Contextual/WarnLogger.pm @@ -3,36 +3,101 @@ package Log::Contextual::WarnLogger; use strict; use warnings; +use Carp 'croak'; + +my @default_levels = qw( trace debug info warn error fatal ); + + +# generate subs to handle the default levels +# anything else will have to be handled by AUTOLOAD at runtime { - my @levels = (qw( trace debug info warn error fatal )); - my %level_num; @level_num{ @levels } = (0 .. $#levels); - for my $name (@levels) { + for my $level (@default_levels) { no strict 'refs'; - my $is_name = "is_$name"; - *{$name} = sub { + my $is_name = "is_$level"; + *{$level} = sub { my $self = shift; - $self->_log( $name, @_ ) + $self->_log( $level, @_ ) if $self->$is_name; }; *{$is_name} = sub { my $self = shift; - return 1 if $ENV{$self->{env_prefix} . '_' . uc $name}; + return 1 if $ENV{$self->{env_prefix} . '_' . uc $level}; my $upto = $ENV{$self->{env_prefix} . '_UPTO'}; return unless $upto; $upto = lc $upto; - return $level_num{$name} >= $level_num{$upto}; + return $self->{level_num}{$level} >= $self->{level_num}{$upto}; }; } } +our $AUTOLOAD; +sub AUTOLOAD { + my $self = $_[0]; + + (my $name = our $AUTOLOAD) =~ s/.*:://; + return if $name eq 'DESTROY'; + + # extract the log level from the sub name + my ($is, $level) = $name =~ m/^(is_)?(.+)$/; + my $is_name = "is_$level"; + + no strict 'refs'; + *{$level} = sub { + my $self = shift; + + $self->_log( $level, @_ ) + if $self->$is_name; + }; + + *{$is_name} = sub { + my $self = shift; + + my $prefix_field = $self->{env_prefix} . '_' . uc $level; + return 1 if $ENV{$prefix_field}; + + # don't log if the variable specifically says not to + return 0 if defined $ENV{$prefix_field} and not $ENV{$prefix_field}; + + my $upto_field = $self->{env_prefix} . '_UPTO'; + my $upto = $ENV{$upto_field}; + + if ($upto) { + $upto = lc $upto; + + croak "Unrecognized log level '$upto' in \$ENV{$upto_field}" + if not defined $self->{level_num}{$upto}; + + return $self->{level_num}{$level} >= $self->{level_num}{$upto}; + } + + # if we don't recognize this level and nothing says otherwise, log! + return 1 if not $self->{custom_levels}; + }; + goto &$AUTOLOAD; +} + sub new { my ($class, $args) = @_; - my $self = bless {}, $class; + + my $levels = $args->{levels}; + croak 'invalid levels specification: must be non-empty arrayref' + if defined $levels and (ref $levels ne 'ARRAY' or !@$levels); + + my $custom_levels = defined $levels; + $levels ||= [ @default_levels ]; + + my %level_num; @level_num{ @$levels } = (0 .. $#{$levels}); + + my $self = bless { + levels => $levels, + level_num => \%level_num, + custom_levels => $custom_levels, + }, $class; $self->{env_prefix} = $args->{env_prefix} or die 'no env_prefix passed to Log::Contextual::WarnLogger->new'; @@ -61,7 +126,8 @@ Log::Contextual::WarnLogger - Simple logger for libraries using Log::Contextual use Log::Contextual::WarnLogger; use Log::Contextual qw( :log ), -default_logger => Log::Contextual::WarnLogger->new({ - env_prefix => 'MY_PACKAGE' + env_prefix => 'MY_PACKAGE', + levels => [ qw(debug info notice warning error critical alert emergency) ], }); # warns '[info] program started' if $ENV{MY_PACKAGE_TRACE} is set @@ -72,6 +138,8 @@ Log::Contextual::WarnLogger - Simple logger for libraries using Log::Contextual ... } + + =head1 DESCRIPTION This module is a simple logger made for libraries using L. We @@ -84,15 +152,42 @@ works. =head2 new -Arguments: C<< Dict[ env_prefix => Str ] $conf >> +Arguments: C<< Dict[ env_prefix => Str, levels => List ] $conf >> my $l = Log::Contextual::WarnLogger->new({ - env_prefix + env_prefix => 'BAR' + }); + +or: + + my $l = Log::Contextual::WarnLogger->new({ + env_prefix => 'BAR', + levels => [ 'level1', 'level2' ] + }); Creates a new logger object where C defines what the prefix is for -the environment variables that will be checked for the six log levels. For -example, if C is set to C the following environment +the environment variables that will be checked for the log levels. + +The log levels may be customized, but if not defined, these are used: + +=over 4 + +=item trace + +=item debug + +=item info + +=item warn + +=item error + +=item fatal + +=back + +For example, if C is set to C the following environment variables will be used: FREWS_PACKAGE_UPTO @@ -108,6 +203,8 @@ Note that C is a convenience variable. If you set C<< FOO_UPTO=TRACE >> it will enable all log levels. Similarly, if you set it to C only fatal will be enabled. +=back + =head2 $level Arguments: C<@anything> @@ -145,6 +242,9 @@ All of the following six methods work the same. The basic pattern is: $l->fatal( '1 is never equal to 0!' ); +If different levels are specified, appropriate functions named for your custom +levels work as you expect. + =head2 is_$level All of the following six functions just return true if their respective @@ -174,6 +274,9 @@ environment variable is enabled. say q{fatal'ing} if $l->is_fatal; +If different levels are specified, appropriate is_$level functions work as you +would expect. + =head1 AUTHOR See L diff --git a/t/warnlogger-with-levels.t b/t/warnlogger-with-levels.t new file mode 100644 index 0000000..3ca3df2 --- /dev/null +++ b/t/warnlogger-with-levels.t @@ -0,0 +1,128 @@ +use strict; +use warnings; + +use Log::Contextual::WarnLogger; # -levels => [qw(custom1 custom2)]; +use Log::Contextual qw{:log set_logger} => -logger => + Log::Contextual::WarnLogger->new({ env_prefix => 'FOO' }); + +use Test::More qw(no_plan); +use Test::Fatal; + +{ + my $l; + like( + exception { $l = Log::Contextual::WarnLogger->new({ levels => '' }) }, + qr/invalid levels specification: must be non-empty arrayref/, + 'cannot pass empty string for levels', + ); + + like( + exception { $l = Log::Contextual::WarnLogger->new({ levels => [] }) }, + qr/invalid levels specification: must be non-empty arrayref/, + 'cannot pass empty list for levels', + ); + + is( + exception { $l = Log::Contextual::WarnLogger->new({ levels => undef, env_prefix => 'FOO' }) }, + undef, + 'ok to leave levels undefined', + ); +} + + +{ + my $l = Log::Contextual::WarnLogger->new({ + env_prefix => 'BAR', + levels => [qw(custom1 custom2)] + }); + + foreach my $sub (qw(is_custom1 is_custom2 custom1 custom2)) + { + is( + exception { $l->$sub }, + undef, + $sub . ' is handled by AUTOLOAD', + ); + } + + foreach my $sub (qw(is_foo foo)) + { + is( + exception { $l->$sub }, + undef, + 'arbitrary sub ' . $sub . ' is handled by AUTOLOAD', + ); + } +} + +{ + # levels is optional - most things should still work otherwise. + my $l = Log::Contextual::WarnLogger->new({ + env_prefix => 'BAR', + }); + + # if we don't know the level, and there are no environment variables set, + # just log everything. + { + ok($l->is_custom1, 'is_custom1 defaults to true on WarnLogger'); + ok($l->is_custom2, 'is_custom2 defaults to true on WarnLogger'); + } + + # otherwise, go with what the variable says. + { + local $ENV{BAR_CUSTOM1} = 0; + local $ENV{BAR_CUSTOM2} = 1; + ok(!$l->is_custom1, 'is_custom1 is false on WarnLogger'); + ok($l->is_custom2, 'is_custom2 is true on WarnLogger'); + + ok($l->is_foo, 'is_foo defaults to true on WarnLogger'); + + local $ENV{BAR_UPTO} = 'foo'; + like( + exception { $l->is_bar }, + qr/\QUnrecognized log level 'foo'\E in \$ENV{BAR_UPTO}\E/, + 'Cannot use an unrecognized log level in UPTO', + ); + } +} + +# these tests taken from t/warnlogger.t + +my $l = Log::Contextual::WarnLogger->new({ + env_prefix => 'BAR', + levels => [qw(custom1 custom2)] +}); + +{ + local $ENV{BAR_CUSTOM1} = 0; + local $ENV{BAR_CUSTOM2} = 1; + ok(!$l->is_custom1, 'is_custom1 is false on WarnLogger'); + ok($l->is_custom2, 'is_custom2 is true on WarnLogger'); + + ok(!$l->is_foo, 'is_foo is false (custom levels supplied) on WarnLogger'); +} + +{ + local $ENV{BAR_UPTO} = 'custom1'; + + ok($l->is_custom1, 'is_custom1 is true on WarnLogger'); + ok($l->is_custom2, 'is_custom2 is true on WarnLogger'); +} + +{ + local $ENV{BAR_UPTO} = 'custom2'; + + ok(!$l->is_custom1, 'is_custom1 is false on WarnLogger'); + ok($l->is_custom2, 'is_custom2 is true on WarnLogger'); +} + +{ + local $ENV{BAR_UPTO} = 'foo'; + + like( + exception { $l->is_custom1 }, + qr/Unrecognized log level 'foo'/, + 'Cannot use an unrecognized log level in UPTO', + ); +} +