File Coverage

blib/lib/Log/Sprintf.pm

Criterion	Covered	Total	%
statement	55	55	100.0
branch	16	16	100.0
condition	6	7	85.7
subroutine	17	17	100.0
pod	6	9	66.6
total	100	104	96.1

package Log::Sprintf;
{
  $Log::Sprintf::VERSION = '0.001002';
}

# ABSTRACT: Format strings the way Log::log4perl does, without all the weight

use strict;
use warnings;

use String::Formatter;
use syntax 'junction';

my %codes = (
  C => 'package',
  c => 'category',
  d => 'date',
  F => 'file',
  H => 'host',
  L => 'line',
  l => 'location',
  M => 'subroutine',
  m => 'message',
  n => 'newline',
  P => 'pid',
  p => 'priority',
  r => 'milliseconds_since_start',
  R => 'milliseconds_since_last_log',
  T => 'stacktrace',
);

sub new { bless $_[1]||{}, $_[0] }

sub _formatter {
  my $self = shift;
  unless (defined $self->{formatter}) {
     $self->{formatter} = String::Formatter->new({
       input_processor => 'require_single_input',
       string_replacer => 'method_replace',
       codes => $self->_codes,
     });
  }
  return $self->{formatter}
}

sub sprintf {
   my ($self, $args) = @_;

   local @{$self}{keys %$args} = values %$args;

   $self->_formatter->format($self->{format}, $self);
}

sub codes { +{} }

sub _codes { return { %codes, %{$_[0]->codes} } }

{
  no strict 'refs';
  for my $name (
    grep { $_ eq none(qw( stacktrace date message priority newline location )) }
    values %codes
  ) {
    *{$name} = sub {
      die "you forgot to pass $name" unless exists $_[0]->{$name};
      $_[0]->{$name}
    }
  }
}

sub date {
   die 'you forgot to pass date' unless exists $_[0]->{date};

   my @date = @{$_[0]->{date}};
   splice @date, 6, 3;
   $date[-1] += 1900;
   $date[-2]++;
   CORE::sprintf '%04i-%02i-%02i %02i:%02i:%02i', reverse @date
}

sub message {
   die 'you forgot to pass message' unless exists $_[0]->{message};
   my $self  = shift;
   my $chomp = shift;
   my $m     = $self->{message};

   chomp $m if defined $chomp && $chomp eq 'chomp';

   $m
}

sub priority {
   die 'you forgot to pass priority' unless exists $_[0]->{priority};
   my $self   = shift;
   my $skinny = shift;
   my $p      = $self->{priority};

   return substr $p, 0, 1 if $skinny;
   $p;
}

sub location {
   exists $_[0]->{$_} or die "you forgot to pass $_"
      for qw(subroutine file line);
   "$_[0]->{subroutine} ($_[0]->{file}:$_[0]->{line})"
}

sub newline() { "\n" }

sub stacktrace {
   die 'you forgot to pass stacktrace' unless exists $_[0]->{stacktrace};
   my $s = $_[0]->{stacktrace};
   "$s->[0][1] line $s->[0][2]\n" .
      join "\n",
      map "\t$_->[3] called at $_->[1] line $_->[2]",
      @{$s}[1..$#$s] # all but the first level
}

sub format { $_[0]->{format} }

1;

__END__