From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Sun, 28 Jun 2009 15:55:18 +0000 (+0200)
Subject: Add base.pm tests from the CPAN distribution
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d19d8ad381fb36912d19688e1f316e244567bb44;p=p5sagit%2Fp5-mst-13.2.git

Add base.pm tests from the CPAN distribution
---

diff --git a/MANIFEST b/MANIFEST
index d2aa371..7c620bc 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1815,7 +1815,10 @@ lib/autouse.t			See if autouse works
 lib/base/Changes		base.pm changelog
 lib/base.pm			Establish IS-A relationship at compile time
 lib/base/t/base.t		See if base works
+lib/base/t/compile-time.t	See if base works
 lib/base/t/fields-base.t	See if fields work
+lib/base/t/fields-5.6.0.t	See if fields work
+lib/base/t/fields-5.8.0.t	See if fields work
 lib/base/t/fields.t		See if fields work
 lib/base/t/isa.t		See if base's behaviour doesn't change
 lib/base/t/lib/Dummy.pm		Test module for base.pm
diff --git a/lib/base/t/compile-time.t b/lib/base/t/compile-time.t
new file mode 100644
index 0000000..2be51f9
--- /dev/null
+++ b/lib/base/t/compile-time.t
@@ -0,0 +1,42 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 3;
+
+my $Has_PH = $] < 5.009;
+my $Field = $Has_PH ? "pseudo-hash field" : "class field";
+
+{
+    package Parent;
+    use fields qw(this that);
+    sub new { fields::new(shift) }
+}
+
+{
+    package Child;
+    use base qw(Parent);
+}
+
+my Child $obj = Child->new;
+
+eval q(return; my Child $obj3 = $obj; $obj3->{notthere} = "");
+like $@, 
+    qr/^No such .*field "notthere" in variable \$obj3 of type Child/,
+    "Compile failure of undeclared fields (helem)";
+
+# Slices
+# We should get compile time failures field name typos
+SKIP: {
+    skip("Pseudo-hashes do not support compile-time slice checks", 2)
+        if $Has_PH;
+
+    eval q(return; my Child $obj3 = $obj; my $k; @$obj3{$k,'notthere'} = ());
+    like $@, 
+        qr/^No such .*field "notthere" in variable \$obj3 of type Child/,
+        "Compile failure of undeclared fields (hslice)";
+
+    eval q(return; my Child $obj3 = $obj; my $k; @{$obj3}{$k,'notthere'} = ());
+    like 
+        $@, qr/^No such .*field "notthere" in variable \$obj3 of type Child/,
+        "Compile failure of undeclared fields (hslice (block form))";
+}
diff --git a/lib/base/t/fields-5.6.0.t b/lib/base/t/fields-5.6.0.t
new file mode 100644
index 0000000..93bca34
--- /dev/null
+++ b/lib/base/t/fields-5.6.0.t
@@ -0,0 +1,228 @@
+# The fields.pm and base.pm regression tests from 5.6.0
+
+# We skip this on 5.9.0 and up since pseudohashes were removed and a lot
+# of it won't work.
+if( $] >= 5.009 ) { 
+    print "1..0 # skip pseudo-hashes removed in 5.9.0\n";
+    exit;
+}
+
+use strict;
+use vars qw($Total_tests);
+
+my $test_num = 1;
+BEGIN { $| = 1; $^W = 1; }
+print "1..$Total_tests\n";
+use fields;
+use base;
+print "ok $test_num\n";
+$test_num++;
+
+# Insert your test code below (better if it prints "ok 13"
+# (correspondingly "not ok 13") depending on the success of chunk 13
+# of the test code):
+sub ok {
+    my($test, $name) = @_;
+    print "not " unless $test;
+    print "ok $test_num";
+    print " - $name" if defined $name;
+    print "\n";
+    $test_num++;
+}
+
+sub eqarray  {
+    my($a1, $a2) = @_;
+    return 0 unless @$a1 == @$a2;
+    my $ok = 1;
+    for (0..$#{$a1}) { 
+        unless($a1->[$_] eq $a2->[$_]) {
+            $ok = 0;
+            last;
+        }
+    }
+    return $ok;
+}
+
+# Change this to your # of ok() calls + 1
+BEGIN { $Total_tests = 14 }
+
+
+my $w;
+
+BEGIN {
+   $^W = 1;
+
+   $SIG{__WARN__} = sub {
+       if ($_[0] =~ /^Hides field 'b1' in base class/) {
+           $w++;
+           return;
+       }
+       print $_[0];
+   };
+}
+
+use strict;
+use vars qw($DEBUG);
+
+package B1;
+use fields qw(b1 b2 b3);
+
+package B2;
+use fields '_b1';
+use fields qw(b1 _b2 b2);
+
+sub new { bless [], shift }
+
+package D1;
+use base 'B1';
+use fields qw(d1 d2 d3);
+
+package D2;
+use base 'B1';
+use fields qw(_d1 _d2);
+use fields qw(d1 d2);
+
+package D3;
+use base 'B2';
+use fields qw(b1 d1 _b1 _d1);  # hide b1
+
+package D4;
+use base 'D3';
+use fields qw(_d3 d3);
+
+package M;
+sub m {}
+
+package D5;
+use base qw(M B2);
+
+package Foo::Bar;
+use base 'B1';
+
+package Foo::Bar::Baz;
+use base 'Foo::Bar';
+use fields qw(foo bar baz);
+
+# Test repeatability for when modules get reloaded.
+package B1;
+use fields qw(b1 b2 b3);
+
+package D3;
+use base 'B2';
+use fields qw(b1 d1 _b1 _d1);  # hide b1
+
+package main;
+
+sub fstr {
+   my $h = shift;
+   my @tmp;
+   for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) {
+	my $v = $h->{$k};
+        push(@tmp, "$k:$v");
+   }
+   my $str = join(",", @tmp);
+   print "$h => $str\n" if $DEBUG;
+   $str;
+}
+
+my %expect;
+BEGIN {
+    %expect = (
+               B1 => "b1:1,b2:2,b3:3",
+               B2 => "_b1:1,b1:2,_b2:3,b2:4",
+               D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6",
+               D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7",
+               D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8",
+               D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10",
+               D5 => "b1:2,b2:4",
+               'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
+              );
+    $Total_tests += int(keys %expect);
+}
+my $testno = 0;
+while (my($class, $exp) = each %expect) {
+   no strict 'refs';
+   my $fstr = fstr(\%{$class."::FIELDS"});
+   ok( $fstr eq $exp, "'$fstr' eq '$exp'" );
+}
+
+# Did we get the appropriate amount of warnings?
+ok( $w == 1 );
+
+# A simple object creation and AVHV attribute access test
+my B2 $obj1 = D3->new;
+$obj1->{b1} = "B2";
+my D3 $obj2 = $obj1;
+$obj2->{b1} = "D3";
+
+ok( $obj1->[2] eq "B2" && $obj1->[5] eq "D3" );
+
+# We should get compile time failures field name typos
+eval q{ my D3 $obj3 = $obj2; $obj3->{notthere} = "" };
+ok( $@ && $@ =~ /^No such pseudo-hash field "notthere"/,
+                                 'compile error -- field name typos' );
+
+
+# Slices
+if( $] >= 5.006 ) {
+    @$obj1{"_b1", "b1"} = (17, 29);
+    ok( "@$obj1[1,2]" eq "17 29" );
+
+    @$obj1[1,2] = (44,28);
+    ok( "@$obj1{'b1','_b1','b1'}" eq "28 44 28" );
+}
+else {
+    ok( 1, 'test skipped for perl < 5.6.0' );
+    ok( 1, 'test skipped for perl < 5.6.0' );
+}
+
+my $ph = fields::phash(a => 1, b => 2, c => 3);
+ok( fstr($ph) eq 'a:1,b:2,c:3' );
+
+$ph = fields::phash([qw/a b c/], [1, 2, 3]);
+ok( fstr($ph) eq 'a:1,b:2,c:3' );
+
+# The way exists() works with psuedohashes changed from 5.005 to 5.6
+$ph = fields::phash([qw/a b c/], [1]);
+if( $] > 5.006 ) {
+    ok( !( exists $ph->{b} or exists $ph->{c} or !exists $ph->{a} ) );
+}
+else {
+    ok( !( defined $ph->{b} or defined $ph->{c} or !defined $ph->{a} ) );
+}
+
+eval { $ph = fields::phash("odd") };
+ok( $@ && $@ =~ /^Odd number of/ );
+
+
+# check if fields autovivify
+if ( $] > 5.006 ) {
+    package Foo;
+    use fields qw(foo bar);
+    sub new { bless [], $_[0]; }
+
+    package main;
+    my Foo $a = Foo->new();
+    $a->{foo} = ['a', 'ok', 'c'];
+    $a->{bar} = { A => 'ok' };
+    ok( $a->{foo}[1]   eq 'ok' );
+    ok( $a->{bar}->{A} eq 'ok' );
+}
+else {
+    ok( 1, 'test skipped for perl < 5.6.0' );
+    ok( 1, 'test skipped for perl < 5.6.0' );
+}
+
+# check if fields autovivify
+{
+    package Bar;
+    use fields qw(foo bar);
+    sub new { return fields::new($_[0]) }
+
+    package main;
+    my Bar $a = Bar::->new();
+    $a->{foo} = ['a', 'ok', 'c'];
+    $a->{bar} = { A => 'ok' };
+    ok( $a->{foo}[1]   eq 'ok' );
+    ok( $a->{bar}->{A} eq 'ok' );
+}
diff --git a/lib/base/t/fields-5.8.0.t b/lib/base/t/fields-5.8.0.t
new file mode 100644
index 0000000..2da1412
--- /dev/null
+++ b/lib/base/t/fields-5.8.0.t
@@ -0,0 +1,254 @@
+#!/usr/bin/perl -w
+
+# We skip this on 5.9.0 and up since pseudohashes were removed and a lot of
+# it won't work.
+if( $] >= 5.009 ) { 
+    print "1..0 # skip pseudo-hashes removed in 5.9.0\n";
+    exit;
+}
+
+
+my $w;
+
+BEGIN {
+   $SIG{__WARN__} = sub {
+       if ($_[0] =~ /^Hides field 'b1' in base class/) {
+           $w++;
+       }
+       else {
+	 print STDERR $_[0];
+       }
+   };
+}
+
+use strict;
+use vars qw($DEBUG);
+
+package B1;
+use fields qw(b1 b2 b3);
+
+package B2;
+use fields '_b1';
+use fields qw(b1 _b2 b2);
+
+sub new { bless [], shift }
+
+package D1;
+use base 'B1';
+use fields qw(d1 d2 d3);
+
+package D2;
+use base 'B1';
+use fields qw(_d1 _d2);
+use fields qw(d1 d2);
+
+package D3;
+use base 'B2';
+use fields qw(b1 d1 _b1 _d1);  # hide b1
+
+package D4;
+use base 'D3';
+use fields qw(_d3 d3);
+
+package M;
+sub m {}
+
+package D5;
+use base qw(M B2);
+
+package Foo::Bar;
+use base 'B1';
+
+package Foo::Bar::Baz;
+use base 'Foo::Bar';
+use fields qw(foo bar baz);
+
+# Test repeatability for when modules get reloaded.
+package B1;
+use fields qw(b1 b2 b3);
+
+package D3;
+use base 'B2';
+use fields qw(b1 d1 _b1 _d1);  # hide b1
+
+package main;
+
+sub fstr {
+    local $SIG{__WARN__} = sub { 
+        return if $_[0] =~ /^Pseudo-hashes are deprecated/ 
+    };
+
+   my $h = shift;
+   my @tmp;
+   for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) {
+	my $v = $h->{$k};
+        push(@tmp, "$k:$v");
+   }
+   my $str = join(",", @tmp);
+   print "$h => $str\n" if $DEBUG;
+   $str;
+}
+
+my %expect = (
+    B1 => "b1:1,b2:2,b3:3",
+    B2 => "_b1:1,b1:2,_b2:3,b2:4",
+    D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6",
+    D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7",
+    D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8",
+    D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10",
+    D5 => "b1:2,b2:4",
+    'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6',
+);
+
+print "1..", int(keys %expect)+21, "\n";
+my $testno = 0;
+while (my($class, $exp) = each %expect) {
+   no strict 'refs';
+   my $fstr = fstr(\%{$class."::FIELDS"});
+   print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp;
+   print "ok ", ++$testno, "\n";
+}
+
+# Did we get the appropriate amount of warnings?
+print "not " unless $w == 1;
+print "ok ", ++$testno, "\n";
+
+# A simple object creation and AVHV attribute access test
+my B2 $obj1 = D3->new;
+$obj1->{b1} = "B2";
+my D3 $obj2 = $obj1;
+$obj2->{b1} = "D3";
+
+print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3";
+print "ok ", ++$testno, "\n";
+
+# We should get compile time failures field name typos
+eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
+print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/;
+print "ok ", ++$testno, "\n";
+
+# Slices
+@$obj1{"_b1", "b1"} = (17, 29);
+print "not " unless "@$obj1[1,2]" eq "17 29";
+print "ok ", ++$testno, "\n";
+@$obj1[1,2] = (44,28);
+print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28";
+print "ok ", ++$testno, "\n";
+
+{
+    local $SIG{__WARN__} = sub { 
+        return if $_[0] =~ /^Pseudo-hashes are deprecated/ 
+    };
+
+    my $ph = fields::phash(a => 1, b => 2, c => 3);
+    print "not " unless fstr($ph) eq 'a:1,b:2,c:3';
+    print "ok ", ++$testno, "\n";
+
+    $ph = fields::phash([qw/a b c/], [1, 2, 3]);
+    print "not " unless fstr($ph) eq 'a:1,b:2,c:3';
+    print "ok ", ++$testno, "\n";
+
+    $ph = fields::phash([qw/a b c/], [1]);
+    print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a};
+    print "ok ", ++$testno, "\n";
+
+    eval '$ph = fields::phash("odd")';
+    print "not " unless $@ && $@ =~ /^Odd number of/;
+    print "ok ", ++$testno, "\n";
+}
+
+#fields::_dump();
+
+# check if fields autovivify
+{
+    package Foo;
+    use fields qw(foo bar);
+    sub new { bless [], $_[0]; }
+
+    package main;
+    my Foo $a = Foo->new();
+    $a->{foo} = ['a', 'ok ' . ++$testno, 'c'];
+    $a->{bar} = { A => 'ok ' . ++$testno };
+    print $a->{foo}[1], "\n";
+    print $a->{bar}->{A}, "\n";
+}
+
+# check if fields autovivify
+{
+    package Bar;
+    use fields qw(foo bar);
+    sub new { return fields::new($_[0]) }
+
+    package main;
+    my Bar $a = Bar::->new();
+    $a->{foo} = ['a', 'ok ' . ++$testno, 'c'];
+    $a->{bar} = { A => 'ok ' . ++$testno };
+    print $a->{foo}[1], "\n";
+    print $a->{bar}->{A}, "\n";
+}
+
+
+# Test $VERSION bug
+package No::Version;
+
+use vars qw($Foo);
+sub VERSION { 42 }
+
+package Test::Version;
+
+use base qw(No::Version);
+print "# $No::Version::VERSION\nnot " unless $No::Version::VERSION =~ /set by base\.pm/;
+print "ok ", ++$testno ,"\n";
+
+# Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION
+package Has::Version;
+
+BEGIN { $Has::Version::VERSION = '42' };
+
+package Test::Version2;
+
+use base qw(Has::Version);
+print "#$Has::Version::VERSION\nnot " unless $Has::Version::VERSION eq '42';
+print "ok ", ++$testno ," # Has::Version\n";
+
+package main;
+
+my $eval1 = q{
+  {
+    package Eval1;
+    {
+      package Eval2;
+      use base 'Eval1';
+      $Eval2::VERSION = "1.02";
+    }
+    $Eval1::VERSION = "1.01";
+  }
+};
+
+eval $eval1;
+printf "# %s\nnot ", $@ if $@;
+print "ok ", ++$testno ," # eval1\n";
+
+print "# $Eval1::VERSION\nnot " unless $Eval1::VERSION == 1.01;
+print "ok ", ++$testno ," # Eval1::VERSION\n";
+
+print "# $Eval2::VERSION\nnot " unless $Eval2::VERSION == 1.02;
+print "ok ", ++$testno ," # Eval2::VERSION\n";
+
+
+eval q{use base reallyReAlLyNotexists;};
+print "not " unless $@;
+print "ok ", ++$testno, " # really not I\n";
+
+eval q{use base reallyReAlLyNotexists;};
+print "not " unless $@;
+print "ok ", ++$testno, " # really not II\n";
+
+BEGIN { $Has::Version_0::VERSION = 0 }
+
+package Test::Version3;
+
+use base qw(Has::Version_0);
+print "#$Has::Version_0::VERSION\nnot " unless $Has::Version_0::VERSION == 0;
+print "ok ", ++$testno ," # Version_0\n";
+
diff --git a/lib/base/t/fields-base.t b/lib/base/t/fields-base.t
index d3e8c7b..b27f066 100644
--- a/lib/base/t/fields-base.t
+++ b/lib/base/t/fields-base.t
@@ -245,6 +245,11 @@ package main;
 	my X $self = shift;
 	$self = fields::new($self) unless ref $self;
 	$self->{X1} = "x1";
+	# FIXME. This code is dead on blead becase the test is skipped.
+	# The test states that it's being skipped because restricted hashes
+	# don't support a feature. Presumably we need to make that feature
+	# supported. Bah.
+	# use Devel::Peek; Dump($self);
 	$self->{_X2} = "_x2";
 	return $self;
     }
@@ -275,6 +280,13 @@ package main;
 
     package main;
 
+    if ($Has_PH) {
 	my Z $c = Z->new();
 	is($c->get_X2, '_x2', "empty intermediate class");
+    }
+    else {
+	SKIP: {
+	    skip "restricted hashes don't support private fields properly", 1;
+	}
+    }
 }