1#!/usr/bin/perl -w 2 3my $Has_PH; 4BEGIN { 5 $Has_PH = $] < 5.009; 6} 7 8use strict; 9use Test::More tests => 16; 10 11BEGIN { use_ok('fields'); } 12 13 14package Foo; 15 16use fields qw(_no Pants who _up_yours); 17use fields qw(what); 18 19sub new { fields::new(shift) } 20sub magic_new { bless [] } # Doesn't 100% work, perl's problem. 21 22package main; 23 24is_deeply( [sort keys %Foo::FIELDS], 25 [sort qw(_no Pants who _up_yours what)] 26); 27 28sub 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 36is_deeply( [sort &show_fields('Foo', fields::PUBLIC)], 37 [sort qw(Pants who what)]); 38is_deeply( [sort &show_fields('Foo', fields::PRIVATE)], 39 [sort qw(_no _up_yours)]); 40 41# We should get compile time failures field name typos 42eval q(my Foo $obj = Foo->new; $obj->{notthere} = ""); 43 44my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"' 45 : q[Attempt to access disallowed key 'notthere' in a ]. 46 q[restricted hash at ]; 47ok( $@ && $@ =~ /^$error/i ); 48 49 50foreach (Foo->new) { 51 my Foo $obj = $_; 52 my %test = ( Pants => 'Whatever', _no => 'Yeah', 53 what => 'Ahh', who => 'Moo', 54 _up_yours => 'Yip' ); 55 56 $obj->{Pants} = 'Whatever'; 57 $obj->{_no} = 'Yeah'; 58 @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip'); 59 60 while(my($k,$v) = each %test) { 61 ok($obj->{$k} eq $v); 62 } 63} 64 65{ 66 local $SIG{__WARN__} = sub { 67 return if $_[0] =~ /^Pseudo-hashes are deprecated/ 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 94package Test::FooBar; 95 96use fields qw(a b c); 97 98sub new { 99 my $self = fields::new(shift); 100 %$self = @_ if @_; 101 $self; 102} 103 104package 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} 113