File Coverage

blib/lib/Text/Haml.pm

Criterion	Covered	Total	%
statement	750	772	97.1
branch	305	360	84.7
condition	98	124	79.0
subroutine	98	98	100.0
pod	27	29	93.1
total	1278	1383	92.4

package Text::Haml;

use strict;
use warnings;

use IO::File;
use Scalar::Util qw/weaken/;
use Encode qw/decode/;
use Carp ();
use File::Spec;
use File::Basename ();
use URI::Escape ();
use Digest::MD5;

our $VERSION = '0.990116';

use constant CHUNK_SIZE => 4096;

BEGIN {
    my $cache_dir = '.text_haml_cache';
    for my $dir ($ENV{HOME}, File::Spec->tmpdir) {
        if (defined($dir) && -d $dir && -w _) {
            $cache_dir = File::Spec->catdir($dir, '.text_haml_cache');
            last;
        }
    }
    *_DEFAULT_CACHE_DIR = sub () { $cache_dir };
}

my $ESCAPE = {
    '\"'   => "\x22",
    "\'"   => "\x27",
    '\\'   => "\x5c",
    '\/'   => "\x2f",
    '\b'   => "\x8",
    '\f'   => "\xC",
    '\n'   => "\xA",
    '\r'   => "\xD",
    '\t'   => "\x9",
    '\\\\' => "\x5c\x5c"
};

my $UNESCAPE_RE = qr/
    \\[\"\'\/\\bfnrt]
/x;

my $STRING_DOUBLE_QUOTES_RE = qr/
    \"
    (?:
    $UNESCAPE_RE
    |
    [\x20-\x21\x23-\x5b\x5b-\x{10ffff}]
    )*
    \"
/x;

my $STRING_SINGLE_QUOTES_RE = qr/
    \'
    (?:
    $UNESCAPE_RE
    |
    [\x20-\x26\x28-\x5b\x5b-\x{10ffff}]
    )*
    \'
/x;

my $STRING_RE = qr/
    $STRING_SINGLE_QUOTES_RE
    |
    $STRING_DOUBLE_QUOTES_RE
/x;

sub new {
    my $class = shift;

    # Default attributes
    my $attrs = {};
    $attrs->{vars_as_subs} = 0;
    $attrs->{tape}         = [];
    $attrs->{encoding}     = 'utf-8';
    $attrs->{escape_html}  = 1;
    $attrs->{helpers}      = {};
    $attrs->{format}       = 'xhtml';
    $attrs->{prepend}      = '';
    $attrs->{append}       = '';
    $attrs->{namespace}    = '';
    $attrs->{path}         = ['.'];
    $attrs->{cache}        = 1; # 0: not cached, 1: checks mtime, 2: always cached
    $attrs->{cache_dir}    = _DEFAULT_CACHE_DIR;

    $attrs->{escape}       = <<'EOF';
    my $s = shift;
    return unless defined $s;
    $s =~ s/&/&/g;
    $s =~ s/
    $s =~ s/>/>/g;
    $s =~ s/"/"/g;
    $s =~ s/'/'/g;
    return $s;
EOF

    $attrs->{filters} = {
        plain => sub { $_[0] =~ s/\n*$//; $_[0] },
        escaped  => sub { $_[0] },
        preserve => sub { $_[0] =~ s/\n/
/g; $_[0] },
        javascript => sub {
            "\n" </td>
</tr>

<tr>
<td  class="h" >
<a name="108">108</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               . "  //<![CDATA[\n" </td>
</tr>

<tr>
<td  class="h" >
<a name="109">109</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               . "    $_[0]\n" </td>
</tr>

<tr>
<td  class="h" >
<a name="110">110</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               . "  //]]>\n" </td>
</tr>

<tr>
<td  class="h" >
<a name="111">111</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               . "";
        },
        css => sub {
            "\n" </td>
</tr>

<tr>
<td  class="h" >
<a name="115">115</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               . "  /*<![CDATA[*/\n" </td>
</tr>

<tr>
<td  class="h" >
<a name="116">116</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               . "    $_[0]\n" </td>
</tr>

<tr>
<td  class="h" >
<a name="117">117</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               . "  /*]]>*/\n" </td>
</tr>

<tr>
<td  class="h" >
<a name="118">118</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">               . "";
        },
    };

    my $self = {%$attrs, @_};
    bless $self, $class;

    # Convert to template fullpath
    $self->path([
        map { ref($_) ? $_ : File::Spec->rel2abs($_) }
            ref($self->path) eq 'ARRAY' ? @{$self->path} : $self->path
    ]);

    $self->{helpers_arg} ||= $self;
    weaken $self->{helpers_arg};

    return $self;
}

# Yes, i know!
sub vars_as_subs  { @_ > 1 ? $_[0]->{vars_as_subs}  = $_[1] : $_[0]->{vars_as_subs}; }
sub format        { @_ > 1 ? $_[0]->{format}        = $_[1] : $_[0]->{format} }
sub encoding      { @_ > 1 ? $_[0]->{encoding}      = $_[1] : $_[0]->{encoding} }
sub escape_html   { @_ > 1 ? $_[0]->{escape_html}   = $_[1] : $_[0]->{escape_html}; }
sub code          { @_ > 1 ? $_[0]->{code}          = $_[1] : $_[0]->{code} }
sub compiled      { @_ > 1 ? $_[0]->{compiled}      = $_[1] : $_[0]->{compiled} }
sub helpers       { @_ > 1 ? $_[0]->{helpers}       = $_[1] : $_[0]->{helpers} }
sub filters       { @_ > 1 ? $_[0]->{filters}       = $_[1] : $_[0]->{filters} }
sub prepend       { @_ > 1 ? $_[0]->{prepend}       = $_[1] : $_[0]->{prepend} }
sub append        { @_ > 1 ? $_[0]->{append}        = $_[1] : $_[0]->{append} }
sub escape        { @_ > 1 ? $_[0]->{escape}        = $_[1] : $_[0]->{escape} }
sub tape          { @_ > 1 ? $_[0]->{tape}          = $_[1] : $_[0]->{tape} }
sub path          { @_ > 1 ? $_[0]->{path}          = $_[1] : $_[0]->{path} }
sub cache         { @_ > 1 ? $_[0]->{cache}         = $_[1] : $_[0]->{cache} }
sub fullpath      { @_ > 1 ? $_[0]->{fullpath}      = $_[1] : $_[0]->{fullpath}; }
sub cache_dir     { @_ > 1 ? $_[0]->{cache_dir}     = $_[1] : $_[0]->{cache_dir}; }
sub cache_path    { @_ > 1 ? $_[0]->{cache_path}    = $_[1] : $_[0]->{cache_path}; }
sub namespace     { @_ > 1 ? $_[0]->{namespace}     = $_[1] : $_[0]->{namespace}; }
sub error         { @_ > 1 ? $_[0]->{error}         = $_[1] : $_[0]->{error} }

sub helpers_arg {
    if (@_ > 1) {
        $_[0]->{helpers_arg} = $_[1];
        weaken $_[0]->{helpers_arg};
    }
    else {
        return $_[0]->{helpers_arg};
    }
}


our @AUTOCLOSE = (qw/meta img link br hr input area param col base/);

sub add_helper {
    my $self = shift;
    my ($name, $code) = @_;

    $self->helpers->{$name} = $code;
}

sub add_filter {
    my $self = shift;
    my ($name, $code) = @_;

    $self->filters->{$name} = $code;
}

sub parse {
    my $self = shift;
    my $tmpl = shift;

    $tmpl = '' unless defined $tmpl;

    $self->tape([]);

    my $level_token    = quotemeta ' ';
    my $escape_token   = quotemeta '&';
    my $unescape_token = quotemeta '!';
    my $expr_token     = quotemeta '=';
    my $tag_start      = quotemeta '%';
    my $class_start    = quotemeta '.';
    my $id_start       = quotemeta '#';

    my $attributes_start = quotemeta '{';
    my $attributes_end   = quotemeta '}';
    my $attribute_arrow  = quotemeta '=>';
    my $attributes_sep   = quotemeta ',';
    my $attribute_prefix = quotemeta ':';
    my $attribute_name   = qr/(?:$STRING_RE|.*?(?= |$attribute_arrow))/;
    my $attribute_value =
      qr/(?:$STRING_RE|[^ $attributes_sep$attributes_end]+)/x;

    my $attributes_start2 = quotemeta '(';
    my $attributes_end2   = quotemeta ')';
    my $attribute_arrow2  = quotemeta '=';
    my $attributes_sep2   = ' ';
    my $attribute_name2   = qr/(?:$STRING_RE|.*?(?= |$attribute_arrow2))/;
    my $attribute_value2 =
      qr/(?:$STRING_RE|[^ $attributes_sep2$attributes_end2]+)/;

    my $filter_token    = quotemeta ':';
    my $quote           = "'";
    my $comment_token   = quotemeta '-#';
    my $trim_in         = quotemeta '<';
    my $trim_out        = quotemeta '>';
    my $autoclose_token = quotemeta '/';
    my $multiline_token = quotemeta '|';

    my $tag_name = qr/([^
        $level_token
        $attributes_start
        $attributes_start2
        $class_start
        $id_start
        $trim_in
        $trim_out
        $unescape_token
        $escape_token
        $expr_token
        $autoclose_token]+)/;

    my $tape = $self->tape;

    my $level;
    my @multiline_el_queue;
    my @lines = split /\n/, $tmpl;
    push @lines, '' if $tmpl =~ m/\n$/;
    @lines = ('') if $tmpl eq "\n";
    for (my $i = 0; $i < @lines; $i++) {
        my $line = $lines[$i];

        if ($line =~ s/^($level_token+)//) {
            $level = length $1;
        }
        else {
            $level = 0;
        }

        my $el = {level => $level, type => 'text', line => $line, lineno => $i+1};

        # Haml comment
        if ($line =~ m/^$comment_token(?: (.*))?/) {
            $el->{type} = 'comment';
            $el->{text} = $1 if $1;
            push @$tape, $el;
            next;
        }

        # Inside a filter
        my $prev = $tape->[-1];
        if ($prev && $prev->{type} eq 'filter') {
            if ($prev->{level} < $el->{level}
                || ($i + 1 < @lines && $line eq ''))
            {
                $prev->{text} .= "\n" if $prev->{text};
                $prev->{text} .= $line;
                $prev->{line} .= "\n" . (' ' x $el->{level}) . $el->{line};
                _update_lineno($prev, $i);
                next;
            }
        }

        # Filter
        if ($line =~ m/^:(\w+)/) {
            $el->{type} = 'filter';
            $el->{name} = $1;
            $el->{text} = '';
            push @$tape, $el;
            next;
        }

        # Doctype
        if ($line =~ m/^!!!(?: ([^ ]+)(?: (.*))?)?$/) {
            $el->{type}   = 'text';
            $el->{escape} = 0;
            $el->{text}   = $self->_doctype($1, $2);
            push @$tape, $el;
            next;
        }

        # HTML comment
        if ($line =~ m/^\/(?:\[if (.*)?\])?(?: *(.*))?/) {
            $el->{type} = 'html_comment';
            $el->{if}   = $1 if $1;
            $el->{text} = $2 if $2;
            push @$tape, $el;
            next;
        }

        # Escaping, everything after is a text
        if ($line =~ s/^\\//) {
            $el->{type} = 'text', $el->{text} = $line;
            push @$tape, $el;
            next;
        }

        # Block
        if ($line =~ s/^- \s*(.*)//) {
            $el->{type} = 'block';
            $el->{text} = $1;
            push @$tape, $el;
            next;
        }

        # Preserve whitespace
        if ($line =~ s/^~ \s*(.*)//) {
            $el->{type}                = 'text';
            $el->{text}                = $1;
            $el->{expr}                = 1;
            $el->{preserve_whitespace} = 1;
            push @$tape, $el;
            next;
        }

        # Tag
        if ($line =~ m/^(?:$tag_start
            |$class_start
            |$id_start
            |$attributes_start[^$attributes_start]
            |$attributes_start2
            )/x
          )
        {
            $el->{type} = 'tag';
            $el->{name} = '';

            if ($line =~ s/^$tag_start$tag_name//) {
                $el->{name} = $1;
            }

            while (1) {
                if ($line =~ s/^$class_start$tag_name//) {
                    my $class = join(' ', split(/\./, $1));

                    $el->{name}  ||= 'div';
                    $el->{class} ||= [];
                    push @{$el->{class}}, $class;
                }
                elsif ($line =~ s/^$id_start$tag_name//) {
                    my $id = $1;

                    $el->{name} ||= 'div';
                    $el->{id} = $id;
                }
                else {
                    last;
                }
            }

            if ($line =~ m/^
                (?:
                    $attributes_start\s*
                    $attribute_prefix?
                    $attribute_name\s*
                    $attribute_arrow\s*
                    $attribute_value
                    |
                    $attributes_start2\s*
                    $attribute_name2\s*
                    $attribute_arrow2\s*
                    $attribute_value2
                )
                /x
              )
            {
                my $attrs = [];

                my $type = 'html';
                if ($line =~ s/^$attributes_start//) {
                    $type = 'perl';
                }
                else {
                    $line =~ s/^$attributes_start2//;
                }

                while (1) {
                    if (!$line) {
                        $line = $lines[++$i] || last;
                        $el->{line} .= "\n$line";
                        _update_lineno($el, $i);
                    }
                    elsif ($type eq 'perl' && $line =~ s/^$attributes_end//) {
                        last;
                    }
                    elsif ($type eq 'html' && $line =~ s/^$attributes_end2//)
                    {
                        last;
                    }
                    else {
                        my ($name, $value);

                        if ($line =~ s/^\s*$attribute_prefix?
                                    ($attribute_name)\s*
                                    $attribute_arrow\s*
                                    ($attribute_value)\s*
                                    (?:$attributes_sep\s*)?//x
                          )
                        {
                            $name  = $1;
                            $value = $2;
                        }
                        elsif (
                            $line =~ s/^\s*
                                    ($attribute_name2)\s*
                                    $attribute_arrow2\s*
                                    ($attribute_value2)\s*
                                    (?:$attributes_sep2\s*)?//x
                          )
                        {
                            $name  = $1;
                            $value = $2;
                        }
                        else {
                            $self->error('Tag attributes parsing error');
                            return;
                        }

                        if ($name =~ s/^(?:'|")//) {
                            $name =~ s/(?:'|")$//;
                            $name =~ s/($UNESCAPE_RE)/$ESCAPE->{$1}/g;
                        }

                        if ($value =~ s/^(?:'|")//) {
                            $value =~ s/(?:'|")$//;
                            $value =~ s/($UNESCAPE_RE)/$ESCAPE->{$1}/g;
                            push @$attrs,
                              $name => {type => 'text', text => $value};
                        }
                        elsif ($value eq 'true' || $value eq 'false') {
                            push @$attrs, $name => {
                                type => 'boolean',
                                text => $value eq 'true' ? 1 : 0
                            };
                        }
                        else {
                            push @$attrs,
                              $name => {type => 'expr', text => $value};
                        }
                    }
                }

                $el->{type} = 'tag';
                $el->{attrs} = $attrs if @$attrs;
            }

            if ($line =~ s/^$trim_out ?//) {
                $el->{trim_out} = 1;
            }

            if ($line =~ s/^$trim_in ?//) {
                $el->{trim_in} = 1;
            }
        }

        if ($line =~ s/^($escape_token|$unescape_token)?$expr_token //) {
            $el->{expr} = 1;
            if ($1) {
                $el->{escape} = quotemeta($1) eq $escape_token ? 1 : 0;
            }
        }

        if ($el->{type} eq 'tag'
            && ($line =~ s/$autoclose_token$//
                || grep { $el->{name} eq $_ } @AUTOCLOSE)
          )
        {
            $el->{autoclose} = 1;
        }

        $line =~ s/^ // if $line;

        # Multiline
        if ($line && $line =~ s/(\s*)$multiline_token$//) {

            # For the first time
            if (!$tape->[-1] || ref $tape->[-1]->{text} ne 'ARRAY') {
                $el->{text} = [$line];
                $el->{line} ||= $line . "$1|"; # XXX: is this really necessary?

                push @$tape, $el;
                push @multiline_el_queue, $el;
            }

            # Continue concatenation
            else {
                my $prev_stack_el = $tape->[-1];
                push @{$prev_stack_el->{text}}, $line;
                $prev_stack_el->{line} .= "\n" . $line . "$1|";
                _update_lineno($prev_stack_el, $i);
            }
        }

        # Normal text
        else {
            $el->{text} = $line if $line;

            push @$tape, $el;
        }
    }

    # Finalize multilines
    for my $el (@multiline_el_queue) {
        $el->{text} = join(" ", @{$el->{text}});
    }
}

# Updates lineno entry on the tape element
# for itens spanning more than one line
sub _update_lineno {
    my ($el, $lineno) = @_;
    $lineno++;    # report line numbers starting at 1 instead of 0
    $el->{lineno} =~ s/^(\d+)(?:-\d+)?/$1-$lineno/;
    return;
}

sub build {
    my $self = shift;
    my %vars = @_;

    my $code;

    my $ESCAPE = $self->escape;
    $ESCAPE = <<"EOF";
no strict 'refs'; no warnings 'redefine';
sub escape;
*escape = sub {
    $ESCAPE
};
use strict; use warnings;
EOF

    $ESCAPE =~ s/\n//g;

    my $namespace = $self->namespace || ref($self) . '::template';
    $code .= qq/package $namespace;/;

    $code .= qq/sub { my \$_H = ''; $ESCAPE;/;

    $code .= qq/my \$self = shift;/;

    $code .= qq/my \%____vars = \@_;/;

    $code .= qq/no strict 'refs'; no warnings 'redefine';/;

    # Install helpers
    for my $name (sort keys %{$self->helpers}) {
        next unless $name =~ m/^\w+$/;

        $code .= "sub $name;";
        $code .= " *$name = sub { \$self";
        $code .= "->helpers->{'$name'}->(\$self->helpers_arg, \@_) };";
    }

    # Install variables
    foreach my $var (sort keys %vars) {
        next unless $var =~ m/^\w+$/;
        if ($self->vars_as_subs) {
            next if $self->helpers->{$var};
            $code
                .= qq/sub $var() : lvalue; *$var = sub () : lvalue {\$____vars{'$var'}};/;
        }
        else {
            $code .= qq/my \$$var = \$____vars{'$var'};/;
        }
    }

    $code .= qq/use strict; use warnings;/;

    $code .= $self->prepend;

    my $stack = [];

    my $output = '';
    my @lines;
    my $count    = 0;
    my $in_block = 0;
  ELEM:
    for my $el (@{$self->tape}) {
        my $level = $el->{level};
        $level -= 2 * $in_block if $in_block;

        my $offset = '';
        $offset .= ' ' x $level;

        my $escape = '';
        if (   (!exists $el->{escape} && $self->escape_html)
            || (exists $el->{escape} && $el->{escape} == 1))
        {
            $escape = 'escape';
        }

        my $prev_el = $self->tape->[$count - 1];
        my $next_el = $self->tape->[$count + 1];

        my $prev_stack_el = $stack->[-1];

        if ($prev_stack_el && $prev_stack_el->{type} eq 'comment') {
            if (   $el->{line}
                && $prev_stack_el->{level} >= $el->{level})
            {
                pop @$stack;
                undef $prev_stack_el;
            }
            else {
                next ELEM;
            }
        }

        if (   $el->{line}
            && $prev_stack_el
            && $prev_stack_el->{level} >= $el->{level})
        {
          STACKEDBLK:
            while (my $poped = pop @$stack) {
                my $level = $poped->{level};
                $level -= 2 * $in_block if $in_block;
                my $poped_offset = ' ' x $level;

                my $ending = '';
                if ($poped->{type} eq 'tag') {
                    $ending .= "{name}>";
                }
                elsif ($poped->{type} eq 'html_comment') {
                    $ending .= "{if};
                    $ending .= "-->";
                }

                if ($poped->{type} ne 'block') {
                    push @lines, qq|\$_H .= "$poped_offset$ending\n";|;
                }

                last STACKEDBLK if $poped->{level} == $el->{level};
            }
        }


      SWITCH: {

            if ($el->{type} eq 'tag') {
                my $ending =
                  $el->{autoclose} && $self->format eq 'xhtml' ? ' /' : '';

                my $attrs = '';
                if ($el->{attrs}) {
                  ATTR:
                    for (my $i = 0; $i < @{$el->{attrs}}; $i += 2) {
                        my $name  = $el->{attrs}->[$i];
                        my $value = $el->{attrs}->[$i + 1];
                        my $text  = $value->{text};

                        if ($name eq 'class') {
                            $el->{class} ||= [];
                            if ($value->{type} eq 'text') {
                                push @{$el->{class}}, $self->_parse_text($text);
                            }
                            else {
                                push @{$el->{class}}, qq/" . $text . "/;
                            }
                            next ATTR;
                        }
                        elsif ($name eq 'id') {
                            $el->{id} ||= '';
                            $el->{id} = $el->{id} . '_' if $el->{id};
                            $el->{id} .= $self->_parse_text($value->{text});
                            next ATTR;
                        }

                        if (   $value->{type} eq 'text'
                            || $value->{type} eq 'expr')
                        {
                            $attrs .= ' ';
                            $attrs .= $name;
                            $attrs .= '=';

                            if ($value->{type} eq 'text') {
                                $attrs
                                  .= "'" . $self->_parse_text($text) . "'";
                            }
                            else {
                                $attrs .= qq/'" . $text . "'/;
                            }
                        }
                        elsif ($value->{type} eq 'boolean' && $value->{text})
                        {
                            $attrs .= ' ';
                            $attrs .= $name;
                            if ($self->format eq 'xhtml') {
                                $attrs .= '=';
                                $attrs .= qq/'$name'/;
                            }
                        }
                    }    #end:for ATTR
                }

                my $tail = '';
                if ($el->{class}) {
                    $tail .= qq/ class='"./;
                    $tail .= qq/join(' ', sort(/;
                    $tail .= join(',', map {"\"$_\""} @{$el->{class}});
                    $tail .= qq/))/;
                    $tail .= qq/."'/;
                }

                if ($el->{id}) {
                    $tail .= qq/ id='$el->{id}'/;
                }

                $output .= qq|"$offset<$el->{name}$tail$attrs$ending>"|;

                if ($el->{text} && $el->{expr}) {
                  if ($escape eq 'escape') {
                    $output .= '. ( do { my $ret = ' .  qq/ $escape( do { $el->{text} } )/ . '; defined($ret) ? $ret : "" } )';
                    $output .= qq| . "{name}>"|;
                  } else {
                    $output .= '. ( do {' . $el->{text} . '} || "")';
                    $output .= qq| . "{name}>"|;
                  }
                }
                elsif ($el->{text}) {
                    $output .= qq/. $escape(/ . '"'
                      . $self->_parse_text($el->{text}) . '");';
                    $output .= qq|\$_H .= "{name}>"|
                      unless $el->{autoclose};
                }
                elsif (
                    !$next_el
                    || (   $next_el
                        && $next_el->{level} <= $el->{level})
                  )
                {
                    $output .= qq|. "{name}>"| unless $el->{autoclose};
                }
                elsif (!$el->{autoclose}) {
                    push @$stack, $el;
                }

                $output .= qq|. "\n"|;
                $output .= qq|;|;
                last SWITCH;
            }

            if ($el->{line} && $el->{type} eq 'text') {
                $output = qq/"$offset"/;

                $el->{text} = '' unless defined $el->{text};

                if ($el->{expr}) {
                    $output .= '. ( do { my $ret = ' .  qq/ $escape( do { $el->{text} } )/ . '; defined($ret) ? $ret : "" } )';
                    $output .= qq/;\$_H .= "\n"/;
                }
                elsif ($el->{text}) {
                    $output
                      .= '.'
                      . qq/$escape / . '"'
                      . $self->_parse_text($el->{text}) . '"';
                    $output .= qq/. "\n"/;
                }

                $output .= qq/;/;
                last SWITCH;
            }

            if ($el->{type} eq 'block') {
                push @lines,  $el->{text};
                push @$stack, $el;

                if ($prev_el && $prev_el->{level} > $el->{level}) {
                    $in_block--;
                }

                if ($next_el && $next_el->{level} > $el->{level}) {
                    $in_block++;
                }
                last SWITCH;
            }

            if ($el->{type} eq 'html_comment') {
                $output = qq/"$offset"/;

                $output .= qq/ . "\n"/;
                }
                else {
                    $output .= qq/. "\n"/;
                    push @$stack, $el;
                }

                $output .= qq/;/;
                last SWITCH;
            }

            if ($el->{type} eq 'comment') {
                push @$stack, $el;
                last SWITCH;
            }

            if ($el->{type} eq 'filter') {
                my $filter = $self->filters->{$el->{name}};
                die "unknown filter: $el->{name}" unless $filter;

                if ($el->{name} eq 'escaped') {
                    $output =
                        qq/escape "/
                      . $self->_parse_text($el->{text})
                      . qq/\n";/;
                }
                else {
                    $el->{text} = $filter->($el->{text});

                    my $text = $self->_parse_text($el->{text});
                    $text =~ s/\\\n/\\n/g;
                    $output = qq/"/ . $text . qq/\n";/;
                }
                last SWITCH;
            }

            unless ($el->{text}) {
                last SWITCH;
            }

            die "unknown type=" . $el->{type};

        }    #end:SWITCH
    }    #end:ELEM
    continue {
        push @lines, '$_H .= ' . $output if $output;
        $output = '';
        $count++;
    }    #ELEM

    my $last_empty_line = 0;
    $last_empty_line = 1
      if $self->tape->[-1] && $self->tape->[-1]->{line} eq '';

    # Close remaining content blocks, last-seen first
    foreach my $el (reverse @$stack) {
        my $offset = ' ' x $el->{level};
        my $ending = '';
        if ($el->{type} eq 'tag') {
            $ending = "{name}>";
        }
        elsif ($el->{type} eq 'html_comment') {
            $ending .= '{if};
            $ending .= "-->";
        }

        push @lines, qq|\$_H .= "$offset$ending\n";| if $ending;
    }

    if ($lines[-1]) {
        $lines[-1] =~ s/\n";$/";/ unless $last_empty_line;
    }

    $code .= join("\n", @lines);

    $code .= $self->append;

    $code .= q/return $_H; };/;

    $self->code($code);

    return $self;
}

sub _parse_text {
    my $self = shift;
    my $text = shift;

    my $expr = 0;
    if ($text =~ m/^\"/ && $text =~ m/\"$/) {
        $text =~ s/^"//;
        $text =~ s/"$//;
        $expr = 1;
    }

    $text =~ s/($UNESCAPE_RE)/$ESCAPE->{$1}/g;

    my $output = '';
    while (1) {
        my $t;
        my $escape = 0;
        my $found  = 0;
        my $variable;

        our $curly_brace_n;
        $curly_brace_n = qr/ (?> [^{}]+ | \{ (??{ $curly_brace_n }) \} )* /x;

        if ($text =~ s/^(.*?)?(?
            $found    = 1;
            $t        = $1;
            $variable = $2;
        }
        elsif ($text =~ s/^(.*?)?\\\\(\#\{$curly_brace_n\})//xms) {
            $found    = 1;
            $t        = $1;
            $variable = $2;
            $escape   = 1;
        }

        if ($t) {
            $t =~ s/\\\#/\#/g;
            $output .= $expr ? $t : quotemeta($t);
        }

        if ($found) {
            $variable =~ s/\#\{(.*)\}/$1/;

            my $prefix = $escape ? quotemeta("\\") : '';
            $output .= qq/$prefix".do { $variable }."/;
        }
        else {
            $text = $self->_parse_interpolation($text);
            $output .= $text;
            last;
        }
    }

    return $expr ? qq/$output/ : $output;
}

sub _parse_interpolation {
    my $self = shift;
    my ($text) = @_;

    my @parts;

    my $start_tag = qr{(?
    my $end_tag   = qr{\}};

    pos $text = 0;
    while (pos $text < length $text) {
        if ($text =~ m/\G $start_tag (.*?) $end_tag/xgcms) {
            push @parts, 'do {' . $1 . '}';
        }
        elsif ($text =~ m/\G (.*?) (?=$start_tag)/xgcms) {
            push @parts, 'qq{' . quotemeta($1) . '}';
        }
        else {
            my $leftover = substr($text, pos($text));
            push @parts, 'qq{' . quotemeta($leftover) . '}';
            last;
        }
    }

    return '' unless @parts;

    return '" . ' . join('.', map {s/\\\\#\\{/#\\{/; $_} @parts) . '."';
}

sub compile {
    my $self = shift;

    my $code = $self->code;
    return unless $code;

    my $compiled = eval $code;

    if ($@) {
        $self->error($@);
        return undef;
    }

    $self->compiled($compiled);

    return $self;
}

sub interpret {
    my $self = shift;

    my $compiled = $self->compiled;

    my $output = eval { $compiled->($self, @_) };

    if ($@) {
        $self->error($@);
        return undef;
    }

    return $output;
}

sub render {
    my $self = shift;
    my $tmpl = shift;

    # Parse
    $self->parse($tmpl);

    # Build
    return unless defined $self->build(@_);

    # Compile
    $self->compile || return undef;

    # Interpret
    return $self->interpret(@_);
}

# For templates in __DATA__ section
sub _eq_checksum {
  my $self = shift;

  # Exit if not virtual path
  return 0 unless ref $self->fullpath eq 'SCALAR';

  return 1 if $self->cache == 2;
  return 0 if $self->cache == 0;

  my $fullpath = $self->fullpath;
  $fullpath = $$fullpath;

  my $file = IO::File->new;
  $file->open($self->cache_path, 'r') or return;
  $file->sysread(my $cache_md5_checksum, 33); # 33 = # + hashsum
  $file->close;

  my $orig_md5_checksum = '#'.$self->_digest($fullpath);

  return $cache_md5_checksum eq $orig_md5_checksum;
}

sub _digest {
    my ($self, $content) = @_;

    my $md5 = Digest::MD5->new();
    $content = decode($self->encoding, $content) if $self->encoding;
    $md5->add($content);
    return $md5->hexdigest();
}

sub render_file {
    my $self = shift;
    my $path = shift;

    # Set file fullpath
    $self->_fullpath($path);

    if ($self->cache >= 1) {
        # Make cache directory
        my $cache_dir = $self->_cache_dir;
        # Set cache path
        $self->_cache_path($path, $cache_dir);

        # Exists same cache file?
        if (-e $self->cache_path && ($self->_eq_mtime || $self->_eq_checksum)) {
          return $self->_interpret_cached(@_);
        }
    }

    my $content = '';
    my $file = IO::File->new;
    if (ref $self->fullpath eq 'SCALAR') { # virtual path
      $content = $self->fullpath;
      $content = $$content;
    } else {
      # Open file
      $file->open($self->fullpath, 'r') or die "Can't open template '$path': $!";

      # Slurp file
      while ($file->sysread(my $buffer, CHUNK_SIZE, 0)) {
          $content .= $buffer;
      }
      $file->close;
    }

    $content =~ s/\r//g;

    # Encoding
    $content = decode($self->encoding, $content) if $self->encoding;

    # Render
    my $output;
    if ($output = $self->render($content, @_)) {
        if ($self->cache >= 1) {
            # Create cache
            if ($file->open($self->cache_path, 'w')) {
                binmode $file, ':utf8';

                if (ref $self->fullpath eq 'SCALAR') {
                  my $md5_checksum = $self->_digest($content);
                  print $file '#'.$md5_checksum."\n".$self->code; # Write with file checksum (virtual path)
                } else {
                  my $mtime = (stat($self->fullpath))[9];
                  print $file '#'.$mtime."\n".$self->code; # Write with file mtime
                }

                $file->close;
            }
        }
    }

    return $output;
}

sub _fullpath {
    my $self = shift;
    my $path = shift;

    if (File::Spec->file_name_is_absolute($path) and -r $path) {
        $self->fullpath($path);
        return;
    }

    for my $p (@{$self->path}) {
      if (ref $p eq 'HASH') { # virtual path
        if (defined(my $content = $p->{$path})) {
          $self->fullpath(\$content);
          return;
        }
      } else {
        my $fullpath = File::Spec->catfile($p, $path);
        if (-r $fullpath) { # is readable ?
          $self->fullpath($fullpath);
          return;
        }
      }
    }

    Carp::croak("Can't find template '$path'");
}

sub _cache_dir {
    my $self = shift;

    my $cache_prefix = (ref $self->fullpath eq 'SCALAR')
      ? 'HASH'
      : URI::Escape::uri_escape(
          File::Basename::dirname($self->fullpath)
        );

    my $cache_dir = File::Spec->catdir(
        $self->cache_dir,
        $cache_prefix,
    );

    if (not -e $cache_dir) {
        require File::Path;
        eval { File::Path::mkpath($cache_dir) };
        Carp::carp("Can't mkpath '$cache_dir': $@") if $@;
    }

    return $cache_dir;
}

sub _cache_path {
    my $self = shift;
    my $path = shift;
    my $cache_dir = shift;

    $self->cache_path(File::Spec->catfile(
        $cache_dir,
        File::Basename::basename($path).'.pl',
    ));
}

sub _eq_mtime {
    my $self = shift;

    # Exit if virtual path
    return 0 if ref $self->fullpath eq 'SCALAR';

    return 1 if $self->cache == 2;
    return 0 if $self->cache == 0;

    my $file = IO::File->new;
    $file->open($self->cache_path, 'r') or return;
    $file->sysread(my $cache_mtime, length('#xxxxxxxxxx'));
    $file->close;
    my $orig_mtime = '#'.(stat($self->fullpath))[9];

    return $cache_mtime eq $orig_mtime;
}

sub _interpret_cached {
    my $self = shift;

    my $compiled = do $self->cache_path;
    $self->compiled($compiled);
    return $self->interpret(@_);
}

sub _doctype {
    my $self = shift;
    my ($type, $encoding) = @_;

    $type     ||= '';
    $encoding ||= 'utf-8';

    $type = lc $type;

    if ($type eq 'xml') {
        return '' if $self->format eq 'html5';
        return '' if $self->format eq 'html4';

        return qq||;
    }

    if ($self->format eq 'xhtml') {
        if ($type eq 'strict') {
            return
              q||;
        }
        elsif ($type eq 'frameset') {
            return
              q||;
        }
        elsif ($type eq '5') {
            return '';
        }
        elsif ($type eq '1.1') {
            return
              q||;
        }
        elsif ($type eq 'basic') {
            return
              q||;
        }
        elsif ($type eq 'mobile') {
            return
              q||;
        }
        else {
            return
              q||;
        }
    }
    elsif ($self->format eq 'html4') {
        if ($type eq 'strict') {
            return
              q||;
        }
        elsif ($type eq 'frameset') {
            return
              q||;
        }
        else {
            return
              q||;
        }
    }
    elsif ($self->format eq 'html5') {
        return '';
    }

    return '';
}

1;
__END__