Perl 6 標準の出力ストリームが少し気に入らなかったので、車輪を発明してしまいました。
単体テスト
流行に乗って、まずテストケースの形で今回実現することを書きます。以下では、
- 出力のカスケードが機能していること (
$obj.s(123).s('abc').g('')) - 標準出力に対してもメモリーストリームに対しても同様に
.str-on()、.gist-on()できること - Gistable が機能していること
を調べています。
なお、謎の segmentation fault がたまに出るので、テストを二つに分割しました。
#!/usr/bin/env perl6
# 念のため Unix 版の rakudo-star-2012.11 を使ってください。
use v6;
use Appendable;
use Symbol;
use Cons;
use Test;
use GrabStdout;
plan *;
my $sym = Symbol.new('xyz');
my $cons = Cons.new($sym, $sym);
$cons = Cons.new($cons, $cons);
my $cons-gist-expected = q :to '!';
(
(
xyz
.
xyz
)
.
(
xyz
.
xyz
)
)
!
{
my $o = $*OUT.clone does Appendable;
is grab-stdout({ $o.s(123).s('abc').g(''); }), "123abc\n";
is grab-stdout({ $o.s($sym).s("\n"); }), "xyz\n";
is grab-stdout({ $o.g('abc').g($sym); }), "abc\nxyz\n";
is grab-stdout({ $o.g($sym); }), "xyz\n";
is(
grab-stdout({ $o.s($cons).s("\n").g($cons); }),
"((xyz . xyz) . (xyz . xyz))\n$cons-gist-expected"
);
}
{
my $o = MemOut.new();
is $o.g($sym).s($sym).s("\n").Str, "xyz\nxyz\n";
is $o.Str, "xyz\nxyz\n";
is $o.g($sym).s($sym).s("\n").Str, "xyz\nxyz\nxyz\nxyz\n";
}
$ perl6 -I. a.t6
ok 1 -
ok 2 -
ok 3 -
ok 4 -
ok 5 -
ok 6 -
ok 7 -
ok 8 -
#!/usr/bin/env perl6
# 念のため Unix 版の rakudo-star-2012.11 を使ってください。
use v6;
use Symbol;
use Cons;
use Test;
use GrabStdout;
plan *;
my $sym = Symbol.new('xyz');
my $cons = Cons.new($sym, $sym);
$cons = Cons.new($cons, $cons);
# say は可能なら gist-on を呼ぶ。
# この例では、gist-on の末尾に "\n" が付く。
# say も末尾に "\n" を出力する。
# つまり、say <gist-on 可能なオブジェクト>; すると、末尾に "\n\n" が出力される。
# print は可能なら print-on を呼ぶ。
# この例では、print-on の末尾に "\n" は付かない。
# print も末尾に "\n" を出力しない。
# つまり、print <print-on 可能なオブジェクト>; しても、
# 末尾に "\n" は出力されない。
my $cons-gist-expected = q :to '!';
(
(
xyz
.
xyz
)
.
(
xyz
.
xyz
)
)
!
print $sym;
{
is $sym.Str, 'xyz';
is $sym.gist, "xyz\n";
is $cons.Str, '((xyz . xyz) . (xyz . xyz))';
is $cons.gist, $cons-gist-expected;
}
{
is grab-stdout({ print $sym; }), 'xyz';
is grab-stdout({ say $sym; }), "xyz\n\n";
is grab-stdout({ print $cons; }), '((xyz . xyz) . (xyz . xyz))';
is grab-stdout({ say $cons; }), "$cons-gist-expected\n";
}
$ perl6 -I. b.t6
ok 1 -
ok 2 -
ok 3 -
ok 4 -
ok 5 -
ok 6 -
ok 7 -
ok 8 -
Java の Appendable インターフェースを真似て、Appendable ロールを定義する
メッセージのカスケーディング
Smalltalk という言語では、obj という オブジェクトにまず m1 というメッセージを送り、次に同じオブジェクトに m2 というメッセージを送り、以下同様にする場合、次のように書けます。
obj m1; m2; m3; m4; ... .
これをメッセージのカスケードと呼びます。もちろん、同じことは
obj m1. obj m2. obj m3. obj m4. obj ... .
でできますが、カスケードの方が何かと便利です。実際、C++ であまりにも有名なのが ostream 用にオーバーライドされた << 演算子で、以下の表現はおなじみでしょう。
cout << "hello" << endl;
言語レベルでカスケードをサポートしていない C++ では、operator<<() が return *this; することで、ライブラリーレベルで、ほぼ同じ効果を実現しています。
Java にも、ライブラリーレベルでの出力のカスケードがあります。これを可能にしているのが Appendable インターフェースです。
StringBuffer.new().append("hello").append("\n").toString();
余談ですが Java に Appendable インターフェースが導入されたのは Java 1.5 からで、実際、
StringBuffer.new().append("hello").append("\n").toString();
は可能でも、
System.out.append("hello").append("\n");
は不可能な時期がありました。
今回は、Perl 6 のロールを使って、Java の Appendable のようなものを作ってみます。
Appendable ロール
Appendable な Perl 6 オブジェクト $a に、$o を出力するには、
$a.s($o);
あるいは
$a.g($o);
とします。
Java のインターフェースと違って、ロールには、実装を書くことができます。Appendable ロールでは、.s()、.g() が self を返すことでメッセージをカスケードできるようにします。またこれらの本体では、引数オブジェクトが .str-on()、.gist-on() を理解するかどうかを調べ、理解したならその結果を取り入れ、理解しなかったら Perl の .Str()、.gist() を使って引数を文字列化したものを self.w() します。
use v6;
role Appendable;
method new($dumb-out = $*OUT)
{
self.bless(*, :$dumb-out);
}
method s($obj)
{
my $print-on = 'str-on';
my $stringify = 'Str';
self._print-str(:$print-on, :$stringify, $obj);
}
method g($obj, $indent = '')
{
my $print-on = 'gist-on';
my $stringify = 'gist';
self._print-str(:$print-on, :$stringify, $obj, "\n", $indent);
}
method _print-str($obj, $new-line = '', $indent = '', :$print-on!, :$stringify!)
{
my $done;
try { $done = $obj."$print-on"(self, $indent); }
unless $done {
self.w($indent, $obj."$stringify"(), $new-line);
}
self;
}
method w(*@strings)
{
for @strings -> Str $str {
self.write($str.encode);
}
self;
}
.w() の代わりに .print() を使うこともできましたが、パラメーターの型を Str に限定したかったこと、.write() の使い方が示したかったことから、.w() を定義しました。
self は、.write() さえ理解すれば何でもかまいません。今回は、MemOut クラスをでっちあげました。なお、ファイルに ちまちま .write() で書きこむのは効率が良くありません。かと言ってこれを最適化しても煩雑になるばかりなので、やめました。
MemOut クラス
use v6;
use Appendable;
class MemOut does Appendable;
has Buf @!bufbuf;
has Buf $!bufcat = Buf.new();
has Str $!strcat;
method print(*@objs)
{
for @objs».Str -> Str $str {
self.w($str);
}
}
method write(Buf $buf)
{
@!bufbuf.push($buf);
$!strcat = Str;
}
method Buf()
{
my $cat = $!bufcat;
$cat = self!catbuf($cat) if 0 < @!bufbuf;
$cat;
}
method Str()
{
my $cat = $!strcat;
$!strcat = $cat = self!catbuf($!bufcat).decode if $cat === Str;
$cat;
}
method !catbuf($old)
{
my $cat = Buf.new($old.contents, @!bufbuf».contents);
@!bufbuf.splice;
$!bufcat = $cat;
}
オブジェクトは、できるだけ .str-on()、.gist-on() を実装する
Symbol と Cons からなる簡単な構造を定義しました。.str-on(Appendable)、.gist-on(Appendable) が定義されていることが重要です。does Gistable; については後述します。
Symbol クラス
use v6;
use Gistable;
use Appendable;
class Symbol does Gistable;
has $.value;
method new($value)
{
self.bless(*, :$value);
}
method str-on(Appendable $a)
{
$a.w($.value);
}
method gist-on(Appendable $a, $indent = '')
{
$a.w($indent, $.value, "\n");
}
Cons クラス
use v6;
use Gistable;
use Appendable;
class Cons does Gistable;
has $.car;
has $.cdr;
method new($car, $cdr)
{
self.bless(*, :$car, :$cdr);
}
method str-on(Appendable $a)
{
$a.w('(');
$.car.str-on($a).w(' . ');
$.cdr.str-on($a).w(')');
}
method gist-on(Appendable $a, $indent = '')
{
my $deeper = $indent ~ ' ';
$a.w($indent, "(\n");
$.car.gist-on($a, $deeper);
$a.w($indent, ".\n");
$.cdr.gist-on($a, $deeper);
$a.w($indent, ")\n")
}
Gistable ロールで、.str-on() → .Str、.gist-on() → .gist を対応づける
.str-on()、.gist-on() で定義した出力をメモリーに対して行って、.Str、.gist を実現します。
Gistable ロール
use v6;
use MemOut;
use Appendable;
role Gistable;
method Str()
{
self._stringify('str-on');
}
method gist($indent = '')
{
self._stringify('gist-on', $indent);
}
method _stringify($print-on, $indent = '')
{
self."$print-on"(MemOut.new()).Str;
}
こうしてみるとロールは、麻薬的に便利です。
grab-stdout()
まだ説明していないのが GrabStdout です。Perl 5 にあった stdout_is() のようなものを実現するために書きました。NativeCall を使ってシステムコールを呼んでいます。これがとても手軽で驚きました。
# Unix 版の rakudo-star を使ってください。
module GrabStdout;
use v6;
use NativeCall;
sub fork() returns Int is native { ... }
sub wait() returns Int is native { ... }
sub pipe(CArray[int]) returns Int is native { ... }
sub close(int) returns Int is native { ... }
sub dup(int $old) returns int is native { ... }
sub dup2(int $old, Int $new) returns Int is native { ... }
sub grab-stdout(&block) is export
{
my @pipes := CArray[int].new();
@pipes[0] = -1;
@pipes[1] = -1;
pipe(@pipes);
my $pid = fork;
if $pid == 0 {
writer(:@pipes, :&block);
exit(0);
}
reader(:@pipes, :$pid);
}
sub writer(:@pipes!, :&block!)
{
dup2(@pipes[1], 1);
close(@pipes[0]);
close(@pipes[1]);
&block();
}
sub reader(:@pipes!, :$pid!)
{
my $backup = dup(0);
dup2(@pipes[0], 0);
close(@pipes[0]);
close(@pipes[1]);
die unless wait() == $pid;
my $rv = $*IN.slurp;
dup2($backup, 0);
close($backup);
$rv;
}