Change 20966 by [EMAIL PROTECTED] on 2003/08/31 08:58:09
Integrate:
[ 20965]
Ouch. Upgrading to base 2.0 made the threads tests very unhappy
both in blead and maint, lots of "Attempt to free non-existent
shared string" and "Unbalanced string table refcount" errors.
Retract #20960 (and #20963).
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#107 integrate
... //depot/maint-5.8/perl/lib/base.pm#5 integrate
... //depot/maint-5.8/perl/lib/base/t/base.t#2 delete
... //depot/maint-5.8/perl/lib/base/t/fb18784.t#2 delete
... //depot/maint-5.8/perl/lib/base/t/fb20922.t#2 delete
... //depot/maint-5.8/perl/lib/base/t/fields.t#2 delete
... //depot/maint-5.8/perl/lib/base/t/fp560.t#3 delete
... //depot/maint-5.8/perl/lib/base/t/fp580.t#2 delete
... //depot/maint-5.8/perl/lib/fields.pm#5 integrate
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#107 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#106~20962~ Sun Aug 31 01:12:31 2003
+++ perl/MANIFEST Sun Aug 31 01:58:09 2003
@@ -961,12 +961,6 @@
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
==== //depot/maint-5.8/perl/lib/base.pm#5 (text) ====
Index: perl/lib/base.pm
--- perl/lib/base.pm#4~20962~ Sun Aug 31 01:12:31 2003
+++ perl/lib/base.pm Sun Aug 31 01:58:09 2003
@@ -1,171 +1,3 @@
-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
@@ -180,16 +12,15 @@
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.
@@ -201,20 +32,63 @@
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;
-L<fields>
+ # 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;
==== //depot/maint-5.8/perl/lib/fields.pm#5 (text) ====
Index: perl/lib/fields.pm
--- perl/lib/fields.pm#4~20962~ Sun Aug 31 01:12:31 2003
+++ perl/lib/fields.pm Sun Aug 31 01:58:09 2003
@@ -1,24 +1,112 @@
package fields;
-require 5.005;
+=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;
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);
+use warnings::register;
+our(%attr, $VERSION);
-$VERSION = '2.0';
+$VERSION = "1.04";
-# constant.pm is slow
-sub PUBLIC () { 2**0 }
-sub PRIVATE () { 2**1 }
-sub INHERITED () { 2**2 }
-sub PROTECTED () { 2**3 }
+use Hash::Util qw(lock_keys);
+# 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
@@ -53,17 +141,13 @@
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) {
@@ -77,9 +161,30 @@
}
}
-sub inherit {
- require base;
- goto &base::inherit_fields;
+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
@@ -97,8 +202,8 @@
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), ")";
}
@@ -107,210 +212,16 @@
}
}
-if ($] < 5.009) {
- eval <<'EOC';
- sub new {
+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'});
+ 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;
- @[EMAIL PROTECTED] = 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 ];
-
+ die "Pseudo-hashes have been removed from Perl";
}
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)], [EMAIL PROTECTED]);
- }
-
- 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
End of Patch.
