decoder

use strict;
use warnings;
use Class::Date qw(now);

# global tokens
my %TOKE = (
  Z => { # my title
    val => 'Data::Logger',
    prm => 1
  },
  A => { # message
    val => 'Thanks for using Data::Logger!',
    prm => 1
  },
  F => { # users current "function title"
    val => 'main',
    prm => 0
  },
  S => { # users script name, doesn't need to be anything special
    val => 'testz0rz.pl', #basename($main::0),#'super cool script.pl',#'fake name',
    prm => 1
  },
  L => { # log level: info, debug, warning, fatal
    val => 'INFO',
    prm => 1
  },
  E => { # $! from the users script, or custom error message
    val => undef,
    prm => 1
  },
  Y => {
    val => _mk_dt('year'),
    prm => 1
  },
  M => {
    val => _mk_dt('month'),
    prm => 1
  },
  D => {
    val => _mk_dt('day'),
    prm => 1
  },
  h => {
    val => _mk_dt('hour'),
    prm => 1
  },
  m => {
    val => _mk_dt('minute'),
    prm => 1
  },
  s => {
    val => _mk_dt('second'),
    prm => 1
  }
); # Y, M, D, h, m, and s are ugly but work


print _decode('\\{%Y-%M-%D\\}[%h:%m:%s]{ %F:} (%L) - %A{ \\{%E\\}}');

# the decoder
sub _take_a_toke { #ha!
  my $smokin = shift;
  $smokin =~ s/(?<!\\)\{(.*?)(?<!\\)\}/_block_decode($1)/ge; #wrapper
  $smokin =~ s/(?<!\\)\%(.)/_decode($1)/ge;
  $smokin =~ s/(?<!\\)\\(.)/$1/g;
  return $smokin;
}

sub _decode {
  my $tok = shift; #enough of that joke
  if (exists $TOKE{$tok} and $TOKE{$tok}->{prm}) { #exists & active
    if (defined $TOKE{$tok}->{val}) { #defined
      return &{$TOKE{$tok}} if ref $TOKE{$tok} eq 'CODE';
      return $TOKE{$tok};
    } else {
      return '?'; # active, but no value (suggests problem)
    }
  } else {
    return; # doesn't exist or not active
  }
}

sub _block_decode {
#NO NEVER!  my $blk = _take_a_toke(shift); #recursive
  my $blk = shift;
  if ($blk =~ /(?<!\\)\%(.)/o) { # first succeeds and all are parsed
    my $dcd = _decode($1);
    return unless $dcd;
    return if $dcd eq '?';
  } else {
    return;
  }

  return $blk; # parent will parse the rest
}

# for datetime
sub _mk_dt {
  my $gm = shift or return;
  return sub {
    my %dt;
    @dt{
      qw(
        year   #0
        month  #1
        day    #2
        hour   #3
        minute #4
        second #5
      )
    } = split(/(?:\s|:|-|;)+/,now);

    return $dt{lc($gm)};
  }
}