This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to base 2.02.
[perl5.git] / lib / fields.t
1 #!/usr/bin/perl -w
2
3 my $Has_PH;
4 BEGIN {
5     $SIG{__WARN__} = sub {
6         return if $_[0] =~ /^Pseudo-hashes are deprecated/ 
7     };
8     $Has_PH = $] < 5.009;
9 }
10
11 use strict;
12 use Test::More tests => 16;
13
14 BEGIN { use_ok('fields'); }
15
16
17 package Foo;
18
19 use fields qw(_no Pants who _up_yours);
20 use fields qw(what);
21
22 sub new { fields::new(shift) }
23 sub magic_new { bless [] }  # Doesn't 100% work, perl's problem.
24
25 package main;
26
27 is_deeply( [sort keys %Foo::FIELDS], 
28            [sort qw(_no Pants who _up_yours what)]
29 );
30
31 sub show_fields {
32     my($base, $mask) = @_;
33     no strict 'refs';
34     my $fields = \%{$base.'::FIELDS'};
35     return grep { ($fields::attr{$base}[$fields->{$_}] & $mask) == $mask} 
36                 keys %$fields;
37 }
38
39 is_deeply( [sort &show_fields('Foo', fields::PUBLIC)],
40            [sort qw(Pants who what)]);
41 is_deeply( [sort &show_fields('Foo', fields::PRIVATE)],
42            [sort qw(_no _up_yours)]);
43
44 # We should get compile time failures field name typos
45 eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");
46
47 my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"'
48                     : q[Attempt to access disallowed key 'notthere' in a ].
49                       q[restricted hash at ];
50 ok( $@ && $@ =~ /^$error/i );
51
52
53 foreach (Foo->new) {
54     my Foo $obj = $_;
55     my %test = ( Pants => 'Whatever', _no => 'Yeah',
56                  what  => 'Ahh',      who => 'Moo',
57                  _up_yours => 'Yip' );
58
59     $obj->{Pants} = 'Whatever';
60     $obj->{_no}   = 'Yeah';
61     @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip');
62
63     while(my($k,$v) = each %test) {
64         ok($obj->{$k} eq $v);
65     }
66 }
67
68 {
69     my $phash;
70     eval { $phash = fields::phash(name => "Joe", rank => "Captain") };
71     if( $Has_PH ) {
72         is( $phash->{rank}, "Captain" );
73     }
74     else {
75         like $@, qr/^Pseudo-hashes have been removed from Perl/;
76     }
77 }
78
79
80 # check if fields autovivify
81 {
82     package Foo::Autoviv;
83     use fields qw(foo bar);
84     sub new { fields::new($_[0]) }
85
86     package main;
87     my Foo::Autoviv $a = Foo::Autoviv->new();
88     $a->{foo} = ['a', 'ok', 'c'];
89     $a->{bar} = { A => 'ok' };
90     is( $a->{foo}[1],    'ok' );
91     is( $a->{bar}->{A},, 'ok' );
92 }
93
94 package Test::FooBar;
95
96 use fields qw(a b c);
97
98 sub new {
99     my $self = fields::new(shift);
100     %$self = @_ if @_;
101     $self;
102 }
103
104 package main;
105
106 {
107     my $x = Test::FooBar->new( a => 1, b => 2);
108
109     is(ref $x, 'Test::FooBar', 'x is a Test::FooBar');
110     ok(exists $x->{a}, 'x has a');
111     ok(exists $x->{b}, 'x has b');
112 }