—

              
package Test::Instruction;
use 5.006; use strict; use warnings; our $VERSION = '0.06';
use Compiled::Params::OO qw/cpo/;
use Types::Standard qw/Optional Str Int Bool Any CodeRef ArrayRef HashRef/;
use B qw/svref_2object/;
use Switch::Again qw/switch/;
use Test::More;
use base 'Import::Export';
our (%EX, $validate); 
BEGIN {
        %EX = (
                instruction => [qw/all/],
                instructions => [qw/all/],
                finish => [qw/all/]
        );
        $validate = cpo(
                instruction => {
                        instance  => Optional->of(Any),
                        meth      => Optional->of(Str),
                        func      => Optional->of(CodeRef),
                        args      => Optional->of(Any),
                        args_list => Optional->of(Bool),
                        test      => Optional->of(Str),
                        expected  => Optional->of(Any),
                        catch     => Optional->of(Bool),
                        key       => Optional->of(Str),
                        index     => Optional->of(Int),
                        ref_key   => Optional->of(Str),
                        ref_index => Optional->of(Int),
                        debug     => Optional->of(Bool),
                },
                instructions => {
                        name => Str,
                        run => ArrayRef,
                        build => Optional->of(HashRef),
                        instance => Optional->of(Any),
                        debug => Optional->of(Bool)
                },
                build => {
                        class => Str,
                        new => Optional->of(Str),
                        args => Optional->of(Any),
                        args_list => Optional->of(Bool)
                },
                debug => {
                        name => Str,
                        message => Str,
                        out => Optional->of(Any),
                }
        );
}
sub instruction {
        my $instruction = $validate->instruction->(@_);
         
        debug (
                name => 'Test instruction',
                message => 'Run the test instruction',
                out => $instruction
        ) if $instruction->debug;
        my ($test_name, @test) = ("", ());
        if ( $instruction->catch ) {
                $test_name = 'catch';
                exits $instruction->test or $instruction->test('like');
                eval { _run_the_code( $instruction ) };
                @test = $@;     
        } else {
                @test = _run_the_code( $instruction );
                $test_name = shift @test;
        }
        if ( not $instruction->test ) {
                ok(0, "No 'test' passed with instruction");
                return;
        }
        debug (
                name => $test_name,
                message => 'Code for the test instruction has been executed', 
                out => \@test
        ) if $instruction->debug;
        switch $instruction->test, 
                "ref" => sub { 
                        return is_deeply( $test[0], $instruction->expected, "${test_name} is ref - is_deeply" );
                },
                ref_key_scalar => sub {
                        return ok(0, "No key passed to test - ref_key_scalar - testing - ${test_name}") 
                                if (! $instruction->key );
                        return is(
                                $test[0]->{$instruction->key},
                                $instruction->expected,
                                sprintf "%s is ref - has scalar key: %s - is - %s",
                                $test_name,
                                $instruction->key,
                                $instruction->expected
                        );
                },
                ref_key_like => sub {
                        return ok(0, "No key passed to test - ref_key_like - testing - ${test_name}") 
                                if (! $instruction->key );
                        my $like = $instruction->expected;
                        return like(
                                $test[0]->{$instruction->key},
                                qr/$like/,
                                sprintf "%s is ref - has scalar key: %s - like - %s",
                                $test_name,
                                $instruction->key,
                                $instruction->expected
                        );
                },
                ref_key_ref => sub {
                        return ok(0, "No key passed to test - ref_key_ref - testing - ${test_name}") 
                                if (! $instruction->key );
                        return is_deeply(
                                $test[0]->{$instruction->key},
                                $instruction->expected,
                                sprintf "%s is ref - has ref key: %s - is_deeply - ref",
                                $test_name,
                                $instruction->key,
                        );
                },
                ref_index_scalar => sub {
                        return ok(0, "No index passed to test - ref_index_scalar - testing - ${test_name}") 
                                if (! defined $instruction->index );
                        return is(
                                $test[0]->[$instruction->index],
                                $instruction->expected,
                                sprintf "%s is ref - has scalar index: %s - is - %s",
                                $test_name,
                                $instruction->index,
                                $instruction->expected
                        );
                },
                ref_index_ref => sub {
                        return ok(0, "No index passed to test - ref_index_ref - testing - ${test_name}") 
                                if (! defined $instruction->index );
                        is_deeply(
                                $test[0]->[$instruction->index],
                                $instruction->expected,
                                sprintf "%s is ref - has ref index: %s - is_deeply - ref",
                                $test_name,
                                $instruction->index,
                        );
                },
                ref_index_like => sub {
                        return ok(0, "No index passed to test - ref_index_like - testing - ${test_name}") 
                                if (! defined $instruction->index );
                        my $like = $instruction->expected;   
                        return like(
                                $test[0]->[$instruction->index],
                                qr/$like/,
                                sprintf "%s is ref - has scalar index: %s - like - %s",
                                $test_name,
                                $instruction->index,
                                $instruction->expected
                        );
                },
                ref_index_obj => sub {
                        return ok(0, "No index passed to test - ref_index_obj - testing - ${test_name}") 
                                if (! defined $instruction->index );
                        return isa_ok(
                                $test[0]->[$instruction->index],
                                $instruction->expected,
                                sprintf "%s is ref - has obj index: %s - isa_ok - %s",
                                $test_name,
                                $instruction->index,
                                $instruction->expected
                        );
                },
                list_index_scalar => sub {
                        return ok(0, "No index passed to test - list_index_scalar - testing - ${test_name}") 
                                if (! defined $instruction->index );
                        return is(
                                $test[$instruction->index],
                                $instruction->expected,
                                sprintf "%s is list - has scalar index: %s - is - %s",
                                $test_name,
                                $instruction->index,
                                $instruction->expected
                        );
                },
                list_index_ref => sub {
                        return ok(0, "No index passed to test - list_index_ref - testing - ${test_name}") 
                                if (! defined $instruction->index );
                        return is_deeply(
                                $test[$instruction->index],
                                $instruction->expected,
                                sprintf "%s is list - has ref index: %s - is_deeply - ref",
                                $test_name,
                                $instruction->index,
                        );
                },
                list_index_like => sub {
                        return ok(0, "No index passed to test - list_index_like - testing - ${test_name}") 
                                if (! defined $instruction->index );
                        my $like = $instruction->expected;   
                        return is(
                                $test[$instruction->index],
                                qr/$like/,
                                sprintf "%s is list - has scalar index: %s - like - %s",
                                $test_name,
                                $instruction->index,
                                $instruction->expected
                        );
                },
                list_index_obj => sub {
                        return ok(0, "No index passed to test - list_index_obj - testing - ${test_name}") 
                                if (! defined $instruction->index );
                        return isa_ok(
                                $test[$instruction->index],
                                $instruction->expected,
                                sprintf "%s is list - has obj index: %s - isa_ok - %s",
                                $test_name,
                                $instruction->index,
                                $instruction->expected
                        ),
                },
                list_key_scalar => sub {
                        return ok(0, "No key passed to test - list_key_scalar - testing - ${test_name}") 
                                if (! $instruction->key );
                        return is(
                                {@test}->{$instruction->key},
                                $instruction->expected,
                                sprintf "%s is list - has scalar key: %s - is - %s",
                                $test_name,
                                $instruction->key,
                                $instruction->expected
                        );
                },
                list_key_ref => sub {
                        return ok(0, "No key passed to test - list_key_ref - testing - ${test_name}") 
                                if (! $instruction->key );
                        return is_deeply(
                                {@test}->{$instruction->key},
                                $instruction->expected,
                                sprintf "%s is list - has ref key: %s - is_deeply - ref",
                                $test_name,
                                $instruction->key,
                        );
                },
                list_key_like => sub {
                        return ok(0, "No key passed to test - list_key_like - testing - ${test_name}") 
                                if (! $instruction->key );
                        my $like = $instruction->expected;   
                        return is(
                                {@test}->{$instruction->key},
                                qr/$like/,
                                sprintf "%s is list - has scalar key: %s - like - %s",
                                $test_name,
                                $instruction->key,
                                $instruction->expected
                        );
                },
                count => sub {
                        return is(
                                scalar @test,
                                $instruction->expected,
                                sprintf "%s is array - count - is - %s",
                                $test_name,
                                $instruction->expected
                        );
                },
                count_ref => sub {
                        return is(
                                scalar @{$test[0]},
                                $instruction->expected,
                                sprintf "%s is ref - count - is - %s",
                                $test_name,
                                $instruction->expected
                        );
                },
                scalar => sub {
                        return is( $test[0], $instruction->expected, sprintf "%s is scalar - is - %s",
                                $test_name, defined $instruction->expected ? $instruction->expected : 'undef');
                },
                hash => sub {
                        return is_deeply(
                                scalar @test == 1 ? $test[0] : {@test},
                                $instruction->expected,
                                sprintf "%s is hash - is_deeply",
                                $test_name,
                        );
                },
                array => sub {
                        return is_deeply(
                                scalar @test == 1 ? $test[0] : \@test,
                                $instruction->expected,
                                sprintf "%s is array - is_deeply",
                                $test_name,
                        );
                },
                obj => sub {
                        return isa_ok(
                                $test[0],
                                $instruction->expected,
                                sprintf "%s isa_ok - %s",
                                $test_name,
                                $instruction->expected
                        );
                },
                code => sub {
                        return is(
                                ref $test[0],
                                'CODE',
                                sprintf "%s is a CODE block",
                                $test_name
                        );
                },
                code_execute => sub {
                        return is_deeply(
                                $test[0]->($instruction->args ? @{$instruction->args} : ()),
                                $instruction->expected,
                                sprintf "%s is deeply %s",
                                $test_name,
                                $instruction->expected
                        );
                },
                like => sub {
                        my $like = $instruction->expected;
                        return like(
                                $test[0],
                                qr/$like/,
                                sprintf "%s is like - %s",
                                $test_name,
                                $instruction->expected
                        );
                },
                true => sub {
                        return ok($test[0], "${test_name} is true - 1");
                },
                false => sub {
                        return ok(!$test[0], "${test_name} is false - 0");
                },
                undef => sub {
                        return is($test[0], undef, "${test_name} is undef");
                },
                ok => sub {
                        return ok(@test, "${test_name} is ok");
                },
                skip => sub {
                        return ok(1, "${test_name} - skip");
                },
                default => sub {
                        ok(0, "Unknown instruction $_[0]: passed to instrcution");
                        return;
                };
}
sub instructions { 
        my $instructions = $validate->instructions->(@_);
        debug (
                name => $instructions->name,
                message => 'running test instructions: ' + caller() 
        ) if $instructions->debug;
        ok(1, sprintf "instructions: %s", $instructions->name);
        my $instance = $instructions->build ? _build($instructions->build) : $instructions->instance;
        debug (
                name => $instructions->name,
                message => 'Built the test instance object', 
                out => $instance
        ) if $instructions->debug;
        my %test_info = (
                fail => 0,
                tested => 0,
        );
        for my $instruction (@{$instructions->run}) {
                $test_info{tested}++;
                 
                debug (
                        name => $instructions->name,
                        message => 'Run the next test instruction', 
                        out => $instruction
                ) if $instructions->debug;
                 
                if (my $subtests = delete $instruction->{instructions}) {
                        my ($test_name, $new_instance) = _run_the_code(
                                $validate->instruction->(
                                        instance => $instance,
                                        ($instructions->debug ? (debug => $instructions->debug) : ()),
                                        %{$instruction}
                                )
                        );
                         
                        debug (
                                name => sprintf("%s -> %s", $instructions->name, $test_name),
                                message => 'Run the subtests of the test instruction', 
                                out => $instruction
                        ) if $instructions->debug;
                         
                        $test_info{fail}++
                                unless instruction(
                                        instance => $new_instance,
                                        test => $instruction->{test},
                                        ($instructions->debug ? (debug => $instructions->debug) : ()),
                                        expected => $instruction->{expected}
                                );
                        instructions(
                                instance => $new_instance,
                                run => $subtests,
                                name => sprintf("Subtest -> %s -> %s", $instructions->name, $test_name),
                                ($instructions->debug ? (debug => $instructions->debug) : ()),
                        );
                        next;
                }
                $test_info{fail}++
                        unless instruction(
                                instance => $instance,
                                ($instructions->debug ? (debug => $instructions->debug) : ()),
                                %{$instruction}
                        );
        }
         
        $test_info{ok} = $test_info{fail} ? 0 : 1;
        return ok(
                $test_info{ok},
                sprintf(
                        "instructions: %s - tested %d instructions - success: %d - failure: %d",
                        $instructions->name,
                        $test_info{tested},
                        ($test_info{tested} - $test_info{fail}),
                        $test_info{fail}
                )
        );
}
sub finish {
        my $done_testing = done_testing(shift);
        return $done_testing;
}
sub _build {
        my $build = $validate->build->(@_);
        my $new = $build->new || 'new';
        return $build->class->$new($build->args_list ? @{ $build->args } : defined $build->args ? $build->args : ());
}
sub _run_the_code {
        my $instruction = shift;
        if ($instruction->meth) {
                my $meth = $instruction->meth;
                return (
                        "function: ${meth}",
                        $instruction->instance->$meth(
                                $instruction->args_list 
                                        ? @{ $instruction->args }
                                        : $instruction->args
                        )
                );
        } elsif ($instruction->func) {
                my $func_name = svref_2object($instruction->func)->GV->NAME;
                return (
                        "function: ${func_name}",
                        $instruction->func->($instruction->args_list ? @{$instruction->args} : $instruction->args)
                );
        } elsif ($instruction->ref_key) {
                my $key = $instruction->ref_key;
                return (
                        "key: ${key}",
                        $instruction->instance->{$key}
                );
        } elsif (defined $instruction->ref_index) {
                my $index = $instruction->ref_index;
                return (
                        "index: ${index}",
                        $instruction->instance->[$index]
                );
        } elsif ($instruction->instance) {
                return ('instance', $instruction->instance); 
        }
        die(
                'instruction passed to _run_the_code must have a func, meth or instance key'
        );
}
sub caller_stack {
        my @caller; my $i = 0; my @stack;
        while(@caller = caller($i++)){
                next if $caller[0] eq 'Log::JSON::Lines';
                $stack[$i+1]->{module} = $caller[0];
                $stack[$i+1]->{file} = $1 if $caller[1] =~ /([^\/]+)$/;;
                $stack[$i+1]->{line} = $1 if $caller[2] =~ /(\d+)/;
                $stack[$i]->{sub} = $1 if $caller[3] =~ /([^:]+)$/;
        }
        my $stacktrace = join '->', reverse map {
                my $module = $_->{module} !~ m/^main$/ ? $_->{module} : $_->{file};
                $_->{sub} 
                        ? $module . '::' . $_->{sub} . ':' . $_->{line}
                        : $module . ':' . $_->{line} 
        } grep {
                $_ && $_->{module} && $_->{line} && $_->{file}
        } @stack;
        return $stacktrace;
}
sub debug {
        my $debug = $validate->debug->(@_);
        diag explain $debug->name . ' ~ ' . caller_stack();
        diag explain $debug->message;
        diag explain $debug->out;
}
__END__
1;
HideShow 312 lines of Pod
=head1 NAME
Test::Instruction - A test framework
=head1 VERSION
Version 0.06
=cut
=head1 SYNOPSIS
        use Test::Instruction qw/all/;
        use Module::To::Test;
        instruction(
                test => 'true',
                func => \&Module::To::Test::true_function
        );
        instruction(
                test => 'false',
                func => \&Module::To::Test::false_function
        );
        my $obj = Module::To::Test->new();
        instruction(
                test => 'hash',
                instance => $obj,
                meth => 'method_that_returns_a_hash',
                expected => { a => 1, b => 2, c => 3 }
        );
        finish(3);
        ...
        use Test::Instruction qw/all/;
        instructions(
                name => 'Checking Many Things',
                debug => 1,
                build => {
                        class => 'London',
                },
                run => [
                        {
                                test => 'hash',
                                expected => {
                                        booking => '66/68',
                                }
                        },
                        {
                                test => 'true',
                                meth => 'true',
                        },
                        {
                                test => 'false',
                                meth => 'false',
                        },
                        {
                                test => 'ok',
                                meth => "chain",
                                instructions => [
                                        {
                                                test => 'hash',
                                                expected => {
                                                        paddington => "sleep"
                                                }
                                        }
                                ]
                        }
                ],
        );
        finish();
=head1 EXPORT
=head2 instruction
    instruction(
        test      => 'ok',
        instance  => Module::To::Test->new(),
        func      => 'okay',
        args      => {
            data  => '...'
        },
    );
  
=head3 test 
you can currently run the following tests.
over
  
=item ok - ok - a true value 
  
=item ref - is_deeply - expected [] or {}
  
=item scalar - is - expected '',
  
=item hash - is_deeply - expected {},
  
=item array - is_deeply - expected [],
  
=item obj - isa_ok - expected '',
  
=item like - like - '',
  
=item true - is - 1,
  
=item false - is - 0,
  
=item undef - is - undef
  
=item ref_key_scalar - is - '' (requires key)
  
=item ref_key_ref - is_deeply - [] or {} (requires key)
  
=item ref_key_like - like - ''
  
=item ref_index_scalar - is - '' (requires index)
  
=item ref_index_ref - is_deeply - [] or {} (required index)
  
=item ref_index_like - like - ''
  
=item ref_index_obj - isa_ok - ''
  
=item list_key_scalar - is - '' (requires key)
  
=item list_key_ref - is_deeply - [] or {} (requires key)
  
=item list_key_like - like - ''
  
=item list_index_scalar - is - '' (requires index)
  
=item list_index_ref - is_deeply - [] or {} (required index)
  
=item list_index_obj - isa_ok - ''
  
=item list_index_like - like - ''
  
=item count - is - ''
  
=item count_ref - is - ''
  
=item skip - ok(1)
=item code - is - 'CODE'
=item code_execute - is_deeply - ''
=back
=head3 catch
  
when you want to catch exceptions....
  
    catch => 1,
  
defaults the instruction{test} to like.
  
=head3 instance
  
    my $instance = My::Test::Module->new();
    instance => $instance,
  
=head3 meth
  
call a method from the instance
  
    instance => $instance,
    meth     => 'render'
  
=head3 func
  
    func => \&My::Test::Module::render,
=head3 ref_key
    instance => { a => 1 },
    ref_key => 'a'
=head3 ref_index
    instance => [ 1, 2, 3 ],
    ref_index => 2
  
=head3 args
  
    {} or []
  
=head3 args_list
  
    args      => [qw/one, two/],
    args_list => 1,
  
=head3 index
  
index - required when testing - ref_index_* and list_index_*
  
=head3 key
  
key - required when testing - ref_key_* and list_key_*
  
=cut
=head2 instructions
        package Foo;
        sub new { bless {}, shift; }
        sub bar { ['a', [1, 2, 3], 'b'] }
        1;
        instructions(
                name => 'Testing Foo',
                build => {
                        class => 'Foo',
                },
                run => [
                        {
                                test => 'ok',
                                meth => 'bar',
                                instructions => [
                                        {
                                                test => 'ref_index_scalar',
                                                index => 0,
                                                expected => 'a'
                                        },
                                        {
                                                test => 'ok',
                                                ref_index => 1,
                                                instructions => [
                                                        {
                                                                test => 'array',
                                                                expected => [1, 2, 3]
                                                        },
                                                        {
                                                                test => 'ref_index_scalar',
                                                                index => 0,
                                                                expected => 1
                                                        }
                                                ]
                                        },
                                        ...
                                ]
                        }
                ]
        );
=cut
=head2 finish
        finish();
        finish($total_number_of_tests);
=cut
=head1 AUTHOR
LNATION, C<< <email at lnation.org> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-test-instruction at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Instruction>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
        perldoc Test::Instruction
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker (report bugs here)
L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Instruction>
=item * CPAN Ratings
L<https://cpanratings.perl.org/d/Test-Instruction>
=item * Search CPAN
L<https://metacpan.org/release/Test-Instruction>
=back
=head1 ACKNOWLEDGEMENTS
=head1 LICENSE AND COPYRIGHT
This software is Copyright (c) 2022 by LNATION.
This is free software, licensed under:
        The Artistic License 2.0 (GPL Compatible)
=cut
1; # End of Test::Instruction