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/fields-560.t See if fields work
+lib/base/t/fields-base.t See if fields work
+lib/base/t/fields.t See if fields work
lib/Benchmark.pm Measure execution time
lib/Benchmark.t See if Benchmark works
lib/bigfloat.pl An arbitrary precision floating point package
lib/Fatal.pm Make errors in functions/builtins fatal
lib/Fatal.t See if Fatal works
lib/fields.pm Set up object field names for pseudo-hash-using classes
-lib/fields.t See if base/fields works
-lib/fields-base.t See if base/fields works
lib/File/Basename.pm Emulate the basename program
lib/File/Basename.t See if File::Basename works
lib/FileCache.pm Keep more files open than the system permits
package base;
+use strict 'vars';
use vars qw($VERSION);
-$VERSION = '2.02';
+$VERSION = '2.03';
# constant.pm is slow
sub SUCCESS () { 1 }
sub has_fields {
my($base) = shift;
my $fglob = ${"$base\::"}{FIELDS};
- return $fglob && *$fglob{HASH};
+ return( ($fglob && *$fglob{HASH}) ? 1 : 0 );
}
sub has_version {
my($base) = shift;
my $vglob = ${$base.'::'}{VERSION};
- return $vglob && *$vglob{SCALAR};
+ return( ($vglob && *$vglob{SCALAR}) ? 1 : 0 );
}
sub has_attr {
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;
}
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;
- }
+ # No multiple fields inheritence *suck*
+ if ($fields_base) {
+ require Carp;
+ Carp::croak("Can't multiply inherit %FIELDS");
+ } else {
+ $fields_base = $base;
}
}
}
}
if( $battr->[$v] & PRIVATE ) {
- $dattr->[$v] = undef;
+ $dattr->[$v] = PRIVATE | INHERITED;
}
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;
}
}
+
+ unless( keys %$bfields ) {
+ foreach my $idx (1..$#{$battr}) {
+ $dattr->[$idx] = $battr->[$idx] & INHERITED;
+ }
+ }
}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 10;
+
+use_ok('base');
+
+
+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' );
+
+# 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;
+
+my $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::SIGDIE;
+
+{
+ local $SIG{__DIE__} = sub {
+ ::fail('sigdie not caught, this test should not run')
+ };
+ eval {
+ 'base'->import(qw(Huh::Boo));
+ };
+
+ ::like($@, qr/^Base class package "Huh::Boo" is empty/,
+ 'Base class empty error message');
+
+}
--- /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' );
+}
}
use strict;
-use Test::More tests => 29;
+use Test::More tests => 25;
BEGIN { use_ok('base'); }
use fields qw(b1 d1 _b1 _d1); # hide b1
+# Test that a package with only private fields gets inherited properly
+package B7;
+use fields qw(_b1);
+
+package D7;
+use base qw(B7);
+use fields qw(b1);
+
+
+# Test that an intermediate package with no fields doesn't cause a problem.
+package B8;
+use fields qw(_b1);
+
+package D8;
+use base qw(B8);
+
+package D8A;
+use base qw(D8);
+use fields qw(b1);
+
+
package main;
my %EXPECT = (
qw(b2 b1 d1 _b1 _d1))], # b1 is hidden
D4 => [(undef,undef,undef,
qw(b2 b1 d1),undef,undef,qw(_d3 d3))],
+
D5 => [undef, 'b1', undef, 'b2'],
B3 => [qw(b4 _b5 b6 _b7)],
+ B7 => [qw(_b1)],
+ D7 => [undef, 'b1'],
+
+ B8 => [qw(_b1)],
+ D8 => [undef],
+ D8A => [undef, 'b1'],
+
'Foo::Bar' => [qw(b1 b2 b3)],
'Foo::Bar::Baz' => [qw(b1 b2 b3 foo bar baz)],
);
::like( $@, qr/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' );
-
-# 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::SIGDIE;
-
-{
- local $SIG{__DIE__} = sub {
- ::fail('sigdie not caught, this test should not run')
- };
- eval {
- 'base'->import(qw(Huh::Boo));
- };
-
- ::like($@, qr/^Base class package "Huh::Boo" is empty/,
- 'Base class empty error message');
-
-}
my $Has_PH;
BEGIN {
- $SIG{__WARN__} = sub {
- return if $_[0] =~ /^Pseudo-hashes are deprecated/
- };
$Has_PH = $] < 5.009;
}
}
{
+ local $SIG{__WARN__} = sub {
+ return if $_[0] =~ /^Pseudo-hashes are deprecated/
+ };
my $phash;
eval { $phash = fields::phash(name => "Joe", rank => "Captain") };
if( $Has_PH ) {
}
use vars qw(%attr $VERSION);
-$VERSION = '2.0';
+$VERSION = '2.03';
# constant.pm is slow
sub PUBLIC () { 2**0 }
my $fattr = ($attr{$package} ||= [1]);
my $next = @$fattr;
+ # Quiet pseudo-hash deprecation warning for uses of fields::new.
+ bless \%{"$package\::FIELDS"}, 'pseudohash';
+
if ($next > $fattr->[0]
and ($fields->{$_[0]} || 0) >= $fattr->[0])
{
my @a;
push(@a, "public") if $fattr & PUBLIC;
push(@a, "private") if $fattr & PRIVATE;
- push(@a, "inherited") if $no < $attr{$pkg}[0];
+ push(@a, "inherited") if $fattr & INHERITED;
print "\t(", join(", ", @a), ")";
}
print "\n";
}
if ($] < 5.009) {
- eval <<'EOC';
- sub new {
+ *new = sub {
my $class = shift;
$class = ref $class if ref $class;
return bless [\%{$class . "::FIELDS"}], $class;
}
-EOC
} else {
- eval <<'EOC';
- sub new {
+ *new = sub {
my $class = shift;
$class = ref $class if ref $class;
- use Hash::Util;
+ require Hash::Util;
my $self = bless {}, $class;
- Hash::Util::lock_keys(%$self, keys %{$class.'::FIELDS'});
+
+ # The lock_keys() prototype won't work since we require Hash::Util :(
+ &Hash::Util::lock_keys(\%$self, keys %{$class.'::FIELDS'});
return $self;
}
-EOC
}
sub phash {
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:
+B<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.
+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
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.
+B<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
+=over 4
=item new
restricted-hash comprised of the fields declared using the C<fields>
pragma into the specified class.
+This function is usable with or without pseudo-hashes. It is the
+recommended way to construct a fields-based object.
This makes it possible to write a constructor like this:
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.
+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:
+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)], [@_]);
- }
+ 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:
+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 $tag = fields::phash(name => "Joe",
+ rank => "captain",
+ ser_num => 42);
- my $pseudohash = fields::phash(%args);
+ 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.
+restricted hashes or fields::new() instead. Using fields::phash()
+will cause an error.
=back
=head1 SEE ALSO
-L<base>,
+L<base>
=cut
projects / p5sagit/p5-mst-13.2.git / commitdiff