小飼弾著「Perl/CGI道場」の chat-final.cgi を今風に

本棚をあさっていたら、小飼弾著「Perl/CGI道場」(2003) ISBN4-8443-1742-3 が出てきました。古き良き牧歌的なほのぼの Perl コードと説明が並び、この 10 年間の Perl をとりまく世界もずいぶんと変化したものです。 2014 年現在の時点で、この書籍で学ぶのは正直勘弁して欲しいもので、ほじくり返すのもなんですが、私なりに今風に chat-final.cgi (同書 209 ページ) を Plack のアプリケーションへ文芸的プログラミングで書き直してみることにしました。

https://gist.github.com/tociyuki/9108312 - TANGLE済み chat.psgi

まず大枠です。このプログラムは、日付からファイル名を生成したログファイルの末尾へ、 POST したフォームから得た投稿者名と一行入力を追加し、ログファイルの末尾から指定行数を読み出して投稿 form と一緒に HTML にしてブラウザへレスポンスします。 MVC のモデルはチャットログです。アップデートとリロードを担当します。 コントローラはブラウザからの要求をモデルへ伝え、モデルによる処理結果とテンプレートからレスポンスを作成します。テンプレートは DATA セクションに置いた HTML 記述です。

#!/usr/bin/env plackup
use strict;
use warnings;

package Chat::Log;
use Encode;
use File::Spec;
use Fcntl qw(:flock);
use Time::Piece;
use Plack::Util::Accessor qw(dir lines maxlines);

our $VERSION = '0.01';

sub new { return bless {%{$_[1] || +{}}}, ref $_[0] || $_[0] }

#@<チャットをアップデートする@>
#@<チャットをリロードする@>
#@<本日の日付からログファイル名を生成する@>
#@<ログファイルへ追加する@>
#@<ログファイルの末尾を指定行数読み出す@>

package Chat::Controller;
use Encode;
use File::Spec;
use Plack::Request;
use Plack::Util;
use Data::Section::Simple qw(get_data_section);

sub chat {
    my($log, $env, $content) = @_;
    my $req = Plack::Request->new($env);
    my $param;
    if ($req->method eq 'POST') {
        my $form = $req->body_parameters;
        $param = $log->update(map { $form->{$_} } qw(lines name message Reload));
    }
    else {
        $param = $log->reload;
    }
#@< レスポンスを作成する@>
}

my $log = Chat::Log->new({
    'dir' => File::Spec->catdir(qw[. chatlog]),
    'lines' => 10,
    'maxlines' => 1000,
});
my $template = decode_utf8(get_data_section('chat.html'));
my $app = sub{ chat($log, $_[0], $template) };

__DATA__

@@ chat.html
#@<チャット画面のテンプレート@>

__END__

#@<POD記述@>

チャット画面のテンプレートはレスポンスの HTML 生成のために使います。単なるパラメータ置換型のテンプレートで用が足りるので、パラメータの展開位置にダブルブレースでパラメータのキーを囲んでおきます。パラメータは、lines、messages、name の 3 つです。lines は表示する行数、messages は lines 行分のログの末尾部分、name は投稿者のニックネームに対応します。同じ HTML には投稿のための form も一緒にまとめておきます。

#@<チャット画面のテンプレート@>=
<!DOCTYPE html>
<html lang="ja">
<head>
<meta charset="utf-8" />
<title>Chat</title>
<style>
table { width: 100% }
input[name="lines"] { width: 3em }
input[name="name"] { width: 4em }
input[name="message"] { width: 32em }
</style>
</head>
<body>
<h1>Welcome to Chat</h1>
<form method="POST" action="/">
<table>
<tr><td colspan="6">Show last <input name="lines" value="{{lines}}" /> lines</td></tr>
<tr><td colspan="6"><pre>{{messages}}</pre></td></tr>
<tr>
<td>Name</td><td><input type="text" name="name" value="{{name}}" /></td>
<td>Message</td><td><input type="text" name="message" /></td>
<td><input type="submit" name="Chat" value="Chat" /></td>
<td><input type="submit" name="Reload" value="Reload" /></td>
</tr>
</table>
</form>
</body>
</html>

レスポンスを作成するため、このテンプレートから HTML を得るには単なるエスケープ付きパラメータ置き換えをおこないます。

#@< レスポンスを作成する@>=
    $content =~ s/\{\{(\w+)\}\}/Plack::Util::encode_html($param->{$1})/egmsx;
    my $body = [encode_utf8($content)];
    return [200, ['Content-Type' => 'text/html; charset=utf-8'], $body];

チャットをアップデートするときは、コントローラが渡した form の値の文字エンコーディングをデコードし、その上で内容の妥当性をチェックしてから、ログに追加します。ログへの追加条件は、name と message が妥当な文字列であり、なおかつ Reload でないときです。ユーザが表示行数を妥当な数値で入力したときは、それも受け入れます。最後に、tail メソッドを呼び出して、ログファイルから末尾 lines 行数を読み取ります。受け入れ可能な文字列は、Unicode の印字すると黒が生じる文字 (\p{Graph}) と空白だけからなるものとします。文字数チェックは、文字単位でおこない、オクテット単位ではないのは、その方がユーザに好ましいからです。なお、URIらしきものが含まれているとはじきます。

#@<チャットをアップデートする@>=
sub update {
    my($self, $lines, $name, $message, $reload) = @_;
    for ($lines, $name, $message) {
        $_ = defined $_ ? decode('UTF-8', $_) : q();
        s/\A[ ]+\z//msx;
    }
    my $param = {'lines' => $self->lines, 'name' => q()};
    if ($name =~ m/\A[\p{Graph} ]{1,16}\z/msx && $name !~ m{\b(?:f|ht)tps?://}msx) {
        $param->{'name'} = $name;
        if (! $reload && $message =~ m/\A[\p{Graph} ]{1,80}\z/msx && $message !~ m{\b(?:f|ht)tps?://}msx) {
            $self->append(join q(: ), $name, $message);
        }
    }
    if ($lines =~ m/\A[1-9][0-9]{0,4}\z/ && $lines <= $self->maxlines) {
        $param->{'lines'} = $lines;
    }
    $param->{'messages'} = $self->tail($param->{'lines'});
    return $param;
}

チャットをリロードするときは単純で、初期値の lines と現在のログファイルの末尾をとりだします。

#@<チャットをリロードする@>=
sub reload {
    my($self) = @_;
    return +{'lines' => $self->lines, 'messages' => $self->tail, 'name' => q()};
}

本日の日付からログファイル名を生成する部分は、オリジナルの chat-final.cgi のものをほぼそのまま利用することができます。Perl の localtime 組み込み手続きをそのまま使うのは避けたいので、書き換えにあたって Time::Piece を使っています。また、ログファイルのパスを作成する部分に行儀良く File::Spec を使うことにします。

#@<本日の日付からログファイル名を生成する@>=
sub todays_log {
    my($self) = @_;
    my $now = localtime;
    my $date = $now->ymd;
    my $time = $now->hms;
    -d $self->dir or mkdir $self->dir;
    my $file = File::Spec->catfile($self->dir, "$date.log");
    return $file if -f $file;
    open my($fh), '>', $file or die "cannot create $file : $!\n";
    binmode $fh;
    print $fh "[new log $file created at $date $time]\n";
    close $fh;
    return $file;
}

ログファイルへ追加する処理も、オリジナルのものをほぼそのまま使えば良いだけです。10年前はファイルハンドラに my 変数を使えない古いバージョンの Perl を使い続けていた Web サーバがしぶとく生き残っていたことからベア・グロブを使っているところに年月の流れを感じました。そんな Perl を使っているサーバは絶滅して欲しいものです。

#@<ログファイルへ追加する@>=
sub append {
    my($self, $line) = @_;
    my $file = $self->todays_log;
    open my($fh), '>>', $file or die "cannot write $file: $!\n";
    binmode $fh;
    flock $fh, LOCK_EX or die "cannot lock $file\n";
    print $fh encode_utf8($line), "\n";
    flock $fh, LOCK_UN;
    close $fh;
    return;
}

ログファイルの末尾を指定行数読み出す部分には、オリジナルの富豪的プログラミングを捨てて、tail(1) コマンド由来のものを使うことにします。tail(1) コマンドもいろんな書き方がありますが、ここでは、mmap を使うやりかたを参考にして seek と read で読み出すように変更したものを採用しました。末尾を指定行数読み出すということは、ファイルの末尾から始めて先頭方向へ向けて指定行数分の改行を探すことで実装できます。改行を文字列の末尾から先頭側へ向けて探すには rindex 手続きを使えば良いので、ファイル末尾からブロック単位で前へと読み込みながら、最後に読んだブロック範囲内で rindex を繰り返せば良いでしょう。

2014-02-21: tail を差し替え。ブロックの割り当て方向を変更しました。前の版はファイルの末尾から割り当てていたのに対して、差し替え版は先頭から割り当てています。どちらでもファイルの末尾側から先頭へと走査するのは同じです。

#@<ログファイルの末尾を指定行数読み出す@>=
sub tail {
    my($self, $lines) = @_;
    $lines ||= $self->lines;
    my $file = $self->todays_log;
    open my($fh), '<', $file or return q();
    binmode $fh;
    flock $fh, LOCK_SH or die "cannot lock $file\n";
    my $file_size = (stat $fh)[7];
    my $tail_str = q();
    my $tail_pos = 0;
    my $block_maxsize = 4096;
    my $block_count = int(($file_size + $block_maxsize - 1) / $block_maxsize);
    for my $block_round (0 .. $block_count - 1) {
#@<     ブロックの位置とサイズを求める@>
#@<     ブロックを読み込む@>
#@<     読んだばかりのブロックの後ろから前へと改行を探索する@>
        last if $lines == 0;
    }
    flock $fh, LOCK_UN;
    close $fh;
    return decode_utf8(substr $tail_str, $tail_pos);    
}

sub max { $_[0] > $_[1] ? $_[0] : $_[1] }
sub min { $_[0] < $_[1] ? $_[0] : $_[1] }

ブロックはファイル先頭から $block_maxsize バイトで並んでいて、最後はそれ以下のサイズのブロックで終わります。ブロックを読み込む for ループは、 $block_round をカウンタにして、ゼロから $block_count - 1 まで増やします。ということは、ブロックのバイト位置は、カウンタの補数に $block_maxsize をかけることで求まります。ただし、この計算式では、ブロックが1個しかないとき、負のアドレスになってしまうので、そのときはゼロを選びます。ブロックのサイズは、ブロックの開始位置からファイルの終わりまでの長さと、ブロックサイズとを比べて小さい方を選びます。

#@<     ブロックの位置とサイズを求める@>=
        my $block_addr = max(0, ($block_count - $block_round - 1) * $block_maxsize);
        my $block_size = min($file_size - $block_addr, $block_maxsize);

ブロックを読み込むには、開始位置へ seek して、 サイズ分を read で読みます。そして、 読んだ分を、 末尾を格納している文字列の前へ追加します。

#@<     ブロックを読み込む@>=
        seek $fh, $block_addr, 0;
        read $fh, my($block), $block_size;
        $tail_str = $block . $tail_str;

読んだばかりのブロックの後ろから前へと改行を探索します。末尾を格納している文字列の先頭から読んだサイズ分だけの領域で rindex を繰り返せば良いわけです。探索の開始位置は読んだサイズ分の末尾ですが、ファイル末尾の改行は数にいれないため、読み飛ばさなければなりません。そこで、 最初のブロックに限り末尾位置の一つ前から探索を開始します。そして、指定行数分の改行の探索を追えた段階 (--$lines == 0 が真) では、探索開始位置のオフセットは欲しい位置よりも一つ前の改行位置にあるので、一つ後ろの文字、つまり行頭へ動かしておきます。

#@<     読んだばかりのブロックの後ろから前へと改行を探索する@>=
        $tail_pos = max(0, $block_round > 0 ? $block_size : $block_size - 1);
        while ($tail_pos > 0) {
            my $i = rindex $tail_str, "\n", $tail_pos - 1;
            $tail_pos = 0;
            last if $i < 0;
            $tail_pos = $i + 1;
            last if --$lines == 0;
            $tail_pos = $i;
        }

POD記述をちょっと加えておきます。

#@<POD記述@>=
=pod

=head1 NAME

chat.psgi - tail lines browsing single line bulletin board system per day

=head1 VERSION

0.01

=head1 SYNOPSIS

    $ plackup chat.psgi

=head1 DEPENDENCIES

L<Plack::Request>
L<Plack::Util>
L<Plack::Util::Accessor>
L<Data::Section::Simple>
L<Time::Piece>

=head1 SEE ALSO

Dan Kogai C<chat-final.cgi> p. 209, 2003, ISBN4-8443-1742-3

=head1 AUTHOR

MIZUTANI Tociyuki

=head1 LICENSE AND COPYRIGHT

Copyright (c) 2014, MIZUTANI Tociyuki C<< <tociyuki@gmail.com> >>.
All rights reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

この chat.psgi はウェブ・チャットとして使うよりも、 tail(1) コマンドのウェブ版として、append を殺し、ログ・ファイルの閲覧用に使うとおもしろいかもしれません。