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