File Coverage

blib/lib/Text/MiniTmpl.pm

Criterion	Covered	Total	%
statement	97	108	89.8
branch	24	30	80.0
condition	2	3	66.6
subroutine	24	26	92.3
pod	5	5	100.0
total	152	172	88.3

package Text::MiniTmpl;
use 5.012000;
use warnings;
use strict;
use utf8;
use Carp;

our $VERSION = 'v2.0.1';

use Export::Attrs;
use JSON::XS qw( encode_json );
use URI::Escape qw();
use HTML::Entities qw();

use constant UNSAFE_HTML=> '&"\'<>' . join q{},map{chr}0..8,11,12,14..31,127;
use constant RAWPRE     => q{$}.__PACKAGE__.'::__ .= ';
use constant RAWPOST    => q{};
use constant UTF8PRE    => q{$}.__PACKAGE__.'::__utf8 = ';
use constant UTF8POST   => 'utf8::encode($'.__PACKAGE__.'::__utf8);' .
                           q{$}.__PACKAGE__.'::__ .= $'.__PACKAGE__.'::__utf8;';

our $__;
our $__utf8;
our $TMPL_DIR = q{./};

my %CACHE;
my ($PRE, $POST) = (UTF8PRE, UTF8POST);


sub raw :Export {
    my ($is_raw) = @_;
    ($PRE, $POST) = $is_raw ? (RAWPRE, RAWPOST) : (UTF8PRE, UTF8POST);
    return;
}

sub render :Export {
    my ($tmpl, %p) = @_;
    my $path = $tmpl =~ m{\A[.]?/}xms ? $tmpl : "$TMPL_DIR$tmpl";
    1 while $path =~ s{(\A|/) (?![.][.]?/) [^/]+/[.][.]/}{$1}xms; ## no critic(ProhibitPostfixControls)
    my $pkg = caller;
    $CACHE{$path}{$pkg} ||= tmpl2code($tmpl);
    return ${ $CACHE{$path}{$pkg}->(%p) };
}

sub tmpl2code :Export {
    my ($tmpl) = @_;
    my $path = $tmpl =~ m{\A[.]?/}xms ? $tmpl : "$TMPL_DIR$tmpl";
    1 while $path =~ s{(\A|/) (?![.][.]?/) [^/]+/[.][.]/}{$1}xms; ## no critic(ProhibitPostfixControls)
    my $dir = $path;
    $dir =~ s{/[^/]*\z}{/}xms;
    my $line = 1;
    my $pkg = caller;
    if ($pkg eq __PACKAGE__) {
        $pkg = caller 1;
    }
    my $e
        = 'package '.$pkg.'; use warnings; use strict;'
        . 'sub {'
        . 'local $'.__PACKAGE__.'::__ = q{};'
        . 'local $'.__PACKAGE__."::TMPL_DIR = \"\Q$dir\E\";"
        . 'local %_ = @_;'
        . "\n#line $line \"$path\"\n"
        ;
    open my $fh, '<', $path or croak "open: $!";
    my $s = do { local $/ = undef; <$fh> };
    close $fh or croak "close: $!";
    while ( 1 ) {
        $e .=
            $s=~/\G/xmsgc
                ? "$1;"
          : $s=~/\G&~    ( (?>[^~]*) .*? ) ~&/xmsgc
                ? "$1;"
          : $s=~/\G@~    ( (?>[^~]*) .*? ) ~@/xmsgc
                ? $PRE."HTML::Entities::encode_entities(''.(do { $1; }), ".__PACKAGE__.'::UNSAFE_HTML);'.$POST
          : $s=~/\G\#~   ( (?>[^~]*) .*? ) ~\#/xmsgc
                ? $PRE."do { $1; };".$POST
          : $s=~/\G\^~   ( (?>[^~]*) .*? ) ~\^/xmsgc
                ? $PRE."URI::Escape::uri_escape_utf8(''.(do { $1; }));".$POST
          : $s=~/\G      ( (?>[^<&@\#^]*) .*? ) (?=