1package Test2::Tools::Tiny;
2use strict;
3use warnings;
4
5BEGIN {
6    if ($] lt "5.008") {
7        require Test::Builder::IO::Scalar;
8    }
9}
10
11use Scalar::Util qw/blessed/;
12
13use Test2::Util qw/try/;
14use Test2::API qw/context run_subtest test2_stack/;
15
16use Test2::Hub::Interceptor();
17use Test2::Hub::Interceptor::Terminator();
18
19our $VERSION = '1.302194';
20
21BEGIN { require Exporter; our @ISA = qw(Exporter) }
22our @EXPORT = qw{
23    ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing
24    warnings exception tests capture
25};
26
27sub ok($;$@) {
28    my ($bool, $name, @diag) = @_;
29    my $ctx = context();
30
31    return $ctx->pass_and_release($name) if $bool;
32    return $ctx->fail_and_release($name, @diag);
33}
34
35sub is($$;$@) {
36    my ($got, $want, $name, @diag) = @_;
37    my $ctx = context();
38
39    my $bool;
40    if (defined($got) && defined($want)) {
41        $bool = "$got" eq "$want";
42    }
43    elsif (defined($got) xor defined($want)) {
44        $bool = 0;
45    }
46    else {    # Both are undef
47        $bool = 1;
48    }
49
50    return $ctx->pass_and_release($name) if $bool;
51
52    $got  = '*NOT DEFINED*' unless defined $got;
53    $want = '*NOT DEFINED*' unless defined $want;
54    unshift @diag => (
55        "GOT:      $got",
56        "EXPECTED: $want",
57    );
58
59    return $ctx->fail_and_release($name, @diag);
60}
61
62sub isnt($$;$@) {
63    my ($got, $want, $name, @diag) = @_;
64    my $ctx = context();
65
66    my $bool;
67    if (defined($got) && defined($want)) {
68        $bool = "$got" ne "$want";
69    }
70    elsif (defined($got) xor defined($want)) {
71        $bool = 1;
72    }
73    else {    # Both are undef
74        $bool = 0;
75    }
76
77    return $ctx->pass_and_release($name) if $bool;
78
79    unshift @diag => "Strings are the same (they should not be)"
80        unless $bool;
81
82    return $ctx->fail_and_release($name, @diag);
83}
84
85sub like($$;$@) {
86    my ($thing, $pattern, $name, @diag) = @_;
87    my $ctx = context();
88
89    my $bool;
90    if (defined($thing)) {
91        $bool = "$thing" =~ $pattern;
92        unshift @diag => (
93            "Value: $thing",
94            "Does not match: $pattern"
95        ) unless $bool;
96    }
97    else {
98        $bool = 0;
99        unshift @diag => "Got an undefined value.";
100    }
101
102    return $ctx->pass_and_release($name) if $bool;
103    return $ctx->fail_and_release($name, @diag);
104}
105
106sub unlike($$;$@) {
107    my ($thing, $pattern, $name, @diag) = @_;
108    my $ctx = context();
109
110    my $bool;
111    if (defined($thing)) {
112        $bool = "$thing" !~ $pattern;
113        unshift @diag => (
114            "Unexpected pattern match (it should not match)",
115            "Value:   $thing",
116            "Matches: $pattern"
117        ) unless $bool;
118    }
119    else {
120        $bool = 0;
121        unshift @diag => "Got an undefined value.";
122    }
123
124    return $ctx->pass_and_release($name) if $bool;
125    return $ctx->fail_and_release($name, @diag);
126}
127
128sub is_deeply($$;$@) {
129    my ($got, $want, $name, @diag) = @_;
130    my $ctx = context();
131
132    no warnings 'once';
133    require Data::Dumper;
134
135    # Otherwise numbers might be unquoted
136    local $Data::Dumper::Useperl  = 1;
137
138    local $Data::Dumper::Sortkeys = 1;
139    local $Data::Dumper::Deparse  = 1;
140    local $Data::Dumper::Freezer  = 'XXX';
141    local *UNIVERSAL::XXX         = sub {
142        my ($thing) = @_;
143        if (ref($thing)) {
144            $thing = {%$thing}  if "$thing" =~ m/=HASH/;
145            $thing = [@$thing]  if "$thing" =~ m/=ARRAY/;
146            $thing = \"$$thing" if "$thing" =~ m/=SCALAR/;
147        }
148        $_[0] = $thing;
149    };
150
151    my $g = Data::Dumper::Dumper($got);
152    my $w = Data::Dumper::Dumper($want);
153
154    my $bool = $g eq $w;
155
156    return $ctx->pass_and_release($name) if $bool;
157    return $ctx->fail_and_release($name, $g, $w, @diag);
158}
159
160sub diag {
161    my $ctx = context();
162    $ctx->diag(join '', @_);
163    $ctx->release;
164}
165
166sub note {
167    my $ctx = context();
168    $ctx->note(join '', @_);
169    $ctx->release;
170}
171
172sub skip_all {
173    my ($reason) = @_;
174    my $ctx = context();
175    $ctx->plan(0, SKIP => $reason);
176    $ctx->release if $ctx;
177}
178
179sub todo {
180    my ($reason, $sub) = @_;
181    my $ctx = context();
182
183    # This code is mostly copied from Test2::Todo in the Test2-Suite
184    # distribution.
185    my $hub    = test2_stack->top;
186    my $filter = $hub->pre_filter(
187        sub {
188            my ($active_hub, $event) = @_;
189            if ($active_hub == $hub) {
190                $event->set_todo($reason) if $event->can('set_todo');
191                $event->add_amnesty({tag => 'TODO', details => $reason});
192            }
193            else {
194                $event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1});
195            }
196            return $event;
197        },
198        inherit => 1,
199        todo    => $reason,
200    );
201    $sub->();
202    $hub->pre_unfilter($filter);
203
204    $ctx->release if $ctx;
205}
206
207sub plan {
208    my ($max) = @_;
209    my $ctx = context();
210    $ctx->plan($max);
211    $ctx->release;
212}
213
214sub done_testing {
215    my $ctx = context();
216    $ctx->done_testing;
217    $ctx->release;
218}
219
220sub warnings(&) {
221    my $code = shift;
222    my @warnings;
223    local $SIG{__WARN__} = sub { push @warnings => @_ };
224    $code->();
225    return \@warnings;
226}
227
228sub exception(&) {
229    my $code = shift;
230    local ($@, $!, $SIG{__DIE__});
231    my $ok = eval { $code->(); 1 };
232    my $error = $@ || 'SQUASHED ERROR';
233    return $ok ? undef : $error;
234}
235
236sub tests {
237    my ($name, $code) = @_;
238    my $ctx = context();
239
240    my $be = caller->can('before_each');
241
242    $be->($name) if $be;
243
244    my $bool = run_subtest($name, $code, 1);
245
246    $ctx->release;
247
248    return $bool;
249}
250
251sub capture(&) {
252    my $code = shift;
253
254    my ($err, $out) = ("", "");
255
256    my $handles = test2_stack->top->format->handles;
257    my ($ok, $e);
258    {
259        my ($out_fh, $err_fh);
260
261        ($ok, $e) = try {
262          # Scalar refs as filehandles were added in 5.8.
263          if ($] ge "5.008") {
264            open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
265            open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!";
266          }
267          # Emulate scalar ref filehandles with a tie.
268          else {
269            $out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT";
270            $err_fh = Test::Builder::IO::Scalar->new(\$err) or die "Failed to open a temporary STDERR";
271          }
272
273            test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]);
274
275            $code->();
276        };
277    }
278    test2_stack->top->format->set_handles($handles);
279
280    die $e unless $ok;
281
282    $err =~ s/ $/_/mg;
283    $out =~ s/ $/_/mg;
284
285    return {
286        STDOUT => $out,
287        STDERR => $err,
288    };
289}
290
2911;
292
293__END__
294
295=pod
296
297=encoding UTF-8
298
299=head1 NAME
300
301Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use
302L<Test2::Suite>.
303
304=head1 DESCRIPTION
305
306You should really look at L<Test2::Suite>. This package is some very basic
307essential tools implemented using L<Test2>. This exists only so that L<Test2>
308and other tools required by L<Test2::Suite> can be tested. This is the package
309L<Test2> uses to test itself.
310
311=head1 USE Test2::Suite INSTEAD
312
313Use L<Test2::Suite> if at all possible.
314
315=head1 EXPORTS
316
317=over 4
318
319=item ok($bool, $name)
320
321=item ok($bool, $name, @diag)
322
323Run a simple assertion.
324
325=item is($got, $want, $name)
326
327=item is($got, $want, $name, @diag)
328
329Assert that 2 strings are the same.
330
331=item isnt($got, $do_not_want, $name)
332
333=item isnt($got, $do_not_want, $name, @diag)
334
335Assert that 2 strings are not the same.
336
337=item like($got, $regex, $name)
338
339=item like($got, $regex, $name, @diag)
340
341Check that the input string matches the regex.
342
343=item unlike($got, $regex, $name)
344
345=item unlike($got, $regex, $name, @diag)
346
347Check that the input string does not match the regex.
348
349=item is_deeply($got, $want, $name)
350
351=item is_deeply($got, $want, $name, @diag)
352
353Check 2 data structures. Please note that this is a I<DUMB> implementation that
354compares the output of L<Data::Dumper> against both structures.
355
356=item diag($msg)
357
358Issue a diagnostics message to STDERR.
359
360=item note($msg)
361
362Issue a diagnostics message to STDOUT.
363
364=item skip_all($reason)
365
366Skip all tests.
367
368=item todo $reason => sub { ... }
369
370Run a block in TODO mode.
371
372=item plan($count)
373
374Set the plan.
375
376=item done_testing()
377
378Set the plan to the current test count.
379
380=item $warnings = warnings { ... }
381
382Capture an arrayref of warnings from the block.
383
384=item $exception = exception { ... }
385
386Capture an exception.
387
388=item tests $name => sub { ... }
389
390Run a subtest.
391
392=item $output = capture { ... }
393
394Capture STDOUT and STDERR output.
395
396Result looks like this:
397
398    {
399        STDOUT => "...",
400        STDERR => "...",
401    }
402
403=back
404
405=head1 SOURCE
406
407The source code repository for Test2 can be found at
408F<http://github.com/Test-More/test-more/>.
409
410=head1 MAINTAINERS
411
412=over 4
413
414=item Chad Granum E<lt>exodist@cpan.orgE<gt>
415
416=back
417
418=head1 AUTHORS
419
420=over 4
421
422=item Chad Granum E<lt>exodist@cpan.orgE<gt>
423
424=back
425
426=head1 COPYRIGHT
427
428Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
429
430This program is free software; you can redistribute it and/or
431modify it under the same terms as Perl itself.
432
433See F<http://dev.perl.org/licenses/>
434
435=cut
436