出力ストリームの再発明

Perl 6 標準の出力ストリームが少し気に入らなかったので、車輪を発明してしまいました。

# 単体テスト

流行に乗って、まずテストケースの形で今回実現することを書きます。以下では、

1. 出力のカスケードが機能していること (`$obj.s(123).s('abc').g('')`)
2. 標準出力に対してもメモリーストリームに対しても同様に `.str-on()`、`.gist-on()` できること
3. Gistable が機能していること

を調べています。

なお、謎の segmentation fault がたまに出るので、テストを二つに分割しました。

```perl6:a.t6
#!/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 - 
```

```perl6:b.t6
#!/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` というメッセージを送り、以下同様にする場合、次のように書けます。

```smalltalk
obj m1; m2; m3; m4; ... .
```

これをメッセージのカスケードと呼びます。もちろん、同じことは

```smalltalk
obj m1. obj m2. obj m3. obj m4. obj ... .
```

でできますが、カスケードの方が何かと便利です。実際、C++ であまりにも有名なのが ostream 用にオーバーライドされた << 演算子で、以下の表現はおなじみでしょう。

```c++
cout << "hello" << endl;
```

言語レベルでカスケードをサポートしていない C++ では、`operator<<()` が `return *this;` することで、ライブラリーレベルで、ほぼ同じ効果を実現しています。

Java にも、ライブラリーレベルでの出力のカスケードがあります。これを可能にしているのが Appendable インターフェースです。

```java
StringBuffer.new().append("hello").append("\n").toString();
```

余談ですが Java に Appendable インターフェースが導入されたのは Java 1.5 からで、実際、

```java
StringBuffer.new().append("hello").append("\n").toString();
```

は可能でも、

```java
System.out.append("hello").append("\n");
```

は不可能な時期がありました。

今回は、Perl 6 のロールを使って、Java の Appendable のようなものを作ってみます。

## `Appendable` ロール

`Appendable` な Perl 6 オブジェクト `$a` に、`$o` を出力するには、

```perl6
$a.s($o);
```

あるいは

```perl6
$a.g($o);
```

とします。

Java のインターフェースと違って、ロールには、実装を書くことができます。`Appendable` ロールでは、`.s()`、`.g()` が `self` を返すことでメッセージをカスケードできるようにします。またこれらの本体では、引数オブジェクトが `.str-on()`、`.gist-on()` を理解するかどうかを調べ、理解したならその結果を取り入れ、理解しなかったら Perl の `.Str()`、`.gist()` を使って引数を文字列化したものを `self.w()` します。

```perl6:Appendable.pm6
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` クラス

```perl6:MemOut.pm6
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` クラス

```perl6:Symbol.pm6
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` クラス

```perl6:Cons.pm6
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` ロール

```perl6:Gistable.pm6
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` を使ってシステムコールを呼んでいます。これがとても手軽で驚きました。

```perl6:GrabStdout.pm6
# 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;
}
```

https://github.com/x19290/2012advent.p6/tree/master/a.streams