view release on metacpan or  search on metacpan

lib/Circle/Loggable.pm  view on Meta::CPAN

);

__PACKAGE__->APPLY_Inheritable_Setting( log_path =>
   description => "Path template for log file name",
   type        => 'str',
);

use Struct::Dumb qw( readonly_struct );

# Data about the log file itself
readonly_struct LogId => [qw(
   path time_start time_until itempath line_timestamp_fmt
)];

# Data about logging from a particular item
readonly_struct LogCtx => [qw(
   path_residue
)];

our $NO_LOG = 0;

sub push_log
{
   my $self = shift;
   my ( $event, $time, $args ) = @_;

   return unless $self->setting_log_enabled;
   return if $NO_LOG;

   # Best-effort
   eval {
      my $logger = $self->logger( $time );

      my $ctx = $self->{logctx};

      $logger->log( $ctx, $time, $event, $args );
      1;
   } and return;

   {
      local $NO_LOG = 1;
      warn "Unable to log - $@";
   }
}

my %time_format_to_idx = (
   Y => 5,
   m => 4,
   d => 3,
   H => 2,
   M => 1,
   S => 0,
);

# Returns a LogId and a LogCtx
sub split_logpath
{
   my $self = shift;
   my ( $time ) = @_;

   my @pcs = split m{/}, $self->enumerable_path;
   shift @pcs; # trim leading /
   @pcs or @pcs = ( "Global" );
   my $path_used = 0;
   my %ts_used = map { $_ => 0 } qw( Y m d H M );

   my @timestamp = localtime $time;

   my %formats = (
      # Specific kinds of time format so we can track the granulity being used
      ( map {
         my $format = $_;
         $format => sub {
            $ts_used{$format}++;
            strftime( "%$format", @timestamp )
         };
        } qw( Y m d H M ) ),
      P => sub {
         my ( $limit ) = @_;
         defined $limit or $limit = @pcs;

         my $path_lower = $path_used;
         my $path_upper = $limit;

         $path_used = $path_upper if $path_upper > $path_used;

         return join '/', map { $_ // "" } @pcs[$path_lower..$path_upper-1];
      },
   );

   my $path = $self->setting_log_path;
   $path =~ s<%(?:{([^}]*)})?(.)>
             {exists $formats{$2} ? $formats{$2}->($1)
                                  : die "Unrecognised escape '%$2"}eg;

   # Reset to zero all the fields that aren't used
   $ts_used{$_} or $timestamp[$time_format_to_idx{$_}] = 0 for qw( Y m d H M S );
   $timestamp[3] or $timestamp[3] = 1; # mday is 1-based

   my $time_start = strftime( "%Y/%m/%d %H:%M:%S", @timestamp );

   # Increment the last timestamp field before a field not used in the file
   # path
   $ts_used{$_} or $timestamp[$time_format_to_idx{$_}+1]++, last for qw( m d H M S );
   my $time_until = mktime @timestamp;

   my $time_fmt_day = join "/", map { $ts_used{$_} ? () : ( "\%$_" ) } qw( Y m d );
   my $time_fmt_sec = join ":", map { $ts_used{$_} ? () : ( "\%$_" ) } qw( H M S );

   my $logid = LogId(
      $path,
      $time_start,
      $time_until,
      join( '/', grep { defined } @pcs[0..$path_used-1] ),
      join( " ", grep { length } $time_fmt_day, $time_fmt_sec ),
   );

   my $logctx = LogCtx(
      join( '/', grep { defined } @pcs[$path_used..$#pcs] ),
   );