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 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.
+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.
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>
-=head1 CAVEATS
+=cut
-Due to the limitations of the pseudo-hash implementation, you must use
-base I<before> you declare any of your own fields.
+package base;
+use 5.006_001;
+our $VERSION = "1.04";
-=head1 SEE ALSO
+sub import {
+ my $class = shift;
+ my $fields_base;
+ my $pkg = caller(0);
-L<fields>
+ 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);
+ }
+}
-=cut
+1;
+++ /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;
- }
- if ($_[0] =~ /^Pseudo-hashes are deprecated/ &&
- ($] >= 5.008 && $] < 5.009)) {
- print "# $_[0]"; # Yes, we know they are deprecated.
- 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;
-require 5.005;
-use strict;
-no strict 'refs';
-unless( eval q{require warnings::register; warnings::register->import} ) {
- *warnings::warnif = sub {
- require Carp;
- Carp::carp(@_);
- }
-}
-use vars qw(%attr $VERSION);
-
-$VERSION = '2.0';
-
-# constant.pm is slow
-sub PUBLIC () { 2**0 }
-sub PRIVATE () { 2**1 }
-sub INHERITED () { 2**2 }
-sub PROTECTED () { 2**3 }
-
-
-# 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
-# an array reference. The first element in the array is the lowest field
-# number not belonging to a base class. The remaining elements' indices
-# are the field numbers. The values are integer bit masks, or undef
-# in the case of base class private fields (which occupy a slot but are
-# otherwise irrelevant to the class).
-
-sub import {
- my $class = shift;
- return unless @_;
- my $package = caller(0);
- # avoid possible typo warnings
- %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
- my $fields = \%{"$package\::FIELDS"};
- my $fattr = ($attr{$package} ||= [1]);
- my $next = @$fattr;
-
- if ($next > $fattr->[0]
- and ($fields->{$_[0]} || 0) >= $fattr->[0])
- {
- # There are already fields not belonging to base classes.
- # Looks like a possible module reload...
- $next = $fattr->[0];
- }
- foreach my $f (@_) {
- my $fno = $fields->{$f};
-
- # Allow the module to be reloaded so long as field positions
- # have not changed.
- 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;
- $next += 1;
- }
- if (@$fattr > $next) {
- # Well, we gave them the benefit of the doubt by guessing the
- # module was reloaded, but they appear to be declaring fields
- # in more than one place. We can't be sure (without some extra
- # bookkeeping) that the rest of the fields will be declared or
- # have the same positions, so punt.
- require Carp;
- Carp::croak ("Reloaded module must declare all fields at once");
- }
-}
-
-sub inherit {
- require base;
- goto &base::inherit_fields;
-}
-
-sub _dump # sometimes useful for debugging
-{
- for my $pkg (sort keys %attr) {
- print "\n$pkg";
- if (@{"$pkg\::ISA"}) {
- print " (", join(", ", @{"$pkg\::ISA"}), ")";
- }
- print "\n";
- my $fields = \%{"$pkg\::FIELDS"};
- for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
- my $no = $fields->{$f};
- print " $no: $f";
- my $fattr = $attr{$pkg}[$no];
- if (defined $fattr) {
- my @a;
- push(@a, "public") if $fattr & PUBLIC;
- push(@a, "private") if $fattr & PRIVATE;
- push(@a, "inherited") if $no < $attr{$pkg}[0];
- print "\t(", join(", ", @a), ")";
- }
- print "\n";
- }
- }
-}
-
-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;
- Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'});
- return $self;
- }
-EOC
-}
-
-sub phash {
- 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
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.
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.
-
-
+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;
=item phash
-B< before perl 5.9.0: >
+Pseudo-hashes have been removed from Perl as of 5.10. Consider using
+restricted hashes instead. Using fields::phash() will cause an error.
- 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.
+=back
- 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:
+=head1 SEE ALSO
- sub dogtag {
- my $tag = fields::phash([qw(name rank ser_num)], [@_]);
- }
+L<base>,
- fields::phash() also accepts a list of key-value pairs that will
- be used to construct the pseudo hash. Examples:
+=cut
- my $tag = fields::phash(name => "Joe",
- rank => "captain",
- ser_num => 42);
+use 5.006_001;
+use strict;
+no strict 'refs';
+use warnings::register;
+our(%attr, $VERSION);
- my $pseudohash = fields::phash(%args);
+$VERSION = "1.04";
-B< perl 5.9.0 and higher: >
+use Hash::Util qw(lock_keys);
-Pseudo-hashes have been removed from Perl as of 5.10. Consider using
-restricted hashes instead. Using fields::phash() will cause an error.
+# some constants
+sub _PUBLIC () { 1 }
+sub _PRIVATE () { 2 }
-=back
+# 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
+# an array reference. The first element in the array is the lowest field
+# number not belonging to a base class. The remaining elements' indices
+# are the field numbers. The values are integer bit masks, or undef
+# in the case of base class private fields (which occupy a slot but are
+# otherwise irrelevant to the class).
-=head1 SEE ALSO
+sub import {
+ my $class = shift;
+ return unless @_;
+ my $package = caller(0);
+ # avoid possible typo warnings
+ %{"$package\::FIELDS"} = () unless %{"$package\::FIELDS"};
+ my $fields = \%{"$package\::FIELDS"};
+ my $fattr = ($attr{$package} ||= [1]);
+ my $next = @$fattr;
-L<base>,
+ if ($next > $fattr->[0]
+ and ($fields->{$_[0]} || 0) >= $fattr->[0])
+ {
+ # There are already fields not belonging to base classes.
+ # Looks like a possible module reload...
+ $next = $fattr->[0];
+ }
+ foreach my $f (@_) {
+ my $fno = $fields->{$f};
-=cut
+ # Allow the module to be reloaded so long as field positions
+ # have not changed.
+ if ($fno and $fno != $next) {
+ require Carp;
+ if ($fno < $fattr->[0]) {
+ 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;
+ $next += 1;
+ }
+ if (@$fattr > $next) {
+ # Well, we gave them the benefit of the doubt by guessing the
+ # module was reloaded, but they appear to be declaring fields
+ # in more than one place. We can't be sure (without some extra
+ # bookkeeping) that the rest of the fields will be declared or
+ # have the same positions, so punt.
+ require Carp;
+ Carp::croak ("Reloaded module must declare all fields at once");
+ }
+}
+
+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 _dump # sometimes useful for debugging
+{
+ for my $pkg (sort keys %attr) {
+ print "\n$pkg";
+ if (@{"$pkg\::ISA"}) {
+ print " (", join(", ", @{"$pkg\::ISA"}), ")";
+ }
+ print "\n";
+ my $fields = \%{"$pkg\::FIELDS"};
+ for my $f (sort {$fields->{$a} <=> $fields->{$b}} keys %$fields) {
+ my $no = $fields->{$f};
+ print " $no: $f";
+ my $fattr = $attr{$pkg}[$no];
+ if (defined $fattr) {
+ my @a;
+ push(@a, "public") if $fattr & _PUBLIC;
+ push(@a, "private") if $fattr & _PRIVATE;
+ push(@a, "inherited") if $no < $attr{$pkg}[0];
+ print "\t(", join(", ", @a), ")";
+ }
+ print "\n";
+ }
+ }
+}
+
+sub new {
+ my $class = shift;
+ $class = ref $class if ref $class;
+ my $self = bless {}, $class;
+ lock_keys(%$self, keys %{$class.'::FIELDS'});
+ return $self;
+}
+
+sub phash {
+ die "Pseudo-hashes have been removed from Perl";
+}
+
+1;
projects / p5sagit/p5-mst-13.2.git / commitdiff