STDERR tests in Test::Warn?
As comes up pretty often, people want to trap stuff on STDERR. I've got adhoc stuff to do that in TieOut.pm, but I've never really found a good place to put it in a module. Test::Warn seems like its a good spot. Warnings and stuff going directly to STDERR are related beasts. So if Janek wants it, I can patch Test::Warn to trap STDERR was well as normal warnings. The question is the interface. Should warning* just trap STDERR like any other warning or should there be seperate functions? I'd argue for the former. First from a DWIM standpoint, and second because sometimes you'll be getting both warnings and output to STDERR from the same code (as just happened to me, prompting this train of thought) and it would be nice to trap both. The downside is the two streams are mixed and can't be seperated by the test without unnecessarily complicating the arguments to warning*. Dunno how important this is, don't think its very.
Re: Test::More::is_deeply problems with blessings and stringified refs
On Thursday 27 February 2003 21:35, [EMAIL PROTECTED] wrote:
> On Thu, Feb 27, 2003 at 09:21:09PM +, Fergal Daly wrote:
>
> Or even better, cmp_objects().
Yep, sounds better.
> > - let _deep_check take it's cue from the second argument. If the second
> > argument is blessed then be strict about the classes, if it's unblessed
> > then ignore the classes. This should happen at all levels in the
> > structures.
>
> This sounds too magical.
Magical how? It may be a bit too hard to explain and so it's probably a bad
idea. It's not that magical to implement though, it just requires something
like this in _deep_check
my ($class1, $base1) = ref($e1) =~ /^(.*)=(.*?)$/;
my ($class2, $base2) = ref($e2) =~ /^(.*)=(.*?)$/;
if ($base1 eq $base2 and ($class2 and $class1 eq $class2))
{
check the contents of $e1 and $e2
}
else
{
fail
}
Then you could get rid of all the UNIVERSAL::isa calls too.
Anyway, I think it's better to explicitly request full checking.
> Either way, Test::More's is_deeply() behavior isn't likely to change, so
> Test::Set will have to take care of it.
Would it be acceptable to add a third argument to _deep_check to switch on/off
bless checking, rather than having to reimplement the whole thing?
Test::Set is going to have to be renamed Test::EvenMore,
F
--
Do you need someone with lots of Unix sysadmin and/or lots of OO software
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html
Test::More::is_deeply problems with blessings and stringified refs
On Thursday 27 February 2003 16:40, [EMAIL PROTECTED] wrote:
> > is_deeply() ignores the classes of blessed refs. So
> >
> > perl -MTest::More=no_plan -e 'is_deeply(bless([], "a"), bless([], "b"))'
> >
> > passes,
>
> Oh. Not sure if that's a bug or a feature. Discuss it on perl-qa.
I think that although a test that ignores blessed classes could be handy in
some circumstances (ie programming in general), I reckon in the context of
test suites it's a bug.
If fixing it makes some tests fail then it means either the tests weren't
really correct or a genuine bug has been discovered.
While I'm at it, a definite problem is that a ref and the stringified version
of the ref are currently considered equal, so
perl -MTest::More=no_plan -e '$a=[];is_deeply($a, $a."", "should fail")'
passes.
The first patch below fixes the second problem. The second patch fixes the
first problem (if you think it is a problem) and will only apply cleanly
after patch1,
F
--
Do you need someone with lots of Unix sysadmin and/or lots of OO software
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html
--- ./lib/Test/More.pm.orig 2002-08-26 17:20:41.0 +0100
+++ ./lib/Test/More.pm 2003-02-21 03:37:56.0 +
@@ -937,7 +937,7 @@
my($this, $that, $name) = @_;
my $ok;
-if( !ref $this || !ref $that ) {
+if( !ref $this && !ref $that ) {
$ok = $Test->is_eq($this, $that, $name);
}
else {
@@ -984,8 +984,9 @@
foreach my $idx (0..$#vals) {
my $val = $vals[$idx];
$vals[$idx] = !defined $val ? 'undef' :
- $val eq $DNE ? "Does not exist"
-: "'$val'";
+ ref $val ? $val eq $DNE ? "Does not exist"
+ : $val
+ : "'$val'"
}
$out .= "$vars[0] = $vals[0]\n";
@@ -1008,7 +1009,7 @@
#'#
sub eq_array {
my($a1, $a2) = @_;
-return 1 if $a1 eq $a2;
+return 1 if !ref $a1 and ! ref $a2 and $a1 eq $a2;
my $ok = 1;
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
@@ -1034,7 +1035,7 @@
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
-if( $e1 eq $e2 ) {
+if( ! ref $e1 and ! ref $e2 and $e1 eq $e2 ) {
$ok = 1;
}
else {
@@ -1083,7 +1084,7 @@
sub eq_hash {
my($a1, $a2) = @_;
-return 1 if $a1 eq $a2;
+return 1 if !ref $a1 and ! ref $a2 and $a1 eq $a2;
my $ok = 1;
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
--- lib/Test/More.pm.fixed_ref 2003-02-27 17:08:09.0 +
+++ lib/Test/More.pm2003-02-27 17:25:20.0 +
@@ -1035,37 +1035,40 @@
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
-if( ! ref $e1 and ! ref $e2 and $e1 eq $e2 ) {
-$ok = 1;
-}
-else {
-if( UNIVERSAL::isa($e1, 'ARRAY') and
-UNIVERSAL::isa($e2, 'ARRAY') )
+if( ref($e1) eq ref($e2)) {
+
+if( !ref($e1)) {
+if ($e1 eq $e2) {
+$ok = 1;
+}
+else {
+push @Data_Stack, { vals => [$e1, $e2] };
+$ok = 0;
+}
+}
+elsif( UNIVERSAL::isa($e1, 'ARRAY') )
{
$ok = eq_array($e1, $e2);
}
-elsif( UNIVERSAL::isa($e1, 'HASH') and
- UNIVERSAL::isa($e2, 'HASH') )
+elsif( UNIVERSAL::isa($e1, 'HASH') )
{
$ok = eq_hash($e1, $e2);
}
-elsif( UNIVERSAL::isa($e1, 'REF') and
- UNIVERSAL::isa($e2, 'REF') )
+elsif( UNIVERSAL::isa($e1, '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( UNIVERSAL::isa($e1, 'SCALAR') )
{
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
}
-else {
-push @Data_Stack, { vals => [$e1, $e2] };
-$ok = 0;
-}
+}
+else {
+push @Data_Stack, { vals => [$e1, $e2] };
+$ok = 0;
}
}
Test::Set
I've been discussing this with Mr Schwern recently but he's a little
indisposed at the moment so this seemed like a good place for feedback.
Test::More's eq_set() is not a set comparison or a bag comparison but a
strange array comparison where the order of scalars doesn't matter but the
order of refs does, except for deeply equalrefs, which can be interchanged.
So
perl -MTest::More -e 'print eq_set([ [], {} ], [ {}, [] ])."\n"'
prints 0
Attached is Test::Set which provides true deep set and bag comparisons and
bagset.t some tests.
Any comments welcome,
F
--
Do you need someone with lots of Unix sysadmin and/or lots of OO software
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html
# -*-perl-*-
use strict;
use Test::More (tests => 13);
use Test::Set;
my $refa_1 = ["a"];
my $refa_2 = ["a"];
my $set = [qw(a b a c d), $refa_1];
is_math_set($set, [qw(a b a c d), $refa_1], "math_set equal");
is_math_set($set, [qw(b c), $refa_1, qw(d a)], "math_set reorder");
is_math_set($set, [qw(b c), $refa_1, qw(d a b c ), $refa_1], "math_set reorder dupes");
is_math_set($set, [qw(b c), $refa_1, qw(d a b c ), $refa_2], "math_set reorder deep-dupes");
ok(! eq_math_set($set, [qw(c), $refa_1, qw(d a c ), $refa_1]), "math_set missing");
ok(! eq_math_set($set, [qw(c b e), $refa_1, qw(d a c ), $refa_1]), "math_set extra");
is_bag([[], $refa_2], [$refa_2, []], "eq_bag deep");
ok(! eq_bag([$refa_2, []], [$refa_2, [], []]), "eq_bag extra");
ok(! eq_bag([$refa_2, [], []], [$refa_2, []]), "eq_bag missing");
check_diff(
[qw(a a b b c)], [qw(e d c d e)],
[qw(d e)], [qw(a b)],
"set", 1
);
check_diff(
[qw(a a b b c)], [qw(e d c d e)],
[qw(d d e e)], [qw(a a b b)],
"bag", 0
);
sub check_diff
{
my ($a1, $a2, $missing, $extra, $name, $is_set) = @_;
my ($m, $e) = Test::Set::_diff_bagset($a1, $a2, $is_set);
is_deeply($missing, [sort @$m], "diff $name m");
is_deeply($extra, [sort @$e], "diff $name e");
}
package Test::Set;
use 5.004;
use strict;
use Test::More;
use vars qw($VERSION @ISA @EXPORT );
$VERSION = '0.01';
@ISA= qw( Exporter );
@EXPORT = qw(
is_bag is_math_set
eq_bag eq_math_set
);
my $Test = Test::Builder->new;
sub eq_deeply
{
# this can be removed when Test::More exports an eq_deeply() function
local @Test::More::Data_Stack = ();
return Test::More::_deep_check(@_);
}
=head1 NAME
Test::Set - some tests for set and bag comparisons
=head1 SYNOPSIS
use Test::More tests => $Num_Tests;
use Test::Set;
is_bag([EMAIL PROTECTED], [EMAIL PROTECTED], $test_name);
is_math_set([EMAIL PROTECTED], [EMAIL PROTECTED], $test_name);
=head1 DESCRIPTION
These are just some extra comaprison functions and tests to add to the ones
already in Test::More. It depends on Test::More for some comparison
functions. You should read the documentation for Test::More before using
these tests.
Test::Set provides a true set comparison and a true bag comparison (a bag is
like a set, the order of elements doesn't matter, however the number of
occurrences of an element does).
It does not provide any way to set up a plan.
=head2 AVAILABLE TESTS
=over 4
=item B
is_math_set( $this, $that, $test_name );
Similar to Test::More's is_deeply(), except that $this and $that must be
array references. Because it is a set comparison, it ignores the order of
elements in $this and $that and it also ignores duplicate elements. This is
a deep check so duplicates are found by deep comparison. If the two sets are
different, it will list the scalar elements in $this that are missing and
that are extra. It will also count the missing and extra reference elements
but will not display their structure as that could get very messy.
=cut
sub _converge_arrays
{
# this takes a master array and some slave arrays.
# it returns one array for each slave array with all references replaced
# by the first deeply equal reference from the master array.
my $all = shift;
# because we'll be do lots of deep_checks against this list, it's best if
# we throw out the refs and the duplicates before we start.
my @all = grep {ref($_)} @$all;
my %all;
@[EMAIL PROTECTED] = @all;
@all = values %all;
my @converged;
foreach my $array (@_)
{
my @array = @$array;
foreach my $elem (@array)
{
next unless ref $elem;
if (my ($master) = grep { eq_deeply($elem, $_) } @all)
{
$elem = $master;
}
}
push(@converged, [EMAIL PROTECTED]);
}
return @converged;
}
sub _diff_bagset
{
# this takes 2 arrays and finds out what is in $a1 but not in $a2 and vice
# versa
# the arrays must contains all refs or all scalars to guarantee the
# correct answer
# a third (boolean) parameter specifies whether it's a bag or set
# comparison. True for set, false for bag
my ($a1, $a2, $is_set) = @_;
if (ref($a1->[0]))
{
# we are dealing with refs so we need to converge them to cope with
# deepness
($a1, $a2) = _converge_arrays([EMAIL PROTECTED], @$a2], $a1, $a2);
}
my (%a1, %a2, %values
Test::More diagostics problem
There's a line missing from Test::More::_deep_check(). It results in funny
diagnostics after comparing scalar refs, so
perl -MTest::More=no_plan -e 'is_deeply([(\"a") x 5, "b"], [(\"a") x 5, "c"])'
gives
# Structures begin differing at:
# $got->[0][1][2][3][4][5] = 'b'
# $expected->[0][1][2][3][4][5] = 'c'
instead of
# Structures begin differing at:
# $got->[5] = 'b'
# $expected->[5] = 'c'
attached patch fixes it,
F
--
Do you need someone with lots of Unix sysadmin and/or lots of OO software
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html
--- ./lib/Test/More.pm.ref 2003-02-27 17:08:09.0 +
+++ ./lib/Test/More.pm 2003-02-27 20:54:34.0 +
@@ -1061,6 +1061,7 @@
{
push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
$ok = _deep_check($$e1, $$e2);
+pop @Data_Stack if $ok;
}
else {
push @Data_Stack, { vals => [$e1, $e2] };
Re: Test::More::is_deeply problems with blessings and stringified refs
On Thursday 27 February 2003 20:54, [EMAIL PROTECTED] wrote:
> On Thu, Feb 27, 2003 at 05:32:42PM +, Fergal Daly wrote:
> > I think that although a test that ignores blessed classes could be handy
> > in some circumstances (ie programming in general), I reckon in the
> > context of test suites it's a bug.
>
> I am already not yet convinced. In particular, it makes this sort of test
> more difficult than it needs be:
>
> is_deeply($obj, { foo => 42, bar => 23 });
Absolutely, but there is currently no way to do this
is_deeply($obj, bless({ foo => 42, bar => 23 }, "MyClass"));
and get a fail if $obj is not in MyClass - as I found out today ;-(
2 solutions spring to mind
- create is_deeply_blessed
- let _deep_check take it's cue from the second argument. If the second
argument is blessed then be strict about the classes, if it's unblessed then
ignore the classes. This should happen at all levels in the structures.
The second option allows your test above to succeed as normal but also allows
mine to be strict. The only tests which will suddenly start failing are ones
where the tester has specified the class, in which case they probably wanted
it to fail. This sounds a little over-complicated but in theory I think it's
good,
F
--
Do you need someone with lots of Unix sysadmin and/or lots of OO software
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html
Re: Test::More::is_deeply problems with blessings and stringified refs
On Thursday 27 February 2003 22:03, Fergal Daly wrote:
> Would it be acceptable to add a third argument to _deep_check to switch
> on/off bless checking, rather than having to reimplement the whole thing?
Below is a very simple patch to do that. That makes cmp_object very easy
F
--
Do you need someone with lots of Unix sysadmin and/or lots of OO software
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html
--- More.pm.scalar 2003-02-27 22:08:37.0 +
+++ More.pm 2003-02-27 22:22:46.0 +
@@ -1027,7 +1027,7 @@
}
sub _deep_check {
-my($e1, $e2) = @_;
+my($e1, $e2, $check_bless) = @_;
my $ok = 0;
my $eq;
@@ -1035,7 +1035,11 @@
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
-if( ! ref $e1 and ! ref $e2 and $e1 eq $e2 ) {
+if ($check_bless and ref($e1) ne ref($e2)) {
+push @Data_Stack, { vals => [$e1, $e2] };
+$ok = 0;
+}
+elsif( ! ref $e1 and ! ref $e2 and $e1 eq $e2 ) {
$ok = 1;
}
else {
One more Test::More problem
Final one tonight!
eq_array and eq_hash don't tidy up after themselves. You would have to be very
unfortunate to be stung by this problem but potentially you could end up with
extra references to some of your variables which could effect tests further
on due to DESTROYs not being called or whatever.
use Test::More;
for(1..10)
{
eq_array( [[]], [{}] )
}
print join(", ", @Test::More::Data_Stack)."\n";
The solution is to make eq_array and eq_hash wrappers around the original
functions. This is needed for the circular structures patch anyway.
Actually, I've gone a little further and made them wrappers around a new
eq_deeply(). All they do is check that the second argument is of the correct
type. This means that all the localling of @Data_Stack is only done in
eq_deeply.
It also means they won't die anymore if the wrong kind of arguments are passed
in. Although, I'm not sure if this is a good idea, maybe dying is preferable.
Patch attached.
Also attached is a test script that exercises the various comparison
functions. It's missing a few cases but it covers a fair bit,
F
--
Do you need someone with lots of Unix sysadmin and/or lots of OO software
development experience? Go on, giz a job.
My CV - http://www.fergaldaly.com/cv.html
--- lib/Test/More.pm.orig 2003-02-27 20:54:34.0 +
+++ lib/Test/More.pm 2003-02-28 00:11:47.0 +
@@ -25,7 +25,7 @@
cmp_ok
skip todo todo_skip
pass fail
- eq_array eq_hash eq_set
+ eq_array eq_hash eq_set eq_deeply
$TODO
plan
can_ok isa_ok
@@ -996,6 +996,12 @@
return $out;
}
+sub eq_deeply {
+my ($a1, $a2) = @_;
+
+local @Data_Stack = ();
+return _deep_check($a1, $a2);
+}
=item B
@@ -1007,7 +1013,14 @@
=cut
#'#
-sub eq_array {
+
+sub eq_array {
+my ($a1, $a2) = @_;
+
+return UNIVERSAL::isa($a2, "ARRAY") ? return eq_deeply($a1, $a2) : 0;
+}
+
+sub _eq_array {
my($a1, $a2) = @_;
return 1 if !ref $a1 and ! ref $a2 and $a1 eq $a2;
@@ -1042,12 +1055,12 @@
if( UNIVERSAL::isa($e1, 'ARRAY') and
UNIVERSAL::isa($e2, 'ARRAY') )
{
-$ok = eq_array($e1, $e2);
+$ok = _eq_array($e1, $e2);
}
elsif( UNIVERSAL::isa($e1, 'HASH') and
UNIVERSAL::isa($e2, 'HASH') )
{
-$ok = eq_hash($e1, $e2);
+$ok = _eq_hash($e1, $e2);
}
elsif( UNIVERSAL::isa($e1, 'REF') and
UNIVERSAL::isa($e2, 'REF') )
@@ -1084,6 +1097,12 @@
=cut
sub eq_hash {
+my ($a1, $a2) = @_;
+
+return UNIVERSAL::isa($a2, "HASH") ? return eq_deeply($a1, $a2) : 0;
+}
+
+sub _eq_hash {
my($a1, $a2) = @_;
return 1 if !ref $a1 and ! ref $a2 and $a1 eq $a2;
# -*-perl-*-
use strict;
use Test::More (tests => 18);
{
my $a = [];
my $b = $a."";
ok(! eq_deeply([$a], [$b]), "stringified");
}
{
# take an array full of a variety of things and break each one
my @a1 = an_array();
my @a2 = an_array();
is_deeply([EMAIL PROTECTED], [EMAIL PROTECTED], "is array");
ok(eq_array([EMAIL PROTECTED], [EMAIL PROTECTED]), "eq array");
for (my $i = 0; $i < @a1; $i++)
{
my @new = an_array();
my $it = $new[$i];
my $broken = break_it($it);
$new[$i] = $broken;
ok(! eq_array([EMAIL PROTECTED], [EMAIL PROTECTED]), "array broken ref='".ref($broken)."'");
}
my @new = an_array();
break_it([EMAIL PROTECTED]);
ok(! eq_array([EMAIL PROTECTED], [EMAIL PROTECTED]), "array broken extra");
}
{
# take a hash full of a variety of things and break each one
my %a1 = a_hash();
my %a2 = a_hash();
is_deeply(\%a1, \%a2, "is hash");
ok(eq_hash(\%a1, \%a2), "eq hash");
foreach my $key (keys %a1)
{
my %new = a_hash();
my $it = $new{$key};
my $broken = break_it($it);
$new{$key} = $broken;
ok(! eq_hash(\%new, \%a1), "hash broken ref='".ref($broken)."'");
}
my %new = a_hash();
break_it(\%new);
ok(! eq_hash(\%new, \%a1), "hash broken extra");
}
# test a messy complex thing
is_deeply(complex_thing(), complex_thing(), "complex");
sub an_array
{
return ( [], {}, "hello", \"ref", \['hello'] );
}
sub a_hash
{
return (
key1 => [],
key2 => {},
key3 => "hello",
key4 => \"ref",
key5 => \['hello']
);
}
sub break_it
{
my $it = shift;
if (UNIVERSAL::isa($it, 'ARRAY'))
{
push(@$it, "extra elem");
}
elsif (UNIVERSAL::isa($it, 'HASH'))
{
$it->{"extra key"} = "extra value";
}
elsif (UNIVERSAL::isa($it, 'REF'))
{
$it = \['a different ref'];
}
elsif (UNIVERSAL::isa($it, 'SCALAR'))
{
$it = \"$$it and something else";
}
else
{
$it = "$it something else";
}
return $it
}
sub complex_thing
{
my $b = [qw( hello world)];
my $a = [
{
key1 => \$b,
key2 => [{}],
key3 => \'scalarref',
key4 => 'scalar',
},
[\"scalarref"],
];
return $a;
}
