lib/base/t/fields.t

   1 # Before `make install' is performed this script should be runnable with
   2 # `make test'. After `make install' it should work as `perl test.pl'
   3
   4 my $Has_PH = $] < 5.009;
   5
   6 $SIG{__WARN__} = sub { return if $_[0] =~ /^Pseudo-hashes are deprecated/ };
   7
   8 ######################### We start with some black magic to print on failure.
   9
  10 # Change 1..1 below to 1..last_test_to_print .
  11 # (It may become useful if the test is moved to ./t subdirectory.)
  12 use strict;
  13
  14 use vars qw($Total_tests);
  15
  16 my $loaded;
  17 my $test_num = 1;
  18 BEGIN { $| = 1; $^W = 1; }
  19 END {print "not ok $test_num\n" unless $loaded;}
  20 print "1..$Total_tests\n";
  21 use fields;
  22 $loaded = 1;
  23 print "ok $test_num\n";
  24 $test_num++;
  25 ######################### End of black magic.
  26
  27 # Insert your test code below (better if it prints "ok 13"
  28 # (correspondingly "not ok 13") depending on the success of chunk 13
  29 # of the test code):
  30 sub ok ($;$) {
  31     my($test, $name) = @_;
  32     print "not " unless $test;
  33     print "ok $test_num";
  34     print " - $name" if defined $name;
  35     print "\n";
  36     $test_num++;
  37 }
  38
  39 sub eqarray  {
  40     my($a1, $a2) = @_;
  41     return 0 unless @$a1 == @$a2;
  42     my $ok = 1;
  43     for (0..$#{$a1}) {
  44         unless($a1->[$_] eq $a2->[$_]) {
  45             $ok = 0;
  46             last;
  47         }
  48     }
  49     return $ok;
  50 }
  51
  52 # Change this to your # of ok() calls + 1
  53 BEGIN { $Total_tests = 10 }
  54
  55
  56 package Foo;
  57
  58 use fields qw(_no Pants who _up_yours);
  59 use fields qw(what);
  60
  61 sub new { fields::new(shift) }
  62 sub magic_new { bless [] }  # Doesn't 100% work, perl's problem.
  63
  64 package main;
  65
  66 ok( eqarray( [sort keys %Foo::FIELDS],
  67              [sort qw(_no Pants who _up_yours what)] )
  68   );
  69
  70 sub show_fields {
  71     my($base, $mask) = @_;
  72     no strict 'refs';
  73     my $fields = \%{$base.'::FIELDS'};
  74     return grep { ($fields::attr{$base}[$fields->{$_}] & $mask) == $mask}
  75                 keys %$fields;
  76 }
  77
  78 ok( eqarray( [sort &show_fields('Foo', fields::PUBLIC)],
  79              [sort qw(Pants who what)]) );
  80 ok( eqarray( [sort &show_fields('Foo', fields::PRIVATE)],
  81              [sort qw(_no _up_yours)]) );
  82
  83 # We should get compile time failures field name typos
  84 eval q(my Foo $obj = Foo->new; $obj->{notthere} = "");
  85
  86 my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"'
  87                     : q[Attempt to access disallowed key 'notthere' in a ].
  88                       q[restricted hash at ];
  89 ok( $@ && $@ =~ /^$error/i );
  90
  91
  92 foreach (Foo->new) {
  93     my Foo $obj = $_;
  94     my %test = ( Pants => 'Whatever', _no => 'Yeah',
  95                  what  => 'Ahh',      who => 'Moo',
  96                  _up_yours => 'Yip' );
  97
  98     $obj->{Pants} = 'Whatever';
  99     $obj->{_no}   = 'Yeah';
 100     @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip');
 101
 102     while(my($k,$v) = each %test) {
 103         ok($obj->{$k} eq $v);
 104     }
 105 }