File Coverage

blib/lib/Text/Caml.pm

Criterion	Covered	Total	%
statement	194	203	95.5
branch	105	122	86.0
condition	18	24	75.0
subroutine	22	22	100.0
pod	5	5	100.0
total	344	376	91.4

package Text::Caml;

use strict;
use warnings;

require Carp;
require Scalar::Util;
use File::Spec ();

our $VERSION = '0.16';

our $LEADING_SPACE  = qr/(?:\n [ ]*)?/x;
our $TRAILING_SPACE = qr/(?:[ ]* \n)?/x;
our $START_TAG      = qr/\{\{/x;
our $END_TAG        = qr/\}\}/x;

our $START_OF_PARTIAL              = quotemeta '>';
our $START_OF_SECTION              = quotemeta '#';
our $START_OF_INVERTED_SECTION     = quotemeta '^';
our $END_OF_SECTION                = quotemeta '/';
our $START_OF_TEMPLATE_INHERITANCE = quotemeta '<';
our $END_OF_TEMPLATE_INHERITANCE   = quotemeta '/';
our $START_OF_BLOCK                = quotemeta '$';
our $END_OF_BLOCK                  = quotemeta '/';

sub new {
    my $class = shift;
    my (%params) = @_;

    my $self = {};
    bless $self, $class;

    $self->{templates_path}            = $params{templates_path};
    $self->{default_partial_extension} = $params{default_partial_extension};

    $self->set_templates_path('.')
      unless $self->templates_path;

    return $self;
}

sub templates_path { $_[0]->{templates_path} }
sub set_templates_path { $_[0]->{templates_path} = $_[1] }

sub render {
    my $self     = shift;
    my $template = shift;
    my $context  = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    $self->_parse($template, $context);
}

sub render_file {
    my $self     = shift;
    my $template = shift;
    my $context  = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    $template = $self->_slurp_template($template);
    return $self->_parse($template, $context);
}

sub _parse {
    my $self     = shift;
    my $template = shift;
    my $context  = shift;
    my $override = shift;

    my $output = '';

    pos $template = 0;
    while (pos $template < length $template) {
        if ($template =~ m/($LEADING_SPACE)?\G $START_TAG /gcxms) {
            my $chunk = '';

            my $leading_newline = !!$1;

            # Tripple
            if ($template =~ m/\G \{ (.*?) \} $END_TAG/gcxms) {
                $chunk .= $self->_parse_tag($1, $context);
            }

            # Replace
            elsif ($template =~ m/\G - (.*?) $END_TAG/gcxms) {
                $chunk .= '{{' . $1 . '}}';
            }

            # Comment
            elsif ($template =~ m/\G ! .*? $END_TAG/gcxms) {
            }

            # Section
            elsif ($template
                =~ m/\G $START_OF_SECTION \s* (.*?) \s* $END_TAG ($TRAILING_SPACE)?/gcxms
              )
            {
                my $name           = $1;
                my $end_of_section = $name;

                if ($template
                    =~ m/\G (.*?) ($LEADING_SPACE)? $START_TAG $END_OF_SECTION $end_of_section $END_TAG ($TRAILING_SPACE)?/gcxms
                  )
                {
                    $chunk .= $self->_parse_section($name, $1, $context);
                }
                else {
                    Carp::croak("Section's '$name' end not found");
                }
            }

            # Inverted section
            elsif ($template
                =~ m/\G $START_OF_INVERTED_SECTION (.*?) $END_TAG ($TRAILING_SPACE)?/gcxms
              )
            {
                my $name = $1;

                if ($template
                    =~ m/ \G (.*?) ($LEADING_SPACE)? $START_TAG $END_OF_SECTION $name $END_TAG ($TRAILING_SPACE)?/gcxms
                  )
                {
                    $chunk
                      .= $self->_parse_inverted_section($name, $1, $context);
                }
                else {
                    Carp::croak("Section's '$name' end not found");
                }
            }

            # End of section
            elsif ($template =~ m/\G $END_OF_SECTION (.*?) $END_TAG/gcxms) {
                Carp::croak("Unexpected end of section '$1'");
            }

            # Partial
            elsif ($template =~ m/\G $START_OF_PARTIAL \s* (.*?) \s* $END_TAG/gcxms) {
                $chunk .= $self->_parse_partial($1, $context);
            }

            # Inherited template
            elsif ($template =~ m/\G $START_OF_TEMPLATE_INHERITANCE \s* (.*?) \s* $END_TAG/gcxms)
            {
                my $name           = $1;
                my $end_of_inherited_template = $name;

                if ($template
                    =~ m/\G (.*?) ($LEADING_SPACE)? $START_TAG $END_OF_TEMPLATE_INHERITANCE $end_of_inherited_template $END_TAG ($TRAILING_SPACE)?/gcxms
                  )
                {
                    $chunk .= $self->_parse_inherited_template($name, $1, $context);
                }
                else {
                    Carp::croak("Nested template's '$name' end not found");
                }
            }

            # block
            elsif ($template =~ m/\G $START_OF_BLOCK \s* (.*?) \s* $END_TAG/gcxms) {
                my $name           = $1;
                my $end_of_block = $name;

                if ($template
                    =~ m/\G (.*?) ($LEADING_SPACE)? $START_TAG $END_OF_BLOCK $end_of_block $END_TAG/gcxms
                  )
                {
                    $chunk .= $self->_parse_block($name, $1, $context, $override);
                }
                else {
                    Carp::croak("Block's '$name' end not found");
                }
            }

            # Tag
            elsif ($template =~ m/\G (.*?) $END_TAG/gcxms) {
                $chunk .= $self->_parse_tag_escaped($1, $context);
            }
            else {
                Carp::croak("Can't find where tag is closed");
            }

            if ($chunk ne '') {
                $output .= $chunk;
            }
            elsif ($output eq '' || $leading_newline) {
                if ($template =~ m/\G $TRAILING_SPACE/gcxms) {
                    $output =~ s/[ ]*\z//xms;
                }
            }
        }

        # Text before tag
        elsif ($template =~ m/\G (.*?) (?=$START_TAG\{?)/gcxms) {
            $output .= $1;
        }

        # Other text
        else {
            $output .= substr($template, pos($template));
            last;
        }
    }

    return $output;
}

sub _parse_tag {
    my $self = shift;
    my ($name, $context) = @_;

    my $value;
    my %args;

    # Current element
    if ($name eq '.') {
        return '' if $self->_is_empty($context, $name);

        $value = $context->{$name};
    }

    else {
        $value = $self->_get_value($context, $name);
    }

    if (ref $value eq 'CODE') {
        my $content = $value->($self, '', $context);
        $content = '' unless defined $content;
        return $self->_parse($content, $context);
    }

    return $value;
}

sub _find_value {
    my $self = shift;
    my ($context, $name) = @_;

    my @parts = split /\./ => $name;

    my $value = $context;

    foreach my $part (@parts) {
        if ( ref $value eq "HASH"
            && exists $value->{'_with'}
            && Scalar::Util::blessed($value->{'_with'})
            && $value->{'_with'}->can($part))
        {
            $value = $value->{'_with'}->$part;
            next;
        }

	if( ref $value eq "ARRAY" ) {
		$value = $value->[$part];
		next;
	}

        if (   exists $value->{'.'}
            && Scalar::Util::blessed($value->{'.'})
            && $value->{'.'}->can($part))
        {
            $value = $value->{'.'}->$part;
            next;
        }

        return undef if $self->_is_empty($value, $part);
        $value =
          Scalar::Util::blessed($value) ? $value->$part : $value->{$part};
    }

    return \$value;
}

sub _get_value {
    my $self = shift;
    my ($context, $name) = @_;

    if ($name eq '.') {
        return '' if $self->_is_empty($context, $name);
        return $context->{$name};
    }

    my $value = $self->_find_value($context, $name);

    return $value ? $$value : '';
}

sub _parse_tag_escaped {
    my $self = shift;
    my ($tag, $context) = @_;

    my $do_not_escape;
    if ($tag =~ s/\A \&//xms) {
        $do_not_escape = 1;
    }

    my $output = $self->_parse_tag($tag, $context);

    $output = $self->_escape($output) unless $do_not_escape;

    return $output;
}

sub _parse_section {
    my $self = shift;
    my ($name, $template, $context) = @_;

    my $value = $self->_get_value($context, $name);

    my $output = '';

    if (ref $value eq 'HASH') {
        $output .= $self->_parse($template, {%$context, %$value});
    }
    elsif (ref $value eq 'ARRAY') {
        my $idx = 0;
        foreach my $el (@$value) {
            my %subcontext = ref $el eq 'HASH' ? %$el : ('.' => $el);
            $subcontext{'_idx'} = $idx;

            $subcontext{'_even'} = $idx % 2 == 0;
            $subcontext{'_odd'}  = $idx % 2 != 0;

            $subcontext{'_first'} = $idx == 0;
            $subcontext{'_last'}  = $idx == $#$value;

            $output .= $self->_parse($template, {%$context, %subcontext});

            $idx++;
        }
    }
    elsif (ref $value eq 'CODE') {
        $template = $self->_parse($template, $context);
        $output
          .= $self->_parse($value->($self, $template, $context), $context);
    }
    elsif (ref $value) {
        $output .= $self->_parse($template, {%$context, _with => $value});
    }
    elsif ($value) {
        $output .= $self->_parse($template, $context);
    }

    return $output;
}

sub _parse_inverted_section {
    my $self = shift;
    my ($name, $template, $context) = @_;

    my $value = $self->_find_value($context, $name);
    return $self->_parse($template, $context)
      unless defined $value;

    $value = $$value;
    my $output = '';

    if (ref $value eq 'HASH') {
    }
    elsif (ref $value eq 'ARRAY') {
        return '' if @$value;

        $output .= $self->_parse($template, $context);
    }
    elsif (!$value) {
        $output .= $self->_parse($template, $context);
    }

    return $output;
}

sub _parse_partial {
    my $self = shift;
    my ($template, $context) = @_;

    if (my $ext = $self->{default_partial_extension}) {
        $template = "$template.$ext";
    }

    my $parse = 1;
    if ($template =~ s{^\&}{}) {
        $parse = 0;
    }

    my $content = $self->_slurp_template($template);

    return $parse ? $self->_parse($content, $context) : $content;
}

sub _parse_inherited_template {
    my $self = shift;
    my ($name, $override, $context) = @_;

    if (my $ext = $self->{default_partial_extension}) {
        $name = "$name.$ext";
    }

    my $content = $self->_slurp_template($name);

    return $self->_parse($content, $context, $override);
}

sub _parse_block {
    my $self = shift;
    my ($name, $template, $context, $override) = @_;

    # get block content from override
    my $content;

    # first, see if we can find any starting block with this name in the override
    if ($override =~ m/ $START_OF_BLOCK \s* $name \s* $END_TAG/gcxms) {
        # get the content of the override block and make sure there's a corresponding end-block tag for it!
        if ($override =~ m/ (.*) $START_TAG $END_OF_BLOCK \s* $name \s* $END_TAG/gcxms){
            my $content = $1;
            return $self->_parse($content, $context);
        } else {
            Carp::croak("Block's '$name' end not found");
        }
    }

    return $self->_parse($template, $context);
}

sub _slurp_template {
    my $self = shift;
    my ($template) = @_;

    my $path =
      defined $self->templates_path
      && !(File::Spec->file_name_is_absolute($template))
      ? File::Spec->catfile($self->templates_path, $template)
      : $template;

    Carp::croak("Can't find '$path'") unless defined $path && -f $path;

    my $content = do {
        local $/;
        open my $file, '<:encoding(UTF-8)', $path or return;
        <$file>;
    };

    Carp::croak("Can't open '$template'") unless defined $content;

    chomp $content;

    return $content;
}

sub _is_empty {
    my $self = shift;
    my ($vars, $name) = @_;

    my $var;

    if (Scalar::Util::blessed($vars)) {
        $var = $vars->$name;
    }
    else {
        return 1 unless exists $vars->{$name};
        $var = $vars->{$name};
    }

    return 1 unless defined $var;
    return 1 if $var eq '';

    return 0;
}

sub _escape {
    my $self  = shift;
    my $value = shift;

    $value =~ s/&/&/g;
    $value =~ s/
    $value =~ s/>/>/g;
    $value =~ s/"/"/g;

    return $value;
}

1;
__END__