Commit | Line | Data |
---|---|---|
33d611b9 | 1 | #!/usr/bin/perl -w |
f1192cee | 2 | |
39063025 RGS |
3 | BEGIN { |
4 | if( $ENV{PERL_CORE} ) { | |
5 | chdir 't' if -d 't'; | |
6 | @INC = qw(../lib); | |
7 | } | |
8 | } | |
9 | ||
33d611b9 | 10 | my $Has_PH; |
f1192cee | 11 | BEGIN { |
33d611b9 | 12 | $Has_PH = $] < 5.009; |
f1192cee GA |
13 | } |
14 | ||
b47ba5cf | 15 | use strict; |
33d611b9 | 16 | use Test::More tests => 16; |
f1192cee | 17 | |
33d611b9 | 18 | BEGIN { use_ok('fields'); } |
f1192cee | 19 | |
f1192cee | 20 | |
33d611b9 | 21 | package Foo; |
f1192cee | 22 | |
33d611b9 JH |
23 | use fields qw(_no Pants who _up_yours); |
24 | use fields qw(what); | |
f1192cee | 25 | |
33d611b9 JH |
26 | sub new { fields::new(shift) } |
27 | sub magic_new { bless [] } # Doesn't 100% work, perl's problem. | |
f30a1143 | 28 | |
f1192cee GA |
29 | package main; |
30 | ||
33d611b9 JH |
31 | is_deeply( [sort keys %Foo::FIELDS], |
32 | [sort qw(_no Pants who _up_yours what)] | |
f1192cee GA |
33 | ); |
34 | ||
33d611b9 JH |
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 | } | |
0ea4badc | 42 | |
33d611b9 JH |
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)]); | |
0ea4badc | 47 | |
33d611b9 | 48 | # We should get compile time failures field name typos |
9e998a43 | 49 | eval q(my Foo $obj = Foo->new; $obj->{notthere} = ""); |
f1192cee | 50 | |
9e998a43 | 51 | like $@, qr/^No such .*field "notthere"/i; |
f1192cee | 52 | |
f1192cee | 53 | |
33d611b9 JH |
54 | foreach (Foo->new) { |
55 | my Foo $obj = $_; | |
56 | my %test = ( Pants => 'Whatever', _no => 'Yeah', | |
57 | what => 'Ahh', who => 'Moo', | |
58 | _up_yours => 'Yip' ); | |
f1192cee | 59 | |
33d611b9 JH |
60 | $obj->{Pants} = 'Whatever'; |
61 | $obj->{_no} = 'Yeah'; | |
62 | @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip'); | |
479ba383 | 63 | |
33d611b9 | 64 | while(my($k,$v) = each %test) { |
20cfb761 | 65 | is($obj->{$k}, $v); |
33d611b9 JH |
66 | } |
67 | } | |
479ba383 | 68 | |
33d611b9 | 69 | { |
864f8ab4 JH |
70 | local $SIG{__WARN__} = sub { |
71 | return if $_[0] =~ /^Pseudo-hashes are deprecated/ | |
72 | }; | |
33d611b9 JH |
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 | } | |
479ba383 | 82 | |
377b21bb | 83 | |
479ba383 | 84 | # check if fields autovivify |
377b21bb | 85 | { |
33d611b9 | 86 | package Foo::Autoviv; |
377b21bb | 87 | use fields qw(foo bar); |
6d822dc4 | 88 | sub new { fields::new($_[0]) } |
377b21bb GS |
89 | |
90 | package main; | |
33d611b9 | 91 | my Foo::Autoviv $a = Foo::Autoviv->new(); |
6d822dc4 MS |
92 | $a->{foo} = ['a', 'ok', 'c']; |
93 | $a->{bar} = { A => 'ok' }; | |
94 | is( $a->{foo}[1], 'ok' ); | |
95 | is( $a->{bar}->{A},, 'ok' ); | |
377b21bb | 96 | } |
479ba383 | 97 | |
0ea4badc JH |
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'); | |
0ea4badc | 116 | } |