From: Jarkko Hietaniemi Date: Sun, 31 Aug 2003 08:07:43 +0000 (+0000) Subject: Upgrade to base.pm 2.0. X-Git-Tag: accepted/trunk/20130322.191538~23165 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=024bc14bff38fc4c191152f9ff965e7edfa1785f;p=platform%2Fupstream%2Fperl.git Upgrade to base.pm 2.0. (Rename the tests around a bit to be more 8.3-friendly.) p4raw-id: //depot/perl@20960 --- diff --git a/MANIFEST b/MANIFEST index 226732b..9a73a3e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -964,6 +964,12 @@ lib/AutoSplit.t See if AutoSplit works lib/autouse.pm Load and call a function only when it's used lib/autouse.t See if autouse works lib/base.pm Establish IS-A relationship at compile time +lib/base/t/base.t See if base works +lib/base/t/fb18784.t See if fields works at blead 18784 +lib/base/t/fb20922.t See if fields works at blead 20922 +lib/base/t/fields.t See if fields works +lib/base/t/fp560.t See if 5.6.0 fields works +lib/base/t/fp580.t See if 5.8.0 fields works lib/Benchmark.pm Measure execution time lib/Benchmark.t See if Benchmark works lib/bigfloat.pl An arbitrary precision floating point package diff --git a/lib/base.pm b/lib/base.pm index 9b34398..e0cc481 100644 --- a/lib/base.pm +++ b/lib/base.pm @@ -1,3 +1,171 @@ +package base; + +use vars qw($VERSION); +$VERSION = '2.0'; + +# constant.pm is slow +sub SUCCESS () { 1 } + +sub PUBLIC () { 2**0 } +sub PRIVATE () { 2**1 } +sub INHERITED () { 2**2 } +sub PROTECTED () { 2**3 } + + +my $Fattr = \%fields::attr; + +sub has_fields { + my($base) = shift; + my $fglob = ${"$base\::"}{FIELDS}; + return $fglob && *$fglob{HASH}; +} + +sub has_version { + my($base) = shift; + my $vglob = ${$base.'::'}{VERSION}; + return $vglob && *$vglob{SCALAR}; +} + +sub has_attr { + my($proto) = shift; + my($class) = ref $proto || $proto; + return exists $Fattr->{$class}; +} + +sub get_attr { + $Fattr->{$_[0]} = [1] unless $Fattr->{$_[0]}; + return $Fattr->{$_[0]}; +} + +sub get_fields { + # Shut up a possible typo warning. + () = \%{$_[0].'::FIELDS'}; + + return \%{$_[0].'::FIELDS'}; +} + +sub show_fields { + my($base, $mask) = @_; + my $fields = \%{$base.'::FIELDS'}; + return grep { ($Fattr->{$base}[$fields->{$_}] & $mask) == $mask} + keys %$fields; +} + + +sub import { + my $class = shift; + + return SUCCESS unless @_; + + # List of base classes from which we will inherit %FIELDS. + my $fields_base; + + my $inheritor = caller(0); + + foreach my $base (@_) { + next if $inheritor->isa($base); + + if (has_version($base)) { + ${$base.'::VERSION'} = '-1, set by base.pm' + unless defined ${$base.'::VERSION'}; + } + else { + local $SIG{__DIE__} = 'IGNORE'; + eval "require $base"; + # Only ignore "Can't locate" errors from our eval require. + # Other fatal errors (syntax etc) must be reported. + die if $@ && $@ !~ /^Can't locate .*? at \(eval /; + unless (%{"$base\::"}) { + require Carp; + Carp::croak(<[0] = @$battr; + + if( keys %$dfields ) { + warn "$derived is inheriting from $base but already has its own ". + "fields!\n". + "This will cause problems with pseudo-hashes.\n". + "Be sure you use base BEFORE declaring fields\n"; + } + + # Iterate through the base's fields adding all the non-private + # ones to the derived class. Hang on to the original attribute + # (Public, Private, etc...) and add Inherited. + # This is all too complicated to do efficiently with add_fields(). + while (my($k,$v) = each %$bfields) { + my $fno; + if ($fno = $dfields->{$k} and $fno != $v) { + require Carp; + Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); + } + + if( $battr->[$v] & PRIVATE ) { + $dattr->[$v] = undef; + } + else { + $dattr->[$v] = INHERITED | $battr->[$v]; + + # Derived fields must be kept in the same position as the + # base in order to make "static" typing work with psuedo-hashes. + # Alas, this kills multiple field inheritance. + $dfields->{$k} = $v; + } + } +} + + +1; + +__END__ + =head1 NAME base - Establish IS-A relationship with base class at compile time @@ -12,15 +180,16 @@ base - Establish IS-A relationship with base class at compile time Roughly similar in effect to BEGIN { - require Foo; - require Bar; - push @ISA, qw(Foo Bar); + require Foo; + require Bar; + push @ISA, qw(Foo Bar); } -Will also initialize the %FIELDS hash if one of the base classes has -it. Multiple inheritance of %FIELDS is not supported. The 'base' -pragma will croak if multiple base classes have a %FIELDS hash. See -L for a description of this feature. +Will also initialize the fields if one of the base classes has it. +Multiple Inheritence of fields is B supported, if two or more +base classes each have inheritable fields the 'base' pragma will +croak. See L, L and L for a description of +this feature. When strict 'vars' is in scope, I also lets you assign to @ISA without having to declare @ISA with the 'vars' pragma first. @@ -32,63 +201,20 @@ $VERSION in the base package. If $VERSION is not detected even after loading it, I will define $VERSION in the base package, setting it to the string C<-1, set by base.pm>. + =head1 HISTORY This module was introduced with Perl 5.004_04. -=head1 SEE ALSO - -L -=cut +=head1 CAVEATS -package base; +Due to the limitations of the pseudo-hash implementation, you must use +base I you declare any of your own fields. -use 5.006_001; -our $VERSION = "1.04"; -sub import { - my $class = shift; - my $fields_base; - my $pkg = caller(0); +=head1 SEE ALSO - foreach my $base (@_) { - next if $pkg->isa($base); - my $vglob; - if ($vglob = ${"$base\::"}{VERSION} and *$vglob{SCALAR}) { - $$vglob = "-1, set by base.pm" unless defined $$vglob; - } else { - eval "require $base"; - # Only ignore "Can't locate" errors from our eval require. - # Other fatal errors (syntax etc) must be reported. - die if $@ && $@ !~ /^Can't locate .*? at \(eval /; - unless (%{"$base\::"}) { - require Carp; - Carp::croak("Base class package \"$base\" is empty.\n", - "\t(Perhaps you need to 'use' the module ", - "which defines that package first.)"); - } - ${"$base\::VERSION"} = "-1, set by base.pm" unless defined ${"$base\::VERSION"}; - } - push @{"$pkg\::ISA"}, $base; - - # A simple test like (defined %{"$base\::FIELDS"}) will - # sometimes produce typo warnings because it would create - # the hash if it was not present before. - my $fglob; - if ($fglob = ${"$base\::"}{"FIELDS"} and *$fglob{HASH}) { - if ($fields_base) { - require Carp; - Carp::croak("Can't multiply inherit %FIELDS"); - } else { - $fields_base = $base; - } - } - } - if ($fields_base) { - require fields; - fields::inherit($pkg, $fields_base); - } -} +L -1; +=cut diff --git a/lib/base/t/base.t b/lib/base/t/base.t new file mode 100644 index 0000000..1e4d413 --- /dev/null +++ b/lib/base/t/base.t @@ -0,0 +1,183 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) +use strict; + +use vars qw($Total_tests); + +my $loaded; +my $test_num = 1; +BEGIN { $| = 1; $^W = 1; } +END {print "not ok $test_num\n" unless $loaded;} +print "1..$Total_tests\n"; +use base; +$loaded = 1; +print "ok $test_num - Compiled\n"; +$test_num++; +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): +sub ok ($$) { + my($test, $name) = @_; + print "not " unless $test; + print "ok $test_num"; + print " - $name" if defined $name; + print "\n"; + $test_num++; +} + +sub eqarray { + my($a1, $a2) = @_; + return 0 unless @$a1 == @$a2; + my $ok = 1; + for (0..$#{$a1}) { + unless($a1->[$_] eq $a2->[$_]) { + $ok = 0; + last; + } + } + return $ok; +} + +# Change this to your # of ok() calls + 1 +BEGIN { $Total_tests = 17 } + +use vars qw( $W ); +BEGIN { + $W = 0; + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field '.*?' in base class/) { + $W++; + } + else { + warn $_[0]; + } + }; +} + +package B1; +use fields qw(b1 b2 b3); + +package B2; +use fields '_b1'; +use fields qw(b1 _b2 b2); + +sub new { bless [], shift } + +package B3; +use fields qw(b4 _b5 b6 _b7); + +package D1; +use base 'B1'; +use fields qw(d1 d2 d3); + +package D2; +use base 'B1'; +use fields qw(_d1 _d2); +use fields qw(d1 d2); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package D4; +use base 'D3'; +use fields qw(_d3 d3); + +package M; +sub m {} + +package D5; +use base qw(M B2); + +# Test that multiple inheritance fails. +package D6; +eval { + 'base'->import(qw(B2 M B3)); +}; +::ok($@ =~ /can't multiply inherit %FIELDS/i, 'No multiple field inheritance'); + +package Foo::Bar; +use base 'B1'; + +package Foo::Bar::Baz; +use base 'Foo::Bar'; +use fields qw(foo bar baz); + +package main; + +my %EXPECT = ( + B1 => [qw(b1 b2 b3)], + B2 => [qw(_b1 b1 _b2 b2)], + B3 => [qw(b4 _b5 b6 _b7)], + D1 => [qw(d1 d2 d3 b1 b2 b3)], + D2 => [qw(b1 b2 b3 _d1 _d2 d1 d2)], + D3 => [qw(b1 b2 d1 _b1 _d1)], + D4 => [qw(b1 b2 d1 _d3 d3)], + M => [qw()], + D5 => [qw(b1 b2)], + 'Foo::Bar' => [qw(b1 b2 b3)], + 'Foo::Bar::Baz' => [qw(b1 b2 b3 foo bar baz)], + ); + +while(my($class, $efields) = each %EXPECT) { + no strict 'refs'; + my @fields = keys %{$class.'::FIELDS'}; + + ::ok( eqarray([sort @$efields], [sort @fields]), + "%FIELDS check: $class" ); +} + +# Did we get the appropriate amount of warnings? +::ok($W == 1, 'got the right warnings'); + + +# Break multiple inheritance with a field name clash. +package E1; +use fields qw(yo this _lah meep 42); + +package E2; +use fields qw(_yo ahhh this); + +eval { + package Broken; + + # The error must occur at run time for the eval to catch it. + require base; + 'base'->import(qw(E1 E2)); +}; +::ok( $@ && $@ =~ /Can't multiply inherit %FIELDS/i, + 'Again, no multi inherit' ); + + +package No::Version; + +use vars qw($Foo); +sub VERSION { 42 } + +package Test::Version; + +use base qw(No::Version); +::ok( $No::Version::VERSION =~ /set by base\.pm/, '$VERSION bug' ); + + +package Test::SIGDIE; + +{ + local $SIG{__DIE__} = sub { + ::ok(0, 'sigdie not caught, this test should not run') + }; + eval { + 'base'->import(qw(Huh::Boo)); + }; + + ::ok($@ =~ /^Base class package "Huh::Boo" is empty./, + 'Base class empty error message'); + +} diff --git a/lib/base/t/fb18784.t b/lib/base/t/fb18784.t new file mode 100644 index 0000000..03b1ab7 --- /dev/null +++ b/lib/base/t/fb18784.t @@ -0,0 +1,222 @@ +#!./perl -w + +# This is bleadperl's fields.t test at 18784 + +# We skip this on anything older than 5.9.0 since some semantics changed +# when pseudo-hashes were removed. +if( $] < 5.009 ) { + print "1..0 # skip fields.pm changed to restricted hashes in 5.9.0\n"; + exit; +} + +my $w; + +BEGIN { + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field 'b1' in base class/) { + $w++; + return; + } + print STDERR $_[0]; + }; +} + +use strict; +use warnings; +use vars qw($DEBUG); + +use Test::More; + + +package B1; +use fields qw(b1 b2 b3); + +package B2; +use fields '_b1'; +use fields qw(b1 _b2 b2); + +sub new { fields::new(shift); } + +package D1; +use base 'B1'; +use fields qw(d1 d2 d3); + +package D2; +use base 'B1'; +use fields qw(_d1 _d2); +use fields qw(d1 d2); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package D4; +use base 'D3'; +use fields qw(_d3 d3); + +package M; +sub m {} + +package D5; +use base qw(M B2); + +package Foo::Bar; +use base 'B1'; + +package Foo::Bar::Baz; +use base 'Foo::Bar'; +use fields qw(foo bar baz); + +# Test repeatability for when modules get reloaded. +package B1; +use fields qw(b1 b2 b3); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package main; + +sub fstr { + my $h = shift; + my @tmp; + for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { + my $v = $h->{$k}; + push(@tmp, "$k:$v"); + } + my $str = join(",", @tmp); + print "$h => $str\n" if $DEBUG; + $str; +} + +my %expect = ( + B1 => "b1:1,b2:2,b3:3", + B2 => "_b1:1,b1:2,_b2:3,b2:4", + D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", + D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", + D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", + D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", + D5 => "b1:2,b2:4", + 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', +); + +plan tests => keys(%expect) + 17; +my $testno = 0; +while (my($class, $exp) = each %expect) { + no strict 'refs'; + my $fstr = fstr(\%{$class."::FIELDS"}); + is( $fstr, $exp, "\%FIELDS check for $class" ); +} + +# Did we get the appropriate amount of warnings? +is( $w, 1 ); + +# A simple object creation and AVHV attribute access test +my B2 $obj1 = D3->new; +$obj1->{b1} = "B2"; +my D3 $obj2 = $obj1; +$obj2->{b1} = "D3"; + +# We should get compile time failures field name typos +eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); +like $@, qr/^Attempt to access disallowed key 'notthere' in a restricted hash/; + +# Slices +@$obj1{"_b1", "b1"} = (17, 29); +is_deeply($obj1, { b1 => 29, _b1 => 17 }); + +@$obj1{'_b1', 'b1'} = (44,28); +is_deeply($obj1, { b1 => 28, _b1 => 44 }); + +eval { fields::phash }; +like $@, qr/^Pseudo-hashes have been removed from Perl/; + +#fields::_dump(); + +# check if fields autovivify +{ + package Foo; + use fields qw(foo bar); + sub new { fields::new($_[0]) } + + package main; + my Foo $a = Foo->new(); + $a->{foo} = ['a', 'ok', 'c']; + $a->{bar} = { A => 'ok' }; + is( $a->{foo}[1], 'ok' ); + is( $a->{bar}->{A},, 'ok' ); +} + +# check if fields autovivify +{ + package Bar; + use fields qw(foo bar); + sub new { return fields::new($_[0]) } + + package main; + my Bar $a = Bar::->new(); + $a->{foo} = ['a', 'ok', 'c']; + $a->{bar} = { A => 'ok' }; + is( $a->{foo}[1], 'ok' ); + is( $a->{bar}->{A}, 'ok' ); +} + + +# Test $VERSION bug +package No::Version; + +use vars qw($Foo); +sub VERSION { 42 } + +package Test::Version; + +use base qw(No::Version); +::like( $No::Version::VERSION, qr/set by base.pm/ ); + +# Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION +package Has::Version; + +BEGIN { $Has::Version::VERSION = '42' }; + +package Test::Version2; + +use base qw(Has::Version); +::is( $Has::Version::VERSION, 42 ); + +package main; + +our $eval1 = q{ + { + package Eval1; + { + package Eval2; + use base 'Eval1'; + $Eval2::VERSION = "1.02"; + } + $Eval1::VERSION = "1.01"; + } +}; + +eval $eval1; +is( $@, '' ); + +is( $Eval1::VERSION, 1.01 ); + +is( $Eval2::VERSION, 1.02 ); + + +eval q{use base 'reallyReAlLyNotexists';}; +like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, + 'base with empty package'); + +eval q{use base 'reallyReAlLyNotexists';}; +like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, + ' still empty on 2nd load'); + +BEGIN { $Has::Version_0::VERSION = 0 } + +package Test::Version3; + +use base qw(Has::Version_0); +::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' ); + diff --git a/lib/base/t/fb20922.t b/lib/base/t/fb20922.t new file mode 100644 index 0000000..2a09b72 --- /dev/null +++ b/lib/base/t/fb20922.t @@ -0,0 +1,246 @@ +#!./perl -w + +# This is bleadperl's fields.t test @20100. + +# We skip this on anything older than 5.9.0 since some semantics changed +# when pseudo-hashes were removed. +if( $] < 5.009 ) { + print "1..0 # skip fields.pm changed to restricted hashes in 5.9.0\n"; + exit; +} + +my $w; + +BEGIN { + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field 'b1' in base class/) { + $w++; + return; + } + print STDERR $_[0]; + }; +} + +use strict; +use warnings; +use vars qw($DEBUG); + +use Test::More; + + +package B1; +use fields qw(b1 b2 b3); + +package B2; +use fields '_b1'; +use fields qw(b1 _b2 b2); + +sub new { fields::new(shift); } + +package D1; +use base 'B1'; +use fields qw(d1 d2 d3); + +package D2; +use base 'B1'; +use fields qw(_d1 _d2); +use fields qw(d1 d2); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package D4; +use base 'D3'; +use fields qw(_d3 d3); + +package M; +sub m {} + +package D5; +use base qw(M B2); + +package Foo::Bar; +use base 'B1'; + +package Foo::Bar::Baz; +use base 'Foo::Bar'; +use fields qw(foo bar baz); + +# Test repeatability for when modules get reloaded. +package B1; +use fields qw(b1 b2 b3); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package main; + +sub fstr { + my $h = shift; + my @tmp; + for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { + my $v = $h->{$k}; + push(@tmp, "$k:$v"); + } + my $str = join(",", @tmp); + print "$h => $str\n" if $DEBUG; + $str; +} + +my %expect = ( + B1 => "b1:1,b2:2,b3:3", + B2 => "_b1:1,b1:2,_b2:3,b2:4", + D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", + D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", + D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", + D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", + D5 => "b1:2,b2:4", + 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', +); + +plan tests => keys(%expect) + 21; + +my $testno = 0; + +while (my($class, $exp) = each %expect) { + no strict 'refs'; + my $fstr = fstr(\%{$class."::FIELDS"}); + is( $fstr, $exp, "\%FIELDS check for $class" ); +} + +# Did we get the appropriate amount of warnings? +is( $w, 1 ); + +# A simple object creation and AVHV attribute access test +my B2 $obj1 = D3->new; +$obj1->{b1} = "B2"; +my D3 $obj2 = $obj1; +$obj2->{b1} = "D3"; + +# We should get compile time failures field name typos +eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); +like $@, qr/^Attempt to access disallowed key 'notthere' in a restricted hash/; + +# Slices +@$obj1{"_b1", "b1"} = (17, 29); +is_deeply($obj1, { b1 => 29, _b1 => 17 }); + +@$obj1{'_b1', 'b1'} = (44,28); +is_deeply($obj1, { b1 => 28, _b1 => 44 }); + +eval { fields::phash }; +like $@, qr/^Pseudo-hashes have been removed from Perl/; + +#fields::_dump(); + +# check if fields autovivify +{ + package Foo; + use fields qw(foo bar); + sub new { fields::new($_[0]) } + + package main; + my Foo $a = Foo->new(); + $a->{foo} = ['a', 'ok', 'c']; + $a->{bar} = { A => 'ok' }; + is( $a->{foo}[1], 'ok' ); + is( $a->{bar}->{A},, 'ok' ); +} + +# check if fields autovivify +{ + package Bar; + use fields qw(foo bar); + sub new { return fields::new($_[0]) } + + package main; + my Bar $a = Bar::->new(); + $a->{foo} = ['a', 'ok', 'c']; + $a->{bar} = { A => 'ok' }; + is( $a->{foo}[1], 'ok' ); + is( $a->{bar}->{A}, 'ok' ); +} + + +# Test $VERSION bug +package No::Version; + +use vars qw($Foo); +sub VERSION { 42 } + +package Test::Version; + +use base qw(No::Version); +::like( $No::Version::VERSION, qr/set by base.pm/ ); + +# Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION +package Has::Version; + +BEGIN { $Has::Version::VERSION = '42' }; + +package Test::Version2; + +use base qw(Has::Version); +::is( $Has::Version::VERSION, 42 ); + +package main; + +our $eval1 = q{ + { + package Eval1; + { + package Eval2; + use base 'Eval1'; + $Eval2::VERSION = "1.02"; + } + $Eval1::VERSION = "1.01"; + } +}; + +eval $eval1; +is( $@, '' ); + +is( $Eval1::VERSION, 1.01 ); + +is( $Eval2::VERSION, 1.02 ); + + +eval q{use base 'reallyReAlLyNotexists'}; +like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, + 'base with empty package'); + +eval q{use base 'reallyReAlLyNotexists'}; +like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty./, + ' still empty on 2nd load'); + +BEGIN { $Has::Version_0::VERSION = 0 } + +package Test::Version3; + +use base qw(Has::Version_0); +::is( $Has::Version_0::VERSION, 0, '$VERSION==0 preserved' ); + +package Test::FooBar; + +use fields qw(a b c); + +sub new { + my $self = fields::new(shift); + %$self = @_ if @_; + $self; +} + +package main; + +{ + my $x = Test::FooBar->new( a => 1, b => 2); + + is(ref $x, 'Test::FooBar', 'x is a Test::FooBar'); + ok(exists $x->{a}, 'x has a'); + ok(exists $x->{b}, 'x has b'); + is(scalar keys %$x, 2, 'x has two fields'); +} + + diff --git a/lib/base/t/fields.t b/lib/base/t/fields.t new file mode 100644 index 0000000..1deb602 --- /dev/null +++ b/lib/base/t/fields.t @@ -0,0 +1,105 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +my $Has_PH = $] < 5.009; + +$SIG{__WARN__} = sub { return if $_[0] =~ /^Pseudo-hashes are deprecated/ }; + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) +use strict; + +use vars qw($Total_tests); + +my $loaded; +my $test_num = 1; +BEGIN { $| = 1; $^W = 1; } +END {print "not ok $test_num\n" unless $loaded;} +print "1..$Total_tests\n"; +use fields; +$loaded = 1; +print "ok $test_num\n"; +$test_num++; +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): +sub ok ($;$) { + my($test, $name) = @_; + print "not " unless $test; + print "ok $test_num"; + print " - $name" if defined $name; + print "\n"; + $test_num++; +} + +sub eqarray { + my($a1, $a2) = @_; + return 0 unless @$a1 == @$a2; + my $ok = 1; + for (0..$#{$a1}) { + unless($a1->[$_] eq $a2->[$_]) { + $ok = 0; + last; + } + } + return $ok; +} + +# Change this to your # of ok() calls + 1 +BEGIN { $Total_tests = 10 } + + +package Foo; + +use fields qw(_no Pants who _up_yours); +use fields qw(what); + +sub new { fields::new(shift) } +sub magic_new { bless [] } # Doesn't 100% work, perl's problem. + +package main; + +ok( eqarray( [sort keys %Foo::FIELDS], + [sort qw(_no Pants who _up_yours what)] ) + ); + +sub show_fields { + my($base, $mask) = @_; + no strict 'refs'; + my $fields = \%{$base.'::FIELDS'}; + return grep { ($fields::attr{$base}[$fields->{$_}] & $mask) == $mask} + keys %$fields; +} + +ok( eqarray( [sort &show_fields('Foo', fields::PUBLIC)], + [sort qw(Pants who what)]) ); +ok( eqarray( [sort &show_fields('Foo', fields::PRIVATE)], + [sort qw(_no _up_yours)]) ); + +# We should get compile time failures field name typos +eval q(my Foo $obj = Foo->new; $obj->{notthere} = ""); + +my $error = $Has_PH ? 'No such(?: [\w-]+)? field "notthere"' + : q[Attempt to access disallowed key 'notthere' in a ]. + q[restricted hash at ]; +ok( $@ && $@ =~ /^$error/i ); + + +foreach (Foo->new) { + my Foo $obj = $_; + my %test = ( Pants => 'Whatever', _no => 'Yeah', + what => 'Ahh', who => 'Moo', + _up_yours => 'Yip' ); + + $obj->{Pants} = 'Whatever'; + $obj->{_no} = 'Yeah'; + @{$obj}{qw(what who _up_yours)} = ('Ahh', 'Moo', 'Yip'); + + while(my($k,$v) = each %test) { + ok($obj->{$k} eq $v); + } +} diff --git a/lib/base/t/fp560.t b/lib/base/t/fp560.t new file mode 100644 index 0000000..93bca34 --- /dev/null +++ b/lib/base/t/fp560.t @@ -0,0 +1,228 @@ +# The fields.pm and base.pm regression tests from 5.6.0 + +# We skip this on 5.9.0 and up since pseudohashes were removed and a lot +# of it won't work. +if( $] >= 5.009 ) { + print "1..0 # skip pseudo-hashes removed in 5.9.0\n"; + exit; +} + +use strict; +use vars qw($Total_tests); + +my $test_num = 1; +BEGIN { $| = 1; $^W = 1; } +print "1..$Total_tests\n"; +use fields; +use base; +print "ok $test_num\n"; +$test_num++; + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): +sub ok { + my($test, $name) = @_; + print "not " unless $test; + print "ok $test_num"; + print " - $name" if defined $name; + print "\n"; + $test_num++; +} + +sub eqarray { + my($a1, $a2) = @_; + return 0 unless @$a1 == @$a2; + my $ok = 1; + for (0..$#{$a1}) { + unless($a1->[$_] eq $a2->[$_]) { + $ok = 0; + last; + } + } + return $ok; +} + +# Change this to your # of ok() calls + 1 +BEGIN { $Total_tests = 14 } + + +my $w; + +BEGIN { + $^W = 1; + + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field 'b1' in base class/) { + $w++; + return; + } + print $_[0]; + }; +} + +use strict; +use vars qw($DEBUG); + +package B1; +use fields qw(b1 b2 b3); + +package B2; +use fields '_b1'; +use fields qw(b1 _b2 b2); + +sub new { bless [], shift } + +package D1; +use base 'B1'; +use fields qw(d1 d2 d3); + +package D2; +use base 'B1'; +use fields qw(_d1 _d2); +use fields qw(d1 d2); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package D4; +use base 'D3'; +use fields qw(_d3 d3); + +package M; +sub m {} + +package D5; +use base qw(M B2); + +package Foo::Bar; +use base 'B1'; + +package Foo::Bar::Baz; +use base 'Foo::Bar'; +use fields qw(foo bar baz); + +# Test repeatability for when modules get reloaded. +package B1; +use fields qw(b1 b2 b3); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package main; + +sub fstr { + my $h = shift; + my @tmp; + for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { + my $v = $h->{$k}; + push(@tmp, "$k:$v"); + } + my $str = join(",", @tmp); + print "$h => $str\n" if $DEBUG; + $str; +} + +my %expect; +BEGIN { + %expect = ( + B1 => "b1:1,b2:2,b3:3", + B2 => "_b1:1,b1:2,_b2:3,b2:4", + D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", + D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", + D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", + D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", + D5 => "b1:2,b2:4", + 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', + ); + $Total_tests += int(keys %expect); +} +my $testno = 0; +while (my($class, $exp) = each %expect) { + no strict 'refs'; + my $fstr = fstr(\%{$class."::FIELDS"}); + ok( $fstr eq $exp, "'$fstr' eq '$exp'" ); +} + +# Did we get the appropriate amount of warnings? +ok( $w == 1 ); + +# A simple object creation and AVHV attribute access test +my B2 $obj1 = D3->new; +$obj1->{b1} = "B2"; +my D3 $obj2 = $obj1; +$obj2->{b1} = "D3"; + +ok( $obj1->[2] eq "B2" && $obj1->[5] eq "D3" ); + +# We should get compile time failures field name typos +eval q{ my D3 $obj3 = $obj2; $obj3->{notthere} = "" }; +ok( $@ && $@ =~ /^No such pseudo-hash field "notthere"/, + 'compile error -- field name typos' ); + + +# Slices +if( $] >= 5.006 ) { + @$obj1{"_b1", "b1"} = (17, 29); + ok( "@$obj1[1,2]" eq "17 29" ); + + @$obj1[1,2] = (44,28); + ok( "@$obj1{'b1','_b1','b1'}" eq "28 44 28" ); +} +else { + ok( 1, 'test skipped for perl < 5.6.0' ); + ok( 1, 'test skipped for perl < 5.6.0' ); +} + +my $ph = fields::phash(a => 1, b => 2, c => 3); +ok( fstr($ph) eq 'a:1,b:2,c:3' ); + +$ph = fields::phash([qw/a b c/], [1, 2, 3]); +ok( fstr($ph) eq 'a:1,b:2,c:3' ); + +# The way exists() works with psuedohashes changed from 5.005 to 5.6 +$ph = fields::phash([qw/a b c/], [1]); +if( $] > 5.006 ) { + ok( !( exists $ph->{b} or exists $ph->{c} or !exists $ph->{a} ) ); +} +else { + ok( !( defined $ph->{b} or defined $ph->{c} or !defined $ph->{a} ) ); +} + +eval { $ph = fields::phash("odd") }; +ok( $@ && $@ =~ /^Odd number of/ ); + + +# check if fields autovivify +if ( $] > 5.006 ) { + package Foo; + use fields qw(foo bar); + sub new { bless [], $_[0]; } + + package main; + my Foo $a = Foo->new(); + $a->{foo} = ['a', 'ok', 'c']; + $a->{bar} = { A => 'ok' }; + ok( $a->{foo}[1] eq 'ok' ); + ok( $a->{bar}->{A} eq 'ok' ); +} +else { + ok( 1, 'test skipped for perl < 5.6.0' ); + ok( 1, 'test skipped for perl < 5.6.0' ); +} + +# check if fields autovivify +{ + package Bar; + use fields qw(foo bar); + sub new { return fields::new($_[0]) } + + package main; + my Bar $a = Bar::->new(); + $a->{foo} = ['a', 'ok', 'c']; + $a->{bar} = { A => 'ok' }; + ok( $a->{foo}[1] eq 'ok' ); + ok( $a->{bar}->{A} eq 'ok' ); +} diff --git a/lib/base/t/fp580.t b/lib/base/t/fp580.t new file mode 100644 index 0000000..c25e041 --- /dev/null +++ b/lib/base/t/fp580.t @@ -0,0 +1,246 @@ +#!/usr/bin/perl -w + +$SIG{__WARN__} = sub { return if $_[0] =~ /^Pseudo-hashes are deprecated/ }; + +# We skip this on 5.9.0 and up since pseudohashes were removed and a lot of +# it won't work. +if( $] >= 5.009 ) { + print "1..0 # skip pseudo-hashes removed in 5.9.0\n"; + exit; +} + + +my $w; + +BEGIN { + $SIG{__WARN__} = sub { + if ($_[0] =~ /^Hides field 'b1' in base class/) { + $w++; + } + else { + print STDERR $_[0]; + } + }; +} + +use strict; +use vars qw($DEBUG); + +package B1; +use fields qw(b1 b2 b3); + +package B2; +use fields '_b1'; +use fields qw(b1 _b2 b2); + +sub new { bless [], shift } + +package D1; +use base 'B1'; +use fields qw(d1 d2 d3); + +package D2; +use base 'B1'; +use fields qw(_d1 _d2); +use fields qw(d1 d2); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package D4; +use base 'D3'; +use fields qw(_d3 d3); + +package M; +sub m {} + +package D5; +use base qw(M B2); + +package Foo::Bar; +use base 'B1'; + +package Foo::Bar::Baz; +use base 'Foo::Bar'; +use fields qw(foo bar baz); + +# Test repeatability for when modules get reloaded. +package B1; +use fields qw(b1 b2 b3); + +package D3; +use base 'B2'; +use fields qw(b1 d1 _b1 _d1); # hide b1 + +package main; + +sub fstr { + my $h = shift; + my @tmp; + for my $k (sort {$h->{$a} <=> $h->{$b}} keys %$h) { + my $v = $h->{$k}; + push(@tmp, "$k:$v"); + } + my $str = join(",", @tmp); + print "$h => $str\n" if $DEBUG; + $str; +} + +my %expect = ( + B1 => "b1:1,b2:2,b3:3", + B2 => "_b1:1,b1:2,_b2:3,b2:4", + D1 => "b1:1,b2:2,b3:3,d1:4,d2:5,d3:6", + D2 => "b1:1,b2:2,b3:3,_d1:4,_d2:5,d1:6,d2:7", + D3 => "b2:4,b1:5,d1:6,_b1:7,_d1:8", + D4 => "b2:4,b1:5,d1:6,_d3:9,d3:10", + D5 => "b1:2,b2:4", + 'Foo::Bar::Baz' => 'b1:1,b2:2,b3:3,foo:4,bar:5,baz:6', +); + +print "1..", int(keys %expect)+21, "\n"; +my $testno = 0; +while (my($class, $exp) = each %expect) { + no strict 'refs'; + my $fstr = fstr(\%{$class."::FIELDS"}); + print "EXP: $exp\nGOT: $fstr\nnot " unless $fstr eq $exp; + print "ok ", ++$testno, "\n"; +} + +# Did we get the appropriate amount of warnings? +print "not " unless $w == 1; +print "ok ", ++$testno, "\n"; + +# A simple object creation and AVHV attribute access test +my B2 $obj1 = D3->new; +$obj1->{b1} = "B2"; +my D3 $obj2 = $obj1; +$obj2->{b1} = "D3"; + +print "not " unless $obj1->[2] eq "B2" && $obj1->[5] eq "D3"; +print "ok ", ++$testno, "\n"; + +# We should get compile time failures field name typos +eval q(my D3 $obj3 = $obj2; $obj3->{notthere} = ""); +print "not " unless $@ && $@ =~ /^No such pseudo-hash field "notthere"/; +print "ok ", ++$testno, "\n"; + +# Slices +@$obj1{"_b1", "b1"} = (17, 29); +print "not " unless "@$obj1[1,2]" eq "17 29"; +print "ok ", ++$testno, "\n"; +@$obj1[1,2] = (44,28); +print "not " unless "@$obj1{'b1','_b1','b1'}" eq "28 44 28"; +print "ok ", ++$testno, "\n"; + +my $ph = fields::phash(a => 1, b => 2, c => 3); +print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; +print "ok ", ++$testno, "\n"; + +$ph = fields::phash([qw/a b c/], [1, 2, 3]); +print "not " unless fstr($ph) eq 'a:1,b:2,c:3'; +print "ok ", ++$testno, "\n"; + +$ph = fields::phash([qw/a b c/], [1]); +print "not " if exists $ph->{b} or exists $ph->{c} or !exists $ph->{a}; +print "ok ", ++$testno, "\n"; + +eval '$ph = fields::phash("odd")'; +print "not " unless $@ && $@ =~ /^Odd number of/; +print "ok ", ++$testno, "\n"; + +#fields::_dump(); + +# check if fields autovivify +{ + package Foo; + use fields qw(foo bar); + sub new { bless [], $_[0]; } + + package main; + my Foo $a = Foo->new(); + $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; + $a->{bar} = { A => 'ok ' . ++$testno }; + print $a->{foo}[1], "\n"; + print $a->{bar}->{A}, "\n"; +} + +# check if fields autovivify +{ + package Bar; + use fields qw(foo bar); + sub new { return fields::new($_[0]) } + + package main; + my Bar $a = Bar::->new(); + $a->{foo} = ['a', 'ok ' . ++$testno, 'c']; + $a->{bar} = { A => 'ok ' . ++$testno }; + print $a->{foo}[1], "\n"; + print $a->{bar}->{A}, "\n"; +} + + +# Test $VERSION bug +package No::Version; + +use vars qw($Foo); +sub VERSION { 42 } + +package Test::Version; + +use base qw(No::Version); +print "# $No::Version::VERSION\nnot " unless $No::Version::VERSION =~ /set by base\.pm/; +print "ok ", ++$testno ,"\n"; + +# Test Inverse of $VERSION bug base.pm should not clobber existing $VERSION +package Has::Version; + +BEGIN { $Has::Version::VERSION = '42' }; + +package Test::Version2; + +use base qw(Has::Version); +print "#$Has::Version::VERSION\nnot " unless $Has::Version::VERSION eq '42'; +print "ok ", ++$testno ," # Has::Version\n"; + +package main; + +our $eval1 = q{ + { + package Eval1; + { + package Eval2; + use base 'Eval1'; + $Eval2::VERSION = "1.02"; + } + $Eval1::VERSION = "1.01"; + } +}; + +eval $eval1; +printf "# %s\nnot ", $@ if $@; +print "ok ", ++$testno ," # eval1\n"; + +print "# $Eval1::VERSION\nnot " unless $Eval1::VERSION == 1.01; +print "ok ", ++$testno ," # Eval1::VERSION\n"; + +print "# $Eval2::VERSION\nnot " unless $Eval2::VERSION == 1.02; +print "ok ", ++$testno ," # Eval2::VERSION\n"; + + +eval q{use base reallyReAlLyNotexists;}; +print "not " unless $@; +print "ok ", ++$testno, " # really not I\n"; + +eval q{use base reallyReAlLyNotexists;}; +print "not " unless $@; +print "ok ", ++$testno, " # really not II\n"; + +BEGIN { $Has::Version_0::VERSION = 0 } + +package Test::Version3; + +use base qw(Has::Version_0); +print "#$Has::Version_0::VERSION\nnot " unless $Has::Version_0::VERSION == 0; +print "ok ", ++$testno ," # Version_0\n"; + diff --git a/lib/fields.pm b/lib/fields.pm index bcdec29..425fdea 100644 --- a/lib/fields.pm +++ b/lib/fields.pm @@ -1,112 +1,24 @@ package fields; -=head1 NAME - -fields - compile-time class fields - -=head1 SYNOPSIS - - { - package Foo; - use fields qw(foo bar _Foo_private); - sub new { - my Foo $self = shift; - unless (ref $self) { - $self = fields::new($self); - $self->{_Foo_private} = "this is Foo's secret"; - } - $self->{foo} = 10; - $self->{bar} = 20; - return $self; - } - } - - my $var = Foo->new; - $var->{foo} = 42; - - # this will generate an error - $var->{zap} = 42; - - # subclassing - { - package Bar; - use base 'Foo'; - use fields qw(baz _Bar_private); # not shared with Foo - sub new { - my $class = shift; - my $self = fields::new($class); - $self->SUPER::new(); # init base fields - $self->{baz} = 10; # init own fields - $self->{_Bar_private} = "this is Bar's secret"; - return $self; - } - } - -=head1 DESCRIPTION - -The C pragma enables compile-time verified class fields. - -NOTE: The current implementation keeps the declared fields in the %FIELDS -hash of the calling package, but this may change in future versions. -Do B update the %FIELDS hash directly, because it must be created -at compile-time for it to be fully useful, as is done by this pragma. - -The related C pragma will combine fields from base classes and any -fields declared using the C pragma. This enables field -inheritance to work properly. - -Field names that start with an underscore character are made private to -the class and are not visible to subclasses. Inherited fields can be -overridden but will generate a warning if used together with the C<-w> -switch. - -The following functions are supported: - -=over 8 - -=item new - -fields::new() creates and blesses a restricted-hash comprised of the -fields declared using the C pragma into the specified class. -This makes it possible to write a constructor like this: - - package Critter::Sounds; - use fields qw(cat dog bird); - - sub new { - my $self = shift; - $self = fields::new($self) unless ref $self; - $self->{cat} = 'meow'; # scalar element - @$self{'dog','bird'} = ('bark','tweet'); # slice - return $self; - } - -=item phash - -Pseudo-hashes have been removed from Perl as of 5.10. Consider using -restricted hashes instead. Using fields::phash() will cause an error. - -=back - -=head1 SEE ALSO - -L, - -=cut - -use 5.006_001; +require 5.005; use strict; no strict 'refs'; -use warnings::register; -our(%attr, $VERSION); +unless( eval q{require warnings::register; warnings::register->import} ) { + *warnings::warnif = sub { + require Carp; + Carp::carp(@_); + } +} +use vars qw(%attr $VERSION); -$VERSION = "1.04"; +$VERSION = '2.0'; -use Hash::Util qw(lock_keys); +# constant.pm is slow +sub PUBLIC () { 2**0 } +sub PRIVATE () { 2**1 } +sub INHERITED () { 2**2 } +sub PROTECTED () { 2**3 } -# some constants -sub _PUBLIC () { 1 } -sub _PRIVATE () { 2 } # The %attr hash holds the attributes of the currently assigned fields # per class. The hash is indexed by class names and the hash value is @@ -141,13 +53,17 @@ sub import { if ($fno and $fno != $next) { require Carp; if ($fno < $fattr->[0]) { + if ($] < 5.006001) { + warn("Hides field '$f' in base class") if $^W; + } else { warnings::warnif("Hides field '$f' in base class") ; + } } else { Carp::croak("Field name '$f' already in use"); } } $fields->{$f} = $next; - $fattr->[$next] = ($f =~ /^_/) ? _PRIVATE : _PUBLIC; + $fattr->[$next] = ($f =~ /^_/) ? PRIVATE : PUBLIC; $next += 1; } if (@$fattr > $next) { @@ -161,30 +77,9 @@ sub import { } } -sub inherit { # called by base.pm when $base_fields is nonempty - my($derived, $base) = @_; - my $base_attr = $attr{$base}; - my $derived_attr = $attr{$derived} ||= []; - # avoid possible typo warnings - %{"$base\::FIELDS"} = () unless %{"$base\::FIELDS"}; - %{"$derived\::FIELDS"} = () unless %{"$derived\::FIELDS"}; - my $base_fields = \%{"$base\::FIELDS"}; - my $derived_fields = \%{"$derived\::FIELDS"}; - - $derived_attr->[0] = $base_attr ? scalar(@$base_attr) : 1; - while (my($k,$v) = each %$base_fields) { - my($fno); - if ($fno = $derived_fields->{$k} and $fno != $v) { - require Carp; - Carp::croak ("Inherited %FIELDS can't override existing %FIELDS"); - } - if ($base_attr->[$v] & _PRIVATE) { - $derived_attr->[$v] = undef; - } else { - $derived_attr->[$v] = $base_attr->[$v]; - $derived_fields->{$k} = $v; - } - } +sub inherit { + require base; + goto &base::inherit_fields; } sub _dump # sometimes useful for debugging @@ -202,8 +97,8 @@ sub _dump # sometimes useful for debugging my $fattr = $attr{$pkg}[$no]; if (defined $fattr) { my @a; - push(@a, "public") if $fattr & _PUBLIC; - push(@a, "private") if $fattr & _PRIVATE; + push(@a, "public") if $fattr & PUBLIC; + push(@a, "private") if $fattr & PRIVATE; push(@a, "inherited") if $no < $attr{$pkg}[0]; print "\t(", join(", ", @a), ")"; } @@ -212,16 +107,210 @@ sub _dump # sometimes useful for debugging } } -sub new { +if ($] < 5.009) { + eval <<'EOC'; + sub new { my $class = shift; $class = ref $class if ref $class; + return bless [\%{$class . "::FIELDS"}], $class; + } +EOC +} else { + eval <<'EOC'; + sub new { + my $class = shift; + $class = ref $class if ref $class; + use Hash::Util; my $self = bless {}, $class; - lock_keys(%$self, keys %{$class.'::FIELDS'}); + Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'}); return $self; + } +EOC } sub phash { - die "Pseudo-hashes have been removed from Perl"; + die "Pseudo-hashes have been removed from Perl" if $] >= 5.009; + my $h; + my $v; + if (@_) { + if (ref $_[0] eq 'ARRAY') { + my $a = shift; + @$h{@$a} = 1 .. @$a; + if (@_) { + $v = shift; + unless (! @_ and ref $v eq 'ARRAY') { + require Carp; + Carp::croak ("Expected at most two array refs\n"); + } + } + } + else { + if (@_ % 2) { + require Carp; + Carp::croak ("Odd number of elements initializing pseudo-hash\n"); + } + my $i = 0; + @$h{grep ++$i % 2, @_} = 1 .. @_ / 2; + $i = 0; + $v = [grep $i++ % 2, @_]; + } + } + else { + $h = {}; + $v = []; + } + [ $h, @$v ]; + } 1; + +__END__ + +=head1 NAME + +fields - compile-time class fields + +=head1 SYNOPSIS + + { + package Foo; + use fields qw(foo bar _Foo_private); + sub new { + my Foo $self = shift; + unless (ref $self) { + $self = fields::new($self); + $self->{_Foo_private} = "this is Foo's secret"; + } + $self->{foo} = 10; + $self->{bar} = 20; + return $self; + } + } + + my $var = Foo->new; + $var->{foo} = 42; + + # this will generate an error + $var->{zap} = 42; + + # subclassing + { + package Bar; + use base 'Foo'; + use fields qw(baz _Bar_private); # not shared with Foo + sub new { + my $class = shift; + my $self = fields::new($class); + $self->SUPER::new(); # init base fields + $self->{baz} = 10; # init own fields + $self->{_Bar_private} = "this is Bar's secret"; + return $self; + } + } + +=head1 DESCRIPTION + +The C pragma enables compile-time verified class fields. + +NOTE: The current implementation keeps the declared fields in the %FIELDS +hash of the calling package, but this may change in future versions. +Do B update the %FIELDS hash directly, because it must be created +at compile-time for it to be fully useful, as is done by this pragma. + + Only valid for perl before 5.9.0: + + If a typed lexical variable holding a reference is used to access a + hash element and a package with the same name as the type has + declared class fields using this pragma, then the operation is + turned into an array access at compile time. + + +The related C pragma will combine fields from base classes and any +fields declared using the C pragma. This enables field +inheritance to work properly. + +Field names that start with an underscore character are made private to +the class and are not visible to subclasses. Inherited fields can be +overridden but will generate a warning if used together with the C<-w> +switch. + + Only valid for perls before 5.9.0: + + The effect of all this is that you can have objects with named + fields which are as compact and as fast arrays to access. This only + works as long as the objects are accessed through properly typed + variables. If the objects are not typed, access is only checked at + run time. + + + +The following functions are supported: + +=over 8 + +=item new + +B< perl before 5.9.0: > fields::new() creates and blesses a +pseudo-hash comprised of the fields declared using the C +pragma into the specified class. + +B< perl 5.9.0 and higher: > fields::new() creates and blesses a +restricted-hash comprised of the fields declared using the C +pragma into the specified class. + + +This makes it possible to write a constructor like this: + + package Critter::Sounds; + use fields qw(cat dog bird); + + sub new { + my $self = shift; + $self = fields::new($self) unless ref $self; + $self->{cat} = 'meow'; # scalar element + @$self{'dog','bird'} = ('bark','tweet'); # slice + return $self; + } + +=item phash + +B< before perl 5.9.0: > + + fields::phash() can be used to create and initialize a plain (unblessed) + pseudo-hash. This function should always be used instead of creating + pseudo-hashes directly. + + If the first argument is a reference to an array, the pseudo-hash will + be created with keys from that array. If a second argument is supplied, + it must also be a reference to an array whose elements will be used as + the values. If the second array contains less elements than the first, + the trailing elements of the pseudo-hash will not be initialized. + This makes it particularly useful for creating a pseudo-hash from + subroutine arguments: + + sub dogtag { + my $tag = fields::phash([qw(name rank ser_num)], [@_]); + } + + fields::phash() also accepts a list of key-value pairs that will + be used to construct the pseudo hash. Examples: + + my $tag = fields::phash(name => "Joe", + rank => "captain", + ser_num => 42); + + my $pseudohash = fields::phash(%args); + +B< perl 5.9.0 and higher: > + +Pseudo-hashes have been removed from Perl as of 5.10. Consider using +restricted hashes instead. Using fields::phash() will cause an error. + +=back + +=head1 SEE ALSO + +L, + +=cut