[catagits/Gitalist.git] / local-lib5 / lib / perl5 / Test / LongString.pm

package Test::LongString;

use strict;
use vars qw($VERSION @ISA @EXPORT $Max $Context);

$VERSION = '0.11';

use Test::Builder;
my $Tester = new Test::Builder();

use Exporter;
@ISA    = ('Exporter');
@EXPORT = qw( is_string is_string_nows like_string unlike_string
    contains_string lacks_string );

# Maximum string length displayed in diagnostics
$Max = 50;

# Amount of context provided when starting displaying a string in the middle
$Context = 10;

sub import {
    (undef, my %args) = @_;
    $Max = $args{max} if defined $args{max};
    @_ = $_[0];
    goto &Exporter::import;
}

# _display($string, [$offset = 0])
# Formats a string for display. Begins at $offset minus $Context.
# This function ought to be configurable, à la od(1).

sub _display {
    my $s = shift;
    if (!defined $s) { return 'undef'; }
    if (length($s) > $Max) {
	my $offset = shift || 0;
	if (defined $Context) {
	    $offset -= $Context;
	    $offset < 0 and $offset = 0;
	}
	else {
	    $offset = 0;
	}
	$s = sprintf(qq("%.${Max}s"...), substr($s, $offset));
	$s = "...$s" if $offset;
    }
    else {
	$s = qq("$s");
    }
    $s =~ s/([\0-\037\200-\377])/sprintf('\x{%02x}',ord $1)/eg;
    return $s;
}

sub _common_prefix_length {
    my ($str1, $str2) = @_;
    my $diff = $str1 ^ $str2;
    my ($pre) = $diff =~ /^(\000*)/;
    return length $pre;
}

sub contains_string($$;$) {
    my ($str,$sub,$name) = @_;

    my $ok;
    if (!defined $str) {
        $Tester->ok($ok = 0, $name);
        $Tester->diag("String to look in is undef");
    } elsif (!defined $sub) {
        $Tester->ok($ok = 0, $name);
        $Tester->diag("String to look for is undef");
    } else {
        my $index = index($str, $sub);
        $ok = ($index >= 0) ? 1 : 0;
        $Tester->ok($ok, $name);
        if (!$ok) {
            my ($g, $e) = (_display($str), _display($sub));
            $Tester->diag(<<DIAG);
    searched: $g
  can't find: $e
DIAG
        }
    }
    return $ok;
}

sub lacks_string($$;$) {
    my ($str,$sub,$name) = @_;

    my $ok;
    if (!defined $str) {
        $Tester->ok($ok = 0, $name);
        $Tester->diag("String to look in is undef");
    } elsif (!defined $sub) {
        $Tester->ok($ok = 0, $name);
        $Tester->diag("String to look for is undef");
    } else {
        my $index = index($str, $sub);
        $ok = ($index < 0) ? 1 : 0;
        $Tester->ok($ok, $name);
        if (!$ok) {
            my ($g, $e) = (_display($str), _display($sub));
            $Tester->diag(<<DIAG);
    searched: $g
   and found: $e
 at position: $index
DIAG
        }
    }
    return $ok;
}

sub is_string ($$;$) {
    my ($got, $expected, $name) = @_;
    if (!defined $got || !defined $expected) {
	my $ok = !defined $got && !defined $expected;
	$Tester->ok($ok, $name);
	if (!$ok) {
	    my ($g, $e) = (_display($got), _display($expected));
	    $Tester->diag(<<DIAG);
         got: $g
    expected: $e
DIAG
	}
	return $ok;
    }
    if ($got eq $expected) {
	$Tester->ok(1, $name);
	return 1;
    }
    else {
	$Tester->ok(0, $name);
	my $common_prefix = _common_prefix_length($got,$expected);
	my ($g, $e) = (
	    _display($got, $common_prefix),
	    _display($expected, $common_prefix),
	);
	$Tester->diag(<<DIAG);
         got: $g
      length: ${\(length $got)}
    expected: $e
      length: ${\(length $expected)}
    strings begin to differ at char ${\($common_prefix + 1)}
DIAG
	return 0;
    }
}

sub is_string_nows ($$;$) {
    my ($got, $expected, $name) = @_;
    if (!defined $got || !defined $expected) {
	my $ok = !defined $got && !defined $expected;
	$Tester->ok($ok, $name);
	if (!$ok) {
	    my ($g, $e) = (_display($got), _display($expected));
	    $Tester->diag(<<DIAG);
         got: $g
    expected: $e
DIAG
	}
	return $ok;
    }
    s/\s+//g for (my $got_nows = $got), (my $expected_nows = $expected);
    if ($got_nows eq $expected_nows) {
	$Tester->ok(1, $name);
	return 1;
    }
    else {
	$Tester->ok(0, $name);
	my $common_prefix = _common_prefix_length($got_nows,$expected_nows);
	my ($g, $e) = (
	    _display($got_nows, $common_prefix),
	    _display($expected_nows, $common_prefix),
	);
	$Tester->diag(<<DIAG);
after whitespace removal:
         got: $g
      length: ${\(length $got_nows)}
    expected: $e
      length: ${\(length $expected_nows)}
    strings begin to differ at char ${\($common_prefix + 1)}
DIAG
	return 0;
    }
}

sub like_string ($$;$) {
    _like($_[0],$_[1],'=~',$_[2]);
}

sub unlike_string ($$;$) {
    _like($_[0],$_[1],'!~',$_[2]);
}

# mostly from Test::Builder::_regex_ok
sub _like {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($got, $regex, $cmp, $name) = @_;
    my $ok = 0;
    my $usable_regex = $Tester->maybe_regex($regex);
    unless (defined $usable_regex) {
	$ok = $Tester->ok( 0, $name );
	$Tester->diag("    '$regex' doesn't look much like a regex to me.");
	return $ok;
    }
    {
	local $^W = 0;
	my $test = $got =~ /$usable_regex/ ? 1 : 0;
	$test = !$test if $cmp eq '!~';
	$ok = $Tester->ok( $test, $name );
    }
    unless( $ok ) {
	my $g = _display($got);
	my $match = $cmp eq '=~' ? "doesn't match" : "matches";
	my $l = defined $got ? length $got : '-';
	$Tester->diag(sprintf(<<DIAGNOSTIC, $g, $match, $regex));
         got: %s
      length: $l
    %13s '%s'
DIAGNOSTIC
    }
    return $ok;
}

1;

__END__

=head1 NAME

Test::LongString - tests strings for equality, with more helpful failures

=head1 SYNOPSIS

    use Test::More tests => 1;
    use Test::LongString;
    like_string( $html, qr/(perl|cpan)\.org/ );

    #     Failed test (html-test.t at line 12)
    #          got: "<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Trans"...
    #       length: 58930
    #     doesn't match '(?-xism:(perl|cpan)\.org)'

=head1 DESCRIPTION

This module provides some drop-in replacements for the string
comparison functions of L<Test::More>, but which are more suitable
when you test against long strings.  If you've ever had to search
for text in a multi-line string like an HTML document, or find
specific items in binary data, this is the module for you.

=head1 FUNCTIONS

=head2 is_string( $string, $expected [, $label ] )

C<is_string()> is equivalent to C<Test::More::is()>, but with more
helpful diagnostics in case of failure.

=over

=item *

It doesn't print the entire strings in the failure message.

=item *

It reports the lengths of the strings that have been compared.

=item *

It reports the length of the common prefix of the strings.

=item *

In the diagnostics, non-ASCII characters are escaped as C<\x{xx}>.

=back

For example:

    is_string( $soliloquy, $juliet );

    #     Failed test (soliloquy.t at line 15)
    #          got: "To be, or not to be: that is the question:\x{0a}Whether"...
    #       length: 1490
    #     expected: "O Romeo, Romeo,\x{0a}wherefore art thou Romeo?\x{0a}Deny thy"...
    #       length: 154
    #     strings begin to differ at char 1

=head2 is_string_nows( $string, $expected [, $label ] )

Like C<is_string()>, but removes whitepace (in the C<\s> sense) from the
arguments before comparing them.

=head2 like_string( $string, qr/regex/ [, $label ] )

=head2 unlike_string( $string, qr/regex/ [, $label ] )

C<like_string()> and C<unlike_string()> are replacements for
C<Test::More:like()> and C<unlike()> that only print the beginning
of the received string in the output.  Unfortunately, they can't
print out the position where the regex failed to match.

    like_string( $soliloquy, qr/Romeo|Juliet|Mercutio|Tybalt/ );

    #     Failed test (soliloquy.t at line 15)
    #          got: "To be, or not to be: that is the question:\x{0a}Whether"...
    #       length: 1490
    #     doesn't match '(?-xism:Romeo|Juliet|Mercutio|Tybalt)'

=head2 contains_string( $string, $substring [, $label ] )

C<contains_string()> searches for I<$substring> in I<$string>.  It's
the same as C<like_string()>, except that it's not a regular
expression search.

    contains_string( $soliloquy, "Romeo" );

    #     Failed test (soliloquy.t at line 10)
    #         searched: "To be, or not to be: that is the question:\x{0a}Whether"...
    #   and can't find: "Romeo"

=head2 lacks_string( $string, $substring [, $label ] )

C<lacks_string()> makes sure that I<$substring> does NOT exist in
I<$string>.  It's the same as C<like_string()>, except that it's not a
regular expression search.

    lacks_string( $soliloquy, "slings" );

    #     Failed test (soliloquy.t at line 10)
    #         searched: "To be, or not to be: that is the question:\x{0a}Whether"...
    #        and found: "slings"
    #      at position: 147

=head1 CONTROLLING OUTPUT

By default, only the first 50 characters of the compared strings
are shown in the failure message.  This value is in
C<$Test::LongString::Max>, and can be set at run-time.

You can also set it by specifying an argument to C<use>:

    use Test::LongString max => 100;

When the compared strings begin to differ after a large prefix,
Test::LongString will not print them from the beginning, but will start at the
middle, more precisely at C<$Test::LongString::Context> characters before the
first difference. By default this value is 10 characters. If you want
Test::LongString to always print the beginning of compared strings no matter
where they differ, undefine C<$Test::LongString::Context>.

=head1 AUTHOR

Written by Rafael Garcia-Suarez. Thanks to Mark Fowler (and to Joss Whedon) for
the inspirational L<Acme::Test::Buffy>. Thanks to Andy Lester for lots of patches.

This program is free software; you may redistribute it and/or modify it under
the same terms as Perl itself.

=head1 SEE ALSO

L<Test::Builder>, L<Test::Builder::Tester>, L<Test::More>.

=cut
Commit	Line	Data
3fea05b9	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