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

   1 package Test::LongString;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA @EXPORT $Max $Context);
   5
   6 $VERSION = '0.11';
   7
   8 use Test::Builder;
   9 my $Tester = new Test::Builder();
  10
  11 use Exporter;
  12 @ISA    = ('Exporter');
  13 @EXPORT = qw( is_string is_string_nows like_string unlike_string
  14     contains_string lacks_string );
  15
  16 # Maximum string length displayed in diagnostics
  17 $Max = 50;
  18
  19 # Amount of context provided when starting displaying a string in the middle
  20 $Context = 10;
  21
  22 sub import {
  23     (undef, my %args) = @_;
  24     $Max = $args{max} if defined $args{max};
  25     @_ = $_[0];
  26     goto &Exporter::import;
  27 }
  28
  29 # _display($string, [$offset = 0])
  30 # Formats a string for display. Begins at $offset minus $Context.
  31 # This function ought to be configurable, à la od(1).
  32
  33 sub _display {
  34     my $s = shift;
  35     if (!defined $s) { return 'undef'; }
  36     if (length($s) > $Max) {
  37         my $offset = shift || 0;
  38         if (defined $Context) {
  39             $offset -= $Context;
  40             $offset < 0 and $offset = 0;
  41         }
  42         else {
  43             $offset = 0;
  44         }
  45         $s = sprintf(qq("%.${Max}s"...), substr($s, $offset));
  46         $s = "...$s" if $offset;
  47     }
  48     else {
  49         $s = qq("$s");
  50     }
  51     $s =~ s/([\0-\037\200-\377])/sprintf('\x{%02x}',ord $1)/eg;
  52     return $s;
  53 }
  54
  55 sub _common_prefix_length {
  56     my ($str1, $str2) = @_;
  57     my $diff = $str1 ^ $str2;
  58     my ($pre) = $diff =~ /^(\000*)/;
  59     return length $pre;
  60 }
  61
  62 sub contains_string($$;$) {
  63     my ($str,$sub,$name) = @_;
  64
  65     my $ok;
  66     if (!defined $str) {
  67         $Tester->ok($ok = 0, $name);
  68         $Tester->diag("String to look in is undef");
  69     } elsif (!defined $sub) {
  70         $Tester->ok($ok = 0, $name);
  71         $Tester->diag("String to look for is undef");
  72     } else {
  73         my $index = index($str, $sub);
  74         $ok = ($index >= 0) ? 1 : 0;
  75         $Tester->ok($ok, $name);
  76         if (!$ok) {
  77             my ($g, $e) = (_display($str), _display($sub));
  78             $Tester->diag(<<DIAG);
  79     searched: $g
  80   can't find: $e
  81 DIAG
  82         }
  83     }
  84     return $ok;
  85 }
  86
  87 sub lacks_string($$;$) {
  88     my ($str,$sub,$name) = @_;
  89
  90     my $ok;
  91     if (!defined $str) {
  92         $Tester->ok($ok = 0, $name);
  93         $Tester->diag("String to look in is undef");
  94     } elsif (!defined $sub) {
  95         $Tester->ok($ok = 0, $name);
  96         $Tester->diag("String to look for is undef");
  97     } else {
  98         my $index = index($str, $sub);
  99         $ok = ($index < 0) ? 1 : 0;
 100         $Tester->ok($ok, $name);
 101         if (!$ok) {
 102             my ($g, $e) = (_display($str), _display($sub));
 103             $Tester->diag(<<DIAG);
 104     searched: $g
 105    and found: $e
 106  at position: $index
 107 DIAG
 108         }
 109     }
 110     return $ok;
 111 }
 112
 113 sub is_string ($$;$) {
 114     my ($got, $expected, $name) = @_;
 115     if (!defined $got || !defined $expected) {
 116         my $ok = !defined $got && !defined $expected;
 117         $Tester->ok($ok, $name);
 118         if (!$ok) {
 119             my ($g, $e) = (_display($got), _display($expected));
 120             $Tester->diag(<<DIAG);
 121          got: $g
 122     expected: $e
 123 DIAG
 124         }
 125         return $ok;
 126     }
 127     if ($got eq $expected) {
 128         $Tester->ok(1, $name);
 129         return 1;
 130     }
 131     else {
 132         $Tester->ok(0, $name);
 133         my $common_prefix = _common_prefix_length($got,$expected);
 134         my ($g, $e) = (
 135             _display($got, $common_prefix),
 136             _display($expected, $common_prefix),
 137         );
 138         $Tester->diag(<<DIAG);
 139          got: $g
 140       length: ${\(length $got)}
 141     expected: $e
 142       length: ${\(length $expected)}
 143     strings begin to differ at char ${\($common_prefix + 1)}
 144 DIAG
 145         return 0;
 146     }
 147 }
 148
 149 sub is_string_nows ($$;$) {
 150     my ($got, $expected, $name) = @_;
 151     if (!defined $got || !defined $expected) {
 152         my $ok = !defined $got && !defined $expected;
 153         $Tester->ok($ok, $name);
 154         if (!$ok) {
 155             my ($g, $e) = (_display($got), _display($expected));
 156             $Tester->diag(<<DIAG);
 157          got: $g
 158     expected: $e
 159 DIAG
 160         }
 161         return $ok;
 162     }
 163     s/\s+//g for (my $got_nows = $got), (my $expected_nows = $expected);
 164     if ($got_nows eq $expected_nows) {
 165         $Tester->ok(1, $name);
 166         return 1;
 167     }
 168     else {
 169         $Tester->ok(0, $name);
 170         my $common_prefix = _common_prefix_length($got_nows,$expected_nows);
 171         my ($g, $e) = (
 172             _display($got_nows, $common_prefix),
 173             _display($expected_nows, $common_prefix),
 174         );
 175         $Tester->diag(<<DIAG);
 176 after whitespace removal:
 177          got: $g
 178       length: ${\(length $got_nows)}
 179     expected: $e
 180       length: ${\(length $expected_nows)}
 181     strings begin to differ at char ${\($common_prefix + 1)}
 182 DIAG
 183         return 0;
 184     }
 185 }
 186
 187 sub like_string ($$;$) {
 188     _like($_[0],$_[1],'=~',$_[2]);
 189 }
 190
 191 sub unlike_string ($$;$) {
 192     _like($_[0],$_[1],'!~',$_[2]);
 193 }
 194
 195 # mostly from Test::Builder::_regex_ok
 196 sub _like {
 197     local $Test::Builder::Level = $Test::Builder::Level + 1;
 198     my ($got, $regex, $cmp, $name) = @_;
 199     my $ok = 0;
 200     my $usable_regex = $Tester->maybe_regex($regex);
 201     unless (defined $usable_regex) {
 202         $ok = $Tester->ok( 0, $name );
 203         $Tester->diag("    '$regex' doesn't look much like a regex to me.");
 204         return $ok;
 205     }
 206     {
 207         local $^W = 0;
 208         my $test = $got =~ /$usable_regex/ ? 1 : 0;
 209         $test = !$test if $cmp eq '!~';
 210         $ok = $Tester->ok( $test, $name );
 211     }
 212     unless( $ok ) {
 213         my $g = _display($got);
 214         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
 215         my $l = defined $got ? length $got : '-';
 216         $Tester->diag(sprintf(<<DIAGNOSTIC, $g, $match, $regex));
 217          got: %s
 218       length: $l
 219     %13s '%s'
 220 DIAGNOSTIC
 221     }
 222     return $ok;
 223 }
 224
 225 1;
 226
 227 __END__
 228
 229 =head1 NAME
 230
 231 Test::LongString - tests strings for equality, with more helpful failures
 232
 233 =head1 SYNOPSIS
 234
 235     use Test::More tests => 1;
 236     use Test::LongString;
 237     like_string( $html, qr/(perl|cpan)\.org/ );
 238
 239     #     Failed test (html-test.t at line 12)
 240     #          got: "<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Trans"...
 241     #       length: 58930
 242     #     doesn't match '(?-xism:(perl|cpan)\.org)'
 243
 244 =head1 DESCRIPTION
 245
 246 This module provides some drop-in replacements for the string
 247 comparison functions of L<Test::More>, but which are more suitable
 248 when you test against long strings.  If you've ever had to search
 249 for text in a multi-line string like an HTML document, or find
 250 specific items in binary data, this is the module for you.
 251
 252 =head1 FUNCTIONS
 253
 254 =head2 is_string( $string, $expected [, $label ] )
 255
 256 C<is_string()> is equivalent to C<Test::More::is()>, but with more
 257 helpful diagnostics in case of failure.
 258
 259 =over
 260
 261 =item *
 262
 263 It doesn't print the entire strings in the failure message.
 264
 265 =item *
 266
 267 It reports the lengths of the strings that have been compared.
 268
 269 =item *
 270
 271 It reports the length of the common prefix of the strings.
 272
 273 =item *
 274
 275 In the diagnostics, non-ASCII characters are escaped as C<\x{xx}>.
 276
 277 =back
 278
 279 For example:
 280
 281     is_string( $soliloquy, $juliet );
 282
 283     #     Failed test (soliloquy.t at line 15)
 284     #          got: "To be, or not to be: that is the question:\x{0a}Whether"...
 285     #       length: 1490
 286     #     expected: "O Romeo, Romeo,\x{0a}wherefore art thou Romeo?\x{0a}Deny thy"...
 287     #       length: 154
 288     #     strings begin to differ at char 1
 289
 290 =head2 is_string_nows( $string, $expected [, $label ] )
 291
 292 Like C<is_string()>, but removes whitepace (in the C<\s> sense) from the
 293 arguments before comparing them.
 294
 295 =head2 like_string( $string, qr/regex/ [, $label ] )
 296
 297 =head2 unlike_string( $string, qr/regex/ [, $label ] )
 298
 299 C<like_string()> and C<unlike_string()> are replacements for
 300 C<Test::More:like()> and C<unlike()> that only print the beginning
 301 of the received string in the output.  Unfortunately, they can't
 302 print out the position where the regex failed to match.
 303
 304     like_string( $soliloquy, qr/Romeo|Juliet|Mercutio|Tybalt/ );
 305
 306     #     Failed test (soliloquy.t at line 15)
 307     #          got: "To be, or not to be: that is the question:\x{0a}Whether"...
 308     #       length: 1490
 309     #     doesn't match '(?-xism:Romeo|Juliet|Mercutio|Tybalt)'
 310
 311 =head2 contains_string( $string, $substring [, $label ] )
 312
 313 C<contains_string()> searches for I<$substring> in I<$string>.  It's
 314 the same as C<like_string()>, except that it's not a regular
 315 expression search.
 316
 317     contains_string( $soliloquy, "Romeo" );
 318
 319     #     Failed test (soliloquy.t at line 10)
 320     #         searched: "To be, or not to be: that is the question:\x{0a}Whether"...
 321     #   and can't find: "Romeo"
 322
 323 =head2 lacks_string( $string, $substring [, $label ] )
 324
 325 C<lacks_string()> makes sure that I<$substring> does NOT exist in
 326 I<$string>.  It's the same as C<like_string()>, except that it's not a
 327 regular expression search.
 328
 329     lacks_string( $soliloquy, "slings" );
 330
 331     #     Failed test (soliloquy.t at line 10)
 332     #         searched: "To be, or not to be: that is the question:\x{0a}Whether"...
 333     #        and found: "slings"
 334     #      at position: 147
 335
 336 =head1 CONTROLLING OUTPUT
 337
 338 By default, only the first 50 characters of the compared strings
 339 are shown in the failure message.  This value is in
 340 C<$Test::LongString::Max>, and can be set at run-time.
 341
 342 You can also set it by specifying an argument to C<use>:
 343
 344     use Test::LongString max => 100;
 345
 346 When the compared strings begin to differ after a large prefix,
 347 Test::LongString will not print them from the beginning, but will start at the
 348 middle, more precisely at C<$Test::LongString::Context> characters before the
 349 first difference. By default this value is 10 characters. If you want
 350 Test::LongString to always print the beginning of compared strings no matter
 351 where they differ, undefine C<$Test::LongString::Context>.
 352
 353 =head1 AUTHOR
 354
 355 Written by Rafael Garcia-Suarez. Thanks to Mark Fowler (and to Joss Whedon) for
 356 the inspirational L<Acme::Test::Buffy>. Thanks to Andy Lester for lots of patches.
 357
 358 This program is free software; you may redistribute it and/or modify it under
 359 the same terms as Perl itself.
 360
 361 =head1 SEE ALSO
 362
 363 L<Test::Builder>, L<Test::Builder::Tester>, L<Test::More>.
 364
 365 =cut