This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow lvalue subs to return COWs in reference context
[perl5.git] / dist / base / t / fields.t
CommitLineData
33d611b9 1#!/usr/bin/perl -w
f1192cee 2
33d611b9 3my $Has_PH;
f1192cee 4BEGIN {
33d611b9 5 $Has_PH = $] < 5.009;
f1192cee
GA
6}
7
b47ba5cf 8use strict;
33d611b9 9use Test::More tests => 16;
f1192cee 10
33d611b9 11BEGIN { use_ok('fields'); }
f1192cee 12
f1192cee 13
33d611b9 14package Foo;
f1192cee 15
33d611b9
JH
16use fields qw(_no Pants who _up_yours);
17use fields qw(what);
f1192cee 18
33d611b9
JH
19sub new { fields::new(shift) }
20sub magic_new { bless [] } # Doesn't 100% work, perl's problem.
f30a1143 21
f1192cee
GA
22package main;
23
33d611b9
JH
24is_deeply( [sort keys %Foo::FIELDS],
25 [sort qw(_no Pants who _up_yours what)]
f1192cee
GA
26);
27
33d611b9
JH
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}
0ea4badc 35
33d611b9
JH
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)]);
0ea4badc 40
33d611b9 41# We should get compile time failures field name typos
9e998a43 42eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");
f1192cee 43
9e998a43 44like $@, qr/^No such .*field "notthere"/i;
f1192cee 45
f1192cee 46
33d611b9
JH
47foreach (Foo->new) {
48 my Foo $obj = $_;
49 my %test = ( Pants => 'Whatever', _no => 'Yeah',
50 what => 'Ahh', who => 'Moo',
51 _up_yours => 'Yip' );
f1192cee 52
33d611b9
JH
53 $obj->{Pants} = 'Whatever';
54 $obj->{_no} = 'Yeah';
55 @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip');
479ba383 56
33d611b9 57 while(my($k,$v) = each %test) {
20cfb761 58 is($obj->{$k}, $v);
33d611b9
JH
59 }
60}
479ba383 61
33d611b9 62{
864f8ab4
JH
63 local $SIG{__WARN__} = sub {
64 return if $_[0] =~ /^Pseudo-hashes are deprecated/
65 };
33d611b9
JH
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}
479ba383 75
377b21bb 76
479ba383 77# check if fields autovivify
377b21bb 78{
33d611b9 79 package Foo::Autoviv;
377b21bb 80 use fields qw(foo bar);
6d822dc4 81 sub new { fields::new($_[0]) }
377b21bb
GS
82
83 package main;
33d611b9 84 my Foo::Autoviv $a = Foo::Autoviv->new();
6d822dc4
MS
85 $a->{foo} = ['a', 'ok', 'c'];
86 $a->{bar} = { A => 'ok' };
87 is( $a->{foo}[1], 'ok' );
88 is( $a->{bar}->{A},, 'ok' );
377b21bb 89}
479ba383 90
0ea4badc
JH
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');
0ea4badc 109}