xref: /openbsd/gnu/usr.bin/perl/dist/base/t/fields.t (revision 898184e3) 
1#!/usr/bin/perl -w
2
3my $Has_PH;
4BEGIN {
5    $Has_PH = $] < 5.009;
6}
7
8use strict;
9use Test::More tests => 18;
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
44like $@, qr/^No such .*field "notthere"/i;
45
46
47foreach (Foo->new) {
48    my Foo $obj = $_;
49    my %test = ( Pants => 'Whatever', _no => 'Yeah',
50                 what  => 'Ahh',      who => 'Moo',
51                 _up_yours => 'Yip' );
52
53    $obj->{Pants} = 'Whatever';
54    $obj->{_no}   = 'Yeah';
55    @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip');
56
57    while(my($k,$v) = each %test) {
58        is($obj->{$k}, $v);
59    }
60}
61
62{
63    local $SIG{__WARN__} = sub {
64        return if $_[0] =~ /^Pseudo-hashes are deprecated/
65    };
66    my $phash;
67    eval { $phash = fields::phash(name => "Joe", rank => "Captain") };
68    if( $Has_PH ) {
69        is( $phash->{rank}, "Captain" );
70    }
71    else {
72        like $@, qr/^Pseudo-hashes have been removed from Perl/;
73    }
74}
75
76
77# check if fields autovivify
78{
79    package Foo::Autoviv;
80    use fields qw(foo bar);
81    sub new { fields::new($_[0]) }
82
83    package main;
84    my Foo::Autoviv $a = Foo::Autoviv->new();
85    $a->{foo} = ['a', 'ok', 'c'];
86    $a->{bar} = { A => 'ok' };
87    is( $a->{foo}[1],    'ok' );
88    is( $a->{bar}->{A},, 'ok' );
89}
90
91package Test::FooBar;
92
93use fields qw(a b c);
94
95sub new {
96    my $self = fields::new(shift);
97    %$self = @_ if @_;
98    $self;
99}
100
101package main;
102
103{
104    my $x = Test::FooBar->new( a => 1, b => 2);
105
106    is(ref $x, 'Test::FooBar', 'x is a Test::FooBar');
107    ok(exists $x->{a}, 'x has a');
108    ok(exists $x->{b}, 'x has b');
109
110    SKIP: {
111        skip "These tests trigger a perl bug", 2 if $] < 5.015;
112        $x->{a} = __PACKAGE__;
113        ok eval { delete $x->{a}; 1 }, 'deleting COW values' or diag $@;
114        $x->{a} = __PACKAGE__;
115        ok eval { %$x = (); 1 }, 'clearing a restr hash containing COWs' or diag $@;
116    }
117}
118