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