diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm')
-rwxr-xr-x | Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm | 425 |
1 files changed, 425 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm b/Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm new file mode 100755 index 00000000000..857a923c6a2 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Test2/Tools/Tiny.pm @@ -0,0 +1,425 @@ +package Test2::Tools::Tiny; +use strict; +use warnings; + +use Scalar::Util qw/blessed/; + +use Test2::Util qw/try/; +use Test2::API qw/context run_subtest test2_stack/; + +use Test2::Hub::Interceptor(); +use Test2::Hub::Interceptor::Terminator(); + +our $VERSION = '1.302073'; + +BEGIN { require Exporter; our @ISA = qw(Exporter) } +our @EXPORT = qw{ + ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing + warnings exception tests capture +}; + +sub ok($;$@) { + my ($bool, $name, @diag) = @_; + my $ctx = context(); + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool ? 1 : 0; +} + +sub is($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($got) && defined($want)) { + $bool = "$got" eq "$want"; + } + elsif (defined($got) xor defined($want)) { + $bool = 0; + } + else { # Both are undef + $bool = 1; + } + + unless ($bool) { + $got = '*NOT DEFINED*' unless defined $got; + $want = '*NOT DEFINED*' unless defined $want; + unshift @diag => ( + "GOT: $got", + "EXPECTED: $want", + ); + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub isnt($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($got) && defined($want)) { + $bool = "$got" ne "$want"; + } + elsif (defined($got) xor defined($want)) { + $bool = 1; + } + else { # Both are undef + $bool = 0; + } + + unshift @diag => "Strings are the same (they should not be)" + unless $bool; + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub like($$;$@) { + my ($thing, $pattern, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($thing)) { + $bool = "$thing" =~ $pattern; + unshift @diag => ( + "Value: $thing", + "Does not match: $pattern" + ) unless $bool; + } + else { + $bool = 0; + unshift @diag => "Got an undefined value."; + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub unlike($$;$@) { + my ($thing, $pattern, $name, @diag) = @_; + my $ctx = context(); + + my $bool; + if (defined($thing)) { + $bool = "$thing" !~ $pattern; + unshift @diag => ( + "Unexpected pattern match (it should not match)", + "Value: $thing", + "Matches: $pattern" + ) unless $bool; + } + else { + $bool = 0; + unshift @diag => "Got an undefined value."; + } + + $ctx->ok($bool, $name, \@diag); + $ctx->release; + return $bool; +} + +sub is_deeply($$;$@) { + my ($got, $want, $name, @diag) = @_; + my $ctx = context(); + + no warnings 'once'; + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Deparse = 1; + local $Data::Dumper::Freezer = 'XXX'; + local *UNIVERSAL::XXX = sub { + my ($thing) = @_; + if (ref($thing)) { + $thing = {%$thing} if "$thing" =~ m/=HASH/; + $thing = [@$thing] if "$thing" =~ m/=ARRAY/; + $thing = \"$$thing" if "$thing" =~ m/=SCALAR/; + } + $_[0] = $thing; + }; + + my $g = Data::Dumper::Dumper($got); + my $w = Data::Dumper::Dumper($want); + + my $bool = $g eq $w; + + my $diff; + + $ctx->ok($bool, $name, [$diff ? $diff : ($g, $w), @diag]); + $ctx->release; + return $bool; +} + +sub diag { + my $ctx = context(); + $ctx->diag(join '', @_); + $ctx->release; +} + +sub note { + my $ctx = context(); + $ctx->note(join '', @_); + $ctx->release; +} + +sub skip_all { + my ($reason) = @_; + my $ctx = context(); + $ctx->plan(0, SKIP => $reason); + $ctx->release if $ctx; +} + +sub todo { + my ($reason, $sub) = @_; + my $ctx = context(); + + # This code is mostly copied from Test2::Todo in the Test2-Suite + # distribution. + my $hub = test2_stack->top; + my $filter = $hub->pre_filter( + sub { + my ($active_hub, $event) = @_; + + # Turn a diag into a note + return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag'; + + # Set todo on ok's + if ($hub == $active_hub && $event->isa('Test2::Event::Ok')) { + $event->set_todo($reason); + $event->set_effective_pass(1); + } + + return $event; + }, + inherit => 1, + todo => $reason, + ); + $sub->(); + $hub->pre_unfilter($filter); + + $ctx->release if $ctx; +} + +sub plan { + my ($max) = @_; + my $ctx = context(); + $ctx->plan($max); + $ctx->release; +} + +sub done_testing { + my $ctx = context(); + $ctx->done_testing; + $ctx->release; +} + +sub warnings(&) { + my $code = shift; + my @warnings; + local $SIG{__WARN__} = sub { push @warnings => @_ }; + $code->(); + return \@warnings; +} + +sub exception(&) { + my $code = shift; + local ($@, $!, $SIG{__DIE__}); + my $ok = eval { $code->(); 1 }; + my $error = $@ || 'SQUASHED ERROR'; + return $ok ? undef : $error; +} + +sub tests { + my ($name, $code) = @_; + my $ctx = context(); + + before_each() if __PACKAGE__->can('before_each'); + + my $bool = run_subtest($name, $code, 1); + + $ctx->release; + + return $bool; +} + +sub capture(&) { + my $code = shift; + + my ($err, $out) = ("", ""); + + my $handles = test2_stack->top->format->handles; + my ($ok, $e); + { + my ($out_fh, $err_fh); + + ($ok, $e) = try { + open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; + open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; + + test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); + + $code->(); + }; + } + test2_stack->top->format->set_handles($handles); + + die $e unless $ok; + + $err =~ s/ $/_/mg; + $out =~ s/ $/_/mg; + + return { + STDOUT => $out, + STDERR => $err, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use +L<Test2::Suite>. + +=head1 DESCRIPTION + +You should really look at L<Test2::Suite>. This package is some very basic +essential tools implemented using L<Test2>. This exists only so that L<Test2> +and other tools required by L<Test2::Suite> can be tested. This is the package +L<Test2> uses to test itself. + +=head1 USE Test2::Suite INSTEAD + +Use L<Test2::Suite> if at all possible. + +=head1 EXPORTS + +=over 4 + +=item ok($bool, $name) + +=item ok($bool, $name, @diag) + +Run a simple assertion. + +=item is($got, $want, $name) + +=item is($got, $want, $name, @diag) + +Assert that 2 strings are the same. + +=item isnt($got, $do_not_want, $name) + +=item isnt($got, $do_not_want, $name, @diag) + +Assert that 2 strings are not the same. + +=item like($got, $regex, $name) + +=item like($got, $regex, $name, @diag) + +Check that the input string matches the regex. + +=item unlike($got, $regex, $name) + +=item unlike($got, $regex, $name, @diag) + +Check that the input string does not match the regex. + +=item is_deeply($got, $want, $name) + +=item is_deeply($got, $want, $name, @diag) + +Check 2 data structures. Please note that this is a I<DUMB> implementation that +compares the output of L<Data::Dumper> against both structures. + +=item diag($msg) + +Issue a diagnostics message to STDERR. + +=item note($msg) + +Issue a diagnostics message to STDOUT. + +=item skip_all($reason) + +Skip all tests. + +=item todo $reason => sub { ... } + +Run a block in TODO mode. + +=item plan($count) + +Set the plan. + +=item done_testing() + +Set the plan to the current test count. + +=item $warnings = warnings { ... } + +Capture an arrayref of warnings from the block. + +=item $exception = exception { ... } + +Capture an exception. + +=item tests $name => sub { ... } + +Run a subtest. + +=item $output = capture { ... } + +Capture STDOUT and STDERR output. + +Result looks like this: + + { + STDOUT => "...", + STDERR => "...", + } + +=back + +=head1 SOURCE + +The source code repository for Test2 can be found at +F<http://github.com/Test-More/test-more/>. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum E<lt>exodist@cpan.orgE<gt> + +=back + +=head1 COPYRIGHT + +Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F<http://dev.perl.org/licenses/> + +=cut |