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