lib/base/t/fields.t

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