define topic() and case_when() functions

oktest4.pl

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

##
## define topic() and case_when() functions
##

use strict;
use warnings;


my $spec = undef;
my $num = 0;
my $depth = 0;


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

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

sub _topic {
    my ($text, $block) = @_;
    my $indent = '  ' x $depth;
    print "# $indent$text\n";
    $depth++;
    $block->();
    $depth--;
}

sub spec {
    my ($text, $block) = @_;
    $spec = $text;
    $num++;
    _run_spec($text, $num, $block);
}

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__) {
    print "1..3\n";
    topic 'package Foo', sub {
        topic 'sub meth1()', sub {
            case_when 'arg is passed', sub {
                spec "1+1 should be 2", sub {
                    OK(1+1 == 2);
                };
                spec "1-1 should be 0", sub {
                    OK(1-1 == 0);
                };
            };
        };
        topic 'sub meth2()', sub {
            spec "1*1 should be 1", sub {
                OK(1*1 == 1);
            };
        };
    };
}