enhance to build intermediate data structure

oktest5.pl

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

##
## enhance to build intermediate data structure
##

use strict;
use warnings;


my $NODES = [];

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) = @_;
    if (! $block) {
        print "not ok $num - $text # TODO not implemented yet\n";
        return;
    }
    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;
    }
}

sub OK {
    my ($expr) = @_;
    my ($pkgname, $filepath, $linenum) = caller();
    unless ($expr) {
        die "AssertionFailed at $filepath line $linenum.\n";
    }
}


if ($0 eq __FILE__) {
    topic 'class Foo', sub {
        topic 'sub meth1()', sub {
            case_when "arg is given", sub {
                spec "1+1 should be 2", sub {
                    OK(1+1 == 2);
                };
            };
            case_when "else", sub {
                spec "1-1 should be 0", sub {
                    OK(1-1 == 0);
                };
            };
        };
    };
    run_all();
}