File Coverage

blib/lib/Date/strftimeq.pm

Criterion	Covered	Total	%
statement	53	53	100.0
branch	4	6	66.6
condition	1	2	50.0
subroutine	14	14	100.0
pod	1	1	100.0
total	73	76	96.0

## no critic: Modules::ProhibitAutomaticExportation

package Date::strftimeq;

our $DATE = '2019-11-20'; # DATE
our $DIST = 'Date-strftimeq'; # DIST
our $VERSION = '0.001'; # VERSION

use 5.010001;
use strict;
use warnings;

use POSIX ();
use Scalar::Util 'blessed';

use Exporter 'import';
our @EXPORT = qw(strftimeq);

our $regex = qr{
                   (?(DEFINE)
                       (? ( [^()]+ | \((?&def_code)\) )*)
                   )
                   (?

                       (?
                           %
                           (? [_0^#-]+)?
                           (? [0-9]+)?
                           (?[EO])?
                           (? [%aAbBcCdDeEFgGhHIjklmMnOpPrRsStTuUVwWxXyYZz+])
                       )|
                       (?
                           %\(
                           (? (?&def_code))
                           \)q)
                   )
           }x;

# faster version, without using named capture
if (0) {
}

sub strftimeq {
    my ($format, @time) = @_;

    my ($caller_pkg) = caller();
    my %compiled_code;

    $format =~ s{$regex}{
        # for faster acccess
        my %m = %+;

        #use DD; dd \%m; # DEBUG

        if (exists $m{code}) {
            unless (defined $compiled_code{$m{code}}) {
                #say "D: compiling $m{code}"; # DEBUG
                $compiled_code{$m{code}} = eval "package $caller_pkg; no strict; no warnings; sub { $m{code} }";
                die "Can't compile code in $m{all}: $@" if $@;
            }
            my $code_res = $compiled_code{$m{code}}->(@time);
            $code_res //= "";
            $code_res =~ s/%/%%/g;
            $code_res;
        } else {
            $m{all};
        }
    }xego;

    POSIX::strftime($format, @time);
}

1;
# ABSTRACT: POSIX::strftime() with support for embedded perl code in %(...)q

__END__