This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: perl@21233 looks ok on VMS 7.3-1
[perl5.git] / lib / fields.t
CommitLineData
33d611b9 1#!/usr/bin/perl -w
f1192cee 2
33d611b9 3my $Has_PH;
f1192cee 4BEGIN {
33d611b9
JH
5 $SIG{__WARN__} = sub {
6 return if $_[0] =~ /^Pseudo-hashes are deprecated/
7 };
8 $Has_PH = $] < 5.009;
f1192cee
GA
9}
10
b47ba5cf 11use strict;
33d611b9 12use Test::More tests => 16;
f1192cee 13
33d611b9 14BEGIN { use_ok('fields'); }
f1192cee 15
f1192cee 16
33d611b9 17package Foo;
f1192cee 18
33d611b9
JH
19use fields qw(_no Pants who _up_yours);
20use fields qw(what);
f1192cee 21
33d611b9
JH
22sub new { fields::new(shift) }
23sub magic_new { bless [] } # Doesn't 100% work, perl's problem.
f30a1143 24
f1192cee
GA
25package main;
26
33d611b9
JH
27is_deeply( [sort keys %Foo::FIELDS],
28 [sort qw(_no Pants who _up_yours what)]
f1192cee
GA
29);
30
33d611b9
JH
31sub show_fields {
32 my($base, $mask) = @_;
33 no strict 'refs';
34 my $fields = \%{$base.'::FIELDS'};
35 return grep { ($fields::attr{$base}[$fields->{$_}] & $mask) == $mask}
36 keys %$fields;
37}
0ea4badc 38
33d611b9
JH
39is_deeply( [sort &show_fields('Foo', fields::PUBLIC)],
40 [sort qw(Pants who what)]);
41is_deeply( [sort &show_fields('Foo', fields::PRIVATE)],
42 [sort qw(_no _up_yours)]);
0ea4badc 43
33d611b9
JH
44# We should get compile time failures field name typos
45eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");
f1192cee 46
33d611b9
JH
47my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"'
48 : q[Attempt to access disallowed key 'notthere' in a ].
49 q[restricted hash at ];
50ok( $@ && $@ =~ /^$error/i );
f1192cee 51
f1192cee 52
33d611b9
JH
53foreach (Foo->new) {
54 my Foo $obj = $_;
55 my %test = ( Pants => 'Whatever', _no => 'Yeah',
56 what => 'Ahh', who => 'Moo',
57 _up_yours => 'Yip' );
f1192cee 58
33d611b9
JH
59 $obj->{Pants} = 'Whatever';
60 $obj->{_no} = 'Yeah';
61 @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip');
479ba383 62
33d611b9
JH
63 while(my($k,$v) = each %test) {
64 ok($obj->{$k} eq $v);
65 }
66}
479ba383 67
33d611b9
JH
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}
479ba383 78
377b21bb 79
479ba383 80# check if fields autovivify
377b21bb 81{
33d611b9 82 package Foo::Autoviv;
377b21bb 83 use fields qw(foo bar);
6d822dc4 84 sub new { fields::new($_[0]) }
377b21bb
GS
85
86 package main;
33d611b9 87 my Foo::Autoviv $a = Foo::Autoviv->new();
6d822dc4
MS
88 $a->{foo} = ['a', 'ok', 'c'];
89 $a->{bar} = { A => 'ok' };
90 is( $a->{foo}[1], 'ok' );
91 is( $a->{bar}->{A},, 'ok' );
377b21bb 92}
479ba383 93
0ea4badc
JH
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');
0ea4badc 112}