LoginSignup
1
0

More than 5 years have passed since last update.

Perl6Advent Calendar 2012Day 3
@x19290(Hiroki Horiuchi)

出力ストリームの再発明

Last updated at Posted at 2012-12-26

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

単体テスト

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

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

を調べています。

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

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

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() します。

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 クラス

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 クラス

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 クラス

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 ロール

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

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;
}

1
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
1
0