lib/base/t/fields.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN {
   4    if( $ENV{PERL_CORE} ) {
   5         chdir 't' if -d 't';
   6         @INC = qw(../lib);
   7     }
   8 }
   9
  10 my $Has_PH;
  11 BEGIN {
  12     $Has_PH = $] < 5.009;
  13 }
  14
  15 use strict;
  16 use Test::More tests => 16;
  17
  18 BEGIN { use_ok('fields'); }
  19
  20
  21 package Foo;
  22
  23 use fields qw(_no Pants who _up_yours);
  24 use fields qw(what);
  25
  26 sub new { fields::new(shift) }
  27 sub magic_new { bless [] }  # Doesn't 100% work, perl's problem.
  28
  29 package main;
  30
  31 is_deeply( [sort keys %Foo::FIELDS],
  32            [sort qw(_no Pants who _up_yours what)]
  33 );
  34
  35 sub show_fields {
  36     my($base, $mask) = @_;
  37     no strict 'refs';
  38     my $fields = \%{$base.'::FIELDS'};
  39     return grep { ($fields::attr{$base}[$fields->{$_}] & $mask) == $mask}
  40                 keys %$fields;
  41 }
  42
  43 is_deeply( [sort &show_fields('Foo', fields::PUBLIC)],
  44            [sort qw(Pants who what)]);
  45 is_deeply( [sort &show_fields('Foo', fields::PRIVATE)],
  46            [sort qw(_no _up_yours)]);
  47
  48 # We should get compile time failures field name typos
  49 eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");
  50
  51 like $@, qr/^No such .*field "notthere"/i;
  52
  53
  54 foreach (Foo->new) {
  55     my Foo $obj = $_;
  56     my %test = ( Pants => 'Whatever', _no => 'Yeah',
  57                  what  => 'Ahh',      who => 'Moo',
  58                  _up_yours => 'Yip' );
  59
  60     $obj->{Pants} = 'Whatever';
  61     $obj->{_no}   = 'Yeah';
  62     @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip');
  63
  64     while(my($k,$v) = each %test) {
  65         is($obj->{$k}, $v);
  66     }
  67 }
  68
  69 {
  70     local $SIG{__WARN__} = sub {
  71         return if $_[0] =~ /^Pseudo-hashes are deprecated/
  72     };
  73     my $phash;
  74     eval { $phash = fields::phash(name => "Joe", rank => "Captain") };
  75     if( $Has_PH ) {
  76         is( $phash->{rank}, "Captain" );
  77     }
  78     else {
  79         like $@, qr/^Pseudo-hashes have been removed from Perl/;
  80     }
  81 }
  82
  83
  84 # check if fields autovivify
  85 {
  86     package Foo::Autoviv;
  87     use fields qw(foo bar);
  88     sub new { fields::new($_[0]) }
  89
  90     package main;
  91     my Foo::Autoviv $a = Foo::Autoviv->new();
  92     $a->{foo} = ['a', 'ok', 'c'];
  93     $a->{bar} = { A => 'ok' };
  94     is( $a->{foo}[1],    'ok' );
  95     is( $a->{bar}->{A},, 'ok' );
  96 }
  97
  98 package Test::FooBar;
  99
 100 use fields qw(a b c);
 101
 102 sub new {
 103     my $self = fields::new(shift);
 104     %$self = @_ if @_;
 105     $self;
 106 }
 107
 108 package main;
 109
 110 {
 111     my $x = Test::FooBar->new( a => 1, b => 2);
 112
 113     is(ref $x, 'Test::FooBar', 'x is a Test::FooBar');
 114     ok(exists $x->{a}, 'x has a');
 115     ok(exists $x->{b}, 'x has b');
 116 }