local-lib5/lib/perl5/Test/Differences.pm

   1 package Test::Differences;
   2
   3 =head1 NAME
   4
   5 Test::Differences - Test strings and data structures and show differences if not ok
   6
   7 =head1 SYNOPSIS
   8
   9    use Test;    ## Or use Test::More
  10    use Test::Differences;
  11
  12    eq_or_diff $got,  "a\nb\nc\n",   "testing strings";
  13    eq_or_diff \@got, [qw( a b c )], "testing arrays";
  14
  15    ## Passing options:
  16    eq_or_diff $got, $expected, $name, { context => 300 };  ## options
  17
  18    ## Using with DBI-like data structures
  19
  20    use DBI;
  21
  22    ... open connection & prepare statement and @expected_... here...
  23
  24    eq_or_diff $sth->fetchall_arrayref, \@expected_arrays  "testing DBI arrays";
  25    eq_or_diff $sth->fetchall_hashref,  \@expected_hashes, "testing DBI hashes";
  26
  27    ## To force textual or data line numbering (text lines are numbered 1..):
  28    eq_or_diff_text ...;
  29    eq_or_diff_data ...;
  30
  31 =head1 EXPORT
  32
  33 This module exports three test functions and four diff-style functions:
  34
  35 =over 4
  36
  37 =item * Test functions
  38
  39 =over 4
  40
  41 =item * C<eq_or_diff>
  42
  43 =item * C<eq_or_diff_data>
  44
  45 =item * C<eq_or_diff_text>
  46
  47 =back
  48
  49 =item * Diff style functions
  50
  51 =over 4
  52
  53 =item * C<table_diff> (the default)
  54
  55 =item * C<unified_diff>
  56
  57 =item * C<oldstyle_diff>
  58
  59 =item * C<context_diff>
  60
  61 =back
  62
  63 =back
  64
  65 =head1 DESCRIPTION
  66
  67 When the code you're testing returns multiple lines, records or data
  68 structures and they're just plain wrong, an equivalent to the Unix
  69 C<diff> utility may be just what's needed.  Here's output from an
  70 example test script that checks two text documents and then two
  71 (trivial) data structures:
  72
  73  t/99example....1..3
  74  not ok 1 - differences in text
  75  #     Failed test ((eval 2) at line 14)
  76  #     +---+----------------+----------------+
  77  #     | Ln|Got             |Expected        |
  78  #     +---+----------------+----------------+
  79  #     |  1|this is line 1  |this is line 1  |
  80  #     *  2|this is line 2  |this is line b  *
  81  #     |  3|this is line 3  |this is line 3  |
  82  #     +---+----------------+----------------+
  83  not ok 2 - differences in whitespace
  84  #     Failed test ((eval 2) at line 20)
  85  #     +---+------------------+------------------+
  86  #     | Ln|Got               |Expected          |
  87  #     +---+------------------+------------------+
  88  #     |  1|        indented  |        indented  |
  89  #     *  2|        indented  |\tindented        *
  90  #     |  3|        indented  |        indented  |
  91  #     +---+------------------+------------------+
  92  not ok 3
  93  #     Failed test ((eval 2) at line 22)
  94  #     +----+-------------------------------------+----------------------------+
  95  #     | Elt|Got                                  |Expected                    |
  96  #     +----+-------------------------------------+----------------------------+
  97  #     *   0|bless( [                             |[                           *
  98  #     *   1|  'Move along, nothing to see here'  |  'Dry, humorless message'  *
  99  #     *   2|], 'Test::Builder' )                 |]                           *
 100  #     +----+-------------------------------------+----------------------------+
 101  # Looks like you failed 3 tests of 3.
 102
 103 eq_or_diff_...() compares two strings or (limited) data structures and
 104 either emits an ok indication or a side-by-side diff.  Test::Differences
 105 is designed to be used with Test.pm and with Test::Simple, Test::More,
 106 and other Test::Builder based testing modules.  As the SYNOPSIS shows,
 107 another testing module must be used as the basis for your test suite.
 108
 109 These functions assume that you are presenting it with "flat" records,
 110 looking like:
 111
 112    - scalars composed of record-per-line
 113    - arrays of scalars,
 114    - arrays of arrays of scalars,
 115    - arrays of hashes containing only scalars
 116
 117 All of these are flattened in to single strings which are then compared
 118 for differences.  Differently data structures can be compared, as long
 119 as they flatten identically.
 120
 121 All other data structures are run through Data::Dumper first.  This is a
 122 bit dangerous, as some versions of perl shipped with Data::Dumpers that
 123 could do the oddest things with unexpected, like core dump.  Only as of
 124 5.8.0 does Data::Dumper sort hash keys, which is necessary for HASH
 125 dumps to be fully predictable.  This will be changed when this bites
 126 somebody or I get some free time.
 127
 128 C<eq_or_diff()> starts counting records at 0 unless you pass it two text
 129 strings:
 130
 131    eq_or_diff $a, $b;   ## First line is line number 1
 132    eq_or_diff @a, @b;   ## First element is element 0
 133    eq_or_diff $a, @b;   ## First line/element is element 0
 134
 135 If you want to force a first record number of 0, use C<eq_or_diff_data>.  If
 136 you want to force a first record number of 1, use C<eq_or_diff_text>.  I chose
 137 this over passing in an options hash because it's clearer and simpler this way.
 138 YMMV.
 139
 140 =head1 OPTIONS
 141
 142 There is currently only one option: "context".  This allows you to
 143 control the amount of context shown:
 144
 145    eq_or_diff $got, $expected, $name, { context => 50000 };
 146
 147 will show you lots and lots of context.  Normally, eq_or_diff() uses
 148 some heuristics to determine whether to show 3 lines of context (like
 149 a normal unified diff) or 25 lines.
 150
 151 =head1 DIFF STYLES
 152
 153 For extremely long strings, a table diff can wrap on your screen and be hard
 154 to read.  If you are comfortable with different diff formats, you can switch
 155 to a format more suitable for your data.  These are the four formats supported
 156 by the L<Text::Diff> module and are set with the following functions:
 157
 158 =over 4
 159
 160 =item * C<table_diff> (the default)
 161
 162 =item * C<unified_diff>
 163
 164 =item * C<oldstyle_diff>
 165
 166 =item * C<context_diff>
 167
 168 =back
 169
 170 You can run the following to understand the different diff output styles:
 171
 172  use Test::More 'no_plan';
 173  use Test::Differences;
 174
 175  my $long_string = join '' => 1..40;
 176
 177  TODO: {
 178      local $TODO = 'Testing diff styles';
 179
 180      # this is the default and does not need to explicitly set unless you need
 181      # to reset it back from another diff type
 182      table_diff;
 183      eq_or_diff $long_string, "-$long_string", 'table diff';
 184
 185      unified_diff;
 186      eq_or_diff $long_string, "-$long_string", 'unified diff';
 187
 188      context_diff;
 189      eq_or_diff $long_string, "-$long_string", 'context diff';
 190
 191      oldstyle_diff;
 192      eq_or_diff $long_string, "-$long_string", 'oldstyle diff';
 193  }
 194
 195 =head1 DEPLOYING
 196
 197 There are several basic ways of deploying Test::Differences requiring more or less
 198 labor by you or your users.
 199
 200 =over
 201
 202 =item *
 203
 204 Fallback to C<is_deeply>.
 205
 206 This is your best option if you want this module to be optional.
 207
 208  use Test::More;
 209  BEGIN {
 210      if (!eval q{ use Test::Differences; 1 }) {
 211          *eq_or_diff = \&is_deeply;
 212      }
 213  }
 214
 215 =item *
 216
 217  eval "use Test::Differences";
 218
 219 If you want to detect the presence of Test::Differences on the fly, something
 220 like the following code might do the trick for you:
 221
 222     use Test qw( !ok );   ## get all syms *except* ok
 223
 224     eval "use Test::Differences";
 225     use Data::Dumper;
 226
 227     sub ok {
 228         goto &eq_or_diff if defined &eq_or_diff && @_ > 1;
 229         @_ = map ref $_ ? Dumper( @_ ) : $_, @_;
 230         goto Test::&ok;
 231     }
 232
 233     plan tests => 1;
 234
 235     ok "a", "b";
 236
 237 =item *
 238
 239 PREREQ_PM => { .... "Test::Differences" => 0, ... }
 240
 241 This method will let CPAN and CPANPLUS users download it automatically.  It
 242 will discomfit those users who choose/have to download all packages manually.
 243
 244 =item *
 245
 246 t/lib/Test/Differences.pm, t/lib/Text/Diff.pm, ...
 247
 248 By placing Test::Differences and its prerequisites in the t/lib directory, you
 249 avoid forcing your users to download the Test::Differences manually if they
 250 aren't using CPAN or CPANPLUS.
 251
 252 If you put a C<use lib "t/lib";> in the top of each test suite before the
 253 C<use Test::Differences;>, C<make test> should work well.
 254
 255 You might want to check once in a while for new Test::Differences releases
 256 if you do this.
 257
 258
 259
 260 =back
 261
 262 =cut
 263
 264 our $VERSION = "0.500"; # or "0.001_001" for a dev release
 265 $VERSION = eval $VERSION;
 266
 267 use Exporter;
 268
 269 @ISA    = qw( Exporter );
 270 @EXPORT = qw(
 271   eq_or_diff
 272   eq_or_diff_text
 273   eq_or_diff_data
 274   unified_diff
 275   context_diff
 276   oldstyle_diff
 277   table_diff
 278 );
 279
 280 use strict;
 281
 282 use Carp;
 283 use Text::Diff;
 284
 285 sub _isnt_ARRAY_of_scalars {
 286     return 1 if ref ne "ARRAY";
 287     return scalar grep ref, @$_;
 288 }
 289
 290 sub _isnt_HASH_of_scalars {
 291     return 1 if ref ne "HASH";
 292     return scalar grep ref, values %$_;
 293 }
 294
 295 use constant ARRAY_of_scalars           => "ARRAY of scalars";
 296 use constant ARRAY_of_ARRAYs_of_scalars => "ARRAY of ARRAYs of scalars";
 297 use constant ARRAY_of_HASHes_of_scalars => "ARRAY of HASHes of scalars";
 298 use constant HASH_of_scalars            => "HASH of scalars";
 299
 300 {
 301     my $diff_style = 'Table';
 302     my %allowed_style = map { $_ => 1 } qw/Unified Context OldStyle Table/;
 303     sub _diff_style {
 304         return $diff_style unless @_;
 305         my $requested_style = shift;
 306         unless ( $allowed_style{$requested_style} ) {
 307            Carp::croak("Uknown style ($requested_style) requested for diff");
 308         }
 309         $diff_style = $requested_style;
 310     }
 311 }
 312
 313 sub unified_diff  { _diff_style('Unified') }
 314 sub context_diff  { _diff_style('Context') }
 315 sub oldstyle_diff { _diff_style('OldStyle') }
 316 sub table_diff    { _diff_style('Table') }
 317
 318 sub _grok_type {
 319     local $_ = shift if @_;
 320     return "SCALAR" unless ref;
 321     if ( ref eq "ARRAY" ) {
 322         return undef unless @$_;
 323         return ARRAY_of_scalars
 324           unless _isnt_ARRAY_of_scalars;
 325         return ARRAY_of_ARRAYs_of_scalars
 326           unless grep _isnt_ARRAY_of_scalars, @$_;
 327         return ARRAY_of_HASHes_of_scalars
 328           unless grep _isnt_HASH_of_scalars, @$_;
 329         return 0;
 330     }
 331     elsif ( ref eq 'HASH' ) {
 332         return HASH_of_scalars
 333           unless _isnt_HASH_of_scalars($_);
 334         return 0;
 335     }
 336 }
 337
 338 ## Flatten any acceptable data structure in to an array of lines.
 339 sub _flatten {
 340     my $type = shift;
 341     local $_ = shift if @_;
 342
 343     return [ split /^/m ] unless ref;
 344
 345     croak "Can't flatten $_" unless $type;
 346
 347     ## Copy the top level array so we don't trash the originals
 348     my ( @recs, %hash_copy );
 349     if ( ref $_ eq 'ARRAY' ) {
 350         @recs = @$_;
 351     }
 352     elsif ( ref $_ eq 'HASH' ) {
 353         %hash_copy = %$_;
 354     }
 355     else {
 356         die "unsupported ref type";
 357     }
 358     if ( $type eq ARRAY_of_ARRAYs_of_scalars ) {
 359         ## Also copy the inner arrays if need be
 360         $_ = [@$_] for @recs;
 361     }
 362     elsif ( $type eq ARRAY_of_HASHes_of_scalars ) {
 363         my %headings;
 364         for my $rec (@recs) {
 365             $headings{$_} = 1 for keys %$rec;
 366         }
 367         my @headings = sort keys %headings;
 368
 369         ## Convert all hashes in to arrays.
 370         for my $rec (@recs) {
 371             $rec = [ map $rec->{$_}, @headings ],;
 372         }
 373
 374         unshift @recs, \@headings;
 375
 376         $type = ARRAY_of_ARRAYs_of_scalars;
 377     }
 378     elsif ( $type eq HASH_of_scalars ) {
 379         my @headings = sort keys %hash_copy;
 380         @recs = ( \@headings, [ map $hash_copy{$_}, @headings ] );
 381         $type = ARRAY_of_ARRAYs_of_scalars;
 382     }
 383
 384     if ( $type eq ARRAY_of_ARRAYs_of_scalars ) {
 385         ## Convert undefs
 386         for my $rec (@recs) {
 387             for (@$rec) {
 388                 $_ = "<undef>" unless defined;
 389             }
 390             $rec = join ",", @$rec;
 391         }
 392     }
 393
 394     return \@recs;
 395 }
 396
 397 sub _identify_callers_test_package_of_choice {
 398     ## This is called at each test in case Test::Differences was used before
 399     ## the base testing modules.
 400     ## First see if %INC tells us much of interest.
 401     my $has_builder_pm = grep $_ eq "Test/Builder.pm", keys %INC;
 402     my $has_test_pm    = grep $_ eq "Test.pm",         keys %INC;
 403
 404     return "Test"          if $has_test_pm  && !$has_builder_pm;
 405     return "Test::Builder" if !$has_test_pm && $has_builder_pm;
 406
 407     if ( $has_test_pm && $has_builder_pm ) {
 408         ## TODO: Look in caller's namespace for hints.  For now, assume Builder.
 409         ## This should only ever be an issue if multiple test suites end
 410         ## up in memory at once.
 411         return "Test::Builder";
 412     }
 413 }
 414
 415 my $warned_of_unknown_test_lib;
 416
 417 sub eq_or_diff_text { $_[3] = { data_type => "text" }; goto &eq_or_diff; }
 418 sub eq_or_diff_data { $_[3] = { data_type => "data" }; goto &eq_or_diff; }
 419
 420 ## This string is a cheat: it's used to see if the two arrays of values
 421 ## are identical.  The stringified values are joined using this joint
 422 ## and compared using eq.  This is a deep equality comparison for
 423 ## references and a shallow one for scalars.
 424 my $joint = chr(0) . "A" . chr(1);
 425
 426 sub eq_or_diff {
 427     my ( @vals, $name, $options );
 428     $options = pop if @_ > 2 && ref $_[-1];
 429     ( $vals[0], $vals[1], $name ) = @_;
 430
 431     my $data_type;
 432     $data_type = $options->{data_type} if $options;
 433     $data_type ||= "text" unless ref $vals[0] || ref $vals[1];
 434     $data_type ||= "data";
 435
 436     my @widths;
 437
 438     my @types = map _grok_type, @vals;
 439
 440     my $dump_it = !$types[0] || !$types[1];
 441
 442     my ( $got, $expected );
 443     if ($dump_it) {
 444         require Data::Dumper;
 445         local $Data::Dumper::Indent    = 1;
 446         local $Data::Dumper::Sortkeys  = 1;
 447         local $Data::Dumper::Purity    = 0;
 448         local $Data::Dumper::Terse     = 1;
 449         local $Data::Dumper::Deepcopy  = 1;
 450         local $Data::Dumper::Quotekeys = 0;
 451         ( $got, $expected ) = map
 452           [ split /^/, Data::Dumper::Dumper($_) ],
 453           @vals;
 454     }
 455     else {
 456         ( $got, $expected ) = (
 457             _flatten( $types[0], $vals[0] ),
 458             _flatten( $types[1], $vals[1] )
 459         );
 460     }
 461
 462     my $caller = caller;
 463
 464     my $passed
 465       = join( $joint, @$got ) eq join( $joint, @$expected );
 466
 467     my $diff;
 468     unless ($passed) {
 469         my $context;
 470
 471         $context = $options->{context}
 472           if exists $options->{context};
 473
 474         $context = $dump_it ? 2**31 : grep( @$_ > 25, $got, $expected ) ? 3 : 25
 475           unless defined $context;
 476
 477         confess "context must be an integer: '$context'\n"
 478           unless $context =~ /\A\d+\z/;
 479
 480         $diff = diff $got, $expected,
 481           { CONTEXT     => $context,
 482             STYLE       => _diff_style(),
 483             FILENAME_A  => "Got",
 484             FILENAME_B  => "Expected",
 485             OFFSET_A    => $data_type eq "text" ? 1 : 0,
 486             OFFSET_B    => $data_type eq "text" ? 1 : 0,
 487             INDEX_LABEL => $data_type eq "text" ? "Ln" : "Elt",
 488           };
 489         chomp $diff;
 490         $diff .= "\n";
 491     }
 492
 493     my $which = _identify_callers_test_package_of_choice;
 494
 495     if ( $which eq "Test" ) {
 496         @_
 497           = $passed
 498           ? ( "", "", $name )
 499           : ( "\n$diff", "No differences", $name );
 500         goto &Test::ok;
 501     }
 502     elsif ( $which eq "Test::Builder" ) {
 503         my $test = Test::Builder->new;
 504         ## TODO: Call exported_to here?  May not need to because the caller
 505         ## should have imported something based on Test::Builder already.
 506         $test->ok( $passed, $name );
 507         $test->diag($diff) unless $passed;
 508     }
 509     else {
 510         unless ($warned_of_unknown_test_lib) {
 511             Carp::cluck
 512               "Can't identify test lib in use, doesn't seem to be Test.pm or Test::Builder based\n";
 513             $warned_of_unknown_test_lib = 1;
 514         }
 515         ## Play dumb and hope nobody notices the fool drooling in the corner
 516         if ($passed) {
 517             print "ok\n";
 518         }
 519         else {
 520             $diff =~ s/^/# /gm;
 521             print "not ok\n", $diff;
 522         }
 523     }
 524 }
 525
 526 =head1 LIMITATIONS
 527
 528 =head2 C<Test> or C<Test::More>
 529
 530 This module "mixes in" with Test.pm or any of the test libraries based on
 531 Test::Builder (Test::Simple, Test::More, etc).  It does this by peeking to see
 532 whether Test.pm or Test/Builder.pm is in %INC, so if you are not using one of
 533 those, it will print a warning and play dumb by not emitting test numbers (or
 534 incrementing them).  If you are using one of these, it should interoperate
 535 nicely.
 536
 537 =head2 Exporting
 538
 539 Exports all 3 functions by default (and by design).  Use
 540
 541     use Test::Differences ();
 542
 543 to suppress this behavior if you don't like the namespace pollution.
 544
 545 This module will not override functions like ok(), is(), is_deeply(), etc.  If
 546 it did, then you could C<eval "use Test::Differences qw( is_deeply );"> to get
 547 automatic upgrading to diffing behaviors without the C<sub my_ok> shown above.
 548 Test::Differences intentionally does not provide this behavior because this
 549 would mean that Test::Differences would need to emulate every popular test
 550 module out there, which would require far more coding and maintenance that I'm
 551 willing to do.  Use the eval and my_ok deployment shown above if you want some
 552 level of automation.
 553
 554 =head2 Unicode
 555
 556 Perls before 5.6.0 don't support characters > 255 at all, and 5.6.0
 557 seems broken.  This means that you might get odd results using perl5.6.0
 558 with unicode strings.
 559
 560 =head2 C<Data::Dumper> and older Perls.
 561
 562 Relies on Data::Dumper (for now), which, prior to perl5.8, will not always
 563 report hashes in the same order.  C< $Data::Dumper::SortKeys > I<is> set to 1,
 564 so on more recent versions of Data::Dumper, this should not occur.  Check CPAN
 565 to see if it's been peeled out of the main perl distribution and backported.
 566 Reported by Ilya Martynov <ilya@martynov.org>, although the SortKeys "future
 567 perfect" workaround has been set in anticipation of a new Data::Dumper for a
 568 while.  Note that the two hashes should report the same here:
 569
 570     not ok 5
 571     #     Failed test (t/ctrl/05-home.t at line 51)
 572     # +----+------------------------+----+------------------------+
 573     # | Elt|Got                     | Elt|Expected                |
 574     # +----+------------------------+----+------------------------+
 575     # |   0|{                       |   0|{                       |
 576     # |   1|  'password' => '',     |   1|  'password' => '',     |
 577     # *   2|  'method' => 'login',  *    |                        |
 578     # |   3|  'ctrl' => 'home',     |   2|  'ctrl' => 'home',     |
 579     # |    |                        *   3|  'method' => 'login',  *
 580     # |   4|  'email' => 'test'     |   4|  'email' => 'test'     |
 581     # |   5|}                       |   5|}                       |
 582     # +----+------------------------+----+------------------------+
 583
 584 Data::Dumper also overlooks the difference between
 585
 586     $a[0] = \$a[1];
 587     $a[1] = \$a[0];   # $a[0] = \$a[1]
 588
 589 and
 590
 591     $x = \$y;
 592     $y = \$x;
 593     @a = ( $x, $y );  # $a[0] = \$y, not \$a[1]
 594
 595 The former involves two scalars, the latter 4: $x, $y, and @a[0,1].
 596 This was carefully explained to me in words of two syllables or less by
 597 Yves Orton <demerphq@hotmail.com>.  The plan to address this is to allow
 598 you to select Data::Denter or some other module of your choice as an
 599 option.
 600
 601 =head1 AUTHOR
 602
 603     Barrie Slaymaker <barries@slaysys.com>
 604
 605 =head1 MAINTAINER
 606
 607     Curtis "Ovid" Poe <ovid@cpan.org>
 608
 609 =head1 LICENSE
 610
 611 Copyright 2001-2008 Barrie Slaymaker, All Rights Reserved.
 612
 613 You may use this software under the terms of the GNU public license, any
 614 version, or the Artistic license.
 615
 616 =cut
 617
 618 1;