File Coverage

blib/lib/Log/Log4perl/Tiny.pm

Criterion	Covered	Total	%
statement	379	406	93.3
branch	164	230	71.3
condition	21	38	55.2
subroutine	40	42	95.2
pod	22	22	100.0
total	626	738	84.8

package Log::Log4perl::Tiny;

use strict;
use warnings;
{ our $VERSION = '1.8.0'; }

use Carp;
use POSIX ();

our ($TRACE, $DEBUG, $INFO, $WARN, $ERROR, $FATAL, $OFF, $DEAD);
my ($_instance, %name_of, %format_for, %id_for);
my $LOGDIE_MESSAGE_ON_STDERR = 1;

sub import {
   my ($exporter, @list) = @_;
   my ($caller, $file, $line) = caller();
   no strict 'refs';

   if (grep { $_ eq ':full_or_fake' } @list) {
      @list = grep { $_ ne ':full_or_fake' } @list;
      my $sue = 'use Log::Log4perl (@list)';
      eval "
         package $caller;
         $sue;
         1;
      " and return;
      unshift @list, ':fake';
   } ## end if (grep { $_ eq ':full_or_fake'...})

   my (%done, $level_set);
 ITEM:
   for my $item (@list) {
      next ITEM if $done{$item};
      $done{$item} = 1;
      if ($item =~ /^[a-zA-Z]/mxs) {
         *{$caller . '::' . $item} = \&{$exporter . '::' . $item};
      }
      elsif ($item eq ':levels') {
         for my $level (qw( TRACE DEBUG INFO WARN ERROR FATAL OFF DEAD )) {
            *{$caller . '::' . $level} = \${$exporter . '::' . $level};
         }
      }
      elsif ($item eq ':subs') {
         push @list, qw(
           ALWAYS TRACE DEBUG INFO WARN ERROR FATAL
           LOGWARN LOGDIE LOGEXIT LOGCARP LOGCLUCK LOGCROAK LOGCONFESS
           get_logger
         );
      } ## end elsif ($item eq ':subs')
      elsif ($item =~ /\A : (mimic | mask | fake) \z/mxs) {

         # module name as a string below to trick Module::ScanDeps
         if (!'Log::Log4perl'->can('easy_init')) {
            $INC{'Log/Log4perl.pm'} = __FILE__;
            *Log::Log4perl::import = sub { };
            *Log::Log4perl::easy_init = sub {
               my ($pack, $conf) = @_;
               if (ref $conf) {
                  $_instance = __PACKAGE__->new($conf);
                  $_instance->level($conf->{level})
                    if exists $conf->{level};
                  $_instance->format($conf->{format})
                    if exists $conf->{format};
                  $_instance->format($conf->{layout})
                    if exists $conf->{layout};
                  $_instance->filter($conf->{filter})
                    if exists $conf->{filter};
               } ## end if (ref $conf)
               elsif (defined $conf) {
                  $_instance->level($conf);
               }
            };
         } ## end if (!'Log::Log4perl'->...)
      } ## end elsif ($item =~ /\A : (mimic | mask | fake) \z/mxs)
      elsif ($item eq ':easy') {
         push @list, qw( :levels :subs :fake );
      }
      elsif (lc($item) eq ':dead_if_first') {
         get_logger()->_set_level_if_first($DEAD);
         $level_set = 1;
      }
      elsif (lc($item) eq ':no_extra_logdie_message') {
         $LOGDIE_MESSAGE_ON_STDERR = 0;
      }
   } ## end ITEM: for my $item (@list)

   if (!$level_set) {
      my $logger = get_logger();
      $logger->_set_level_if_first($INFO);
      $logger->level($logger->level());
   }

   return;
} ## end sub import

sub new {
   my $package = shift;
   my %args = ref($_[0]) ? %{$_[0]} : @_;

   $args{format} = $args{layout} if exists $args{layout};

   my $channels_input = [fh => \*STDERR];
   if (exists $args{channels}) {
      $channels_input = $args{channels};
   }
   else {
      for my $key (qw< file_append file_create file_insecure file fh >) {
         next unless exists $args{$key};
         $channels_input = [$key => $args{$key}];
         last;
      }
   } ## end else [ if (exists $args{channels...})]
   my $channels = build_channels($channels_input);
   $channels = $channels->[0] if @$channels == 1;    # remove outer shell

   my $self = bless {
      fh    => $channels,
      level => $INFO,
   }, $package;

   for my $accessor (qw( level fh format filter )) {
      next unless defined $args{$accessor};
      $self->$accessor($args{$accessor});
   }

   $self->format('[%d] [%5p] %m%n') unless exists $self->{format};

   if (exists $args{loglocal}) {
      my $local = $args{loglocal};
      $self->loglocal($_, $local->{$_}) for keys %$local;
   }

   return $self;
} ## end sub new

sub build_channels {
   my @pairs = (@_ && ref($_[0])) ? @{$_[0]} : @_;
   my @channels;
   while (@pairs) {
      my ($key, $value) = splice @pairs, 0, 2;

      # some initial validation
      croak "build_channels(): undefined key in list"
        unless defined $key;
      croak "build_channels(): undefined value for key $key"
        unless defined $value;

      # analyze the key-value pair and set the channel accordingly
      my ($channel, $set_autoflush);
      if ($key =~ m{\A(?: fh | sub | code | channel )\z}mxs) {
         $channel = $value;
      }
      elsif ($key eq 'file_append') {
         open $channel, '>>', $value
           or croak "open('$value') for appending: $!";
         $set_autoflush = 1;
      }
      elsif ($key eq 'file_create') {
         open $channel, '>', $value
           or croak "open('$value') for creating: $!";
         $set_autoflush = 1;
      }
      elsif ($key =~ m{\A file (?: _insecure )? \z}mxs) {
         open $channel, $value
           or croak "open('$value'): $!";
         $set_autoflush = 1;
      }
      else {
         croak "unsupported channel key '$key'";
      }

      # autoflush new filehandle if applicable
      if ($set_autoflush) {
         my $previous = select($channel);
         $|++;
         select($previous);
      }

      # record the channel, on to the next
      push @channels, $channel;
   } ## end while (@pairs)
   return \@channels;
} ## end sub build_channels

sub get_logger { return $_instance ||= __PACKAGE__->new(); }
sub LOGLEVEL { return get_logger()->level(@_); }

sub LEVELID_FOR {
   my $level = shift;
   return $id_for{$level} if exists $id_for{$level};
   return;
} ## end sub LEVELID_FOR

sub LEVELNAME_FOR {
   my $id = shift;
   return $name_of{$id} if exists $name_of{$id};
   return $id if exists $id_for{$id};
   return;
} ## end sub LEVELNAME_FOR

sub loglocal {
   my $self   = shift;
   my $key    = shift;
   my $retval = delete $self->{loglocal}{$key};
   $self->{loglocal}{$key} = shift if @_;
   return $retval;
} ## end sub loglocal
sub LOGLOCAL { return get_logger->loglocal(@_) }

sub filter {
   my $self = shift;
   $self->{filter} = shift if @_;
   return $self->{filter};
}
sub FILTER { return get_logger->filter(@_) }

sub format {
   my $self = shift;

   if (@_) {
      $self->{format} = shift;
      $self->{args}   = \my @args;
      my $replace = sub {
         if (defined $_[2]) {    # op with options
            my ($num, $opts, $op) = @_[0 .. 2];
            push @args, [$op, $opts];
            return "%$num$format_for{$op}[0]";
         }
         if (defined $_[4]) {    # op without options
            my ($num, $op) = @_[3, 4];
            push @args, [$op];
            return "%$num$format_for{$op}[0]";
         }

         # not an op
         my $char = ((!defined($_[5])) || ($_[5] eq '%')) ? '' : $_[5];
         return '%%' . $char;    # keep the percent AND the char, if any
      };

      # transform into real format
      my ($with_options, $standalone) = ('', '');
      for my $key (keys %format_for) {
         my $type = $format_for{$key}[2] || '';
         $with_options .= $key if $type;
         $standalone   .= $key if $type ne 'required';
      }

      # quotemeta or land on impossible character class if empty
      $_ = length($_) ? quotemeta($_) : '^\\w\\W'
        for ($with_options, $standalone);
      $self->{format} =~ s<
            %                      # format marker
            (?:
                  (?:                       # something with options
                     ( -? \d* (?:\.\d+)? )  # number
                     ( (?:\{ .*? \}) )      # options
                     ([$with_options])     # specifier
                  )
               |  (?:
                     ( -? \d* (?:\.\d+)? )  # number
                     ([$standalone])        # specifier
                  )
               |  (.)                       # just any char
               |  \z                        # just the end of it!
            )
         >
         {
            $replace->($1, $2, $3, $4, $5, $6);
         }gsmex;
   } ## end if (@_)
   return $self->{format};
} ## end sub format

*layout = \&format;

sub emit_log {
   my ($self, $message) = @_;
   my $fh = $self->{fh};
   for my $channel ((ref($fh) eq 'ARRAY') ? (@$fh) : ($fh)) {
      (ref($channel) eq 'CODE')
        ? $channel->($message, $self)
        : print {$channel} $message;
   }
   return $message;
} ## end sub emit_log

sub log {
   my $self = shift;
   return if $self->{level} == $DEAD;

   my $level = shift;
   return if $level > $self->{level};

   my %data_for = (
      level   => $level,
      message => \@_,
      (exists($self->{loglocal}) ? (loglocal => $self->{loglocal}) : ()),
   );
   my $message = sprintf $self->{format},
     map { $format_for{$_->[0]}[1]->(\%data_for, @$_); } @{$self->{args}};

   $message = $self->{filter}->($message) if $self->{filter};

   return $self->emit_log($message);
} ## end sub log

sub ALWAYS { return $_instance->log($OFF, @_); }

sub _exit {
   my $self = shift || $_instance;
   exit $self->{logexit_code} if defined $self->{logexit_code};
   exit $Log::Log4perl::LOGEXIT_CODE
     if defined $Log::Log4perl::LOGEXIT_CODE;
   exit 1;
} ## end sub _exit

sub logwarn {
   my $self = shift;

   my @message;
   @message = __expand_message_list({message => \@_})
      if $self->is_warn() || $LOGDIE_MESSAGE_ON_STDERR;

   $self->warn(@message);

   if ($LOGDIE_MESSAGE_ON_STDERR) {
      # default warning when nothing is passed to warn
      push @message, "Warning: something's wrong" unless @message;

      # add 'at  line ' unless argument ends in "\n";
      my (undef, $file, $line) = caller(1);
      push @message, sprintf " at %s line %d.\n", $file, $line
         if substr($message[-1], -1, 1) ne "\n";

      # go for it!
      CORE::warn(@message);
   }

   return
} ## end sub logwarn

sub logdie {
   my $self = shift;

   my @message;
   @message = __expand_message_list({message => \@_})
      if $self->is_fatal() || $LOGDIE_MESSAGE_ON_STDERR;

   $self->fatal(@message);

   if ($LOGDIE_MESSAGE_ON_STDERR) {
      # default die message when nothing is passed to die
      push @message, "Died" unless @message;

      # add 'at  line ' unless argument ends in "\n";
      my (undef, $file, $line) = caller(1);
      push @message, sprintf " at %s line %d.\n", $file, $line
         if substr($message[-1], -1, 1) ne "\n";

      # go for it!
      CORE::die(@message);
   }

   $self->_exit();
} ## end sub logdie

sub logexit {
   my $self = shift;
   $self->fatal(@_);
   $self->_exit();
}

sub _carpstuff {
   my $self = shift;
   my $renderer = shift;
   my $emitter  = shift;
   my $log_level = shift;

   my $emit_log = $self->can("is_$log_level")->($self);

   require Carp;
   local $Carp::Internal{'' . __PACKAGE__} = 1;
   local $Carp::CarpLevel = $Carp::CarpLevel + 2;

   my @message;
   @message = __expand_message_list({message => \@_})
      if $emit_log || $LOGDIE_MESSAGE_ON_STDERR;

   if ($emit_log) {    # avoid unless we're allowed to emit
      my $message = Carp->can($renderer)->(@message);
      my $method = $self->can($log_level);
      $self->$method($_) for split m{\n}mxs, $message;
   }
   if ($LOGDIE_MESSAGE_ON_STDERR) {
      Carp->can($emitter)->(@message);
   }

   return;
}

sub logcarp {
   my $self = shift;
   return $self->_carpstuff(qw< shortmess carp warn >, @_);
} ## end sub logcarp

sub logcluck {
   my $self = shift;
   return $self->_carpstuff(qw< longmess cluck warn >, @_);
} ## end sub logcluck

sub logcroak {
   my $self = shift;
   $self->_carpstuff(qw< shortmess croak fatal >, @_);
   $self->_exit();
} ## end sub logcroak

sub logconfess {
   my $self = shift;
   $self->_carpstuff(qw< longmess confess fatal >, @_);
   $self->_exit();
} ## end sub logconfess

sub level {
   my $self = shift;
   $self = $_instance unless ref $self;
   if (@_) {
      my $level = shift;
      return unless exists $id_for{$level};
      $self->{level} = $id_for{$level};
      $self->{_count}++;
   } ## end if (@_)
   return $self->{level};
} ## end sub level

sub _set_level_if_first {
   my ($self, $level) = @_;
   if (!$self->{_count}) {
      $self->level($level);
      delete $self->{_count};
   }
   return;
} ## end sub _set_level_if_first

sub __expand_message_list {
   join(
      (defined $, ? $, : ''),
      map { ref($_) eq 'CODE' ? $_->() : $_; } @{shift->{message}}
   );
}

BEGIN {

   # Time tracking's start time. Used to be tied to $^T but Log::Log4perl
   # does differently and uses Time::HiRes if available
   my $has_time_hires;
   my $gtod = sub { return (time(), 0) };
   eval {
      require Time::HiRes;
      $has_time_hires = 1;
      $gtod           = \&Time::HiRes::gettimeofday;
   };

   my $start_time = [$gtod->()];

   # For supporting %R
   my $last_log = $start_time;

   # Timezones are... differently supported somewhere
   my $strftime_has_tz_offset =
      POSIX::strftime('%z', localtime()) =~ m<\A [-+] \d{4} \z>mxs;
   if (! $strftime_has_tz_offset) {
      require Time::Local;
   }

   { # alias to the one in Log::Log4perl, for easier switching towards that
      no strict 'refs';
      *caller_depth = *Log::Log4perl::caller_depth;
   }
   our $caller_depth;
   $caller_depth ||= 0;

   # %format_for idea from Log::Tiny by J. M. Adler
   %format_for = (    # specifiers according to Log::Log4perl
      c => [s => sub { 'main' }],
      C => [
         s => sub {
            my ($internal_package) = caller 0;
            my $max_i = 5;
            my $i = 1;
            my $package;
            while ($i <= $max_i) {
               ($package) = caller $i;
               return '*undef*' unless defined $package;
               last if $package ne $internal_package;
               ++$i;
            } ## end while ($i <= 4)
            return '*undef' if $i > $max_i;
            ($package) = caller($i += $caller_depth) if $caller_depth;
            return $package;
         },
      ],
      d => [
         s => sub {
            my ($epoch) = @{shift->{tod} ||= [$gtod->()]};
            return POSIX::strftime('%Y/%m/%d %H:%M:%S', localtime($epoch));
         },
      ],
      D => [
         s => sub {
            my ($data, $op, $options) = @_;
            $options = '{}' unless defined $options;
            $options = substr $options, 1, length($options) - 2;
            my %flag_for = map { $_ => 1 } split /\s*,\s*/, lc($options);
            my ($s, $u) = @{$data->{tod} ||= [$gtod->()]};
            $u = substr "000000$u", -6, 6;    # padding left with 0
            return POSIX::strftime("%Y-%m-%d %H:%M:%S.$u+0000", gmtime $s)
              if $flag_for{utc};

            my @localtime = localtime $s;
            return POSIX::strftime("%Y-%m-%d %H:%M:%S.$u%z", @localtime)
               if $strftime_has_tz_offset;

            my $sign = '+';
            my $offset = Time::Local::timegm(@localtime) - $s;
            ($sign, $offset) = ('-', -$offset) if $offset < 0;
            my $z = sprintf '%s%02d%02d',
              $sign,                    # sign
              int($offset / 3600),      # hours
              (int($offset / 60) % 60); # minutes
            return POSIX::strftime("%Y-%m-%d %H:%M:%S.$u$z", @localtime);
         },
         'optional'
      ],
      e => [
         s => sub {
            my ($data, $op, $options) = @_;
            $data->{tod} ||= [$gtod->()];     # guarantee consistency here
            my $local = $data->{loglocal} or return '';
            my $key = substr $options, 1, length($options) - 2;
            return '' unless exists $local->{$key};
            my $target = $local->{$key};
            return '' unless defined $target;
            my $reft = ref $target or return $target;
            return '' unless $reft eq 'CODE';
            return $target->($data, $op, $options);
         },
         'required',
      ],
      F => [
         s => sub {
            my ($internal_package) = caller 0;
            my $i = 1;
            my ($package, $file);
            while ($i <= 4) {
               ($package, $file) = caller $i;
               return '*undef*' unless defined $package;
               last if $package ne $internal_package;
               ++$i;
            } ## end while ($i <= 4)
            return '*undef' if $i > 4;
            (undef, $file) = caller($i += $caller_depth) if $caller_depth;
            return $file;
         },
      ],
      H => [
         s => sub {
            eval { require Sys::Hostname; Sys::Hostname::hostname() }
              || '';
         },
      ],
      l => [
         s => sub {
            my ($internal_package) = caller 0;
            my $i = 1;
            my ($package, $filename, $line);
            while ($i <= 4) {
               ($package, $filename, $line) = caller $i;
               return '*undef*' unless defined $package;
               last if $package ne $internal_package;
               ++$i;
            } ## end while ($i <= 4)
            return '*undef' if $i > 4;
            (undef, $filename, $line) = caller($i += $caller_depth)
              if $caller_depth;
            my (undef, undef, undef, $subroutine) = caller($i + 1);
            $subroutine = "main::" unless defined $subroutine;
            return sprintf '%s %s (%d)', $subroutine, $filename, $line;
         },
      ],
      L => [
         d => sub {
            my ($internal_package) = caller 0;
            my $i = 1;
            my ($package, $line);
            while ($i <= 4) {
               ($package, undef, $line) = caller $i;
               return -1 unless defined $package;
               last if $package ne $internal_package;
               ++$i;
            } ## end while ($i <= 4)
            return -1 if $i > 4;
            (undef, undef, $line) = caller($i += $caller_depth)
              if $caller_depth;
            return $line;
         },
      ],
      m => [s => \&__expand_message_list,],
      M => [
         s => sub {
            my ($internal_package) = caller 0;
            my $max_i = 5;
            my $i = 1;
            while ($i <= $max_i) {
               my ($package) = caller $i;
               return '*undef*' unless defined $package;
               last if $package ne $internal_package;
               ++$i;
            } ## end while ($i <= 4)
            return '*undef' if $i > $max_i;
            $i += $caller_depth if $caller_depth;
            my (undef, undef, undef, $subroutine) = caller($i + 1);
            $subroutine = "main::" unless defined $subroutine;
            return $subroutine;
         },
      ],
      n => [s => sub { "\n" },],
      p => [s => sub { $name_of{shift->{level}} },],
      P => [d => sub { $$ },],
      r => [
         d => sub {
            my ($s, $u) = @{shift->{tod} ||= [$gtod->()]};
            $s -= $start_time->[0];
            my $m = int(($u - $start_time->[1]) / 1000);
            ($s, $m) = ($s - 1, $m + 1000) if $m < 0;
            return $m + 1000 * $s;
         },
      ],
      R => [
         d => sub {
            my ($sx, $ux) = @{shift->{tod} ||= [$gtod->()]};
            my $s = $sx - $last_log->[0];
            my $m = int(($ux - $last_log->[1]) / 1000);
            ($s, $m) = ($s - 1, $m + 1000) if $m < 0;
            $last_log = [$sx, $ux];
            return $m + 1000 * $s;
         },
      ],
      T => [
         s => sub {
            my ($internal_package) = caller 0;
            my $level = 1;
            while ($level <= 4) {
               my ($package) = caller $level;
               return '*undef*' unless defined $package;
               last if $package ne $internal_package;
               ++$level;
            } ## end while ($level <= 4)
            return '*undef' if $level > 4;

            # usage of Carp::longmess() and substitutions is mostly copied
            # from Log::Log4perl for better alignment and easier
            # transition to the "bigger" module
            local $Carp::CarpLevel =
              $Carp::CarpLevel + $level + $caller_depth;
            chomp(my $longmess = Carp::longmess());
            $longmess =~ s{(?:\A\s*at.*?\n|^\s*)}{}mxsg;
            $longmess =~ s{\n}{, }g;
            return $longmess;
         },
      ],
   );

   # From now on we're going to play with GLOBs...
   no strict 'refs';

   for my $name (qw( FATAL ERROR WARN INFO DEBUG TRACE )) {

      # create the ->level methods
      *{__PACKAGE__ . '::' . lc($name)} = sub {
         my $self = shift;
         return $self->log($$name, @_);
      };

      # create ->is_level and ->isLevelEnabled methods as well
      *{__PACKAGE__ . '::is' . ucfirst(lc($name)) . 'Enabled'} =
        *{__PACKAGE__ . '::is_' . lc($name)} = sub {
         return 0 if $_[0]->{level} == $DEAD || $$name > $_[0]->{level};
         return 1;
        };
   } ## end for my $name (qw( FATAL ERROR WARN INFO DEBUG TRACE ))

   for my $name (
      qw(
      FATAL ERROR WARN INFO DEBUG TRACE
      LOGWARN LOGDIE LOGEXIT
      LOGCARP LOGCLUCK LOGCROAK LOGCONFESS
      )
     )
   {
      *{__PACKAGE__ . '::' . $name} = sub {
         $_instance->can(lc $name)->($_instance, @_);
      };
   } ## end for my $name (qw( FATAL ERROR WARN INFO DEBUG TRACE...))

   for my $accessor (qw( fh logexit_code )) {
      *{__PACKAGE__ . '::' . $accessor} = sub {
         my $self = shift;
         $self = $_instance unless ref $self;
         $self->{$accessor} = shift if @_;
         return $self->{$accessor};
      };
   } ## end for my $accessor (qw( fh logexit_code ))

   my $index = -1;
   for my $name (qw( DEAD OFF FATAL ERROR WARN INFO DEBUG TRACE )) {
      $name_of{$$name = $index} = $name;
      $id_for{$name}  = $index;
      $id_for{$index} = $index;
      ++$index;
   } ## end for my $name (qw( DEAD OFF FATAL ERROR WARN INFO DEBUG TRACE ))

   get_logger();    # initialises $_instance;
} ## end BEGIN

1;                  # Magic true value required at end of module