lib/Log/Contextual/WarnLogger.pm

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