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 _decode {
  my $tdc = shift;
  while ($tdc =~ s/(?<!\\)\{(.*?)(?<!\\)\}/\\CURRENT\//o) {
    my $blk = $1;

    if ($blk =~ /\%(\S)/o) {
      my $tok = $1;
      if ($TOKE{$tok}->{prm} and defined $TOKE{$tok}->{val}) {
        if (ref $TOKE{$tok}->{val} eq 'CODE') {
          $blk =~ s/\%$tok/&{$TOKE{$tok}->{val}}/e;
        } else {
          $blk =~ s/\%$tok/$TOKE{$tok}->{val}/;
        }

        $tdc =~ s/\\CURRENT\//$blk/;
      }
    }

    $tdc =~ s/\\CURRENT\///go; # /g just for safety
  }
  while ($tdc =~ /\%(\S)/o) {
    my $tok = $1;
    if ($TOKE{$tok}->{prm}) {
      if (defined $TOKE{$tok}->{val}) {
        if (ref $TOKE{$tok}->{val} eq 'CODE') {
          $tdc =~ s/\%$tok/&{$TOKE{$tok}->{val}}/eg;
        } else {
          $tdc =~ s/\%$tok/$TOKE{$tok}->{val}/g;
        }
      } else {
        $tdc =~ s/\%$tok/\?/g; # tag is supposed to be defined
      }
    } else {
      $tdc =~ s/\%$tok//g; # tag isn't active
    }
  }

  $tdc =~ s/\\\{/\{/go; # would s/\\(\{|\}/$1/g; be faster?
  $tdc =~ s/\\\}/\}/go; #
  return $tdc;
}

# 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{$gm};
  }
}