File Coverage

File:local/lib/perl5/Test/Differences.pm
Coverage:11.5%

linestmtbrancondsubtimecode
1package Test::Differences;
2
3 - 284
=head1 NAME

Test::Differences - Test strings and data structures and show differences if not ok

=head1 VERSION

0.61

=head1 SYNOPSIS

   use Test;    ## Or use Test::More
   use Test::Differences;

   eq_or_diff $got,  "a\nb\nc\n",   "testing strings";
   eq_or_diff \@got, [qw( a b c )], "testing arrays";

   ## Passing options:
   eq_or_diff $got, $expected, $name, { context => 300 };  ## options

   ## Using with DBI-like data structures

   use DBI;

   ... open connection & prepare statement and @expected_... here...

   eq_or_diff $sth->fetchall_arrayref, \@expected_arrays  "testing DBI arrays";
   eq_or_diff $sth->fetchall_hashref,  \@expected_hashes, "testing DBI hashes";

   ## To force textual or data line numbering (text lines are numbered 1..):
   eq_or_diff_text ...;
   eq_or_diff_data ...;

=head1 EXPORT

This module exports three test functions and four diff-style functions:

=over 4

=item * Test functions

=over 4

=item * C<eq_or_diff>

=item * C<eq_or_diff_data>

=item * C<eq_or_diff_text>

=back

=item * Diff style functions

=over 4

=item * C<table_diff> (the default)

=item * C<unified_diff>

=item * C<oldstyle_diff>

=item * C<context_diff>

=back

=back

=head1 DESCRIPTION

When the code you're testing returns multiple lines, records or data
structures and they're just plain wrong, an equivalent to the Unix
C<diff> utility may be just what's needed.  Here's output from an
example test script that checks two text documents and then two
(trivial) data structures:

 t/99example....1..3
 not ok 1 - differences in text
 #     Failed test ((eval 2) at line 14)
 #     +---+----------------+----------------+
 #     | Ln|Got             |Expected        |
 #     +---+----------------+----------------+
 #     |  1|this is line 1  |this is line 1  |
 #     *  2|this is line 2  |this is line b  *
 #     |  3|this is line 3  |this is line 3  |
 #     +---+----------------+----------------+
 not ok 2 - differences in whitespace
 #     Failed test ((eval 2) at line 20)
 #     +---+------------------+------------------+
 #     | Ln|Got               |Expected          |
 #     +---+------------------+------------------+
 #     |  1|        indented  |        indented  |
 #     *  2|        indented  |\tindented        *
 #     |  3|        indented  |        indented  |
 #     +---+------------------+------------------+
 not ok 3
 #     Failed test ((eval 2) at line 22)
 #     +----+-------------------------------------+----------------------------+
 #     | Elt|Got                                  |Expected                    |
 #     +----+-------------------------------------+----------------------------+
 #     *   0|bless( [                             |[                           *
 #     *   1|  'Move along, nothing to see here'  |  'Dry, humorless message'  *
 #     *   2|], 'Test::Builder' )                 |]                           *
 #     +----+-------------------------------------+----------------------------+
 # Looks like you failed 3 tests of 3.

eq_or_diff_...() compares two strings or (limited) data structures and
either emits an ok indication or a side-by-side diff.  Test::Differences
is designed to be used with Test.pm and with Test::Simple, Test::More,
and other Test::Builder based testing modules.  As the SYNOPSIS shows,
another testing module must be used as the basis for your test suite.

These functions assume that you are presenting it with "flat" records,
looking like:

   - scalars composed of record-per-line
   - arrays of scalars,
   - arrays of arrays of scalars,
   - arrays of hashes containing only scalars

All of these are flattened in to single strings which are then compared
for differences.  Differently data structures can be compared, as long
as they flatten identically.

All other data structures are run through Data::Dumper first.  This is a
bit dangerous, as some versions of perl shipped with Data::Dumpers that
could do the oddest things with unexpected, like core dump.  Only as of
5.8.0 does Data::Dumper sort hash keys, which is necessary for HASH
dumps to be fully predictable.  This will be changed when this bites
somebody or I get some free time.

C<eq_or_diff()> starts counting records at 0 unless you pass it two text
strings:

   eq_or_diff $a, $b;   ## First line is line number 1
   eq_or_diff @a, @b;   ## First element is element 0
   eq_or_diff $a, @b;   ## First line/element is element 0

If you want to force a first record number of 0, use C<eq_or_diff_data>.  If
you want to force a first record number of 1, use C<eq_or_diff_text>.  I chose
this over passing in an options hash because it's clearer and simpler this way.
YMMV.

=head1 OPTIONS

The options to C<eq_or_diff> give some fine-grained control over the output.

=over 4

=item * C<context>

This allows you to control the amount of context shown:

   eq_or_diff $got, $expected, $name, { context => 50000 };

will show you lots and lots of context.  Normally, eq_or_diff() uses
some heuristics to determine whether to show 3 lines of context (like
a normal unified diff) or 25 lines.

=item * C<data_type>

C<text> or C<data>. See C<eq_or_diff_text> and C<eq_or_diff_data> to
understand this. You can usually ignore this.

=item * C<Sortkeys>

If passed, whatever value is added is used as the argument for L<Data::Dumper>
Sortkeys option. See the L<Data::Dumper> docs to understand how you can
control the Sortkeys behavior.

=back

=head1 DIFF STYLES

For extremely long strings, a table diff can wrap on your screen and be hard
to read.  If you are comfortable with different diff formats, you can switch
to a format more suitable for your data.  These are the four formats supported
by the L<Text::Diff> module and are set with the following functions:

=over 4

=item * C<table_diff> (the default)

=item * C<unified_diff>

=item * C<oldstyle_diff>

=item * C<context_diff>

=back

You can run the following to understand the different diff output styles:

 use Test::More 'no_plan';
 use Test::Differences;

 my $long_string = join '' => 1..40;

 TODO: {
     local $TODO = 'Testing diff styles';

     # this is the default and does not need to explicitly set unless you need
     # to reset it back from another diff type
     table_diff;
     eq_or_diff $long_string, "-$long_string", 'table diff';

     unified_diff;
     eq_or_diff $long_string, "-$long_string", 'unified diff';

     context_diff;
     eq_or_diff $long_string, "-$long_string", 'context diff';

     oldstyle_diff;
     eq_or_diff $long_string, "-$long_string", 'oldstyle diff';
 }

=head1 DEPLOYING

There are several basic ways of deploying Test::Differences requiring more or less
labor by you or your users.

=over

=item *

Fallback to C<is_deeply>.

This is your best option if you want this module to be optional.

 use Test::More;
 BEGIN {
     if (!eval q{ use Test::Differences; 1 }) {
         *eq_or_diff = \&is_deeply;
     }
 }

=item *

 eval "use Test::Differences";

If you want to detect the presence of Test::Differences on the fly, something
like the following code might do the trick for you:

    use Test qw( !ok );   ## get all syms *except* ok

    eval "use Test::Differences";
    use Data::Dumper;

    sub ok {
        goto &eq_or_diff if defined &eq_or_diff && @_ > 1;
        @_ = map ref $_ ? Dumper( @_ ) : $_, @_;
        goto Test::&ok;
    }

    plan tests => 1;

    ok "a", "b";

=item *

PREREQ_PM => { .... "Test::Differences" => 0, ... }

This method will let CPAN and CPANPLUS users download it automatically.  It
will discomfit those users who choose/have to download all packages manually.

=item *

t/lib/Test/Differences.pm, t/lib/Text/Diff.pm, ...

By placing Test::Differences and its prerequisites in the t/lib directory, you
avoid forcing your users to download the Test::Differences manually if they
aren't using CPAN or CPANPLUS.

If you put a C<use lib "t/lib";> in the top of each test suite before the
C<use Test::Differences;>, C<make test> should work well.

You might want to check once in a while for new Test::Differences releases
if you do this.



=back

=cut
285
286our $VERSION = "0.61"; # or "0.001_001" for a dev release
287$VERSION = eval $VERSION;
288
289
6
6
6
14
4
195
use Exporter;
290
291@ISA    = qw( Exporter );
292@EXPORT = qw(
293  eq_or_diff
294  eq_or_diff_text
295  eq_or_diff_data
296  unified_diff
297  context_diff
298  oldstyle_diff
299  table_diff
300);
301
302
6
6
6
12
5
61
use strict;
303
304
6
6
6
12
4
158
use Carp;
305
6
6
6
844
6
1494
use Text::Diff;
306
307sub _isnt_ARRAY_of_scalars {
308
0
    return 1 if ref ne "ARRAY";
309
0
    return scalar grep ref, @$_;
310}
311
312sub _isnt_HASH_of_scalars {
313
0
    return 1 if ref ne "HASH";
314
0
    return scalar grep ref, values %$_;
315}
316
317
6
6
6
19
0
146
use constant ARRAY_of_scalars           => "ARRAY of scalars";
318
6
6
6
13
2
96
use constant ARRAY_of_ARRAYs_of_scalars => "ARRAY of ARRAYs of scalars";
319
6
6
6
9
5
80
use constant ARRAY_of_HASHes_of_scalars => "ARRAY of HASHes of scalars";
320
6
6
6
8
5
4145
use constant HASH_of_scalars            => "HASH of scalars";
321
322{
323    my $diff_style = 'Table';
324    my %allowed_style = map { $_ => 1 } qw/Unified Context OldStyle Table/;
325    sub _diff_style {
326
0
        return $diff_style unless @_;
327
0
        my $requested_style = shift;
328
0
        unless ( $allowed_style{$requested_style} ) {
329
0
           Carp::croak("Uknown style ($requested_style) requested for diff");
330        }
331
0
        $diff_style = $requested_style;
332    }
333}
334
335
0
sub unified_diff  { _diff_style('Unified') }
336
0
sub context_diff  { _diff_style('Context') }
337
0
sub oldstyle_diff { _diff_style('OldStyle') }
338
0
sub table_diff    { _diff_style('Table') }
339
340sub _grok_type {
341
0
    local $_ = shift if @_;
342
0
    return "SCALAR" unless ref;
343
0
    if ( ref eq "ARRAY" ) {
344
0
        return undef unless @$_;
345
0
        return ARRAY_of_scalars
346          unless _isnt_ARRAY_of_scalars;
347
0
        return ARRAY_of_ARRAYs_of_scalars
348          unless grep _isnt_ARRAY_of_scalars, @$_;
349
0
        return ARRAY_of_HASHes_of_scalars
350          unless grep _isnt_HASH_of_scalars, @$_;
351
0
        return 0;
352    }
353    elsif ( ref eq 'HASH' ) {
354
0
        return HASH_of_scalars
355          unless _isnt_HASH_of_scalars($_);
356
0
        return 0;
357    }
358}
359
360## Flatten any acceptable data structure in to an array of lines.
361sub _flatten {
362
0
    my $type = shift;
363
0
    local $_ = shift if @_;
364
365
0
    return [ split /^/m, _quote_str($_) ] unless ref;
366
367
0
    croak "Can't flatten $_" unless $type;
368
369    ## Copy the top level array so we don't trash the originals
370
0
    my ( @recs, %hash_copy );
371
0
    if ( ref $_ eq 'ARRAY' ) {
372
0
        @recs = @$_;
373    }
374    elsif ( ref $_ eq 'HASH' ) {
375
0
        %hash_copy = %$_;
376    }
377    else {
378
0
        die "unsupported ref type";
379    }
380
0
    if ( $type eq ARRAY_of_scalars) {
381
0
0
        @recs = map { _quote_str($_) } @recs;
382    }
383    elsif ( $type eq ARRAY_of_ARRAYs_of_scalars ) {
384        ## Also copy the inner arrays if need be
385
0
        $_ = [@$_] for @recs;
386    }
387    elsif ( $type eq ARRAY_of_HASHes_of_scalars ) {
388
0
        my %headings;
389
0
        for my $rec (@recs) {
390
0
            $headings{$_} = 1 for keys %$rec;
391        }
392
0
        my @headings = sort keys %headings;
393
394        ## Convert all hashes in to arrays.
395
0
        for my $rec (@recs) {
396
0
            $rec = [ map $rec->{$_}, @headings ],;
397        }
398
399
0
        unshift @recs, \@headings;
400
401
0
        $type = ARRAY_of_ARRAYs_of_scalars;
402    }
403    elsif ( $type eq HASH_of_scalars ) {
404
0
        my @headings = sort keys %hash_copy;
405
0
        @recs = ( \@headings, [ map $hash_copy{$_}, @headings ] );
406
0
        $type = ARRAY_of_ARRAYs_of_scalars;
407    }
408
409
0
    if ( $type eq ARRAY_of_ARRAYs_of_scalars ) {
410        ## Quote strings
411
0
        for my $rec (@recs) {
412
0
            for (@$rec) {
413
0
                $_ = _quote_str($_);
414            }
415
0
            $rec = join ",", @$rec;
416        }
417    }
418
419
0
    return \@recs;
420}
421
422sub _quote_str {
423
0
    my $str = shift;
424
0
    return 'undef' unless defined $str;
425
0
    return $str if $str =~ /^[0-9]+$/;
426
0
    $str =~ s{([\\\'])}{\\$1}g;
427
0
    return "'$str'";
428}
429
430sub _identify_callers_test_package_of_choice {
431    ## This is called at each test in case Test::Differences was used before
432    ## the base testing modules.
433    ## First see if %INC tells us much of interest.
434
0
    my $has_builder_pm = grep $_ eq "Test/Builder.pm", keys %INC;
435
0
    my $has_test_pm    = grep $_ eq "Test.pm",         keys %INC;
436
437
0
    return "Test"          if $has_test_pm  && !$has_builder_pm;
438
0
    return "Test::Builder" if !$has_test_pm && $has_builder_pm;
439
440
0
    if ( $has_test_pm && $has_builder_pm ) {
441        ## TODO: Look in caller's namespace for hints.  For now, assume Builder.
442        ## This should only ever be an issue if multiple test suites end
443        ## up in memory at once.
444
0
        return "Test::Builder";
445    }
446}
447
448my $warned_of_unknown_test_lib;
449
450
0
0
sub eq_or_diff_text { $_[3] = { data_type => "text" }; goto &eq_or_diff; }
451
0
0
sub eq_or_diff_data { $_[3] = { data_type => "data" }; goto &eq_or_diff; }
452
453## This string is a cheat: it's used to see if the two arrays of values
454## are identical.  The stringified values are joined using this joint
455## and compared using eq.  This is a deep equality comparison for
456## references and a shallow one for scalars.
457my $joint = chr(0) . "A" . chr(1);
458
459sub eq_or_diff {
460
0
    my ( @vals, $name, $options );
461
0
    $options = pop if @_ > 2 && ref $_[-1];
462
0
    ( $vals[0], $vals[1], $name ) = @_;
463
464
0
    my $data_type;
465
0
    $data_type = $options->{data_type} if $options;
466
0
    $data_type ||= "text" unless ref $vals[0] || ref $vals[1];
467
0
    $data_type ||= "data";
468
469
0
    my @widths;
470
471
0
    my @types = map _grok_type, @vals;
472
473
0
    my $dump_it = !$types[0] || !$types[1];
474
475
0
    my ( $got, $expected );
476
0
    if ($dump_it) {
477
0
        require Data::Dumper;
478
0
        local $Data::Dumper::Indent    = 1;
479
0
        local $Data::Dumper::Purity    = 0;
480
0
        local $Data::Dumper::Terse     = 1;
481
0
        local $Data::Dumper::Deepcopy  = 1;
482
0
        local $Data::Dumper::Quotekeys = 0;
483
0
        local $Data::Dumper::Sortkeys =
484          exists $options->{Sortkeys} ? $options->{Sortkeys} : 1;
485
0
        ( $got, $expected ) = map
486          [ split /^/, Data::Dumper::Dumper($_) ],
487          @vals;
488    }
489    else {
490
0
        ( $got, $expected ) = (
491            _flatten( $types[0], $vals[0] ),
492            _flatten( $types[1], $vals[1] )
493        );
494    }
495
496
0
    my $caller = caller;
497
498
0
    my $passed
499      = join( $joint, @$got ) eq join( $joint, @$expected );
500
501
0
    my $diff;
502
0
    unless ($passed) {
503
0
        my $context;
504
505
0
        $context = $options->{context}
506          if exists $options->{context};
507
508
0
        $context = $dump_it ? 2**31 : grep( @$_ > 25, $got, $expected ) ? 3 : 25
509          unless defined $context;
510
511
0
        confess "context must be an integer: '$context'\n"
512          unless $context =~ /\A\d+\z/;
513
514
0
        $diff = diff $got, $expected,
515          { CONTEXT     => $context,
516            STYLE       => _diff_style(),
517            FILENAME_A  => "Got",
518            FILENAME_B  => "Expected",
519            OFFSET_A    => $data_type eq "text" ? 1 : 0,
520            OFFSET_B    => $data_type eq "text" ? 1 : 0,
521            INDEX_LABEL => $data_type eq "text" ? "Ln" : "Elt",
522          };
523
0
        chomp $diff;
524
0
        $diff .= "\n";
525    }
526
527
0
    my $which = _identify_callers_test_package_of_choice;
528
529
0
    if ( $which eq "Test" ) {
530        @_
531
0
          = $passed
532          ? ( "", "", $name )
533          : ( "\n$diff", "No differences", $name );
534
0
        goto &Test::ok;
535    }
536    elsif ( $which eq "Test::Builder" ) {
537
0
        my $test = Test::Builder->new;
538        ## TODO: Call exported_to here?  May not need to because the caller
539        ## should have imported something based on Test::Builder already.
540
0
        $test->ok( $passed, $name );
541
0
        $test->diag($diff) unless $passed;
542    }
543    else {
544
0
        unless ($warned_of_unknown_test_lib) {
545
0
            Carp::cluck
546              "Can't identify test lib in use, doesn't seem to be Test.pm or Test::Builder based\n";
547
0
            $warned_of_unknown_test_lib = 1;
548        }
549        ## Play dumb and hope nobody notices the fool drooling in the corner
550
0
        if ($passed) {
551
0
            print "ok\n";
552        }
553        else {
554
0
            $diff =~ s/^/# /gm;
555
0
            print "not ok\n", $diff;
556        }
557    }
558}
559
560 - 650
=head1 LIMITATIONS

=head2 C<Test> or C<Test::More>

This module "mixes in" with Test.pm or any of the test libraries based on
Test::Builder (Test::Simple, Test::More, etc).  It does this by peeking to see
whether Test.pm or Test/Builder.pm is in %INC, so if you are not using one of
those, it will print a warning and play dumb by not emitting test numbers (or
incrementing them).  If you are using one of these, it should interoperate
nicely.

=head2 Exporting

Exports all 3 functions by default (and by design).  Use

    use Test::Differences ();

to suppress this behavior if you don't like the namespace pollution.

This module will not override functions like ok(), is(), is_deeply(), etc.  If
it did, then you could C<eval "use Test::Differences qw( is_deeply );"> to get
automatic upgrading to diffing behaviors without the C<sub my_ok> shown above.
Test::Differences intentionally does not provide this behavior because this
would mean that Test::Differences would need to emulate every popular test
module out there, which would require far more coding and maintenance that I'm
willing to do.  Use the eval and my_ok deployment shown above if you want some
level of automation.

=head2 Unicode

Perls before 5.6.0 don't support characters > 255 at all, and 5.6.0
seems broken.  This means that you might get odd results using perl5.6.0
with unicode strings.

=head2 C<Data::Dumper> and older Perls.

Relies on Data::Dumper (for now), which, prior to perl5.8, will not always
report hashes in the same order.  C< $Data::Dumper::SortKeys > I<is> set to 1,
so on more recent versions of Data::Dumper, this should not occur.  Check CPAN
to see if it's been peeled out of the main perl distribution and backported.
Reported by Ilya Martynov <ilya@martynov.org>, although the SortKeys "future
perfect" workaround has been set in anticipation of a new Data::Dumper for a
while.  Note that the two hashes should report the same here:

    not ok 5
    #     Failed test (t/ctrl/05-home.t at line 51)
    # +----+------------------------+----+------------------------+
    # | Elt|Got                     | Elt|Expected                |
    # +----+------------------------+----+------------------------+
    # |   0|{                       |   0|{                       |
    # |   1|  'password' => '',     |   1|  'password' => '',     |
    # *   2|  'method' => 'login',  *    |                        |
    # |   3|  'ctrl' => 'home',     |   2|  'ctrl' => 'home',     |
    # |    |                        *   3|  'method' => 'login',  *
    # |   4|  'email' => 'test'     |   4|  'email' => 'test'     |
    # |   5|}                       |   5|}                       |
    # +----+------------------------+----+------------------------+

Data::Dumper also overlooks the difference between

    $a[0] = \$a[1];
    $a[1] = \$a[0];   # $a[0] = \$a[1]

and

    $x = \$y;
    $y = \$x;
    @a = ( $x, $y );  # $a[0] = \$y, not \$a[1]

The former involves two scalars, the latter 4: $x, $y, and @a[0,1].
This was carefully explained to me in words of two syllables or less by
Yves Orton <demerphq@hotmail.com>.  The plan to address this is to allow
you to select Data::Denter or some other module of your choice as an
option.

=head1 AUTHOR

    Barrie Slaymaker <barries@slaysys.com>

=head1 MAINTAINER

    Curtis "Ovid" Poe <ovid@cpan.org>

=head1 LICENSE

Copyright 2001-2008 Barrie Slaymaker, All Rights Reserved.

You may use this software under the terms of the GNU public license, any
version, or the Artistic license.

=cut
651
6521;