Commit | Line | Data |
33d611b9 |
1 | #!/usr/bin/perl -w |
f1192cee |
2 | |
33d611b9 |
3 | my $Has_PH; |
f1192cee |
4 | BEGIN { |
33d611b9 |
5 | $Has_PH = $] < 5.009; |
f1192cee |
6 | } |
7 | |
b47ba5cf |
8 | use strict; |
33d611b9 |
9 | use Test::More tests => 16; |
f1192cee |
10 | |
33d611b9 |
11 | BEGIN { use_ok('fields'); } |
f1192cee |
12 | |
f1192cee |
13 | |
33d611b9 |
14 | package Foo; |
f1192cee |
15 | |
33d611b9 |
16 | use fields qw(_no Pants who _up_yours); |
17 | use fields qw(what); |
f1192cee |
18 | |
33d611b9 |
19 | sub new { fields::new(shift) } |
20 | sub magic_new { bless [] } # Doesn't 100% work, perl's problem. |
f30a1143 |
21 | |
f1192cee |
22 | package main; |
23 | |
33d611b9 |
24 | is_deeply( [sort keys %Foo::FIELDS], |
25 | [sort qw(_no Pants who _up_yours what)] |
f1192cee |
26 | ); |
27 | |
33d611b9 |
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 | } |
0ea4badc |
35 | |
33d611b9 |
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)]); |
0ea4badc |
40 | |
33d611b9 |
41 | # We should get compile time failures field name typos |
e75d1f10 |
42 | eval q(return; my Foo $obj = Foo->new; $obj->{notthere} = ""); |
f1192cee |
43 | |
ef5bf20b |
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 ); |
f1192cee |
47 | |
f1192cee |
48 | |
33d611b9 |
49 | foreach (Foo->new) { |
50 | my Foo $obj = $_; |
51 | my %test = ( Pants => 'Whatever', _no => 'Yeah', |
52 | what => 'Ahh', who => 'Moo', |
53 | _up_yours => 'Yip' ); |
f1192cee |
54 | |
33d611b9 |
55 | $obj->{Pants} = 'Whatever'; |
56 | $obj->{_no} = 'Yeah'; |
57 | @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip'); |
479ba383 |
58 | |
33d611b9 |
59 | while(my($k,$v) = each %test) { |
20cfb761 |
60 | is($obj->{$k}, $v); |
33d611b9 |
61 | } |
62 | } |
479ba383 |
63 | |
33d611b9 |
64 | { |
864f8ab4 |
65 | local $SIG{__WARN__} = sub { |
66 | return if $_[0] =~ /^Pseudo-hashes are deprecated/ |
67 | }; |
33d611b9 |
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 | } |
479ba383 |
77 | |
377b21bb |
78 | |
479ba383 |
79 | # check if fields autovivify |
377b21bb |
80 | { |
33d611b9 |
81 | package Foo::Autoviv; |
377b21bb |
82 | use fields qw(foo bar); |
6d822dc4 |
83 | sub new { fields::new($_[0]) } |
377b21bb |
84 | |
85 | package main; |
33d611b9 |
86 | my Foo::Autoviv $a = Foo::Autoviv->new(); |
6d822dc4 |
87 | $a->{foo} = ['a', 'ok', 'c']; |
88 | $a->{bar} = { A => 'ok' }; |
89 | is( $a->{foo}[1], 'ok' ); |
90 | is( $a->{bar}->{A},, 'ok' ); |
377b21bb |
91 | } |
479ba383 |
92 | |
0ea4badc |
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'); |
0ea4badc |
111 | } |