Synch with CPAN Test-Simple 1.302140.
[perl.git] / cpan / Test-Simple / lib / Test2 / Tools / Tiny.pm
1 package Test2::Tools::Tiny;
2 use strict;
3 use warnings;
4
5 BEGIN {
6     if ($] lt "5.008") {
7         require Test::Builder::IO::Scalar;
8     }
9 }
10
11 use Scalar::Util qw/blessed/;
12
13 use Test2::Util qw/try/;
14 use Test2::API qw/context run_subtest test2_stack/;
15
16 use Test2::Hub::Interceptor();
17 use Test2::Hub::Interceptor::Terminator();
18
19 our $VERSION = '1.302140';
20
21 BEGIN { require Exporter; our @ISA = qw(Exporter) }
22 our @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
27 sub 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
35 sub 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
62 sub 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
85 sub 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
106 sub 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
128 sub 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
160 sub diag {
161     my $ctx = context();
162     $ctx->diag(join '', @_);
163     $ctx->release;
164 }
165
166 sub note {
167     my $ctx = context();
168     $ctx->note(join '', @_);
169     $ctx->release;
170 }
171
172 sub skip_all {
173     my ($reason) = @_;
174     my $ctx = context();
175     $ctx->plan(0, SKIP => $reason);
176     $ctx->release if $ctx;
177 }
178
179 sub 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
207 sub plan {
208     my ($max) = @_;
209     my $ctx = context();
210     $ctx->plan($max);
211     $ctx->release;
212 }
213
214 sub done_testing {
215     my $ctx = context();
216     $ctx->done_testing;
217     $ctx->release;
218 }
219
220 sub warnings(&) {
221     my $code = shift;
222     my @warnings;
223     local $SIG{__WARN__} = sub { push @warnings => @_ };
224     $code->();
225     return \@warnings;
226 }
227
228 sub 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
236 sub 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
251 sub 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
291 1;
292
293 __END__
294
295 =pod
296
297 =encoding UTF-8
298
299 =head1 NAME
300
301 Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use
302 L<Test2::Suite>.
303
304 =head1 DESCRIPTION
305
306 You should really look at L<Test2::Suite>. This package is some very basic
307 essential tools implemented using L<Test2>. This exists only so that L<Test2>
308 and other tools required by L<Test2::Suite> can be tested. This is the package
309 L<Test2> uses to test itself.
310
311 =head1 USE Test2::Suite INSTEAD
312
313 Use 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
323 Run a simple assertion.
324
325 =item is($got, $want, $name)
326
327 =item is($got, $want, $name, @diag)
328
329 Assert 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
335 Assert that 2 strings are not the same.
336
337 =item like($got, $regex, $name)
338
339 =item like($got, $regex, $name, @diag)
340
341 Check that the input string matches the regex.
342
343 =item unlike($got, $regex, $name)
344
345 =item unlike($got, $regex, $name, @diag)
346
347 Check 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
353 Check 2 data structures. Please note that this is a I<DUMB> implementation that
354 compares the output of L<Data::Dumper> against both structures.
355
356 =item diag($msg)
357
358 Issue a diagnostics message to STDERR.
359
360 =item note($msg)
361
362 Issue a diagnostics message to STDOUT.
363
364 =item skip_all($reason)
365
366 Skip all tests.
367
368 =item todo $reason => sub { ... }
369
370 Run a block in TODO mode.
371
372 =item plan($count)
373
374 Set the plan.
375
376 =item done_testing()
377
378 Set the plan to the current test count.
379
380 =item $warnings = warnings { ... }
381
382 Capture an arrayref of warnings from the block.
383
384 =item $exception = exception { ... }
385
386 Capture an exception.
387
388 =item tests $name => sub { ... }
389
390 Run a subtest.
391
392 =item $output = capture { ... }
393
394 Capture STDOUT and STDERR output.
395
396 Result looks like this:
397
398     {
399         STDOUT => "...",
400         STDERR => "...",
401     }
402
403 =back
404
405 =head1 SOURCE
406
407 The source code repository for Test2 can be found at
408 F<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
428 Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
429
430 This program is free software; you can redistribute it and/or
431 modify it under the same terms as Perl itself.
432
433 See F<http://dev.perl.org/licenses/>
434
435 =cut