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({ env_prefix => 'BAR' });
 159
 160 or:
 161
 162  my $l = Log::Contextual::WarnLogger->new({
 163    env_prefix => 'BAR',
 164    levels => [ 'level1', 'level2' ],
 165  });
 166
 167 Creates a new logger object where C<env_prefix> defines what the prefix is for
 168 the environment variables that will be checked for the log levels.
 169
 170 The log levels may be customized, but if not defined, these are used:
 171
 172 =over 4
 173
 174 =item trace
 175
 176 =item debug
 177
 178 =item info
 179
 180 =item warn
 181
 182 =item error
 183
 184 =item fatal
 185
 186 =back
 187
 188 For example, if C<env_prefix> is set to C<FREWS_PACKAGE> the following environment
 189 variables will be used:
 190
 191  FREWS_PACKAGE_UPTO
 192
 193  FREWS_PACKAGE_TRACE
 194  FREWS_PACKAGE_DEBUG
 195  FREWS_PACKAGE_INFO
 196  FREWS_PACKAGE_WARN
 197  FREWS_PACKAGE_ERROR
 198  FREWS_PACKAGE_FATAL
 199
 200 Note that C<UPTO> is a convenience variable.  If you set
 201 C<< FOO_UPTO=TRACE >> it will enable all log levels.  Similarly, if you
 202 set it to C<FATAL> only fatal will be enabled.
 203
 204 =head2 $level
 205
 206 Arguments: C<@anything>
 207
 208 All of the following six methods work the same.  The basic pattern is:
 209
 210  sub $level {
 211    my $self = shift;
 212
 213    warn "[$level] " . join qq{\n}, @_;
 214       if $self->is_$level;
 215  }
 216
 217 =head3 trace
 218
 219  $l->trace( 'entered method foo with args ' join q{,}, @args );
 220
 221 =head3 debug
 222
 223  $l->debug( 'entered method foo' );
 224
 225 =head3 info
 226
 227  $l->info( 'started process foo' );
 228
 229 =head3 warn
 230
 231  $l->warn( 'possible misconfiguration at line 10' );
 232
 233 =head3 error
 234
 235  $l->error( 'non-numeric user input!' );
 236
 237 =head3 fatal
 238
 239  $l->fatal( '1 is never equal to 0!' );
 240
 241 If different levels are specified, appropriate functions named for your custom
 242 levels work as you expect.
 243
 244 =head2 is_$level
 245
 246 All of the following six functions just return true if their respective
 247 environment variable is enabled.
 248
 249 =head3 is_trace
 250
 251  say 'tracing' if $l->is_trace;
 252
 253 =head3 is_debug
 254
 255  say 'debuging' if $l->is_debug;
 256
 257 =head3 is_info
 258
 259  say q{info'ing} if $l->is_info;
 260
 261 =head3 is_warn
 262
 263  say 'warning' if $l->is_warn;
 264
 265 =head3 is_error
 266
 267  say 'erroring' if $l->is_error;
 268
 269 =head3 is_fatal
 270
 271  say q{fatal'ing} if $l->is_fatal;
 272
 273 If different levels are specified, appropriate is_$level functions work as you
 274 would expect.
 275
 276 =head1 AUTHOR
 277
 278 See L<Log::Contextual/"AUTHOR">
 279
 280 =head1 COPYRIGHT
 281
 282 See L<Log::Contextual/"COPYRIGHT">
 283
 284 =head1 LICENSE
 285
 286 See L<Log::Contextual/"LICENSE">
 287
 288 =cut
 289