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
+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(<<ERROR);
+Base class package "$base" is empty.
+ (Perhaps you need to 'use' the module which defines that package first.)
+ERROR
+
+ }
+ ${$base.'::VERSION'} = "-1, set by base.pm"
+ unless defined ${$base.'::VERSION'};
+ }
+ push @{"$inheritor\::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.
+ #
+ # We don't just check to see if the base in question has %FIELDS
+ # defined, we also check to see if it has -inheritable- fields.
+ # Its perfectly alright to inherit from multiple classes that have
+ # %FIELDS as long as only one of them has fields to give.
+ if ( has_fields($base) || has_attr($base) ) {
+ # Check to see if there are fields to be inherited.
+ if ( show_fields($base, PUBLIC) or
+ show_fields($base, PROTECTED) ) {
+ # No multiple fields inheritence *suck*
+ if ($fields_base) {
+ require Carp;
+ Carp::croak("Can't multiply inherit %FIELDS");
+ } else {
+ $fields_base = $base;
+ }
+ }
+ }
+ }
+
+ if( defined $fields_base ) {
+ inherit_fields($inheritor, $fields_base);
+ }
+}
+
+
+sub inherit_fields {
+ my($derived, $base) = @_;
+
+ return SUCCESS unless $base;
+
+ my $battr = get_attr($base);
+ my $dattr = get_attr($derived);
+ my $dfields = get_fields($derived);
+ my $bfields = get_fields($base);
+
+ $dattr->[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
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<fields> 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<NOT> supported, if two or more
+base classes each have inheritable fields the 'base' pragma will
+croak. See L<fields>, L<public> and L<protected> for a description of
+this feature.
When strict 'vars' is in scope, I<base> also lets you assign to @ISA
without having to declare @ISA with the 'vars' pragma first.
loading it, I<base> 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<fields>
-=cut
+=head1 CAVEATS
-package base;
+Due to the limitations of the pseudo-hash implementation, you must use
+base I<before> 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<fields>
-1;
+=cut
--- /dev/null
+# 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');
+
+}
--- /dev/null
+#!./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' );
+
--- /dev/null
+#!./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');
+}
+
+
--- /dev/null
+# 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);
+ }
+}
--- /dev/null
+# 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' );
+}
--- /dev/null
+#!/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";
+
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<fields> 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<not> 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<base> pragma will combine fields from base classes and any
-fields declared using the C<fields> 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<fields> 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<base>,
-
-=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
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) {
}
}
-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
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), ")";
}
}
}
-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<fields> 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<not> 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<base> pragma will combine fields from base classes and any
+fields declared using the C<fields> 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<fields>
+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<fields>
+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<base>,
+
+=cut
projects / p5sagit/p5-mst-13.2.git / commitdiff