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