require Exporter;
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.50';
+$VERSION = '0.54';
+$VERSION = eval $VERSION; # make the alpha version come out as a number
+
@ISA = qw(Exporter);
@EXPORT = qw(ok use_ok require_ok
is isnt like unlike is_deeply
sub plan {
my(@plan) = @_;
- my $caller = caller;
-
- $Test->exported_to($caller);
-
- my @cleaned_plan;
- my @imports = ();
my $idx = 0;
+ my @cleaned_plan;
while( $idx <= $#plan ) {
- if( $plan[$idx] eq 'import' ) {
- @imports = @{$plan[$idx+1]};
- $idx += 2;
- }
- elsif( $plan[$idx] eq 'no_diag' ) {
+ my $item = $plan[$idx];
+
+ if( $item eq 'no_diag' ) {
$Show_Diag = 0;
- $idx++;
}
else {
- push @cleaned_plan, $plan[$idx];
- $idx++;
+ push @cleaned_plan, $item;
}
+
+ $idx++;
}
$Test->plan(@cleaned_plan);
-
- __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
}
sub import {
my($class) = shift;
- goto &plan;
+
+ my $caller = caller;
+
+ $Test->exported_to($caller);
+
+ my $idx = 0;
+ my @plan;
+ my @imports;
+ while( $idx <= $#_ ) {
+ my $item = $_[$idx];
+
+ if( $item eq 'import' ) {
+ push @imports, @{$_[$idx+1]};
+ $idx++;
+ }
+ else {
+ push @plan, $item;
+ }
+
+ $idx++;
+ }
+
+ plan(@plan);
+
+ __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
}
diag(@diagnostic_message);
Prints a diagnostic message which is guaranteed not to interfere with
-test output. Handy for this sort of thing:
+test output. Like C<print> @diagnostic_message is simply concatinated
+together.
+
+Handy for this sort of thing:
ok( grep(/foo/, @users), "There's a foo user" ) or
diag("Since there's no foo, check that /etc/bar is set up right");
=item B<require_ok>
require_ok($module);
+ require_ok($file);
-Like use_ok(), except it requires the $module.
+Like use_ok(), except it requires the $module or $file.
=cut
my $pack = caller;
+ # Try to deterine if we've been given a module name or file.
+ # Module names must be barewords, files not.
+ $module = qq['$module'] unless _is_module_name($module);
+
local($!, $@); # eval sometimes interferes with $!
eval <<REQUIRE;
package $pack;
return $ok;
}
+
+sub _is_module_name {
+ my $module = shift;
+
+ # Module names start with a letter.
+ # End with an alphanumeric.
+ # The rest is an alphanumeric or ::
+ $module =~ s/\b::\b//g;
+ $module =~ /^[a-zA-Z]\w+$/;
+}
+
=back
=head2 Conditional tests
If the user does not have HTML::Lint installed, the whole block of
code I<won't be run at all>. Test::More will output special ok's
which Test::Harness interprets as skipped, but passing, tests.
+
It's important that $how_many accurately reflects the number of tests
in the SKIP block so the # of tests run will match up with your plan.
+If your plan is C<no_plan> $how_many is optional and will default to 1.
It's perfectly safe to nest SKIP blocks. Each SKIP block must have
the label C<SKIP>, or Test::More can't work its magic.
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "skip() needs to know \$how_many tests are in the block"
- unless $Test::Builder::No_Plan;
+ unless $Test->has_plan eq 'no_plan';
$how_many = 1;
}
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "todo_skip() needs to know \$how_many tests are in the block"
- unless $Test::Builder::No_Plan;
+ unless $Test->has_plan eq 'no_plan';
$how_many = 1;
}
need to see if two arrays are equivalent, for instance. For these
instances, Test::More provides a handful of useful functions.
-B<NOTE> These are NOT well-tested on circular references. Nor am I
-quite sure what will happen with filehandles.
+B<NOTE> I'm not quite sure what will happen with filehandles.
=over 4
=cut
-use vars qw(@Data_Stack);
+use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
sub is_deeply {
unless( @_ == 2 or @_ == 3 ) {
my($this, $that, $name) = @_;
my $ok;
- if( !ref $this || !ref $that ) {
+ if( !ref $this xor !ref $that ) { # one's a reference, one isn't
+ $ok = 0;
+ }
+ if( !ref $this and !ref $that ) {
$ok = $Test->is_eq($this, $that, $name);
}
else {
local @Data_Stack = ();
+ local %Refs_Seen = ();
if( _deep_check($this, $that) ) {
$ok = $Test->ok(1, $name);
}
}
+sub _type {
+ my $thing = shift;
+
+ return '' if !ref $thing;
+
+ for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) {
+ return $type if UNIVERSAL::isa($thing, $type);
+ }
+
+ return '';
+}
+
+
=item B<eq_array>
eq_array(\@this, \@that);
=cut
#'#
-sub eq_array {
+sub eq_array {
+ local @Data_Stack;
+ local %Refs_Seen;
+ _eq_array(@_);
+}
+
+sub _eq_array {
my($a1, $a2) = @_;
+
+ if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
+ warn "eq_array passed a non-array ref";
+ return 0;
+ }
+
return 1 if $a1 eq $a2;
+ if($Refs_Seen{$a1}) {
+ return $Refs_Seen{$a1} eq $a2;
+ }
+ else {
+ $Refs_Seen{$a1} = "$a2";
+ }
+
my $ok = 1;
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
for (0..$max) {
last unless $ok;
}
+
return $ok;
}
my($e1, $e2) = @_;
my $ok = 0;
- my $eq;
{
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
- if( $e1 eq $e2 ) {
+ $Test->_unoverload(\$e1, \$e2);
+
+ # Either they're both references or both not.
+ my $same_ref = !(!ref $e1 xor !ref $e2);
+
+ if( defined $e1 xor defined $e2 ) {
+ $ok = 0;
+ }
+ elsif ( $e1 == $DNE xor $e2 == $DNE ) {
+ $ok = 0;
+ }
+ elsif ( $same_ref and ($e1 eq $e2) ) {
$ok = 1;
}
else {
- if( UNIVERSAL::isa($e1, 'ARRAY') and
- UNIVERSAL::isa($e2, 'ARRAY') )
- {
- $ok = eq_array($e1, $e2);
+ my $type = _type($e1);
+ $type = '' unless _type($e2) eq $type;
+
+ if( !$type ) {
+ push @Data_Stack, { vals => [$e1, $e2] };
+ $ok = 0;
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $ok = _eq_array($e1, $e2);
}
- elsif( UNIVERSAL::isa($e1, 'HASH') and
- UNIVERSAL::isa($e2, 'HASH') )
- {
- $ok = eq_hash($e1, $e2);
+ elsif( $type eq 'HASH' ) {
+ $ok = _eq_hash($e1, $e2);
}
- elsif( UNIVERSAL::isa($e1, 'REF') and
- UNIVERSAL::isa($e2, 'REF') )
- {
+ elsif( $type eq 'REF' ) {
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
pop @Data_Stack if $ok;
}
- elsif( UNIVERSAL::isa($e1, 'SCALAR') and
- UNIVERSAL::isa($e2, 'SCALAR') )
- {
+ elsif( $type eq 'SCALAR' ) {
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
- }
- else {
- push @Data_Stack, { vals => [$e1, $e2] };
- $ok = 0;
+ pop @Data_Stack if $ok;
}
}
}
=cut
sub eq_hash {
+ local @Data_Stack;
+ local %Refs_Seen;
+ return _eq_hash(@_);
+}
+
+sub _eq_hash {
my($a1, $a2) = @_;
+
+ if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
+ warn "eq_hash passed a non-hash ref";
+ return 0;
+ }
+
return 1 if $a1 eq $a2;
+ if( $Refs_Seen{$a1} ) {
+ return $Refs_Seen{$a1} eq $a2;
+ }
+ else {
+ $Refs_Seen{$a1} = "$a2";
+ }
+
my $ok = 1;
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
foreach my $k (keys %$bigger) {
=cut
-# We must make sure that references are treated neutrally. It really
-# doesn't matter how we sort them, as long as both arrays are sorted
-# with the same algorithm.
-sub _bogus_sort { local $^W = 0; ref $a ? -1 : ref $b ? 1 : $a cmp $b }
-
sub eq_set {
my($a1, $a2) = @_;
return 0 unless @$a1 == @$a2;
# There's faster ways to do this, but this is easiest.
- return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
+ local $^W = 0;
+
+ # We must make sure that references are treated neutrally. It really
+ # doesn't matter how we sort them, as long as both arrays are sorted
+ # with the same algorithm.
+ # Have to inline the sort routine due to a threading/sort bug.
+ # See [rt.cpan.org 6782]
+ return eq_array(
+ [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a1],
+ [sort { ref $a ? -1 : ref $b ? 1 : $a cmp $b } @$a2]
+ );
}
=back
If you fail more than 254 tests, it will be reported as 254.
-=head1 NOTES
+=head1 CAVEATS and NOTES
+
+=over 4
-Test::More is B<explicitly> tested all the way back to perl 5.004.
+=item Backwards compatibility
-=head1 BUGS and CAVEATS
+Test::More works with Perls as old as 5.004_05.
+
+
+=item Overloaded objects
+
+String overloaded objects are compared B<as strings>. This prevents
+Test::More from piercing an object's interface allowing better blackbox
+testing. So if a function starts returning overloaded objects instead of
+bare strings your tests won't notice the difference. This is good.
+
+However, it does mean that functions like is_deeply() cannot be used to
+test the internals of string overloaded objects. In this case I would
+suggest Test::Deep which contains more flexible testing functions for
+complex data structures.
-=over 4
=item Threads
use Test::More
use threads;
-=item Making your own ok()
-
-If you are trying to extend Test::More, don't. Use Test::Builder
-instead.
-
-=item The eq_* family has some caveats.
=item Test::Harness upgrade
Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
from Joshua Pritikin's Test module and lots of help from Barrie
-Slaymaker, Tony Bowden, blackstar.co.uk, chromatic and the perl-qa gang.
+Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
+the perl-qa gang.
+
+
+=head1 BUGS
+
+See F<http://rt.cpan.org> to report and view bugs.
=head1 COPYRIGHT
-Copyright 2001, 2002 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
projects / p5sagit/p5-mst-13.2.git / blobdiff