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