dslinux/user/perl/lib/base/t base.t fields-base.t fields.t

[cayenne]

Update of /cvsroot/dslinux/dslinux/user/perl/lib/base/t
In directory antilope:/tmp/cvs-serv7729/lib/base/t

Added Files:
	base.t fields-base.t fields.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: fields-base.t ---
#!/usr/bin/perl -w

my $Has_PH;
BEGIN { 
    $Has_PH = $] < 5.009;
}

my $W;

BEGIN {
    $W = 0;
    $SIG{__WARN__} = sub {
        if ($_[0] =~ /^Hides field '.*?' in base class/) {
            $W++;
        }
        else {
            warn $_[0];
        }
    };
}

use strict;
use Test::More tests => 27;

BEGIN { use_ok('base'); }

package B1;
use fields qw(b1 b2 b3);

package B2;
use fields '_b1';
use fields qw(b1 _b2 b2);

sub new { fields::new(shift) }

package B3;
use fields qw(b4 _b5 b6 _b7);

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);

# Test that multiple inheritance fails.
package D6;
eval { 'base'->import(qw(B2 M B3)); };
::like($@, qr/can't multiply inherit %FIELDS/i, 
                                        'No multiple field inheritance');

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


# Test that a package with only private fields gets inherited properly
package B7;
use fields qw(_b1);

package D7;
use base qw(B7);
use fields qw(b1);


# Test that an intermediate package with no fields doesn't cause a problem.
package B8;
use fields qw(_b1);

package D8;
use base qw(B8);

package D8A;
use base qw(D8);
use fields qw(b1);


package main;

my %EXPECT = (
              B1 => [qw(b1 b2 b3)],
              D1 => [qw(b1 b2 b3 d1 d2 d3)],
              D2 => [qw(b1 b2 b3 _d1 _d2 d1 d2)],

              M  => [qw()],
              B2 => [qw(_b1 b1 _b2 b2)],
              D3 => [(undef,undef,undef,
                                qw(b2 b1 d1 _b1 _d1))],     # b1 is hidden
              D4 => [(undef,undef,undef,
                                qw(b2 b1 d1),undef,undef,qw(_d3 d3))],

              D5 => [undef, 'b1', undef, 'b2'],

              B3 => [qw(b4 _b5 b6 _b7)],

              B7 => [qw(_b1)],
              D7 => [undef, 'b1'],

              B8  => [qw(_b1)],
              D8  => [undef],
              D8A => [undef, 'b1'],

              'Foo::Bar'        => [qw(b1 b2 b3)],
              'Foo::Bar::Baz'   => [qw(b1 b2 b3 foo bar baz)],
             );

while(my($class, $efields) = each %EXPECT) {
    no strict 'refs';
    my %fields = %{$class.'::FIELDS'};
    my %expected_fields;
    foreach my $idx (1..@$efields) {
        my $key = $efields->[$idx-1];
        next unless $key;
        $expected_fields{$key} = $idx;
    }

    ::is_deeply(\%fields, \%expected_fields, "%FIELDS check:  $class");
}

# Did we get the appropriate amount of warnings?
is( $W, 1, 'right warnings' );


# A simple object creation and attribute access test
my B2 $obj1 = D3->new;
$obj1->{b1} = "B2";
my D3 $obj2 = $obj1;
$obj2->{b1} = "D3";

# We should get compile time failures field name typos
eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = "");
if( $Has_PH ) {
    like $@, 
      qr/^No such pseudo-hash field "notthere" in variable \$obj3 of type D3/;
}
else {
    like $@, 
      qr/^Attempt to access disallowed key 'notthere' in a restricted hash/;
}

# Slices
@$obj1{"_b1", "b1"} = (17, 29);
is( $obj1->{_b1}, 17 );
is( $obj1->{b1},  29 );

@$obj1{'_b1', 'b1'} = (44,28);
is( $obj1->{_b1}, 44 );
is( $obj1->{b1},  28 );



# Break multiple inheritance with a field name clash.
package E1;
use fields qw(yo this _lah meep 42);

package E2;
use fields qw(_yo ahhh this);

eval {
    package Broken;

    # The error must occur at run time for the eval to catch it.
    require base;
    'base'->import(qw(E1 E2));
};
::like( $@, qr/Can't multiply inherit %FIELDS/i, 'Again, no multi inherit' );


# Test that a package with no fields can inherit from a package with
# fields, and that pseudohash messages don't show up

package B9;
use fields qw(b1);

sub _mk_obj { fields::new($_[0])->{'b1'} };

package D9;
use base qw(B9);

package main;

{
    my $w = 0;
    local $SIG{__WARN__} = sub { $w++ };
    
    B9->_mk_obj();
    # used tp emit a warning that pseudohashes are deprecated, because
    # %FIELDS wasn't blessed.
    D9->_mk_obj();
    
    is ($w, 0, "pseudohash warnings in derived class with no fields of it's own");	
}

# [perl #31078] an intermediate class with no additional fields caused
# hidden fields in base class to get stomped on

{
    package X;
    use fields qw(X1 _X2);
    sub new {
	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 becaues 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;
    }
    sub get_X2 { my X $self = shift; $self->{_X2} }

    package Y;
    use base qw(X);

    sub new {
	my Y $self = shift;
	$self = fields::new($self) unless ref $self;
	$self->SUPER::new();
	return $self;
    }


    package Z;
    use base qw(Y);
    use fields qw(Z1);

    sub new {
	my Z $self = shift;
	$self = fields::new($self) unless ref $self;
	$self->SUPER::new();
	$self->{Z1} = 'z1';
	return $self;
    }

    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;
	}
    }
}

--- NEW FILE: base.t ---
#!/usr/bin/perl -w

use strict;
use Test::More tests => 10;

use_ok('base');


package No::Version;

use vars qw($Foo);
sub VERSION { 42 }

package Test::Version;

use base qw(No::Version);
::ok( $No::Version::VERSION =~ /set by base\.pm/,          '$VERSION bug' );

# 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);
::is( $Has::Version::VERSION, 42 );

package main;

my $eval1 = q{
  {
    package Eval1;
    {
      package Eval2;
      use base 'Eval1';
      $Eval2::VERSION = "1.02";
    }
    $Eval1::VERSION = "1.01";
  }
};

eval $eval1;
is( $@, '' );

is( $Eval1::VERSION, 1.01 );

is( $Eval2::VERSION, 1.02 );


eval q{use base 'reallyReAlLyNotexists'};
like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./,
                                          'base with empty package');

eval q{use base 'reallyReAlLyNotexists'};
like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./,
                                          '  still empty on 2nd load');

BEGIN { $Has::Version_0::VERSION = 0 }

package Test::Version3;

use base qw(Has::Version_0);
::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' );


package Test::SIGDIE;

{ 
    local $SIG{__DIE__} = sub { 
        ::fail('sigdie not caught, this test should not run') 
    };
    eval {
      'base'->import(qw(Huh::Boo));
    };

    ::like($@, qr/^Base class package "Huh::Boo" is empty/, 
         'Base class empty error message');

}

--- NEW FILE: fields.t ---
#!/usr/bin/perl -w

my $Has_PH;
BEGIN {
    $Has_PH = $] < 5.009;
}

use strict;
use Test::More tests => 16;

BEGIN { use_ok('fields'); }


package Foo;

use fields qw(_no Pants who _up_yours);
use fields qw(what);

sub new { fields::new(shift) }
sub magic_new { bless [] }  # Doesn't 100% work, perl's problem.

package main;

is_deeply( [sort keys %Foo::FIELDS], 
           [sort qw(_no Pants who _up_yours what)]
);

sub show_fields {
    my($base, $mask) = @_;
    no strict 'refs';
    my $fields = \%{$base.'::FIELDS'};
    return grep { ($fields::attr{$base}[$fields->{$_}] & $mask) == $mask} 
                keys %$fields;
}

is_deeply( [sort &show_fields('Foo', fields::PUBLIC)],
           [sort qw(Pants who what)]);
is_deeply( [sort &show_fields('Foo', fields::PRIVATE)],
           [sort qw(_no _up_yours)]);

# We should get compile time failures field name typos
eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");

my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"'
                    : q[Attempt to access disallowed key 'notthere' in a ].
                      q[restricted hash at ];
ok( $@ && $@ =~ /^$error/i );


foreach (Foo->new) {
    my Foo $obj = $_;
    my %test = ( Pants => 'Whatever', _no => 'Yeah',
                 what  => 'Ahh',      who => 'Moo',
                 _up_yours => 'Yip' );

    $obj->{Pants} = 'Whatever';
    $obj->{_no}   = 'Yeah';
    @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip');

    while(my($k,$v) = each %test) {
        ok($obj->{$k} eq $v);
    }
}

{
    local $SIG{__WARN__} = sub {
        return if $_[0] =~ /^Pseudo-hashes are deprecated/ 
    };
    my $phash;
    eval { $phash = fields::phash(name => "Joe", rank => "Captain") };
    if( $Has_PH ) {
        is( $phash->{rank}, "Captain" );
    }
    else {
        like $@, qr/^Pseudo-hashes have been removed from Perl/;
    }
}


# check if fields autovivify
{
    package Foo::Autoviv;
    use fields qw(foo bar);
    sub new { fields::new($_[0]) }

    package main;
    my Foo::Autoviv $a = Foo::Autoviv->new();
    $a->{foo} = ['a', 'ok', 'c'];
    $a->{bar} = { A => 'ok' };
    is( $a->{foo}[1],    'ok' );
    is( $a->{bar}->{A},, 'ok' );
}

package Test::FooBar;

use fields qw(a b c);

sub new {
    my $self = fields::new(shift);
    %$self = @_ if @_;
    $self;
}

package main;

{
    my $x = Test::FooBar->new( a => 1, b => 2);

    is(ref $x, 'Test::FooBar', 'x is a Test::FooBar');
    ok(exists $x->{a}, 'x has a');
    ok(exists $x->{b}, 'x has b');
}