define AssertionObject class

oktest7.pl

# -*- coding: utf-8 -*-

##
## define AssertionObject class
##

use strict;
use warnings;


package AssertionObject;
use Data::Dumper;

sub new {
    my ($class, $actual) = @_;
    my $self = {actual=>$actual};
    return bless($self, $class);
}

sub _compare {
    my ($self, $expr, $actual, $op, $expected) = @_;
    unless ($expr) {
        my ($pkgname, $filepath, $linenum) = caller(1);
        my $msg = $self->_failed_msg($actual, $op, $expected, $filepath, $linenum);
        die $msg;
    }
    return $self;
}

sub _failed_msg {
    my ($self, $actual, $op, $expected, $filepath, $linenum) = @_;
    return "AssertionFailed at $filepath line $linenum.\n"
          ."\$actual $op \$expected: failed\n"
          ."  actual:   ".$self->_dump($actual)."\n"
          ."  expected: ".$self->_dump($expected)."\n";
}

sub _dump {
    my ($self, $value) = @_;
    local $Data::Dumper::Terse = 1;
    $_ = Dumper($value);
    s/\n\z//;
    return $_;
}

## operator overload
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,
    '=~' => \&match;    # not supported?


## '==' operator
sub num_eq {
    my ($self, $expected) = @_;
    return $self->_compare($self->{actual} == $expected,
                           $self->{actual}, '==', $expected);
}

## 'eq' operator
sub str_eq {
    my ($self, $expected) = @_;
    return $self->_compare($self->{actual} eq $expected,
                           $self->{actual}, 'eq', $expected);
}

## '=~' operator
sub match {
    my ($self, $expected) = @_;
    return $self->_compare($self->{actual} =~ $expected,
                           $self->{actual}, '=~', $expected);
}

## instead of 'is_deeply()'
sub equals {
    my ($self, $expected) = @_;
    my $a_dump = Dumper($self->{actual});
    my $e_dump = Dumper($expected);
    unless ($a_dump eq $e_dump) {
        require Text::Diff;
        my ($pkgname, $filepath, $linenum) = caller(0);
        my $diff = Text::Diff::diff(\$e_dump, \$a_dump, {STYLE=>'Unified'});
        my $msg = "AssertionFailed at $filepath line $linenum\n"
                 ."\$actual equals to \$expected : failed.\n"
                 ."--- Dumper(\$expected)\n"
                 ."+++ Dumper(\$actual)\n"
                 .$diff;
        die $msg;
    };
    return $self;
}


package main;

my $NODES = [];
my @BLOCKS = ();


sub topic {
    my ($name, $block) = @_;
    _topic($name, '*', $block);
}

sub case_when {
    my ($condition, $block) = @_;
    _topic("when $condition", '-', $block);
}

sub _topic {
    my ($name, $prefix, $block) = @_;
    my $node = {name=>$name, prefix=>$prefix, children=>[]};
    push @$NODES, $node;
    my $bkup = $NODES;
    $NODES = $node->{children};
    $block->();
    $NODES = $bkup;
}

sub spec {
    my ($text, $block) = @_;
    push @$NODES, [$text, $block];
}

sub _count_specs {
    my ($nodes) = @_;
    my $n = 0;
    for (@$nodes) {
        $n += ref($_) eq 'HASH'  ? _count_specs($_->{children})  # topic
            : ref($_) eq 'ARRAY' ? 1 : 0;                        # spec
    }
    return $n;
}

sub run_all {
    print "1..", _count_specs($NODES), "\n";
    _run_all($NODES, 0, 0);
}

sub _run_all {
    my ($nodes, $depth, $num) = @_;
    my $indent = '  ' x $depth;
    for my $x (@$nodes) {
        if (ref($x) eq 'HASH') {      # topic
            print "# $indent$x->{prefix} $x->{name}\n";
            $num = _run_all($x->{children}, $depth + 1, $num);
        }
        elsif (ref($x) eq 'ARRAY') {  # spec
            my ($text, $block) = @$x;
            $num++;
            _run_spec($text, $num, $block);
        }
    }
    return $num;
}

sub _run_spec {
    my ($text, $num, $block) = @_;
    eval {
        $block->();
    };
    my $err = $@;
    $@ = undef;
    if (! $err) {
        print "ok $num - $text\n";
    }
    else {
        print "not ok $num - $text\n";
        $err =~ s/^/#   /mg;
        $err .= "\n" unless $err =~ /\n\z/;
        print STDERR $err;
    }
    ## call and clear registered blocks
    for (reverse(@BLOCKS)) {
        $_->();
    }
    @BLOCKS = ();
}

sub at_end(&) {
    my ($block) = @_;
    push @BLOCKS, $block;
}

sub OK {
    my ($actual) = @_;
    return AssertionObject->new($actual);
}


if ($0 eq __FILE__) {
    no warnings 'void';
    topic 'class Foo', sub {
        topic 'sub meth1()', sub {
            case_when "arg is given", sub {
                spec "...spec#1...", sub {
                    OK (1+1) == 2;
                    OK ('hom') eq 'hom';
                    #OK('hom') =~ qr/^\w+$/;   # not work
                };
            };
            case_when "else", sub {
                spec "...spec#2...", sub {
                    OK ("1.0") == 1.0;
                };
                spec "...spec#3...", sub {
                    OK ("1.0") eq 1.0;          # will fail
                };
                spec "...spec#4...", sub {
                    OK ({name=>'Homura'})->equals({name=>'HomHom'});  # will fail
                };
            };
        };
    };
    run_all();
}