PostScript風なテンプレートのインタープリタ部の試作

PostScript のような逆ポーランド記法でロジック部分を記述できるテンプレートは、どんな感じになるのだろうと、興味本位で作ってみました。まだ、テンプレート・コンパイラを作っておらず、Perl の配列にコンパイラの出力を手打ちしないといけません。けれど、そこは逆ポーランド記法の便利さで、機械的に書き直すだけで手動コンパイルできます。

試しに YukiWiki-2.1.3 のブラウズ・ページ・ビューを記述するとこんな風になります。テンプレートにしたい HTML 文字列をシングルクォートで切り刻み、間に逆ポーランド記法のテンプレートのロジックを書き込みます。forall の直後に繰り返し用の実行時オペレータを追加します。最後に、ブロック開始記号の直後に対応するブロック終了記号までの要素数を追加するとできあがりです。要素数Perl に数えさせるのが間違いがなく、先頭のブロックの要素数は次のようにして求めます。

use feature qw(say);

my @blksize = (qw( %]),q( - ),qw([% /html 1 index show } ));
say scalar @blksize; #=> 8

このように、ブロック開始記号の直後から、ブロック終了記号までを配列にして、要素数を求めます。

修正: FORTH 風の over を PostScript 風の 1 index に、swap を exch に、drop を pop に変更。
修正: add オペレータと for オペレータを追加。forall の繰り返し実行オペレータを for と共用できるように修正。

use strict;
use warnings;
use Carp;

my $browse = [
qw(%]),q(<!DOCTYPE html>
<html lang="ja">
<head>
<meta charset="UTF-8" />
<title>),qw([%
    /html env /entry get /mypage get show
    env /entry get /subject get
    dup length { 8 %]),q( - ),qw([% /html 1 index show } if pop
%]),q(</title>
</head>
<body>
<h1>),qw([%
    env /entry get /is_fixed get { 8
        /html env /entry get /mypage get show
    } { 24
%]),q(<a href="),qw([% /uri env /link get /searchthis get show %]),q(">),qw([%
        /html env /entry get /mypage get show
%]),q(</a>),qw([%
    } ifelse
    env /entry get /subject get
    dup length { 8 %]),q( - ),qw([% /html 1 index show } if pop
%]),q(</h1>
<nav>
<div class="tools">
),qw([%
    env /entry get /is_fixed get not { 50
%]),q(<a href="),qw([% /uri env /link get /admineditform get show %]),q(">AdminEdit</a> | 
),qw([%
        env /entry get /is_frozen get not { 14
%]),q(<a href="),qw([% /uri env /link get /editform get show %]),q(">Edit</a> | 
),qw([%
        } if
%]),q(<a href="),qw([% /uri env /link get /diff get show %]),q(">Diff</a> | 
),qw([%
    } if
%]),q(<a href="),qw([% /uri env /link get /frontpage get show %]),q(">FrontPage</a> | 
<a href="),qw([% /uri env /link get /indexpage get show %]),q(">IndexPage</a>
</div>
</nav>

),qw([% /asis env /entry get /texttohtml get show %]),q(

<div>Tag: ),qw([%
    env /entry get /tags get { 14
        env /i get { 4 %]),q(, ),qw([% } if
        /html exch show
    } forall (for)
%]),q(</div>

<aside>
<h1>Recent Changes</h1>
<ol>
),qw([%
    env /recents get dup /offset get exch /limit get
    -1 add 1 index add 1 exch { 25
        env /recents get /values get exch get dup defined { 12
%]),q(<li>),qw([% /html exch /name get show %]),q(</li>
),qw([%
        } if
    } for (for)
%]),q(</ol>
</aside>

<footer>derived from YukiWiki 2.1.3</footer>
</body>
</html>
),qw([%),
];

print execute($browse, {
    'entry' => {
        'mypage' => 'HelloPage',
        'subject' => 'hello world',
        'is_fixed' => 0,
        'is_frozen' => 0,
        'texttohtml' => '<p>Hello, world.</p>',
        'tags' => ['Practice', 'Hello'],
    },
    'link' => {
        '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' => 3,
        'limit' => 5,
        'values' => [
            {'name' => 'entry 0'},
            {'name' => 'entry 1'},
            {'name' => 'entry 2'},
            {'name' => 'entry 3'},
            {'name' => 'entry 4'},
            {'name' => 'entry 5'},
            {'name' => 'entry 6'},
            {'name' => 'entry 7'},
            {'name' => 'entry 8'},
        ],
    },
});

/html などのリテラルは show にエスケープ処理の種類を指定するためのもので、必ず指定しなければなりません。env はインタープリタに渡すパラメータ・ハッシュをデータ・スタックへ置くオペレータです。get オペレータはハッシュや配列から要素を取り出し、put オペレータで格納します。forall オペレータは現在の要素をデータ・スタックに置いてブロックを実行します。env の i に現在の添字を置きます。添字はゼロから始まります。i は perl の local 変数のようにふるまい、ブロックから抜け出すと、外の値に復活します。

このテンプレートの良いところは、テンプレートのデータ構造がフラットな配列であることと、配列の要素がすべてリファレンスではないスカラーリテラルである点です。キャッシュに保管するのに向いていそうです。

インタープリタは単純です。データとアドレスの2本のスタックを使った、スタック・マシンになっています。

ブロック処理のやりかたは私のオリジナルで、30年ほど前に Smalltalk-80 の構文を横目で見つつ自分用に作成した MC6809 プロセッサ用オブジェクト指向 FORTH を作っているときに思いついた方法です。ブロックを無名サブルーチン扱いするのが肝です。ブロックはそのままオペレータ配列の中に並んでおり、ブロック開始記号オペレータを実行すると、ブロック開始番地をアドレス・スタックへプッシュしてブロック終了記号オペレータの次の番地へジャンプします。このプッシュされたアドレスを if オペレータ等の制御オペレータがアドレス・スタックからポップし、条件成立時にブロックをサブルーチン・コールするのに使います。通常、ブロックからのリターン先は呼び出したオペレータの次のアドレスになりますが、foreach の実行時繰り返し用オペレータは自分自身を再実行するようにアドレスをプッシュします。

# エスケープ関数のモック
sub escape_htmlall { return $_[0] }
sub escape_html { return $_[0] }
sub escape_uriall { return $_[0] }
sub escape_uri { return $_[0] }

sub execute {
    my($expr, $env) = @_;
    my $result = q();
    my($pc, @data, @ret);
    my %operator = (
        'dup' => sub{
            my $r = $data[-1];
            push @data, $r;
        },
        'index' => sub{
            my $i = pop @data;
            my $r = $data[-1 - $i];
            push @data, $r;
        },
        'exch' => sub{ @data[-1, -2] = @data[-2, -1] },
        'pop' => sub{ pop @data },
        'add' => sub{
            my $r = pop @data;
            $data[-1] += $r;
        },
        '[%' => sub{},
        '%]' => sub{ $result .= $expr->[$pc++] },
        'env' => sub{ push @data, $env },
        'get' => sub{
            my($obj, $k) = splice @data, -2;
            push @data, ref $obj eq 'HASH' ? $obj->{$k}
                : ref $obj eq 'ARRAY' ? $obj->[$k]
                : eval{ $obj->can($k) } ? $obj->$k
                : q();
        },
        'put' => sub{
            my($v, $obj, $k) = splice @data, -3;
            if (ref $obj eq 'HASH') {
                $obj->{$k} = $v;
            }
            elsif (ref $obj eq 'ARRAY') {
                $obj->[$k] = $v;
            }
            elsif (eval{ $obj->can($k) }) {
                $obj->$k($v);
            }
        },
        'show' => sub{
            my($filter, $text) = splice @data, -2;
            $result .= $filter eq 'asis' ? $text
                : $filter eq 'htmlall' ? escape_htmlall($text)
                : $filter eq 'uriall' ? escape_uriall($text)
                : $filter eq 'uri' ? escape_uri($text)
                : escape_html($text);
        },
        'length' => sub{
            my $v = pop @data;
            push @data, ref $v eq 'ARRAY' ? (scalar @{$v})
                : defined $v ? length "$v"
                : 0;
        },
        '{' => sub{
            push @ret, $pc + 1;
            $pc += $expr->[$pc] + 1;
        },
        '}' => sub{ $pc = pop @ret },
        'if' => sub{
            my $proc = pop @ret;
            return if ! pop @data;
            push @ret, $pc;
            $pc = $proc;
        },
        'ifelse' => sub{
            my($proc1, $proc2) = splice @ret, -2;
            push @ret, $pc;
            $pc = pop @data ? $proc1 : $proc2;
        },
        'not' => sub{ $data[-1] = $data[-1] ? 0 : 1 },
        'defined' => sub{ $data[-1] = defined $data[-1] ? 1 : 0 },
        'odd' => sub{ $data[-1] = $data[-1] % 2 ? 1 : 0 },
        'even' => sub{ $data[-1] = $data[-1] % 2 ? 0 : 1 },
        'equal' => sub{
            my $r = pop @data;
            $data[-1] = $data[-1] eq $r ? 1 : 0;
        },
        'eq' => sub{
            my $r = pop @data;
            $data[-1] = $data[-1] == $r ? 1 : 0;
        },
        'for' => sub{
            my $proc = pop @ret;
            my($i0, $d, $limit) = splice @data, -3;
            push @ret, $env->{'i'}, $i0, $d, $limit, undef, $proc;
        },
        'forall' => sub{
            my $proc = pop @ret;
            my $list = pop @data;
            if (ref $list eq 'HASH') {
                $list = [values %{$list}];
            }
            push @ret, $env->{'i'}, 0, 1, $#{$list}, $list, $proc;
        },
        '(for)' => sub{
            my($i, $d, $limit, $list, $proc) = splice @ret, -5;
            $env->{'i'} = pop @ret;
            return if $d == 0;
            return if $d > 0 && $i > $limit;
            return if $d < 0 && $i < $limit;
            push @data, defined $list ? $list->[$i] : $i;
            push @ret, $env->{'i'}, $i + $d, $d, $limit, $list, $proc, $pc - 1;
            $env->{'i'} = $i;
            $pc = $proc;
        },
    );
    $pc = 0;
    while ($pc < @{$expr}) {
        my $op = $expr->[$pc++];
        if (q(/) eq (substr $op, 0, 1) && length $op > 1) {
            push @data, substr $op, 1;
        }
        elsif (my $f = $operator{$op}) {
            $f->();
        }
        else {
            push @data, $op;
        }
    }
    return $result;
}

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