File Coverage

blib/lib/Here/Template.pm

Criterion	Covered	Total	%
statement	17	49	34.6
branch	2	16	12.5
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	25	71	35.2

package Here::Template;

=head1 NAME

Here::Template - heredoc templates

=head1 SYNOPSIS

    use Here::Template;

    print <<'TMPL';

        Hello, my pid is
        Let's count to 10: $_

    TMPL

=head1 DESCRIPTION

Simple Filter::Util::Call based implementation of heredoc templates.

To enable templates in some heredoc use quoted heredoc mark that contains
B. Output is added to the buffer C<$here>. You can append data
there as well:

    print <<'TMPL';

        Hello, my pid is
        Let's count to 10:

    TMPL

=head1 EXPORT

This module doesn't export anything by default.

Special argument B can be used to disable strict and
warnings inside templates. E.g.:

    use strict;
    use warnings;

    use Here::Template 'relaxed';

    print <<'TMPL';

        Let's count to 10:
            for $k (1..10) {
                $here .= "$k ";
            }
        ?>

    TMPL

=cut

our $VERSION = '0.2';

use strict;
use warnings;
no  warnings 'uninitialized';

use Filter::Util::Call;

sub import {
    my $ctl = $_[1] eq 'relaxed'
                 ? 'no strict; no warnings;' : '';

    filter_add  sub {

        my $st = filter_read();

        if ( m/  << \s* (['"]) ( [^\1]* TMPL [^\1]* ) \1 \s* /gcx ) {
            my $q       = $1;
            my $eof     = quotemeta $2;
            my $start   = quotemeta '
            my $out     = '$here';
            my $end     = quotemeta '?>';

            my $buf     = substr($_, 0, pos($_) - length($&));
            my $buf_end = substr($_, pos($_));

            chomp($buf_end);

            return $st
                if /^\s*#/;

            $_ = '';

            # do { my $var = '
            $buf .= "do{ $ctl \n".($out eq '$_' ? 'local' : 'my')." $out =$q";

            while (1) {
                $st = filter_read();

                if (/ $start (=)? /gcx) {
                    my $echo = $1;

                    # foo bar\' baz
                    my $tmp  =  substr($_, 0, pos($_) - length($&));
                       $_    =  substr($_, pos($_));
                       $tmp  =~ s/$q/\\$q/g;
                       $buf .=  $tmp;

                    $st = filter_read()
                        while !/ $end /gcx;

                    # '; ... ; $out .='
                    $tmp  =  substr($_, 0, pos($_) - length($&));
                    $_    =  substr($_, pos($_));
                    $buf .= "$q; ".
                             ($echo ? "$out.=$tmp" : "$tmp").
                             "; $out .=$q";
                }

                if (/ $eof /gcx) {
                    my $tmp  =  substr($_, 0, pos($_) - length($&));
                       $_    =  substr($_, pos($_));
                       $tmp  =~ s/$q/\\$q/g;
                       $buf .=  $tmp;

                    # '; $var }
                    $buf .= "$q; $out }";
                    $_    = $buf.$buf_end.$_;
                    last;
                }

                last
                    unless $st;
            }
        }

        return $st;
    };
}


=head1 AUTHOR

Alexandr Gomoliako

=head1 LICENSE

Copyright 2011-2012 Alexandr Gomoliako. All rights reserved.

This module is free software. It may be used, redistributed and/or modified
under the same terms as perl itself.

=cut

1;