lib/Log/Contextual/WarnLogger.pm

   1 package Log::Contextual::WarnLogger;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp 'croak';
   7
   8 my @default_levels = qw( trace debug info warn error fatal );
   9
  10 # generate subs to handle the default levels
  11 # anything else will have to be handled by AUTOLOAD at runtime
  12 {
  13    for my $level (@default_levels) {
  14
  15       no strict 'refs';
  16
  17       my $is_name = "is_$level";
  18       *{$level} = sub {
  19          my $self = shift;
  20
  21          $self->_log($level, @_)
  22            if $self->$is_name;
  23       };
  24
  25       *{$is_name} = sub {
  26          my $self = shift;
  27          return 1 if $ENV{$self->{env_prefix} . '_' . uc $level};
  28          my $upto = $ENV{$self->{env_prefix} . '_UPTO'};
  29          return unless $upto;
  30          $upto = lc $upto;
  31
  32          return $self->{level_num}{$level} >= $self->{level_num}{$upto};
  33       };
  34    }
  35 }
  36
  37 our $AUTOLOAD;
  38
  39 sub AUTOLOAD {
  40    my $self = $_[0];
  41
  42    (my $name = our $AUTOLOAD) =~ s/.*:://;
  43    return if $name eq 'DESTROY';
  44
  45    # extract the log level from the sub name
  46    my ($is, $level) = $name =~ m/^(is_)?(.+)$/;
  47    my $is_name = "is_$level";
  48
  49    no strict 'refs';
  50    *{$level} = sub {
  51       my $self = shift;
  52
  53       $self->_log($level, @_)
  54         if $self->$is_name;
  55    };
  56
  57    *{$is_name} = sub {
  58       my $self = shift;
  59
  60       my $prefix_field = $self->{env_prefix} . '_' . uc $level;
  61       return 1 if $ENV{$prefix_field};
  62
  63       # don't log if the variable specifically says not to
  64       return 0 if defined $ENV{$prefix_field} and not $ENV{$prefix_field};
  65
  66       my $upto_field = $self->{env_prefix} . '_UPTO';
  67       my $upto       = $ENV{$upto_field};
  68
  69       if ($upto) {
  70          $upto = lc $upto;
  71
  72          croak "Unrecognized log level '$upto' in \$ENV{$upto_field}"
  73            if not defined $self->{level_num}{$upto};
  74
  75          return $self->{level_num}{$level} >= $self->{level_num}{$upto};
  76       }
  77
  78       # if we don't recognize this level and nothing says otherwise, log!
  79       return 1 if not $self->{custom_levels};
  80    };
  81    goto &$AUTOLOAD;
  82 }
  83
  84 sub new {
  85    my ($class, $args) = @_;
  86
  87    my $levels = $args->{levels};
  88    croak 'invalid levels specification: must be non-empty arrayref'
  89      if defined $levels and (ref $levels ne 'ARRAY' or !@$levels);
  90
  91    my $custom_levels = defined $levels;
  92    $levels ||= [@default_levels];
  93
  94    my %level_num;
  95    @level_num{@$levels} = (0 .. $#{$levels});
  96
  97    my $self = bless {
  98       levels        => $levels,
  99       level_num     => \%level_num,
 100       custom_levels => $custom_levels,
 101    }, $class;
 102
 103    $self->{env_prefix} = $args->{env_prefix}
 104      or die 'no env_prefix passed to Log::Contextual::WarnLogger->new';
 105    return $self;
 106 }
 107
 108 sub _log {
 109    my $self    = shift;
 110    my $level   = shift;
 111    my $message = join("\n", @_);
 112    $message .= "\n" unless $message =~ /\n$/;
 113    warn "[$level] $message";
 114 }
 115
 116 1;
 117
 118 __END__
 119
 120 =head1 NAME
 121
 122 Log::Contextual::WarnLogger - Simple logger for libraries using Log::Contextual
 123
 124 =head1 SYNOPSIS
 125
 126  package My::Package;
 127  use Log::Contextual::WarnLogger;
 128  use Log::Contextual qw( :log ),
 129    -default_logger => Log::Contextual::WarnLogger->new({
 130       env_prefix => 'MY_PACKAGE',
 131       levels => [ qw(debug info notice warning error critical alert emergency) ],
 132    });
 133
 134  # warns '[info] program started' if $ENV{MY_PACKAGE_TRACE} is set
 135  log_info { 'program started' }; # no-op because info is not in levels
 136  sub foo {
 137    # warns '[debug] entered foo' if $ENV{MY_PACKAGE_DEBUG} is set
 138    log_debug { 'entered foo' };
 139    ...
 140  }
 141
 142
 143
 144 =head1 DESCRIPTION
 145
 146 This module is a simple logger made for libraries using L<Log::Contextual>.  We
 147 recommend the use of this logger as your default logger as it is simple and
 148 useful for most users, yet users can use L<Log::Contextual/set_logger> to override
 149 your choice of logger in their own code thanks to the way L<Log::Contextual>
 150 works.
 151
 152 =head1 METHODS
 153
 154 =head2 new
 155
 156 Arguments: C<< Dict[ env_prefix => Str, levels => List ] $conf >>
 157
 158  my $l = Log::Contextual::WarnLogger->new({
 159    env_prefix => 'BAR'
 160  });
 161
 162 or:
 163
 164  my $l = Log::Contextual::WarnLogger->new({
 165    env_prefix => 'BAR',
 166    levels => [ 'level1', 'level2' ]
 167
 168  });
 169
 170 Creates a new logger object where C<env_prefix> defines what the prefix is for
 171 the environment variables that will be checked for the log levels.
 172
 173 The log levels may be customized, but if not defined, these are used:
 174
 175 =over 4
 176
 177 =item trace
 178
 179 =item debug
 180
 181 =item info
 182
 183 =item warn
 184
 185 =item error
 186
 187 =item fatal
 188
 189 =back
 190
 191 For example, if C<env_prefix> is set to C<FREWS_PACKAGE> the following environment
 192 variables will be used:
 193
 194  FREWS_PACKAGE_UPTO
 195
 196  FREWS_PACKAGE_TRACE
 197  FREWS_PACKAGE_DEBUG
 198  FREWS_PACKAGE_INFO
 199  FREWS_PACKAGE_WARN
 200  FREWS_PACKAGE_ERROR
 201  FREWS_PACKAGE_FATAL
 202
 203 Note that C<UPTO> is a convenience variable.  If you set
 204 C<< FOO_UPTO=TRACE >> it will enable all log levels.  Similarly, if you
 205 set it to C<FATAL> only fatal will be enabled.
 206
 207 =back
 208
 209 =head2 $level
 210
 211 Arguments: C<@anything>
 212
 213 All of the following six methods work the same.  The basic pattern is:
 214
 215  sub $level {
 216    my $self = shift;
 217
 218    warn "[$level] " . join qq{\n}, @_;
 219       if $self->is_$level;
 220  }
 221
 222 =head3 trace
 223
 224  $l->trace( 'entered method foo with args ' join q{,}, @args );
 225
 226 =head3 debug
 227
 228  $l->debug( 'entered method foo' );
 229
 230 =head3 info
 231
 232  $l->info( 'started process foo' );
 233
 234 =head3 warn
 235
 236  $l->warn( 'possible misconfiguration at line 10' );
 237
 238 =head3 error
 239
 240  $l->error( 'non-numeric user input!' );
 241
 242 =head3 fatal
 243
 244  $l->fatal( '1 is never equal to 0!' );
 245
 246 If different levels are specified, appropriate functions named for your custom
 247 levels work as you expect.
 248
 249 =head2 is_$level
 250
 251 All of the following six functions just return true if their respective
 252 environment variable is enabled.
 253
 254 =head3 is_trace
 255
 256  say 'tracing' if $l->is_trace;
 257
 258 =head3 is_debug
 259
 260  say 'debuging' if $l->is_debug;
 261
 262 =head3 is_info
 263
 264  say q{info'ing} if $l->is_info;
 265
 266 =head3 is_warn
 267
 268  say 'warning' if $l->is_warn;
 269
 270 =head3 is_error
 271
 272  say 'erroring' if $l->is_error;
 273
 274 =head3 is_fatal
 275
 276  say q{fatal'ing} if $l->is_fatal;
 277
 278 If different levels are specified, appropriate is_$level functions work as you
 279 would expect.
 280
 281 =head1 AUTHOR
 282
 283 See L<Log::Contextual/"AUTHOR">
 284
 285 =head1 COPYRIGHT
 286
 287 See L<Log::Contextual/"COPYRIGHT">
 288
 289 =head1 LICENSE
 290
 291 See L<Log::Contextual/"LICENSE">
 292
 293 =cut
 294