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';
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
...
}
+
+
=head1 DESCRIPTION
This module is a simple logger made for libraries using L<Log::Contextual>. We
=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<env_prefix> defines what the prefix is for
-the environment variables that will be checked for the six log levels. For
-example, if C<env_prefix> is set to C<FREWS_PACKAGE> 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<env_prefix> is set to C<FREWS_PACKAGE> the following environment
variables will be used:
FREWS_PACKAGE_UPTO
C<< FOO_UPTO=TRACE >> it will enable all log levels. Similarly, if you
set it to C<FATAL> only fatal will be enabled.
+=back
+
=head2 $level
Arguments: C<@anything>
$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
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<Log::Contextual/"AUTHOR">
--- /dev/null
+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',
+ );
+}
+
projects / p5sagit/Log-Contextual.git / commitdiff