The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
use strict;
use warnings;
use Test::More qw(no_plan);
use IO::Capture::Stdout;

my $capture_stdout = IO::Capture::Stdout->new();

    # Pass any command line argument to have this test print the
    # Test::Usage output.
my $show_examples_output = defined $ARGV[0];

# --------------------------------------------------------------------
package test1;
use Test::Usage;

sub try {
    my ($exp_lines, $expr_to_eval, $options) = @_;
    t()->reset_options();
    while (my($key, $val) = each %$options) {
        t()->options()->{$key} = $val;
    }
        # Color may interfere with parsing of captured IO.
    t()->options()->{c} = 0;

    $capture_stdout->start();
    eval $expr_to_eval;
    $capture_stdout->stop();
    my $got_text = join '', $capture_stdout->read();
    print($got_text), return if $show_examples_output;
    my ($exp_Ok, $exp_NotOk, $exp_Exp, $exp_Got, $exp_label) = @$exp_lines;
    $exp_label = '-' unless defined $exp_label;
        # There will be a label only if there is an 'ok' or 'not ok' line.
    if ($exp_Ok || $exp_NotOk) {
        Test::More::ok(
            scalar($got_text =~ /^.*$exp_label/),
            "Expecting label to match '$exp_label'."
        ) or Test::More::diag("But it didn't:\n$got_text");
    }
    my $exp_nb_lines = $exp_Ok + $exp_NotOk + $exp_Exp + $exp_Got;
    my $got_nb_lines = @{[split /\n/, $got_text]};
    Test::More::ok(
        $got_nb_lines == $exp_nb_lines,
        "Expecting output to have $exp_nb_lines lines."
        ) or Test::More::diag("But got $got_nb_lines:\n$got_text");
    foo($got_text, $exp_Ok,    '(?<!not )ok');
    foo($got_text, $exp_NotOk, 'not ok');
    foo($got_text, $exp_Exp,   'Exp');
    foo($got_text, $exp_Got,   'Got');
};

sub foo {
    my ($got_text, $exp_matched, $patt) = @_;
    my $got_matched = $got_text =~ /$patt/;
    Test::More::ok(
        $got_matched == $exp_matched,
        sprintf("Expecting '$patt' %sto match.", $exp_matched ? '' : 'not ')
    ) or Test::More::diag("But it didn't:\n$got_text");
}

# --------------------------------------------------------------------
# The actual tests.

  # Expressions we want to test.
my $ok_1 = q.ok(1).;
my $ok_2 = q.ok(1, 'Exp').;
my $ok_3 = q.ok(1, 'Exp', 'Got').;
my $ok_4 = q.ok(0).;
my $ok_5 = q.ok(0, 'Exp').;
my $ok_6 = q.ok(0, 'Exp', 'Got').;
my $ok_7 = q.ok_labeled('a', 1).;

  # Expected results associated to expressions and option values.
my @tries = (
    # Expected counts of
    # [[notOk, Ok, Exp, Got], $expr, test_options],

    [[0, 0, 0, 0], $ok_1 , {v => 0}],
    [[0, 0, 0, 0], $ok_1 , {v => 1}],
    [[1, 0, 0, 0], $ok_1 , {v => 2}],

    [[0, 0, 0, 0], $ok_2 , {v => 0}],
    [[0, 0, 0, 0], $ok_2 , {v => 1}],
    [[1, 0, 1, 0], $ok_2 , {v => 2}],

    [[0, 0, 0, 0], $ok_3 , {v => 0}],
    [[0, 0, 0, 0], $ok_3 , {v => 1}],
    [[1, 0, 1, 0], $ok_3 , {v => 2}],

    [[0, 0, 0, 0], $ok_4 , {v => 0}],
    [[0, 1, 0, 0], $ok_4 , {v => 1}],
    [[0, 1, 0, 0], $ok_4 , {v => 2}],

    [[0, 0, 0, 0], $ok_5 , {v => 0}],
    [[0, 1, 1, 0], $ok_5 , {v => 1}],
    [[0, 1, 1, 0], $ok_5 , {v => 2}],

    [[0, 0, 0, 0], $ok_6 , {v => 0}],
    [[0, 1, 1, 1], $ok_6 , {v => 1}],
    [[0, 1, 1, 1], $ok_6 , {v => 2}],

    [[0, 1, 0, 0], $ok_1 , {v => 2, f => 1}],
    [[0, 1, 0, 0, '-.a'], $ok_7 , {v => 2, f => 1}],
);

try(@$_) for @tries;