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.302113';
  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 2017 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