lib/fields.t

   1 #!/usr/bin/perl -w
   2
   3 my $Has_PH;
   4 BEGIN {
   5     $SIG{__WARN__} = sub {
   6         return if $_[0] =~ /^Pseudo-hashes are deprecated/
   7     };
   8     $Has_PH = $] < 5.009;
   9 }
  10
  11 use strict;
  12 use Test::More tests => 16;
  13
  14 BEGIN { use_ok('fields'); }
  15
  16
  17 package Foo;
  18
  19 use fields qw(_no Pants who _up_yours);
  20 use fields qw(what);
  21
  22 sub new { fields::new(shift) }
  23 sub magic_new { bless [] }  # Doesn't 100% work, perl's problem.
  24
  25 package main;
  26
  27 is_deeply( [sort keys %Foo::FIELDS],
  28            [sort qw(_no Pants who _up_yours what)]
  29 );
  30
  31 sub 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 }
  38
  39 is_deeply( [sort &show_fields('Foo', fields::PUBLIC)],
  40            [sort qw(Pants who what)]);
  41 is_deeply( [sort &show_fields('Foo', fields::PRIVATE)],
  42            [sort qw(_no _up_yours)]);
  43
  44 # We should get compile time failures field name typos
  45 eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");
  46
  47 my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"'
  48                     : q[Attempt to access disallowed key 'notthere' in a ].
  49                       q[restricted hash at ];
  50 ok( $@ && $@ =~ /^$error/i );
  51
  52
  53 foreach (Foo->new) {
  54     my Foo $obj = $_;
  55     my %test = ( Pants => 'Whatever', _no => 'Yeah',
  56                  what  => 'Ahh',      who => 'Moo',
  57                  _up_yours => 'Yip' );
  58
  59     $obj->{Pants} = 'Whatever';
  60     $obj->{_no}   = 'Yeah';
  61     @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip');
  62
  63     while(my($k,$v) = each %test) {
  64         ok($obj->{$k} eq $v);
  65     }
  66 }
  67
  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 }
  78
  79
  80 # check if fields autovivify
  81 {
  82     package Foo::Autoviv;
  83     use fields qw(foo bar);
  84     sub new { fields::new($_[0]) }
  85
  86     package main;
  87     my Foo::Autoviv $a = Foo::Autoviv->new();
  88     $a->{foo} = ['a', 'ok', 'c'];
  89     $a->{bar} = { A => 'ok' };
  90     is( $a->{foo}[1],    'ok' );
  91     is( $a->{bar}->{A},, 'ok' );
  92 }
  93
  94 package Test::FooBar;
  95
  96 use fields qw(a b c);
  97
  98 sub new {
  99     my $self = fields::new(shift);
 100     %$self = @_ if @_;
 101     $self;
 102 }
 103
 104 package 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');
 112 }