1package Test2::Tools::ClassicCompare; 2use strict; 3use warnings; 4 5our $VERSION = '0.000143'; 6 7our @EXPORT = qw/is is_deeply isnt like unlike cmp_ok/; 8use base 'Exporter'; 9 10use Carp qw/carp/; 11use Scalar::Util qw/reftype/; 12 13use Test2::API qw/context/; 14use Test2::Compare qw/compare strict_convert/; 15use Test2::Util::Ref qw/rtype render_ref/; 16use Test2::Util::Table qw/table/; 17 18use Test2::Compare::Array(); 19use Test2::Compare::Bag(); 20use Test2::Compare::Custom(); 21use Test2::Compare::Event(); 22use Test2::Compare::Hash(); 23use Test2::Compare::Meta(); 24use Test2::Compare::Number(); 25use Test2::Compare::Object(); 26use Test2::Compare::OrderedSubset(); 27use Test2::Compare::Pattern(); 28use Test2::Compare::Ref(); 29use Test2::Compare::Regex(); 30use Test2::Compare::Scalar(); 31use Test2::Compare::Set(); 32use Test2::Compare::String(); 33use Test2::Compare::Undef(); 34use Test2::Compare::Wildcard(); 35 36sub is($$;$@) { 37 my ($got, $exp, $name, @diag) = @_; 38 my $ctx = context(); 39 40 my @caller = caller; 41 42 my $delta = compare($got, $exp, \&is_convert); 43 44 if ($delta) { 45 $ctx->fail($name, $delta->diag, @diag); 46 } 47 else { 48 $ctx->ok(1, $name); 49 } 50 51 $ctx->release; 52 return !$delta; 53} 54 55sub isnt($$;$@) { 56 my ($got, $exp, $name, @diag) = @_; 57 my $ctx = context(); 58 59 my @caller = caller; 60 61 my $delta = compare($got, $exp, \&isnt_convert); 62 63 if ($delta) { 64 $ctx->fail($name, $delta->diag, @diag); 65 } 66 else { 67 $ctx->ok(1, $name); 68 } 69 70 $ctx->release; 71 return !$delta; 72} 73 74sub is_convert { 75 my ($thing) = @_; 76 return Test2::Compare::Undef->new() 77 unless defined $thing; 78 return Test2::Compare::String->new(input => $thing); 79} 80 81sub isnt_convert { 82 my ($thing) = @_; 83 return Test2::Compare::Undef->new() 84 unless defined $thing; 85 my $str = Test2::Compare::String->new(input => $thing, negate => 1); 86} 87 88sub like($$;$@) { 89 my ($got, $exp, $name, @diag) = @_; 90 my $ctx = context(); 91 92 my $delta = compare($got, $exp, \&like_convert); 93 94 if ($delta) { 95 $ctx->fail($name, $delta->diag, @diag); 96 } 97 else { 98 $ctx->ok(1, $name); 99 } 100 101 $ctx->release; 102 return !$delta; 103} 104 105sub unlike($$;$@) { 106 my ($got, $exp, $name, @diag) = @_; 107 my $ctx = context(); 108 109 my $delta = compare($got, $exp, \&unlike_convert); 110 111 if ($delta) { 112 $ctx->fail($name, $delta->diag, @diag); 113 } 114 else { 115 $ctx->ok(1, $name); 116 } 117 118 $ctx->release; 119 return !$delta; 120} 121 122sub like_convert { 123 my ($thing) = @_; 124 return Test2::Compare::Pattern->new( 125 pattern => $thing, 126 stringify_got => 1, 127 ); 128} 129 130sub unlike_convert { 131 my ($thing) = @_; 132 return Test2::Compare::Pattern->new( 133 negate => 1, 134 stringify_got => 1, 135 pattern => $thing, 136 ); 137} 138 139sub is_deeply($$;$@) { 140 my ($got, $exp, $name, @diag) = @_; 141 my $ctx = context(); 142 143 my @caller = caller; 144 145 my $delta = compare($got, $exp, \&strict_convert); 146 147 if ($delta) { 148 # Temporary thing. 149 my $count = 0; 150 my $implicit = 0; 151 my @deltas = ($delta); 152 while (my $d = shift @deltas) { 153 my $add = $d->children; 154 push @deltas => @$add if $add && @$add; 155 next if $d->verified; 156 $count++; 157 $implicit++ if $d->note && $d->note eq 'implicit end'; 158 } 159 160 if ($implicit == $count) { 161 $ctx->ok(1, $name); 162 my $meth = $ENV{AUTHOR_TESTING} ? 'throw' : 'alert'; 163 my $type = $delta->render_check; 164 $ctx->$meth( 165 join "\n", 166 "!!! NOTICE OF BEHAVIOR CHANGE !!!", 167 "This test uses at least 1 $type check without using end() or etc().", 168 "The exising behavior is to default to etc() when inside is_deeply().", 169 "The new behavior is to default to end().", 170 "This test will soon start to fail with the following diagnostics:", 171 $delta->diag->as_string, 172 "", 173 ); 174 } 175 else { 176 $ctx->fail($name, $delta->diag, @diag); 177 } 178 } 179 else { 180 $ctx->ok(1, $name); 181 } 182 183 $ctx->release; 184 return !$delta; 185} 186 187our %OPS = ( 188 '==' => 'num', 189 '!=' => 'num', 190 '>=' => 'num', 191 '<=' => 'num', 192 '>' => 'num', 193 '<' => 'num', 194 '<=>' => 'num', 195 196 'eq' => 'str', 197 'ne' => 'str', 198 'gt' => 'str', 199 'lt' => 'str', 200 'ge' => 'str', 201 'le' => 'str', 202 'cmp' => 'str', 203 '!~' => 'str', 204 '=~' => 'str', 205 206 '&&' => 'logic', 207 '||' => 'logic', 208 'xor' => 'logic', 209 'or' => 'logic', 210 'and' => 'logic', 211 '//' => 'logic', 212 213 '&' => 'bitwise', 214 '|' => 'bitwise', 215 216 '~~' => 'match', 217); 218sub cmp_ok($$$;$@) { 219 my ($got, $op, $exp, $name, @diag) = @_; 220 221 my $ctx = context(); 222 223 # Warnings and syntax errors should report to the cmp_ok call, not the test 224 # context. They may not be the same. 225 my ($pkg, $file, $line) = caller; 226 227 my $type = $OPS{$op}; 228 if (!$type) { 229 carp "operator '$op' is not supported (you can add it to %Test2::Tools::ClassicCompare::OPS)"; 230 $type = 'unsupported'; 231 } 232 233 local ($@, $!, $SIG{__DIE__}); 234 235 my $test; 236 my $lived = eval <<" EOT"; 237#line $line "(eval in cmp_ok) $file" 238\$test = (\$got $op \$exp); 2391; 240 EOT 241 my $error = $@; 242 $ctx->send_event('Exception', error => $error) unless $lived; 243 244 if ($test && $lived) { 245 $ctx->ok(1, $name); 246 $ctx->release; 247 return 1; 248 } 249 250 # Ugh, it failed. Do roughly the same thing Test::More did to try and show 251 # diagnostics, but make it better by showing both the overloaded and 252 # unoverloaded form if overloading is in play. Also unoverload numbers, 253 # Test::More only unoverloaded strings. 254 255 my ($display_got, $display_exp); 256 if($type eq 'str') { 257 $display_got = defined($got) ? "$got" : undef; 258 $display_exp = defined($exp) ? "$exp" : undef; 259 } 260 elsif($type eq 'num') { 261 $display_got = defined($got) ? $got + 0 : undef; 262 $display_exp = defined($exp) ? $exp + 0 : undef; 263 } 264 else { # Well, we did what we could. 265 $display_got = $got; 266 $display_exp = $exp; 267 } 268 269 my $got_ref = ref($got) ? render_ref($got) : $got; 270 my $exp_ref = ref($exp) ? render_ref($exp) : $exp; 271 272 my @table; 273 my $show_both = ( 274 (defined($got) && $got_ref ne "$display_got") 275 || 276 (defined($exp) && $exp_ref ne "$display_exp") 277 ); 278 279 if ($show_both) { 280 @table = table( 281 header => ['TYPE', 'GOT', 'OP', 'CHECK'], 282 rows => [ 283 [$type, $display_got, $op, $lived ? $display_exp : '<EXCEPTION>'], 284 ['orig', $got_ref, '', $exp_ref], 285 ], 286 ); 287 } 288 else { 289 @table = table( 290 header => ['GOT', 'OP', 'CHECK'], 291 rows => [[$display_got, $op, $lived ? $display_exp : '<EXCEPTION>']], 292 ); 293 } 294 295 $ctx->ok(0, $name, [join("\n", @table), @diag]); 296 $ctx->release; 297 return 0; 298} 299 300 3011; 302 303__END__ 304 305=pod 306 307=encoding UTF-8 308 309=head1 NAME 310 311Test2::Tools::ClassicCompare - Classic (Test::More style) comparison tools. 312 313=head1 DESCRIPTION 314 315This provides comparison functions that behave like they did in L<Test::More>, 316unlike the L<Test2::Tools::Compare> plugin which has modified them. 317 318=head1 SYNOPSIS 319 320 use Test2::Tools::ClassicCompare qw/is is_deeply isnt like unlike cmp_ok/; 321 322 is($got, $expect, "These are the same when stringified"); 323 isnt($got, $unexpect, "These are not the same when stringified"); 324 325 like($got, qr/.../, "'got' matches the pattern"); 326 unlike($got, qr/.../, "'got' does not match the pattern"); 327 328 is_deeply($got, $expect, "These structures are same when checked deeply"); 329 330 cmp_ok($GOT, $OP, $WANT, 'Compare these items using the specified operatr'); 331 332=head1 EXPORTS 333 334=over 4 335 336=item $bool = is($got, $expect) 337 338=item $bool = is($got, $expect, $name) 339 340=item $bool = is($got, $expect, $name, @diag) 341 342This does a string comparison of the two arguments. If the two arguments are the 343same after stringification the test passes. The test will also pass if both 344arguments are undef. 345 346The test C<$name> is optional. 347 348The test C<@diag> is optional, it is extra diagnostics messages that will be 349displayed if the test fails. The diagnostics are ignored if the test passes. 350 351It is important to note that this tool considers C<"1"> and C<"1.0"> to not be 352equal as it uses a string comparison. 353 354See L<Test2::Tools::Compare> if you want an C<is()> function that tries 355to be smarter for you. 356 357=item $bool = isnt($got, $dont_expect) 358 359=item $bool = isnt($got, $dont_expect, $name) 360 361=item $bool = isnt($got, $dont_expect, $name, @diag) 362 363This is the inverse of C<is()>, it passes when the strings are not the same. 364 365=item $bool = like($got, $pattern) 366 367=item $bool = like($got, $pattern, $name) 368 369=item $bool = like($got, $pattern, $name, @diag) 370 371Check if C<$got> matches the specified pattern. Will fail if it does not match. 372 373The test C<$name> is optional. 374 375The test C<@diag> is optional. It contains extra diagnostics messages that will 376be displayed if the test fails. The diagnostics are ignored if the test passes. 377 378=item $bool = unlike($got, $pattern) 379 380=item $bool = unlike($got, $pattern, $name) 381 382=item $bool = unlike($got, $pattern, $name, @diag) 383 384This is the inverse of C<like()>. This will fail if C<$got> matches 385C<$pattern>. 386 387=item $bool = is_deeply($got, $expect) 388 389=item $bool = is_deeply($got, $expect, $name) 390 391=item $bool = is_deeply($got, $expect, $name, @diag) 392 393This does a deep check, comparing the structures in C<$got> with those in 394C<$expect>. It will recurse into hashrefs, arrayrefs, and scalar refs. All 395other values will be stringified and compared as strings. It is important to 396note that this tool considers C<"1"> and C<"1.0"> to not be equal as it uses a 397string comparison. 398 399This is the same as C<Test2::Tools::Compare::is()>. 400 401=item cmp_ok($got, $op, $expect) 402 403=item cmp_ok($got, $op, $expect, $name) 404 405=item cmp_ok($got, $op, $expect, $name, @diag) 406 407Compare C<$got> to C<$expect> using the operator specified in C<$op>. This is 408effectively an C<eval "\$got $op \$expect"> with some other stuff to make it 409more sane. This is useful for comparing numbers, overloaded objects, etc. 410 411B<Overloading Note:> Your input is passed as-is to the comparison. 412If the comparison fails between two overloaded objects, the diagnostics will 413try to show you the overload form that was used in comparisons. It is possible 414that the diagnostics will be wrong, though attempts have been made to improve 415them since L<Test::More>. 416 417B<Exceptions:> If the comparison results in an exception then the test will 418fail and the exception will be shown. 419 420C<cmp_ok()> has an internal list of operators it supports. If you provide an 421unsupported operator it will issue a warning. You can add operators to the 422C<%Test2::Tools::ClassicCompare::OPS> hash, the key should be the operator, and 423the value should either be 'str' for string comparison operators, 'num' for 424numeric operators, or any other true value for other operators. 425 426Supported operators: 427 428=over 4 429 430=item == (num) 431 432=item != (num) 433 434=item >= (num) 435 436=item <= (num) 437 438=item > (num) 439 440=item < (num) 441 442=item <=> (num) 443 444=item eq (str) 445 446=item ne (str) 447 448=item gt (str) 449 450=item lt (str) 451 452=item ge (str) 453 454=item le (str) 455 456=item cmp (str) 457 458=item !~ (str) 459 460=item =~ (str) 461 462=item && 463 464=item || 465 466=item xor 467 468=item or 469 470=item and 471 472=item // 473 474=item & 475 476=item | 477 478=item ~~ 479 480=back 481 482=back 483 484=head1 SOURCE 485 486The source code repository for Test2-Suite can be found at 487F<https://github.com/Test-More/Test2-Suite/>. 488 489=head1 MAINTAINERS 490 491=over 4 492 493=item Chad Granum E<lt>exodist@cpan.orgE<gt> 494 495=back 496 497=head1 AUTHORS 498 499=over 4 500 501=item Chad Granum E<lt>exodist@cpan.orgE<gt> 502 503=back 504 505=head1 COPYRIGHT 506 507Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. 508 509This program is free software; you can redistribute it and/or 510modify it under the same terms as Perl itself. 511 512See F<http://dev.perl.org/licenses/> 513 514=cut 515