Ter.pm

PHPをテンプレートとして用いたのと同じような動きをします。<% 〜 %>内はPerlのコードして解釈<%= 〜 %>はechoでし
ただし、<% for(...) { %>〜〜<% } %>ってのは醜いと思うので<% for(...) %>〜〜<% end %>としてます。

package Ter;

=head1 NAME

Ter - small template engine

=head1 SYNOPSIS

  use Ter;
  print Ter->load( filename => 'hoge.t' )->compile( qw/var1/ )->execute( var1 => val, ... );

  my $obj = Ter->new();
  $obj->source("template text...");
  print $obj->compile( qw/var1/ )->execute( var1 => val, ... );

=cut

use strict;
use warnings;
use Carp;

sub new{
    my $class = shift;
    my $self  = bless({
        __PACKAGE__ . '_source'   => undef,
        __PACKAGE__ . '_perlcode' => undef
    }, $class);

    return $self;
}

sub load{
    my $class = shift;
    my $self  = $class->new();
    my %args  = @_;

    croak "args: filename" unless defined $args{filename};

    open( my $in, '<', $args{filename} ) or croak $!;
    { my $t = join('', <$in>); $self->source($t); }
    close($in);

    return $self;
}

sub save{
    my $self  = shift;
    my %args  = @_;

    croak "args: filename" unless defined $args{filename};

    open( my $out, '>', $args{filename} ) or croak $!;
    print $out $self->perlcode;
    close($out);

    return $self;
}

sub execute{
    my $self = shift;
    my $code = $self->perlcode;

    croak "execute after compile" unless $code;

    my $s = eval( $code );
    croak $@ if( $@ );

    return $s->(@_);
}

sub compile{
    my $self = shift;
    my @vars = @_;
    my $body = $self->source;

    my $dec_vars;
    $dec_vars .= '    my $' . $_ . ' = $param{' . $_ . "};\n" foreach (@vars);;

    my $head = <<END;
return sub {
    my \$buffer;
    my \%param = \@_;
$dec_vars;
    \$buffer .= <<'___TEMPLATE___';
END
    my $foot = <<'END';
___TEMPLATE___
    return $buffer;
}
END

    my $begin = q{$buffer .= <<'___TEMPLATE___';} . "\n";
    my $end   = "\n___TEMPLATE___\n" . q{    chomp $buffer;} . "\n";
    $body  =~ s{
                   <%(=?) \s* (.+?) \s* \%> (\r?\n?)
           }{$end . _parse($1, $2, $3) . $begin}emgx;

    $self->perlcode( $head . $body . $foot );

    return $self;
}

sub _parse{
    my $print   = shift;
    my $content = shift;
    my $rn      = shift;

    $print = 0 unless defined $print;
    $rn    = 1 unless defined $rn;

    if( $print ){
        $content .= ' . "\n"' if $rn;
        return <<END
    \$buffer .= $content;
END
    }

    if( $content =~ /^(foreach|for|while|if|unless)\s*\((.+)\)$/ ){
        return <<END
    $1($2){
END
    }
    elsif( $content =~ /^(foreach|for)\s*(.+)\s*\((.+)\)$/ ){
        return <<END
    $1 $2 ($3){
END
    }
    elsif( $content =~ /^elsif\((.+)\)$/ ){
        return <<END
    }
    elsif($1){
END
    }
    elsif( $content =~ /^else$/ ){
        return <<END
    }
    else{
END
    }
    elsif( $content eq 'end' ){
        return <<END
    }
END
    }
    else {
        return <<END
    $content;
END
    }

}

###accessors
sub source{
    my $self = shift;
    $self->{__PACKAGE__ . "_source"} = shift if @_;
    return $self->{__PACKAGE__ . "_source"};
}

sub perlcode{
    my $self = shift;
    $self->{__PACKAGE__ . "_perlcode"} = shift if @_;
    return $self->{__PACKAGE__ . "_perlcode"};
}

return 1;