add at_end() which registers blocks called end of test.

oktest6.pl

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

##
## add at_end() which registers blocks called end of test.
##

use strict;
use warnings;


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) = @_;
    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;
    }
    ## call and clear registered blocks
    for (reverse(@BLOCKS)) {
        $_->();
    }
    @BLOCKS = ();
}

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

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 {
            my $fx_file = sub {
                my ($content) = @_;
                $content = "" unless defined($content);
                my $file = "hoge.data";
                open(my $f, '>', $file) or die $!;
                print $f $content;
                close($f);
                ## remove file at end of test
                at_end { unlink $file if -f $file; };
                ##
                return $file;
            };
            case_when "arg is given", sub {
                spec "fixture example", sub {
                    my $file = $fx_file->("HOMHOM");
                    OK(-f $file);
                    OK(-s $file == 6);
                };
            };
        };
    };
    run_all();
}