File Coverage

blib/lib/Oktest.pm

Criterion	Covered	Total	%
statement	1040	1099	94.6
branch	346	388	89.1
condition	73	82	89.0
subroutine	223	234	95.3
pod	11	51	21.5
total	1693	1854	91.3

###
### $Release: 0.0103 $
### $Copyright: copyright(c) 2010-2011 kuwata-lab.com all rights reserved $
### $License: MIT License $
###

use strict;
use warnings;
use Data::Dumper;



package Oktest;
use base 'Exporter';
our @EXPORT    = qw(OK pre_cond topic case_when spec before after before_all after_all at_end skip_when TODO);
our @EXPORT_OK = qw(run main with);
our $VERSION   = ('$Release: 0.0103 $' =~ /\d+(\.\d+)*/ && $&);
our @__assertion_objects = ();
our @__at_end_blocks  = ();

sub OK {
    my ($actual) = shift;
    my ($pkgname, $filepath, $linenum) = caller();
    my $location = [$filepath, $linenum, $pkgname];
    my $ao = Oktest::AssertionObject->new($actual, $location);
    push(@__assertion_objects, $ao);
    return $ao;
}

*pre_cond = *OK;    ## alias of OK(), representing pre-condition

sub topic {
    my ($topic_name, $block) = @_;
    my $to = Oktest::TopicObject->new($topic_name);
    return __yield_block($to, $block);
}

sub case_when {
    my ($description, $block) = @_;
    my $co = Oktest::CaseObject->new('When ' . $description, $block);
    return __yield_block($co, $block);
};

sub __yield_block {
    my ($to, $block) = @_;
    my $parent = $Oktest::TopicObject::__current;
    if ($parent) {
        $parent->_add_topic($to);
    }
    else {
        push(@Oktest::TopicObject::__tops, $to);
    }
    $Oktest::TopicObject::__current = $to;
    $block->($to);
    $Oktest::TopicObject::__current = $parent;
    return $to;
}

sub spec {
    my ($spec_desc, $block) = @_;
    $block ||= sub { TODO("not implemented yet.") };
    my $so = Oktest::SpecObject->new($spec_desc, $block);
    my $to = $Oktest::TopicObject::__current;
    $to->_add_spec($so) if $to;
    return $so;
}

sub _set_fixture {
    my ($name, $block) = @_;
    my $to = $Oktest::TopicObject::__current
        or die "$name() should be called in topic block.";
    $to->$name($block);
}

sub before(&) {
    _set_fixture('before', @_);
}

sub after(&) {
    _set_fixture('after', @_);
}

sub before_all(&) {
    _set_fixture('before_all', @_);
}

sub after_all(&) {
    _set_fixture('after_all', @_);
}

sub at_end(&) {
    my ($block) = @_;
    ## todo: check whether at_end() is called in spec block.
    push(@Oktest::__at_end_blocks, $block);
}

sub __at_end_of_spec {
    ## run closures in reverse order
    for my $block (reverse(@Oktest::__at_end_blocks)) {
        $block->();
    }
    @Oktest::__at_end_blocks = ();
}

sub skip_when {
    my ($condition, $reason) = @_;
    if ($condition) {
        die "[Skipped] " . $reason . "\n";
    }
}

sub TODO {
    my ($description) = @_;
    die "[TODO] " . $description . "\n";
}

our %_default_opts = (
    reporter => undef,
    style    => 'tap',
    spec     => undef,
    topic    => undef,
    report_skipped => 0==1,
    report_todo    => 0==1,
);

sub run {
    my %opts = @_;
    %opts = (%_default_opts, %opts);
    my $reporter = $opts{reporter} || Oktest::Reporter::create_instance($opts{style});
    my $runner = $Oktest::Runner::RUNNER->new();
    $runner->{reporter}      = $reporter;
    $runner->{filter_spec}   = $opts{spec};
    $runner->{filter_topic} = $opts{topic};
    $reporter->{report_skipped} ||= $opts{report_skipped};
    $reporter->{report_todo}    ||= $opts{report_todo};
    my @topics = @Oktest::TopicObject::__tops;
    $runner->run_all(@topics);
}

sub main {
    Oktest::MainApp->new(@_)->execute();
}

sub with(&) {
    my ($block) = @_;
    return $block;
}

sub __clear {
    @__assertion_objects = ();
    Oktest::TopicObject::__clear();
}

sub __at_exit {
    for my $ao (@__assertion_objects) {
        unless ($ao->{_done}) {
            my ($filepath, $linenum, $pkgname) = @{$ao->{location}};
            warn "*** OK() called but not tested at '$filepath' line $linenum.\n";
        }
    }
}

END {
    __at_exit();
}

sub __sweep {
    @__assertion_objects = grep { ! $_->{_done} } @__assertion_objects;
}



package Oktest::TopicObject;

our $__current = undef;
our @__tops = ();

our $EXEC   = 1;
our $IGNORE = 0;
our $ENTER  = -1;

sub __last {
    return $__tops[$#__tops];
}

sub __clear {
    $Oktest::TopicObject::__current = undef;
    @Oktest::TopicObject::__tops = ();
}

sub new {
    my ($class, $name, $parent) = @_;
    my $this = {
        name     => $name,
        parent   => $parent,
        topics  => [],
        specs    => [],
        status   => $EXEC,
    };
    return bless($this, $class);
}

sub accept {
    my ($this, $runner, $depth) = @_;
    return $runner->run_topic($this, $depth);
}

sub _add_topic {
    my ($this, $to) = @_;
    die unless $to->isa('Oktest::TopicObject');
    push(@{$this->{topics}}, $to);
    $to->{parent} = $this;
    return $this;
}

sub _add_spec {
    my ($this, $so) = @_;
    die unless $so->isa('Oktest::SpecObject');
    push(@{$this->{specs}}, $so);
    $so->{parent} = $this;
    return $this;
}

sub _count_specs {
    my ($this) = @_;
    my $n = 0;
    for my $to (@{$this->{topics}}) {
        $n += $to->_count_specs();
    }
    if ($this->{status} == $EXEC) {
        for my $so (@{$this->{specs}}) {
            $n++ if $so->{status} == $EXEC;
        }
    }
    return $n;
}

sub before {
    my ($this, $block) = @_;
    $this->{_before} = $block;
}

sub after {
    my ($this, $block) = @_;
    $this->{_after} = $block;
}

sub before_all {
    my ($this, $block) = @_;
    $this->{_before_all} = $block;
}

sub after_all {
    my ($this, $block) = @_;
    $this->{_after_all} = $block;
}

$INC{'Oktest/TopicObject'} = __FILE__;



package Oktest::CaseObject;
our @ISA = ('Oktest::TopicObject');

sub new {
    my ($class, $desc) = @_;
    my $this = $class->SUPER::new($desc);
    return $this;
}



package Oktest::SpecObject;

our $EXEC = $Oktest::TopicObject::EXEC;

sub new {
    my ($class, $desc, $block) = @_;
    my $this = {
        desc   => $desc,
        parent => undef,
        block  => $block,
        status => $EXEC,
    };
    return bless($this, $class);
}

sub accept {
    my ($this, $runner, $depth) = @_;
    return $runner->run_spec($this, $depth);
}



package Oktest::AssertionObject;
use Text::Diff;
use Scalar::Util qw(refaddr);
use Data::Dumper;

sub new {
    my ($class, $actual, $location) = @_;
    my $this = {
        actual   => $actual,
        location => $location,
        _done    => 0==1,
    };
    return bless($this, $class);
}

sub _done {
    my ($this) = @_;
    $this->{_done} = 1==1;
    return $this;
}

our $__dumped_with_indent;
{
    local $Data::Dumper::Terse = 1;
    $_ = Dumper([1]);
    $__dumped_with_indent = /        1/m;    ## true for Perl<=5.22, false for Perl>=5.14
}

sub _repr {
    my ($arg) = @_;
    local $Data::Dumper::Terse = 1;
    if ($__dumped_with_indent) {
        return Dumper($arg);
    }
    else {
        local $Data::Dumper::Pad = '        ';
        my $s = Dumper($arg);
        $s =~ s/^        //;
        return $s;
    }
}

sub _validate_expected {
    my ($this, $expected, $op) = @_;
    my $msg;
    if (Oktest::Util::is_string($expected)) {
        $msg =
            "[ERROR] right hand of '" . $op . "' should not be a string.\n" .
            "  \$actual:   " . _repr($this->{actual}) .
            "  \$expected: " . _repr($expected);
    }
    return $msg;
}

sub _failed_message {
    my ($this, $actual, $op, $expected) = @_;
    my $msg =
        "[Failed] \$actual " . $op . " \$expected : failed.\n" .
        "  \$actual:   " . _repr($actual) .
        "  \$expected: " . _repr($expected);
    return $msg;
}

sub _die {
    my ($this, $errmsg) = @_;
    my $stacktrace = _stacktrace(2, 20);
    $errmsg .= "\n" unless $errmsg =~ /\n$/;
    die $errmsg . $stacktrace;
}

sub _stacktrace {
    my ($depth) = @_;
    my $max = 20;
    my $i = $depth;
    for (; $i < $max; $i++) {
        my ($pkgname, $filename, $linenum, @rest) = caller($i);
        last if $filename ne __FILE__;
    }
    my $str = "";
    for (; $i < $max; $i++) {
        my ($pkgname, $filename, $linenum, @rest) = caller($i);
        last if ! $filename || $filename eq __FILE__;
        $str .= "File '$filename', line $linenum:\n";
        if (-f $filename) {
            my $line = Oktest::Util::read_line_from($filename, $linenum);
            $str .= "    " . Oktest::Util::strip($line) . "\n";
        }
    }
    return $str;
}

sub _assert(&@) {
    my ($closure, $op, $validate, $this, $expected) = @_;
    $this->_done();
    if ($validate) {
        my $msg = $this->_validate_expected($expected, $op);
        die $msg if $msg;
    }
    #unless (defined($expected)) {
    #    my $msg =
    #        "[ERROR] OK() $op \$expected: \$expected is undefined value.\n" .
    #        "  \$expected: " . _repr($expected);
    #    $this->_die($msg);
    #}
    my $actual = $this->{actual};
    #unless (defined($actual)) {
    #    my $msg =
    #        "[ERROR] OK(\$actual): \$actual is undefined value.\n" .
    #        "  \$actual:   " . _repr($actual);
    #    $this->_die($msg);
    #}
    return $this if $closure->($actual, $expected);
    my $msg = $this->_failed_message($actual, $op, $expected);
    $this->_die($msg);
}

use overload
    '==' => \&_num_eq,
    '!=' => \&_num_ne,
    '>'  => \&_num_gt,
    '>=' => \&_num_ge,
    '<'  => \&_num_lt,
    '<=' => \&_num_le,
    'eq' => \&_str_eq,
    'ne' => \&_str_ne,
    'lt' => \&_str_lt,
    'le' => \&_str_le,
    'gt' => \&_str_gt,
    'ge' => \&_str_ge;

sub _num_eq {
    #my ($this, $expected) = @_;
    no warnings 'uninitialized';   # suppress warning 'Use of uninitialized value'
    return _assert { $_[0] == $_[1] } '==', 1, @_;
}

sub _num_ne {
    #my ($this, $expected) = @_;
    no warnings 'uninitialized';
    return _assert { $_[0] != $_[1] } '!=', 1, @_;
}

sub _num_gt {
    no warnings 'uninitialized';
    return _assert { $_[0] > $_[1] } '>', 1, @_;
}

sub _num_ge {
    no warnings 'uninitialized';
    return _assert { $_[0] >= $_[1] } '>=', 1, @_;
}

sub _num_lt {
    no warnings 'uninitialized';
    return _assert { $_[0] < $_[1] } '<', 1, @_;
}

sub _num_le {
    no warnings 'uninitialized';
    return _assert { $_[0] <= $_[1] } '<=', 1, @_;
}

sub _str_eq {
    no warnings 'uninitialized';
    #return _assert { $_[0] eq $_[1] } 'eq', 0, @_;
    my ($this, $expected) = @_;
    $this->_done();
    my $actual = $this->{actual};
    return $this if $actual eq $expected;
    if ($actual !~ /\n/ && $expected !~ /\n/) {
        my $msg =
            "[Failed] \$actual eq \$expected : failed.\n" .
            "  \$actual:   " . _repr($actual) .
            "  \$expected: " . _repr($expected);
        $this->_die($msg);
    }
    else {
        #if ($actual !~ /\n$/ || $expected !~ /\n$/) {
            my $append = "\\ No newline at end\n";
            $actual   .= $append if $actual   !~ /\n$/;
            $expected .= $append if $expected !~ /\n$/;
        #}
        my $diff = Text::Diff::diff(\$expected, \$actual, {STYLE=>'Unified'});
        my $msg =
            "[Failed] \$actual eq \$expected : failed.\n" .
            "--- \$expected\n" .
            "+++ \$actual\n" .
            $diff;
        $this->_die($msg);
    }
}

sub _str_ne {
    no warnings 'uninitialized';
    return _assert { $_[0] ne $_[1] } 'ne', 0, @_;
}

sub _str_gt {
    no warnings 'uninitialized';
    return _assert { $_[0] gt $_[1] } 'gt', 0, @_;
}

sub _str_ge {
    no warnings 'uninitialized';
    return _assert { $_[0] ge $_[1] } 'ge', 0, @_;
}

sub _str_lt {
    no warnings 'uninitialized';
    return _assert { $_[0] lt $_[1] } 'lt', 0, @_;
}

sub _str_le {
    no warnings 'uninitialized';
    return _assert { $_[0] le $_[1] } 'le', 0, @_;
}

sub cmp {
    my ($this, $op, $expected) = @_;
    if    ($op eq '==') { return $this->_num_eq($expected); }
    elsif ($op eq '!=') { return $this->_num_ne($expected); }
    elsif ($op eq '<' ) { return $this->_num_lt($expected); }
    elsif ($op eq '<=') { return $this->_num_le($expected); }
    elsif ($op eq '>' ) { return $this->_num_gt($expected); }
    elsif ($op eq '>=') { return $this->_num_ge($expected); }
    elsif ($op eq 'eq') { return $this->_str_eq($expected); }
    elsif ($op eq 'ne') { return $this->_str_ne($expected); }
    elsif ($op eq 'lt') { return $this->_str_lt($expected); }
    elsif ($op eq 'le') { return $this->_str_le($expected); }
    elsif ($op eq 'gt') { return $this->_str_gt($expected); }
    elsif ($op eq 'ge') { return $this->_str_ge($expected); }
    elsif ($op eq '=~') { return $this->matches($expected); }
    elsif ($op eq '!~') { return $this->not_match($expected); }
    else { $this->_die("[ERROR] OK()->cmp(): '$op': unknown operator.\n"); }
}

sub in_delta {
    my ($this, $expected, $delta) = @_;
    $this->_done();
    my $actual = $this->{actual};
    my ($min, $max) = ($expected - $delta, $expected + $delta);
    unless ($min <= $actual) {
        my $msg =
            '[Failed] $expected - $delta <= $actual : failed.\n' .
            '  $expected - $delta: ' . $min . '\n' .
            '  $actual:            ' . $actual . '\n';
        $msg =~ s/\\n/\n/g;
        $this->_die($msg);
    }
    unless ($actual <= $max) {
        my $msg =
            '[Failed] $actual <= $expected + $delta : failed.\n' .
            '  $actual:            ' . $actual . '\n' .
            '  $expected + $delta: ' . $max . '\n';
        $msg =~ s/\\n/\n/g;
        $this->_die($msg);
    }
    return $this;
}

sub matches {
    my ($this, $expected) = @_;
    $this->_done();
    defined($expected)
        or $this->_die("[ERROR] OK(): use matches(qr/pattern/) instead of matches(/pattern/).");
    return _assert { $_[0] =~ $_[1] } '=~', 0, @_;
}

sub not_match {
    my ($this, $expected) = @_;
    $this->_done();
    defined($expected)
        or $this->_die("[ERROR] OK(): use not_match(qr/pattern/) instead of not_match(/pattern/).");
    return _assert { $_[0] !~ $_[1] } '!~', 0, @_;
}

sub is_a {
    no warnings 'misc';    # suppress warning of "Can't locate package %s for %s::ISA" (for Perl 5.8)
    no warnings 'syntax';  # suppress warning of "Can't locate package %s for %s::ISA" (for Perl 5.10 or later)
    my ($this, $expected) = @_;
    $this->_done();
    #return _assert { $_[0]->isa($_[1]) } ' instanceof ', 0, @_;
    my $actual = $this->{actual};
    unless ($actual->isa($expected)) {
        #my $msg = $this->_failed_message($actual, $op, $expected);
        my $msg = "[Failed] \$actual->isa(\$expected) : failed.\n"
            . "  \$actual:   " . _repr($actual)
            . "  \$expected: " . _repr($expected);
        $this->_die($msg);
    }
    return $this;
}

sub not_a {
    no warnings 'misc';    # suppress warning of "Can't locate package %s for %s::ISA" (for Perl 5.8)
    no warnings 'syntax';  # suppress warning of "Can't locate package %s for %s::ISA" (for Perl 5.10 or later)
    my ($this, $expected) = @_;
    $this->_done();
    #return _assert { ! $_[0]->isa($_[1]) } ' instanceof ', 0, @_;
    my $actual = $this->{actual};
    if ($actual->isa($expected)) {
        #my $msg = $this->_failed_message($actual, $op, $expected);
        my $msg = "[Failed] ! \$actual->isa(\$expected) : failed.\n"
            . "  \$actual:   " . _repr($actual)
            . "  \$expected: " . _repr($expected);
        $this->_die($msg);
    }
    return $this;
}

sub dies {
    my ($this, $errmsg) = @_;
    $this->_done();
    $errmsg = '' unless defined($errmsg);
    my $actual = $this->{actual};
    undef $@;
    eval { $actual->() };
    unless ($@) {
        my $msg =
            "[Failed] exception expected but nothing thrown.\n" .
            "  \$expected: " . _repr($errmsg);
        $this->_die($msg);
    }
    my $ok = 1==1;
    my $op;
    if (! $errmsg) {
        # pass
    }
    elsif (ref($errmsg) eq 'Regexp') {
        $ok = $@ =~ $errmsg;
        $op = '=~';
    }
    else {
        $ok = $@ eq $errmsg;
        if (! $ok) {
            my $s = substr($@, 0, length($errmsg));
            my $rest = substr($@, length($errmsg));
            $ok = $s eq $errmsg && $rest =~ / at .*/;
        };
        $op = 'eq';
    }
    unless ($ok) {
        my $msg =
            '[Failed] $@ ' . $op . ' $expected : failed.' . "\n" .
            '  $@:        ' . _repr($@) .
            '  $expected: ' . _repr($errmsg);
        $this->_die($msg);
    }
    return $this;
}

sub not_die {
    my ($this) = @_;
    $this->_done();
    my $actual = $this->{actual};
    undef $@;
    eval { $actual->() };
    if ($@) {
        my $msg =
            "[Failed] no exception expected but thrown.\n" .
            "  \$\@: " . _repr($@);
        undef $@;
        $this->_die($msg);
    }
    return $this;
}

sub warns {
    my ($this, $expected) = @_;
    $this->_done();
    my $actual = $this->{actual};
    #my $warning = &Oktest::Util::capture_stderr(sub { $actual->() });
    my $warning;
    local $SIG{__WARN__} = sub { $warning = shift };
    $actual->();
    unless ($warning) {
        my $msg =
            "[Failed] warning expected : failed (nothing printed).\n" .
            "  \$expected: " . _repr($expected);
        $this->_die($msg);
    }
    my $new_msg = sub {
        my ($op) = @_;
        return
            "[Failed] \$warning $op \$expected : failed.\n" .
            "  \$warning:  " . _repr($warning) .
            "  \$expected: " . _repr($expected);
    };
    if (ref($expected) eq 'Regexp') {
        #$this->_die($new_msg->('=~')) unless $warning =~ $expected;
        unless ($warning =~ $expected) {
            my $msg = $new_msg->('=~');
            $this->_die($msg);
        }
    }
    else {
        #$this->_die($new_msg->('eq')) unless $warning eq $expected;
        unless ($warning eq $expected) {
            my $msg = $new_msg->('eq');
            $this->_die($msg);
        }
    }
    return $this;
}

sub not_warn {
    my ($this) = @_;
    $this->_done();
    my $actual = $this->{actual};
    my $warning = &Oktest::Util::capture_stderr(sub { $actual->() });
    unless (! $warning) {
        my $msg =
            "[Failed] no warning expected : failed.\n" .
            "  \$warning: " . _repr($warning);
        $this->_die($msg);
    }
    return $this;
}

sub is_string {
    my ($this) = @_;
    return $this->_is_type('string', Oktest::Util::is_string($this->{actual}));
}

sub is_number {
    my ($this) = @_;
    return $this->_is_type('number', Oktest::Util::is_number($this->{actual}));
}

sub is_integer {
    my ($this) = @_;
    return $this->_is_type('integer', Oktest::Util::is_integer($this->{actual}));
}

sub is_float {
    my ($this) = @_;
    return $this->_is_type('float', Oktest::Util::is_float($this->{actual}));
}

sub _is_type {
    my ($this, $type, $bool) = @_;
    $this->_done();
    my $actual = $this->{actual};
    if (! $bool) {
        my $msg =
            "[Failed] \$actual : $type expected, but not.\n" .
            "  \$actual:   " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}

sub is_ref {
    my ($this, $expected) = @_;
    return $this->_is_reference($expected, 'eq', 1==1);
}

sub not_ref {
    my ($this, $expected) = @_;
    return $this->_is_reference($expected, 'ne', 0==1);
}

sub _is_reference {
    my ($this, $expected, $op, $bool) = @_;
    $this->_done();
    my $actual = $this->{actual};
    unless ((ref($actual) eq $expected) == $bool) {
        my $msg =
            "[Failed] ref(\$actual) $op '$expected' : failed.\n" .
            "  ref(\$actual): '" . ref($actual) . "'\n" .
            "  \$actual:    " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}

#sub is_arrayref {
#    my ($this) = @_;
#    return $this->_is_reftype('ARRAY');
#}
#
#sub is_hashref {
#    my ($this) = @_;
#    return $this->_is_reftype('HASH');
#}
#
#sub is_coderef {
#    my ($this) = @_;
#    return $this->_is_reftype('CODE');
#}
#
#sub _is_reftype {
#    my ($this, $reftype) = @_;
#    $this->_done();
#    my $actual = $this->{actual};
#    if (ref($actual) ne $reftype) {
#        my $msg =
#            "[Failed] ref(\$actual) : $reftype expected, but got " . ref($actual) . ".\n" .
#            "  \$actual:   " . _repr($actual);
#        $this->_die($msg);
#    }
#    return $this;
#}

sub length {
    my ($this, $expected) = @_;
    $this->_done();
    my $actual = $this->{actual};
    if (Oktest::Util::is_string($actual)) {
        unless (CORE::length($actual) == $expected) {
            my $msg =
                "[Failed] length(\$actual) == \$expected : failed.\n" .
                "  \$actual:   " . _repr($actual) .
                "  \$expected: " . _repr($expected);
            $this->_die($msg);
        }
    }
    elsif (ref($actual)) {
        my $n = $#{$actual} + 1;
        unless ($n == $expected) {
            my $msg =
                "[Failed] \$\#{$actual} + 1 == \$expected : failed.\n" .
                "  \$actual+1: $n\n" .
                "  \$expected: $expected\n";
            $this->_die($msg);
        }
    }
    else {
        my $msg =
            "[ERROR] \$actual : string or array expected.\n" .
            "  \$actual:   " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}

sub has {
    my ($this, $name, $expected) = @_;
    $this->_done();
    my $actual = $this->{actual};
    unless (defined($actual->{$name})) {
        my $msg =
            "[Failed] defined(\$actual->{$name}) : failed.\n" .
            '  $actual:   ' . _repr($actual);
        $this->_die($msg);
    }
    if ($#_ == 2) {  # when expected value is passed
        unless ($actual->{$name} eq $expected) {
            my $msg =
                "[Failed] \$actual->{$name} eq \$expected : failed.\n" .
                "  \$actual->{$name}: " . _repr($actual->{$name}) .
                "  \$expected:      " . _repr($expected);
            $this->_die($msg);
        }
    }
    return $this;
}

sub can_ {
    my ($this, $method) = @_;
    return $this->_can_or_not($method, 1==1, 'can_', '');
}

sub can_not {
    my ($this, $method) = @_;
    return $this->_can_or_not($method, 0==1, 'can_not', '! ');
}

sub _can_or_not {
    my ($this, $method, $bool, $caller, $op) = @_;
    $this->_done();
    my $actual = $this->{actual};
    unless ($method) {
        my $msg =
            "[ERROR] OK()->$caller(): method name required.\n";
        $this->_die($msg);
    }
    unless (!! $actual->can($method) == $bool) {
        my $msg =
            "[Failed] $op\$actual->can('$method') : failed.\n" .
            "  \$actual:   " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}

sub same {
    my ($this, $expected) = @_;
    return $this->_same_or_not($expected, '==', 1==1);
}

sub not_same {
    my ($this, $expected) = @_;
    return $this->_same_or_not($expected, '!=', 1!=1);
}

sub _same_or_not {
    my ($this, $expected, $op, $bool) = @_;
    $this->_done();
    my $actual = $this->{actual};
    unless ((refaddr($actual) == refaddr($expected)) == $bool) {
        my $msg =
            '[Failed] refaddr($actual) ' . $op . ' refaddr($expected) : failed.' . "\n" .
            '  $actual:   ' . _repr($actual) .
            '  $expected: ' . _repr($expected);
        $this->_die($msg);
    }
    return $this;
}

sub is_truthy {
    my ($this) = @_;
    $this->_done();
    unless ($this->{actual}) {
        my $msg =
            "[Failed] OK(\$expression) : assertion failed.\n" .
            "  \$expression:  " . _repr($this->{actual});
        $this->_die($msg);
    }
    return $this;
}

sub is_falsy {
    my ($this) = @_;
    $this->_done();
    unless (! $this->{actual}) {
        my $msg =
            "[Failed] OK(! \$expression) : assertion failed.\n" .
            "  \$expression:  " . _repr($this->{actual});
        $this->_die($msg);
    }
    return $this;
}

sub is_defined {
    my ($this) = @_;
    $this->_done();
    my $actual = $this->{actual};
    unless (defined($actual)) {
        my $msg =
            "[Failed] defined(\$actual) : failed.\n" .
            "  \$actual:  " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}

sub not_defined {
    my ($this) = @_;
    $this->_done();
    my $actual = $this->{actual};
    unless (! defined($actual)) {
        my $msg =
            "[Failed] ! defined(\$actual) : failed.\n" .
            "  \$actual:  " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}

sub equals {     ## !! EXPERIMENTAL !!
    my ($this, $expected) = @_;
    $this->_done();
    my $actual = $this->{actual};
    #
    unless (ref($actual) eq ref($expected)) {
        my $msg =
            '[Failed] ref($actual) eq ref($expected) : failed.' . "\n" .
            '  ref($actual):   ' . _repr(ref($actual)) .
            '  ref($expected): ' . _repr(ref($expected)) .
            '  $actual:   ' . _repr($actual) .
            '  $expected: ' . _repr($expected);
        $this->_die($msg);
    }
    #
    my $actual_dump   = Dumper($actual);    # _repr($actual);
    my $expected_dump = Dumper($expected);  # _repr($expected);
    unless ($actual_dump eq $expected_dump) {
        my $diff = Text::Diff::diff(\$expected_dump, \$actual_dump, {STYLE=>'Unified'});
        my $msg =
            "[Failed] \$actual equals to \$expected : failed.\n" .
            "--- Dumper(\$expected)\n" .
            "+++ Dumper(\$actual)\n" .
            $diff;
        $this->_die($msg);
    };
    #
    return $this;
}

sub not_equal {     ## !! EXPERIMENTAL !!
    my ($this, $expected) = @_;
    $this->_done();
    my $actual = $this->{actual};
    if (Dumper($actual) eq Dumper($expected)) {
        my $msg =
            "[Failed] \$actual and \$expected are not equal: failed.\n" .
            "  \$actual and \$expected: " . _repr($actual);
        $this->_die($msg);
    };
    return $this;
}

sub all {
    my ($this, $block) = @_;
    $this->_done();
    my $actual = $this->{actual};
    my $index = &Oktest::Util::index_denied($block, @$actual);
    my $found = $index >= 0;
    if ($found) {
        my $msg =
            "[Failed] OK(\$actual)->all(sub{...}) : failed at index=$index.\n" .
            "  \$actual->[$index]: " . _repr($actual->[$index]);
        $this->_die($msg);
    }
    return $this;
}

sub any {
    my ($this, $block) = @_;
    $this->_done();
    my $actual = $this->{actual};
    my $found = &Oktest::Util::index($block, @$actual) >= 0;
    unless ($found) {
        my $msg =
            "[Failed] OK(\$actual)->any(sub{...}) : failed.\n" .
            "  \$actual: " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}

sub file_exists {
    my ($this) = @_;
    return $this->_file_or_dir_exists('file', '-f', -f $this->{actual});
}

sub dir_exists {
    my ($this) = @_;
    return $this->_file_or_dir_exists('directory', '-d', -d $this->{actual});
}

sub _file_or_dir_exists {
    my ($this, $kind, $op, $bool) = @_;
    $this->_done();
    my $actual = $this->{actual};
    unless ($bool) {
        my $msg = ! -e $actual
            ? "[Failed] $op \$actual : failed ($kind not exist).\n"
            : "[Failed] $op \$actual : failed (not a $kind).\n";
        $msg .= "  \$actual:   " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}

#sub not_file {
#    my ($this) = @_;
#    return $this->_not_file_or_dir('file', '-f', -f $this->{actual});
#}
#
#sub not_dir {
#    my ($this) = @_;
#    return $this->_not_file_or_dir('directory', '-d', -d $this->{actual});
#}
#
#sub _not_file_or_dir {
#    my ($this, $kind, $op, $bool) = @_;
#    $this->_done();
#    my $actual = $this->{actual};
#    unless (! $bool) {
#        my $msg =
#            "[Failed] ! $op \$actual : failed ($kind exists).\n" .
#            "  \$actual:   " . _repr($actual);
#        $this->_die($msg);
#    }
#    return $this;
#}
#
#sub exist {
#    my ($this) = @_;
#    $this->_done();
#    my $actual = $this->{actual};
#    unless (-e $actual) {
#        my $msg =
#            "[Failed] -e \$actual : failed (file or directory not found).\n" .
#            "  \$actual:   " . _repr($actual);
#        $this->_die($msg);
#    }
#    return $this;
#}

sub not_exist {
    my ($this) = @_;
    $this->_done();
    my $actual = $this->{actual};
    unless (! -e $actual) {
        my $msg =
            "[Failed] ! -e \$actual : failed (file or directory exists).\n" .
            "  \$actual:   " . _repr($actual);
        $this->_die($msg);
    }
    return $this;
}



package Oktest::Runner;

our $RUNNER = 'Oktest::Runner::DefaultRunner';



package Oktest::Runner::Base;

sub new {
    my ($class) = @_;
    my $this = {
        'reporter' => undef,
    };
    return bless($this, $class);
}

sub reporter {
    my ($this) = @_;
    $this->{reporter} ||= $Oktest::Reporter::REPORTER->new();
    return $this->{reporter};
}

sub run_all {
    my ($this, @topics) = @_;
}

sub run_topic {
    my ($this, $to, $depth) = @_;
}

sub run_spec {
    my ($this, $so, $depth) = @_;
}

sub detect_status {
    my ($this, $errmsg) = @_;
    return '.' unless $errmsg;
    return 'f' if $errmsg =~ /^\[Failed\]/;
    return 'E' if $errmsg =~ /^\[ERROR\]/;
    return 's' if $errmsg =~ /^\[Skipped\]/;
    return 't' if $errmsg =~ /^\[TODO\]/;
    #return '?';
    return 'E';
}



package Oktest::Runner::DefaultRunner;
our @ISA = ('Oktest::Runner::Base');

our $EXEC   = $Oktest::TopicObject::EXEC;
our $IGNORE = $Oktest::TopicObject::IGNORE;
our $ENTER  = $Oktest::TopicObject::ENTER;

sub new {
    my ($class) = @_;
    my $this = $class->SUPER::new();
    $this->{depth} = 0;
    return $this;
}

sub run_all {
    my ($this, @topics) = @_;
    $this->_filter(@topics);
    $this->reporter->enter_all(@topics);
    for my $to (@topics) {
        #$this->run_topic($to, 0);
        $to->accept($this, 0);
    }
    $this->reporter->exit_all(@topics);
}

sub run_topic {
    my ($this, $to, $depth) = @_;        ## $to is a TopicObject
    return if $to->{status} == $IGNORE;
    $this->reporter->enter_topic($to, $depth);
    $to->{_before_all}->() if $to->{_before_all};
    #
    if ($to->{status} == $EXEC) {
        for my $so (@{$to->{specs}}) {
            #$this->run_spec($so, $depth + 1) if $so->{status} == $EXEC;
            $so->accept($this, $depth + 1) if $so->{status} == $EXEC;
        }
    }
    #
    for my $child (@{$to->{topics}}) {
        #$this->run_topic($child, $depth + 1);
        $child->accept($this, $depth + 1);
    }
    #
    $to->{_after_all}->() if $to->{_after_all};
    $this->reporter->exit_topic($to, $depth);
}

sub run_spec {
    my ($this, $so, $depth) = @_;        ## $so is a SpecObject
    $this->reporter->enter_spec($so, $depth);
    my $context = {
        spec  => $so->{desc},
        topic => $so->{parent}->{name},
    };
    my $errmsg;
    undef $@;
    eval { $this->_run_befores($so, $context) };
    if ($@) {
        $errmsg = $@;
        undef $@;
    }
    else {
        eval { $so->{block}->($context) };
        $errmsg = $@;
        undef $@;
        eval { Oktest::__at_end_of_spec() };
        $errmsg .= $@ if $@;
        undef $@;
        eval { $this->_run_afters($so, $context) };
        $errmsg .= $@ if $@;
        undef $@;
    }
    my $status = $this->detect_status($errmsg);
    $this->reporter->exit_spec($so, $depth, $status, $errmsg);
    Oktest::__sweep();
}

sub _run_befores {
    my ($this, $so, $context) = @_;
    my $to = $so->{parent};
    ## parent-first
    my @arr = ();
    while ($to) {
        push(@arr, $to);
        $to = $to->{parent};
    }
    for $to (reverse(@arr)) {
        $to->{_before}->($context) if $to->{_before};
    }
}

sub _run_afters {
    my ($this, $so, $context) = @_;
    my $to = $so->{parent};
    ## child-first
    while ($to) {
        $to->{_after}->($context) if $to->{_after};
        $to = $to->{parent};
    }
}

sub _filter {
    my ($this, @topics) = @_;
    #
    my $pat1 = $this->{filter_spec};
    _filter_specs($pat1, @topics) if $pat1;
    #
    my $pat2 = $this->{filter_topic};
    _filter_topics($pat2, @topics) if $pat2;
    #
    if ($pat1 || $pat2) {
        _change_status_recursively($_) for @topics;
    }
}

sub _filter_specs {
    my ($pat, @topics) = @_;
    for my $to (@topics) {
        my $found = 0==1;
        for my $so (@{$to->{specs}}) {
            if ($so->{desc} =~ $pat) {
                $found = 1==1;
            }
            else {
                $so->{status} = $IGNORE;
            }
        }
        $to->{status} = $IGNORE unless $found;
        _filter_specs($pat, @{$to->{topics}});
    }
}

sub _filter_topics {
    my ($pat, @topics) = @_;
    for my $to (@topics) {
        unless ($to->{name} =~ $pat) {
            $to->{status} = $IGNORE;
            _filter_topics($pat, @{$to->{topics}});
        }
    }
}

sub _change_status_recursively {
    my ($to) = @_;
    my $flag = 0==1;
    for my $child (@{$to->{topics}}) {
        my $ret = _change_status_recursively($child);
        $flag = 1==1 if $ret;
    }
    if ($to->{status} != $IGNORE) {
        return 1==1;   # not ignored
    }
    elsif ($flag) {
        $to->{status} = $ENTER;
        return 1==1;   # not ignored, because non-ignored topic exists in topics
    }
    else {
        return 0==1;   # ignored
    }
}



package Oktest::Reporter;

our $REPORTER = 'Oktest::Reporter::TapReporter';

our %_registered = (
    tap     => 'Oktest::Reporter::TapReporter',
    verbose => 'Oktest::Reporter::VerboseReporter',
    simple  => 'Oktest::Reporter::SimpleReporter',
    plain   => 'Oktest::Reporter::PlainReporter',
    't'     => 'Oktest::Reporter::TapReporter',
    'v'     => 'Oktest::Reporter::VerboseReporter',
    's'     => 'Oktest::Reporter::SimpleReporter',
    'p'     => 'Oktest::Reporter::PlainReporter',
);

sub create_instance {
    my ($style) = @_;
    $style ||= 'tap';    # default: 'tap' style
    my $class = $Oktest::Reporter::_registered{$style};
    return unless $class;
    return $class->new();
}



package Oktest::Reporter::Base;
use Time::HiRes qw(gettimeofday tv_interval);

our %STATUS_LABELS = (
    '.' => 'ok',
    'f' => 'Failed',
    'E' => 'ERROR',
    's' => 'Skipped',
    't' => 'TODO',
    '?' => '???',
);

sub new {
    my ($class) = @_;
    my $this = {
        count     => 0,
        counts    => {},
        separator => '-' x 70,
    };
    return bless($this, $class);
}

sub _indent {
    my ($this, $depth) = @_;
    return '  ' x $depth;
}

sub enter_all {
    my ($this, @topics) = @_;
    $this->{_started_at} = [gettimeofday()];
};

sub exit_all {
    my ($this, @topics) = @_;
    my $elapsed = tv_interval($this->{_started_at});
    undef $this->{_started_at};
    my $c = $this->{counts};
    my $s = sprintf("## ok:%s, failed:%s, error:%s, skipped:%s, todo:%s  (elapsed: %.3f)\n",
                    $c->{'.'}||0, $c->{'f'}||0, $c->{'E'}||0, $c->{'s'}||0, $c->{'t'}||0, $elapsed);
    print $s;
}

sub enter_topic {
    my ($this, $to, $depth) = @_;
};

sub exit_topic {
    my ($this, $to, $depth) = @_;
};

sub enter_spec {
    my ($this, $so, $depth) = @_;
};

sub exit_spec {
    my ($this, $so, $depth, $status, $errmsg) = @_;
    ++$this->{counts}->{$status};
    ++$this->{count};
};

sub _error_should_be_reported {
    my ($this, $status) = @_;
    return 1==1 if $status eq 's' && $this->{report_skipped};
    return 1==1 if $status eq 't' && $this->{report_todo};
    return 1==1 if $status ne 's' && $status ne 't';
    return 0==1;
}

sub _report_errmsg_list {
    my ($this, @exc_items) = @_;
    for (@exc_items) {
        my ($so, $depth, $status, $errmsg) = @$_;
        $this->_print_separator();
        $this->_report_errmsg($so, $status, $errmsg);
    }
    $this->_print_separator() if @exc_items;
}

sub _print_separator {
    my ($this) = @_;
    print '# ', $this->{separator}, "\n";
}

sub _report_errmsg {
    my ($this, $so, $status, $errmsg) = @_;
    if    ($status eq 'f') { $errmsg =~ s/^\[Failed\]/Assertion:/ }
    elsif ($status eq 'E') { }
    elsif ($status eq 's') { $errmsg =~ s/^\[Skipped\]/Reason:/ }
    elsif ($status eq 't') { $errmsg =~ s/^\[TODO\]/Description:/ }
    else                   { }
    print '# [', $STATUS_LABELS{$status}, '] * ', $this->_breadcrumb($so), "\n";
    $_ = $errmsg;
    s/^/# /mg;
    s/\n$//;
    print $_, "\n";
}

sub _breadcrumb {
    my ($this, $so) = @_;
    my @arr = $this->_path_elems($so);
    return join(' > ', @arr);
}

sub _path_elems {
    my ($this, $so) = @_;
    my @arr;
    my $x = $so->{desc};
    push(@arr, $so->{desc});
    my $to = $so->{parent};
    while ($to) {
        push(@arr, $to->{name});
        $to = $to->{parent};
    }
    return reverse(@arr);
}

sub _itemize {
    my ($this, $to) = @_;
    return $to->isa('Oktest::CaseObject') ? '- ' : '* ';
}


package Oktest::Reporter::TapReporter;
our @ISA = ('Oktest::Reporter::Base');

sub enter_all {
    my ($this, @topics) = @_;
    $this->SUPER::enter_all(@topics);
    my $n = 0;
    for my $to (@topics) {
        $n += $to->_count_specs();
    }
    print "1..$n\n";
}

sub enter_topic {
    my ($this, $to, $depth) = @_;
    print '## ', $this->_indent($depth), $this->_itemize($to), $to->{name}, "\n";
};

sub exit_spec {
    my ($this, $so, $depth, $status, $errmsg) = @_;
    $this->SUPER::exit_spec($so, $depth, $status, $errmsg);
    my $n = $this->{count};
    if (! $errmsg) {
        print 'ok ', $n, ' - ', $so->{desc}, "\n";
    }
    elsif ($status eq 's') {
        my $reason = $errmsg;
        $reason =~ s/^\[Skipped\] ?//;
        chomp($reason);
        print 'ok ', $n, ' - ', $so->{desc}, ' # skip - ', $reason, "\n";
    }
    elsif ($status eq 't') {
        my $desc = $errmsg;
        $desc =~ s/^\[TODO\] ?//;
        chomp($desc);
        print 'not ok ', $n, ' - ', $so->{desc}, ' # TODO - ', $desc, "\n";
    }
    else {
        print 'not ok ', $n, ' - ', $so->{desc}, "\n";
        $this->_print_separator();
        $this->_report_errmsg($so, $status, $errmsg);
        $this->_print_separator();
    }
}



package Oktest::Reporter::VerboseReporter;
our @ISA = ('Oktest::Reporter::Base');

sub enter_all {
    my ($this, @topics) = @_;
    $this->SUPER::enter_all(@topics);
    $this->{exc_stack} = [];
}

sub enter_topic {
    my ($this, $to, $depth) = @_;
    $this->SUPER::enter_topic($to, $depth);
    push(@{$this->{exc_stack}}, []);
    print $this->_indent($depth), $this->_itemize($to), $to->{name}, "\n";
};

sub exit_topic {
    my ($this, $to, $depth) = @_;
    $this->SUPER::exit_topic($to, $depth);
    my $exc_items = pop(@{$this->{exc_stack}});
    $this->_report_errmsg_list(@$exc_items);
    undef @$exc_items;
};

sub exit_spec {
    my ($this, $so, $depth, $status, $errmsg) = @_;
    $this->SUPER::exit_spec($so, $depth, $status, $errmsg);
    my $label = $Oktest::Reporter::Base::STATUS_LABELS{$status};
    print $this->_indent($depth), "- [", $label, "] ", $so->{desc};
    if ($errmsg) {
        if ($status eq 's' || $status eq 't') {
            $_ = $errmsg;
            s/^\[(Skipped|TODO)\] ?//;
            chomp();
            print ' ## ', $_;
        }
        if ($this->_error_should_be_reported($status)) {
            my $arr = Oktest::Util::last_item(@{$this->{exc_stack}});
            push(@$arr, [$so, $depth, $status, $errmsg]);
        }
    }
    print "\n";
}



package Oktest::Reporter::SimpleReporter;
our @ISA = ('Oktest::Reporter::Base');

sub enter_all {
    my ($this, @topics) = @_;
    $this->SUPER::enter_all(@topics);
    $this->{exc_stack} = [];
    $this->{_nl} = 1==1;
}

sub enter_topic {
    my ($this, $to, $depth) = @_;
    return if $to->isa('Oktest::CaseObject');
    $this->SUPER::enter_topic($to, $depth);
    push(@{$this->{exc_stack}}, []);
    print "\n" unless $this->{_nl};
    print $this->_indent($depth), $this->_itemize($to), $to->{name};
    print ": " if @{$to->{specs}};
    $this->{_nl} = 0==1;
};

sub exit_topic {
    my ($this, $to, $depth) = @_;
    return if $to->isa('Oktest::CaseObject');
    $this->SUPER::exit_topic($to, $depth);
    my $exc_items = pop(@{$this->{exc_stack}});
    print "\n" unless $this->{_nl};
    $this->{_nl} = 1==1;
    $this->_report_errmsg_list(@$exc_items);
    undef @$exc_items;
};

sub exit_spec {
    my ($this, $so, $depth, $status, $errmsg) = @_;
    $this->SUPER::exit_spec($so, $depth, $status, $errmsg);
    print $status;
    if ($errmsg) {
        if ($this->_error_should_be_reported($status)) {
            #my @stack = @{$this->{exc_stack}};
            #my $arr = $stack[$#stack];
            my $arr = Oktest::Util::last_item(@{$this->{exc_stack}});
            push(@$arr, [$so, $depth, $status, $errmsg]);
        }
    }
}



package Oktest::Reporter::PlainReporter;
our @ISA = ('Oktest::Reporter::Base');

sub enter_all {
    my ($this, @topics) = @_;
    $this->SUPER::enter_all(@topics);
    $this->{exc_items} = [];
}

sub exit_all {
    my ($this, @topics) = @_;
    print "\n";
    $this->_report_errmsg_list(@{$this->{exc_items}});
    $this->SUPER::exit_all(@topics);
}

sub exit_spec {
    my ($this, $so, $depth, $status, $errmsg) = @_;
    $this->SUPER::exit_spec($so, $depth, $status, $errmsg);
    print $status;
    if ($errmsg) {
        my $v = $this->_error_should_be_reported($status);
        if ($this->_error_should_be_reported($status)) {
            push(@{$this->{exc_items}}, [$so, $depth, $status, $errmsg]);
        }
    }
}



package Oktest::Util;
use base 'Exporter';
our @EXPORT_OK = qw(strip last_item length
                    is_string is_number is_integer is_float
                    read_file write_file read_line_from rm_rf system3
                    capture capture_stdouterr capture_stdout capture_stderr);

sub strip {
    my ($s) = @_;
    $s =~ s/^\s+//;
    $s =~ s/\s+$//;
    return $s;
}

sub last_item {
    my (@arr) = @_;
    return $arr[$#arr] if @arr;
    return;
}

sub length {
    my (@arr) = @_;
    return $#arr + 1;
}

sub index(&@) {
    my ($block, @arr) = @_;
    my $i = 0;
    for (@arr) {
        return $i if $block->($_);
        $i++;
    }
    return -1;
}

sub index_denied(&@) {
    my ($block, @arr) = @_;
    my $i = 0;
    for (@arr) {
        return $i unless $block->($_);
        $i++;
    }
    return -1;
}

sub is_string {
    my ($arg) = @_;
    return 0 if ref($arg);              # not scalar
    return 0 unless defined($arg);      # undef
    return 0 if ($arg ^ $arg) eq '0';   # number
    return 1;                           # string
}

sub is_number {
    my ($arg) = @_;
    return 0 if ref($arg);              # not scalar
    return 0 unless defined($arg);      # undef
    return 1 if ($arg ^ $arg) eq '0';   # number
    return 0;                           # string
}

sub is_integer {
    my ($arg) = @_;
    return is_number($arg) && $arg =~ /^-?\d+$/ ? 1 : 0;
}

sub is_float {
    my ($arg) = @_;
    return is_number($arg) && $arg =~ /^-?\d+\.\d+$/ ? 1 : 0;
}

sub read_file {
    my ($filename) = @_;
    open(my $fh, '<', $filename)
        or die "$filename: $!";
    local $/ = undef;
    my $content = <$fh>;
    close($fh)
        or die "$filename: $!";
    return $content;
}

sub write_file {
    my ($filename, $content) = @_;
    open(my $fh, '>', $filename)
        or die "$filename: $!";
    print $fh $content;
    close($fh)
        or die "$filename: $!";
}

our $__read_filename = '';
our @__read_lines = ();

sub read_line_from {
    my ($filename, $linenum) = @_;
    if ($filename ne $__read_filename) {
        open(my $fh, '<', $filename)
            or die "$filename: $!";
        @__read_lines = <$fh>;
        close($fh)
            or die "$filename: $!";
        $__read_filename = $filename;
    }
    return $__read_lines[$linenum-1];
}

sub rm_rf {
    my (@patterns) = @_;
    for my $pattern (@patterns) {
        for my $path (glob($pattern)) {
            _rm_rf($path) if -e $path;
        }
    }
}

sub _rm_rf {
    my ($path) = @_;
    if (-f $path) {
        unlink($path);
    }
    elsif (-d $path) {
        opendir(my $dh, $path);
        my @children = readdir($dh);
        closedir($dh);
        for (@children) {
            _rm_rf("$path/$_") unless $_ eq '.' || $_ eq '..';
        }
        rmdir($path);
    }
}

sub system3 {
    use IPC::Open3;
    use Symbol;
    my ($command, $input) = @_;
    my ($IN, $OUT, $ERR) = (gensym, gensym, gensym);
    open3($IN, $OUT, $ERR, $command);
    print $IN $input if $input;
    close $IN;
    my @output = <$OUT>;
    my @error  = <$ERR>;
    close $OUT;
    close $ERR;
    return join("", @output), join("", @error);
}

sub capture(&) {
    my ($block) = @_;
    my $sout = tie(local *STDOUT, 'Oktest::Util::__PrintHandler');
    local *STDERR = *STDOUT;
    $block->();
    return $sout->output;
}

sub capture_stdouterr(&) {
    my ($block) = @_;
    my $sout = tie(local *STDOUT, 'Oktest::Util::__PrintHandler');
    my $serr = tie(local *STDERR, 'Oktest::Util::__PrintHandler');
    $block->();
    return ($sout->output, $serr->output);
}

sub capture_stdout(&) {
    my ($block) = @_;
    my $sout = tie(local *STDOUT, 'Oktest::Util::__PrintHandler');
    $block->();
    return $sout->output;
}

sub capture_stderr(&) {
    my ($block) = @_;
    my $serr = tie(local *STDERR, 'Oktest::Util::__PrintHandler');
    $block->();
    return $serr->output;
}

$INC{'Oktest/Util.pm'} = __FILE__;



package Oktest::Util::__PrintHandler;

sub TIEHANDLE {
    my ($class) = @_;
    my $this = { output => "" };
    return bless($this, $class);
}

sub PRINT {
    my ($this, @args) = @_;
    for my $arg (@args) {
        $this->{output} .= $arg;
    }
}

sub output {
    my ($this) = @_;
    return $this->{output};
}



package Oktest::Migration::TestMore;    ## !! EXPERIMENTAL !!
use base 'Exporter';
our @EXPORT = qw(ok is isnt like unlike cmp_ok is_deeply can_ok isa_ok pass fail
                 throws_ok dies_ok lives_ok lives_and warning_like diag note explain);
#use Oktest;
no warnings 'void';

sub ok {
    my ($condition, $test_name) = @_;
    Oktest::OK ($condition)->is_truthy();
    return 1==1;
}

sub is {
    my ($this, $that, $test_name) = @_;
    Oktest::OK ($this) eq $that;
    return 1==1;
}

sub isnt {
    my ($this, $that, $test_name) = @_;
    Oktest::OK ($this) ne $that;
    return 1==1;
}

sub like {
    my ($this, $regexp, $test_name) = @_;
    Oktest::OK ($this)->matches($regexp);
    return 1==1;
}

sub unlike {
    my ($this, $regexp, $test_name) = @_;
    Oktest::OK ($this)->not_match($regexp);
    return 1==1;
}

sub cmp_ok {
    my ($this, $op, $that, $test_name) = @_;
    if    ($op eq '==') { Oktest::OK ($this) == $that }
    elsif ($op eq '!=') { Oktest::OK ($this) != $that }
    elsif ($op eq '>' ) { Oktest::OK ($this) >  $that }
    elsif ($op eq '>=') { Oktest::OK ($this) >= $that }
    elsif ($op eq '<' ) { Oktest::OK ($this) <  $that }
    elsif ($op eq '<=') { Oktest::OK ($this) <= $that }
    elsif ($op eq 'eq') { Oktest::OK ($this) eq $that }
    elsif ($op eq 'ne') { Oktest::OK ($this) ne $that }
    elsif ($op eq 'gt') { Oktest::OK ($this) gt $that }
    elsif ($op eq 'ge') { Oktest::OK ($this) ge $that }
    elsif ($op eq 'lt') { Oktest::OK ($this) lt $that }
    elsif ($op eq 'le') { Oktest::OK ($this) le $that }
    elsif ($op eq '=~') { Oktest::OK ($this)->matches($that) }
    elsif ($op eq '!~') { Oktest::OK ($this)->not_match($that) }
    else { die "Oktest::TestMoreMigration::cmp_ok(): operator '$op' not supported.\n" };
    return 1==1;
}

sub is_deeply {
    my ($complex_structure1, $complex_structure2, $test_name) = @_;
    Oktest::OK ($complex_structure1)->equals($complex_structure2);
    return 1==1;
}

sub can_ok {
    my ($module, @methods) = @_;
    Oktest::OK ($module)->can_($_) for (@methods);
    return 1==1;
}

sub isa_ok {
    my ($object, $class) = @_;
    Oktest::OK ($object)->is_a($class);
    return 1==1;
}

sub pass {
    my ($test_name) = @_;
    return 1==1;
}

sub fail {
    my ($test_name) = @_;
    my $msg =
        "[Failed] $test_name\n";
    Oktest::OK()->_done()->_die($msg);
    return;
}

#sub eq_array {
#    my ($this, $that) = @_;
#    Oktest::OK ($this)->equals($that);
#}
#
#sub eq_hash {
#    my ($this, $that) = @_;
#    Oktest::OK ($this)->equals($that);
#}
#
#sub eq_set {
#    my ($this, $that) = @_;
#    Oktest::OK ($this)->equals($that);
#}

sub throws_ok(&$;$) {
    my ($coderef, $pattern, $description) = @_;
    Oktest::OK ($coderef)->dies($pattern);
    return 1==1;
}

sub dies_ok(&;$) {
    my ($coderef, $description) = @_;
    Oktest::OK ($coderef)->dies();
    return 1==1;
}

sub lives_ok(&;$) {
    my ($coderef, $description) = @_;
    Oktest::OK ($coderef)->not_die();
    return 1==1;
}

sub lives_and(&;$) {
    my ($test, $description) = @_;
    Oktest::OK ($test)->not_die();
    return 1==1;
}

sub warning_like(&$;$) {
    my ($coderef, $pattern, $test_name) = @_;
    Oktest::OK ($coderef)->warns($pattern);
    return 1==1;
}

sub diag {
    my ($message) = @_;
    print STDOUT "# $message\n";
    return 0==1;
}

sub note {              ## TODO: check original spec
    my ($message) = @_;
    print STDOUT "# $message\n";
    return 0==1;
}

sub explain {           ## TODO: check original spec
    my ($value) = @_;
    use Data::Dumper;
    local $Data::Dumper::Terse = 1;
    $_ = Dumper($value);
    s/^        //mg;
    return $_;
}

$INC{'Oktest/Migration/TestMore.pm'} = __FILE__;



package Oktest::MainApp;

our $optdef_table = [
    ## name,   short,  long,      argname,    desc
    ['help',      'h', 'help',    '',         'show help'],
    ['version',   'v', 'version', '',         'show version'],
    ['style',     's', 'style',   'name',     'reporting style (tap/verbose/simple/plain, or t/v/s/p)'],
    ['spec',      '',  'spec',    'regexp',   'filter by spec description'],
    ['topic',    '',  'topic',  'regexp',   'filter by topic name'],
    ['r_skipped', '',  'report-skipped', '',  'report detail of skipped items'],
    ['r_todo',    '',  'report-todo',    '',  'report detail of TODO items'],
    ['debug',     'D', 'debug',   '',         ''],
];

our $optdef_list = [];
our $optdef_dict = {};
for (@$optdef_table) {
    my ($name, $short, $long, $argname, $desc) = @$_;
    my $item = { name=>$name, short=>$short, long=>$long, argname=>$argname, desc=>$desc, };
    push(@$optdef_list, $item);
    $optdef_dict->{$short} = $item if $short;
    $optdef_dict->{$long}  = $item if $long;
}

sub new {
    my ($class, $argv, $command) = @_;
    my $this = {
        argv    => $argv || \@ARGV,
        command => $command || ($0 =~ /([-\w.]+)$/ and $1),
    };
    return bless($this, $class);
}

sub _help_message {
    my ($this) = @_;
    my $str =
        $this->{command} . " - a new-style testing library.\n" .
        "Usage:  oktest.pl [options] file_or_dir [file_or_dir2...]\n";
    for my $item (@$optdef_list) {
        $_ = $item;
        my ($name, $short, $long, $argname, $desc) =
            ($_->{name}, $_->{short}, $_->{long}, $_->{argname}, $_->{desc});
        next unless $desc;
        my $s = $short && $long ? "-$short, --$long" . ($argname ? "=$argname" : "")
              : $short          ? "-$short"          . ($argname ? " $argname" : "")
              : $long           ? "    --$long"      . ($argname ? "=$argname" : "")
              : undef;
        $str .= sprintf("  %-20s : %s\n", $s, $desc);
    }
    return $str;
}

sub execute {
    my ($this) = @_;
    my ($opts, $props) = $this->_parse_argv();
    my $DEBUG = $opts->{debug};
    ## help
    if ($opts->{help}) {
        print $this->_help_message();
        return;
    }
    ## version
    if ($opts->{version}) {
        print $Oktest::VERSION, "\n";
        return;
    }
    ## reporter
    my $reporter = Oktest::Reporter::create_instance($opts->{style})
        or die "-s $opts->{style}: unknown reporting style.\n";
    $reporter->{report_skipped} = 1==1 if $opts->{r_skipped};
    $reporter->{report_todo}    = 1==1 if $opts->{r_todo};
    ## options for Oktest::run()
    my $run_options = {
        reporter => $reporter,
        spec     => _str_or_rexp($opts->{spec}),
        topic   => _str_or_rexp($opts->{topic}),
    };
    ## load files
    my @filepaths = ();
    for my $arg (@{$this->{argv}}) {
        -e $arg
            or die "$arg: no such file or directory.\n";
        my @arr = -d $arg ? _find_files($arg, qr/\.t$/) : ($arg);
        push(@filepaths, @arr);
    }
    for my $fpath (@filepaths) {
        print "## require '$fpath'\n" if $DEBUG;
        require $fpath;
    }
    ##
    Oktest::run(%$run_options);
}

sub _str_or_rexp {
    my ($pattern) = @_;
    if ($pattern && $pattern =~ /^\/(.*)\/$/) {
        my $rexp = qr/$1/;
        return $rexp;
    }
    return $pattern;
}

sub _parse_argv {
    my ($this) = @_;
    my $argv    = $this->{argv};
    my $command = $this->{command};
    my $opts    = {};
    #my $props   = {};
    while ($argv->[0] && $argv->[0] =~ /^-/) {
        my $optstr = shift(@$argv);
        last if $optstr eq '--';
        if ($optstr =~ /^--/) {
            $optstr =~ /^--(\w[-\w]*)(=(.*))?$/
                or die "$command: $optstr: invalid option.\n";
            #$props->{$1} = $2 ? $3 : 1;
            my $has_arg = !! $2;
            my ($key, $val) = ($1, $has_arg ? $3 : 1);
            my $item = $optdef_dict->{$key}
                or die "$command: $optstr: unknown option.\n";
            my $arg_required = !! $item->{argname};
            $arg_required && ! $has_arg
                and die "$command: $optstr: argument required.\n";
            ! $arg_required && $has_arg
                and die "$command: $optstr: unexpected argument.\n";
            #$opts->{$key} = $val;
            $opts->{$item->{name}} = $val;
        }
        else {
            my @optchars = split('', substr($optstr, 1));
            while (my $ch = shift(@optchars)) {
                my $item = $optdef_dict->{$ch}
                    or die "$command: -$ch: unknown option.\n";
                my $val;
                my $argname = $item->{argname};
                if    (! $argname) { $val = 1; }
                elsif (@optchars)  { $val = join('', @optchars); @optchars = (); }
                elsif (@$argv)     { $val = shift(@$argv); }
                else { die "$command: -$ch: argument required.\n"; }
                $opts->{$item->{name}} = $val;
            }
        }
    }
    #return $opts, $props;
    return $opts;
};

sub _find_files {
    my ($arg, $rexp) = @_;
    if (-f $arg) {
        return if $rexp && $arg !~ $rexp;
        return ($arg);
    }
    elsif (-d $arg) {
        my @arr = ();
        for (glob("$arg/*")) {
            push(@arr, _find_files($_, $rexp));
        }
        return @arr;
    }
    else {
        die "_find_files(): $arg: not file nor directory.\n";
    }
}



1;


__END__