PostScript風なテンプレート・プロセッサの続き

3月に興味本位で作ってみた「PostScript風なテンプレートのインタープリタ部の試作」の続きです。前回の試作でテンプレート記述が冗長すぎたことを反省して、今回は記述が素直になるように工夫してみました。

新しい仕組みにあわせて、前回の YukiWiki-2.1.3 のブラウズ・ページ・ビューを書き直すと次のようになります。もはや、変数を get したり show したりする必要がなく、変数の値がスカラーなら HTML エスケープして自動的に出力するようになりました。内部動作を正確に表すと、出力はデータ・スタックへ積み上がっていくようになり、テンプレート処理完了時に、データ・スタックを join して出力ストリングを得るようになりました。変数だけでなく、テンプレート処理記述外の HTML 記述もリテラル扱いで、データ・スタックへ積み上がっていきます。さらに、forall と with オペレータは、要素がハッシュなら、パラメータ・ハッシュに一時的にそれをマージしてブロックを実行するようにしたため、入れ子のデータ構造でも、変数参照即出力の利便性を享受できるようになりました。変数名をリテラルとしてスタックへ積んで get オペレータで取得する方法も残してあり、これを使うことで HTML エスケープをバイパスしたり、他のエスケープ処理を適用するようにすることもできます。

<!DOCTYPE html>
<html lang="ja">
<head>
<meta charset="UTF-8" />
<title>[%
    entry {
      mypage
      subject length { %] - [% subject } if
    } with
%]</title>
</head>
<body>

[%  entry { %]
<h1>[%
      is_fixed
        { mypage }
        { links { %]<a href="[% searchthis %]">[% mypage %]</a>[% } with }
      ifelse
      subject length { %] - [% subject } if
%]</h1>

<nav>
<div class="tools">
[%
      links {
        is_fixed not {
%]<a href="[% admineditform %]">AdminEdit</a> | 
[%        is_frozen not {
%]<a href="[% editform %]">Edit</a> | 
[%        } if
%]<a href="[% diff %]">Diff</a> | 
[%      } if
%]<a href="[% frontpage %]">FrontPage</a> | 
<a href="[% indexpage %]">IndexPage</a>
[%    } with %]
</div>
</nav>

[%    var /texttohtml raw_get! %]

<div>Tag: [%
      tags {
        i { %], [% } if
        %]<a href="[% link %]">[% name %]</a>[%
      } forall
%]</div>
[%  } with %]

<aside>
<h1>Recent Changes</h1>
<ol>
[%  recents {
      offset limit -1 add 1 index add 1 exch {
        values exch get dup { { %]
<li><a href="[% link %]">[% name %]</a></li>
[%      } with } if
      } for
    } with
%]</ol>
</aside>

<footer>derived from YukiWiki 2.1.3</footer>
</body>
</html>

上のテンプレートへデータを差し込んでみます。Text::PostTemplate がこのテンプレート処理系の名前です。コンパイルして、パラメータ・ハッシュを適用すると、出力ストリングを返します。

use strict;
use warnings;
use Encode;
use File::Slurp;
use Text::PostTemplate;

my $source = decode('UTF-8', read_file('yukipage.tmpl'));
my $template = Text::PostTemplate->compile($source);
my $output = Text::PostTemplate->apply($template, {
    'entry' => {
        'mypage' => 'HelloPage',
        'subject' => 'hello world',
        'is_fixed' => 0,
        'is_frozen' => 0,
        'texttohtml' => '<p>Hello, world.</p>',
        'tags' => [
            {'name' => 'Practice',  'link' => '/wiki.cgi?Tag:Practice'},
            {'name' => 'Hello',     'link' => '/wiki.cgi?Tag:Hello'},
        ],
        'links' => {
            'searchthis' => '/wiki.cgi?mycmd=search&amp;mymsg=HelloPage',
            'admineditform' => '/wiki.cgi?mycmd=adminedit&amp;mypage=HelloPage',
            'editform' => '/wiki.cgi?mycmd=edit&amp;mypage=HelloPage',
            'diff' => '/wiki.cgi?mycmd=diff&amp;mypage=HelloPage',
            'frontpage' => '/wiki.cgi?FrontPage',
            'indexpage' => '/wiki.cgi?IndexPage',
        },
    },
    'recents' => {
        'offset' => 0,
        'limit' => 5,
        'values' => [
            {'name' => 'EntryZero',     'link' => '/wiki.cgi?EntryZero'},
            {'name' => 'EntryOne',      'link' => '/wiki.cgi?EntryOne'},
            {'name' => 'EntryTwo',      'link' => '/wiki.cgi?EntryTwo'},
            {'name' => 'EntryThree',    'link' => '/wiki.cgi?EntryThree'},
            {'name' => 'EntryFour',     'link' => '/wiki.cgi?EntryFour'},
            {'name' => 'EntryFive',     'link' => '/wiki.cgi?EntryFive'},
            {'name' => 'EntrySix',      'link' => '/wiki.cgi?EntrySix'},
            {'name' => 'EntrySeven',    'link' => '/wiki.cgi?EntrySeven'},
            {'name' => 'EntryEight',    'link' => '/wiki.cgi?EntryEight'},
        ],
    },
});
print encode('UTF-8', $output);

コンパイラされたテンプレート・コードは、前回はフラットな配列リファレンスでしたが、今回は入れ子の配列リファレンスに変更しました。オペレータは空白で区切り、ブロックの開始・終端記号はブレースなのは前回から変えていません。

package Text::PostTemplate;
use strict;
use warnings;
use Carp;
use Encode;
use Scalar::Util qw(looks_like_number);

our $VERSION = '0.001';

sub compile {
    my($class, $source) = @_;
    my @block = ([]);
    while ($source =~ m{\G(.*?)\[\%\s*(.*?)\s*\%\]\n?}gcmsx) {
        my($lit, $operators) = ($1, $2);
        if ($lit ne q()) {
            push @{$block[-1]}, '%]', $lit, '[%';
        }
        for my $op (split /\s+/msx, $operators) {
            if ($op eq '{') {
                push @block, [];
            }
            elsif ($op eq '}') {
                my $a = pop @block;
                push @{$block[-1]}, $a;
            }
            else {
                push @{$block[-1]}, $op;
            }
        }
    }
    if (@block != 1) {
        croak 'Template Error';
    }
    if (pos $source) {
        $source = substr $source, pos $source;
    }
    if ($source ne q()) {
        push @{$block[-1]}, '%]', $source, '[%';
    }
    return $block[0];    
}

# 下に続く

インタープリタは apply です。今回はブロック単位での再帰呼び出しにしました。なお、今回の実装ではデータ・スタックにブロックを積む機能がないので、def でオペレータを定義することはできません。def はパラメータ・ハッシュへ値をセットするのに使います。

sub apply {
    my($class, $template, $param) = @_;
    my $result = _apply_block([q()], $template, $param);
    return join q(), @{$result};
}

my %BINARY_OPERATOR = (
    'exch' => sub { ($_[1], $_[0]) },
    'add'  => sub { $_[0] + $_[1] },
    'sub'  => sub { $_[0] - $_[1] },
    'mul'  => sub { $_[0] * $_[1] },
    'div'  => sub { $_[0] / $_[1] },
    'mod'  => sub { $_[0] % $_[1] },
    'eq' => sub { _compare(@_) == 0 ? 1 : 0 },
    'ne' => sub { _compare(@_) != 0 ? 1 : 0 },
    'lt' => sub { _compare(@_) <  0 ? 1 : 0 },
    'le' => sub { _compare(@_) <= 0 ? 1 : 0 },
    'gt' => sub { _compare(@_) >  0 ? 1 : 0 },
    'ge' => sub { _compare(@_) >= 0 ? 1 : 0 },
    'get!'        => sub { _fetch($_[0], $_[1], \&escape_raw) },
    'raw_get!'    => sub { _fetch($_[0], $_[1], \&escape_raw) },
    'get'         => sub { _fetch($_[0], $_[1], \&escape_html) },
    'html_get'    => sub { _fetch($_[0], $_[1], \&escape_html) },
    'htmlall_get' => sub { _fetch($_[0], $_[1], \&escape_htmlall) },
    'uri_get'     => sub { _fetch($_[0], $_[1], \&escape_uri) },
    'uriall_get'  => sub { _fetch($_[0], $_[1], \&escape_uriall) },
);

my %UNARY_OPERATOR = (
    'not' => sub { ! $_[0] ? 1 : 0 },
    'neg' => sub { -$_[0] },
    'dup' => sub { ($_[0], $_[0]) },
    'pop' => sub { () },
    'length' => sub { length $_[0] },
    'even' => sub { $_[0] % 2 == 0 ? 1 : 0 },
    'odd'  => sub { $_[0] % 2 != 0 ? 1 : 0 },
);

sub _apply_block {
    my($data, $block, $param) = @_;
    my $pc = 0;
    while ($pc <= $#{$block}) {
        my $op = $block->[$pc++];
        next if ref $op || $op eq '[%' || $op eq 'show';
        if ($op eq '%]') {
            push @{$data}, $block->[$pc++];
            next;
        }
        if (q(/) eq (substr $op, 0, 1) && length $op > 1) {
            push @{$data}, (substr $op, 1);
            next;
        }
        if (looks_like_number($op)) {
            push @{$data}, $op;
            next;
        }
        if ($op eq 'index') {
            my $i = pop @{$data};
            my $r = $data->[-1 - $i];
            push @{$data}, $r;
            next;
        }
        if ($op eq 'var') {
            push @{$data}, $param;
            next;
        }
        if ($op eq 'def') {
            my($key, $value) = splice @{$data}, -2;
            _store($param, $key, $value);
            next;
        }
        if ($op eq 'put') {
            my($value, $obj, $key) = splice @{$data}, -3;
            _store($obj, $key, $value);
            next;
        }
        if ($op eq 'if') {
            my $cond = pop @{$data};
            if ($cond) {
                _apply_block($data, $block->[$pc - 2], $param);
            }
            next;
        }
        if ($op eq 'ifelse') {
            my $cond = pop @{$data};
            if ($cond) {
                _apply_block($data, $block->[$pc - 3], $param);
            }
            else {
                _apply_block($data, $block->[$pc - 2], $param);
            }
            next;
        }
        if ($op eq 'for') {
            my($i, $d, $limit) = splice @{$data}, -3;
            while (($d > 0 && $i <= $limit) || ($d < 0 && $i >= $limit)) {
                push @{$data}, $i;
                _apply_block($data, $block->[$pc - 2], $param);
                $i += $d;
            }
            next;
        }
        if ($op eq 'with' || $op eq 'forall') {
            my $list = pop @{$data};
            if (ref $list ne 'ARRAY') {
                $list = [$list];
            }
            for my $i (0 .. $#{$list}) {
                my $item = $list->[$i];
                _apply_block($data, $block->[$pc - 2], {
                    %{$param},
                    'i' => $i,
                    ref $item eq 'HASH' ? %{$item} : ('item' => $item),
                });
            }
            next;
        }
        if (exists $BINARY_OPERATOR{$op}) {
            my($a, $b) = splice @{$data}, -2;
            push @{$data}, $BINARY_OPERATOR{$op}->($a, $b, $param);
            next;
        }
        if (exists $UNARY_OPERATOR{$op}) {
            my $a = pop @{$data};
            push @{$data}, $UNARY_OPERATOR{$op}->($a, $param);
            next;
        }
        if (! ref $data->[-1]
            && $data->[-1] =~ m/[ \t\n\r](?:href|src|action)="\z/msx
        ) {
            push @{$data}, _fetch($param, $op, \&escape_uri);
        }
        else {
            push @{$data}, _fetch($param, $op, \&escape_html);
        }
    }
    return $data;
}

sub _compare {
    my($a, $b) = @_;
    if (looks_like_number($a) && looks_like_number($b)) {
        return $a <=> $b;
    }
    else {
        return $a cmp $b;
    }
}

sub _fetch {
    my($obj, $key, $filter) = @_;
    $filter ||= \&escape_html;
    my $value = ref $obj eq 'HASH' ? $obj->{$key}
        : ref $obj eq 'ARRAY' ? $obj->[$key]
        : eval{ $obj->can($key) } ? $obj->$key
        : q();
    return $value if ref $value || looks_like_number($value);
    return $filter->($value);
}

sub _store {
    my($obj, $key, $value) = @_;
    if (ref $obj eq 'HASH') {
        $obj->{$key} = $value;
    }
    elsif (ref $obj eq 'ARRAY') {
        $obj->[$key] = $value;
    }
    elsif (eval{ $obj->can($key) }) {
        $obj->$key($value);
    }
    return;
}

エスケープ関数は次の 5 つを使います。

my %XML_SPECIAL = (
    q(&) => q(&amp;), q(<) => q(&lt;), q(>) => q(&gt;),
    q(") => q(&quot;), q(') => q(&#39;), q(\\) => q(&#92;),
);

my $ALPHA = q(A-Za-z);
my $DIGIT = q(0-9);
my $ALNUM = q(A-Za-z0-9);

sub escape_htmlall {
    my($t) = @_;
    $t = defined $t ? $t : q();
    $t =~ s{([&<>"'\\])}{ $XML_SPECIAL{$1} }egmosx;
    return $t;
}

sub escape_html {
    my($t) = @_;
    $t = defined $t ? $t : q();
    $t =~ s{
        (?:([<>"'\\])
        |\& (?:([_$ALPHA][_$ALNUM]*|\#(?:[$DIGIT]{1,5}|x[[:xdigit:]]{2,4}));)?
        )
    }{
        $1 ? $XML_SPECIAL{$1} : $2 ? qq(\&$2;) : q(&amp;)
    }egmosx;
    return $t;
}

sub escape_uriall {
    my($t) = @_;
    $t = defined $t ? $t : q();
    if (utf8::is_utf8($t)) {
        $t = Encode::encode('UTF-8', $t);
    }
    $t =~ s{([^$ALNUM\-_~/.,;:])}{ sprintf '%%%02X', ord $1 }egmosx;
    return $t;
}

sub escape_uri {
    my($t) = @_;
    $t = defined $t ? $t : q();
    if (utf8::is_utf8($t)) {
        $t = Encode::encode('UTF-8', $t);
    }
    $t =~ s{
        (%([[:xdigit:]]{2})?)|(&(?:amp;)?)|([^$ALNUM\-_~*+=/.!,;:\@?\#])
    }{
        $2 ? $1 : $1 ? q(%25) : $3 ? q(&amp;) : sprintf '%%%02X', ord $4
    }egmosx;
    return $t;
}

sub escape_raw { return $_[0] }

1;

PostScript風なテンプレート・プロセッサの続き(その2)