Change 21015 by [EMAIL PROTECTED] on 2003/09/03 07:06:08
Integrate:
[ 21008]
VMS does not have quite UNIX glob semantics.
[ 21009]
Subject: Re: [EMAIL PROTECTED] or before broke mp2 ithreads test
From: "Marcus Holland-Moritz" <[EMAIL PROTECTED]>
Date: Wed, 3 Sep 2003 06:07:54 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 21010]
Subject: {PATCH 5.8.1] Re: [perl #23651] Debugger dump failed for blessed REF
object
From: Joe McMahon <[EMAIL PROTECTED]>
Date: Tue, 2 Sep 2003 18:02:14 -0400
Message-Id: <[EMAIL PROTECTED]>
[ 21011]
Changing the test count is a good idea.
[ 21012]
Upgrade to base 2.01 from CPAN.
[ 21013]
use IO; is deprecated.
[ 21014]
Subject: [PATCH] Re: [EMAIL PROTECTED] or before broke mp2 ithreads test
From: Marcus Holland-Moritz <[EMAIL PROTECTED]>
Date: Wed, 3 Sep 2003 08:57:25 +0200 (MEST)
Message-ID: <[EMAIL PROTECTED]>
The other half of #20930 should be still good.
(The fields.pm from the base 2.01 not integrated, though,
because otherwise fields.t and t/lib/warnings/doio will
start emitting "Pseudo-hashes are deprecated" warnings)
Affected files ...
... //depot/maint-5.8/perl/ext/threads/t/join.t#14 integrate
... //depot/maint-5.8/perl/lib/base.pm#6 integrate
... //depot/maint-5.8/perl/lib/dumpvar.pl#2 integrate
... //depot/maint-5.8/perl/op.c#40 integrate
... //depot/maint-5.8/perl/t/run/fresh_perl.t#8 integrate
Differences ...
==== //depot/maint-5.8/perl/ext/threads/t/join.t#14 (text) ====
Index: perl/ext/threads/t/join.t
--- perl/ext/threads/t/join.t#13~19991~ Fri Jul 4 06:54:33 2003
+++ perl/ext/threads/t/join.t Wed Sep 3 00:06:08 2003
@@ -10,7 +10,7 @@
use ExtUtils::testlib;
use strict;
-BEGIN { print "1..12\n" };
+BEGIN { print "1..14\n" };
use threads;
use threads::shared;
@@ -139,3 +139,12 @@
$ok++ if($@ =~/Thread already joined/);
ok($ok, "Double join works");
}
+
+{
+ # The "use IO::File" is not actually used for anything; its only
+ # purpose is to incite a lot of calls to newCONSTSUB. See the p5p
+ # archives for the thread "[EMAIL PROTECTED] or before broke mp2 ithreads test".
+ use IO::File;
+ $_->join for map threads->new(sub{ok($_, "stress newCONSTSUB")}), 1..2;
+}
+
==== //depot/maint-5.8/perl/lib/base.pm#6 (text) ====
Index: perl/lib/base.pm
--- perl/lib/base.pm#5~20966~ Sun Aug 31 01:58:09 2003
+++ perl/lib/base.pm Wed Sep 3 00:06:08 2003
@@ -1,3 +1,171 @@
+package base;
+
+use vars qw($VERSION);
+$VERSION = '2.01';
+
+# 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
@@ -12,15 +180,16 @@
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.
@@ -32,63 +201,20 @@
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
-package base;
+=head1 CAVEATS
-use 5.006_001;
-our $VERSION = "1.04";
+Due to the limitations of the pseudo-hash implementation, you must use
+base I<before> you declare any of your own fields.
-sub import {
- my $class = shift;
- my $fields_base;
- my $pkg = caller(0);
- 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;
+=head1 SEE ALSO
- # 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
==== //depot/maint-5.8/perl/lib/dumpvar.pl#2 (text) ====
Index: perl/lib/dumpvar.pl
--- perl/lib/dumpvar.pl#1~17645~ Fri Jul 19 12:29:57 2002
+++ perl/lib/dumpvar.pl Wed Sep 3 00:06:08 2003
@@ -136,7 +136,19 @@
my $val = $v;
$val = &{'overload::StrVal'}($v)
if %overload:: and defined &{'overload::StrVal'};
- ($address) = $val =~ /(0x[0-9a-f]+)\)$/ ;
+ # Match type and address.
+ # Unblessed references will look like TYPE(0x...)
+ # Blessed references will look like Class=TYPE(0x...)
+ ($start_part, $val) = split /=/,$val;
+ $val = $start_part unless defined $val;
+ ($item_type, $address) =
+ $val =~ /([^\(]+) # Keep stuff that's
+ # not an open paren
+ \( # Skip open paren
+ (0x[0-9a-f]+) # Save the address
+ \) # Skip close paren
+ $/x; # Should be at end now
+
if (!$dumpReused && defined $address) {
$address{$address}++ ;
if ( $address{$address} > 1 ) {
@@ -145,6 +157,7 @@
}
}
} elsif (ref \$v eq 'GLOB') {
+ # This is a raw glob. Special handling for that.
$address = "$v" . ""; # To avoid a bug with globs
$address{$address}++ ;
if ( $address{$address} > 1 ) {
@@ -154,13 +167,15 @@
}
if (ref $v eq 'Regexp') {
+ # Reformat the regexp to look the standard way.
my $re = "$v";
$re =~ s,/,\\/,g;
print "$sp-> qr/$re/\n";
return;
}
- if ( UNIVERSAL::isa($v, 'HASH') ) {
+ if ( $item_type eq 'HASH' ) {
+ # Hash ref or hash-based object.
@sortKeys = sort keys(%$v) ;
undef $more ;
$tHashDepth = $#sortKeys ;
@@ -193,14 +208,19 @@
}
print "$sp empty hash\n" unless @sortKeys;
print "$sp$more" if defined $more ;
- } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
+ } elsif ( $item_type eq 'ARRAY' ) {
+ # Array ref or array-based object. Also: undef.
+ # See how big the array is.
$tArrayDepth = $#{$v} ;
undef $more ;
+ # Bigger than the max?
$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
if defined $arrayDepth && $arrayDepth ne '';
+ # Yep. Don't show it all.
$more = "....\n" if $tArrayDepth < $#{$v} ;
$shortmore = "";
$shortmore = " ..." if $tArrayDepth < $#{$v} ;
+
if ($compactDump && !grep(ref $_, @{$v})) {
if ($#$v >= 0) {
$short = $sp . "0..$#{$v} " .
@@ -220,20 +240,35 @@
return if $DB::signal;
print "$sp$num ";
if (exists $v->[$num]) {
- DumpElem $v->[$num], $s, $m-1;
+ if (defined $v->[$num]) {
+ DumpElem $v->[$num], $s, $m-1;
+ }
+ else {
+ print "undef\n";
+ }
} else {
print "empty slot\n";
}
}
print "$sp empty array\n" unless @$v;
print "$sp$more" if defined $more ;
- } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
+ } elsif ( $item_type eq 'SCALAR' ) {
+ unless (defined $$v) {
+ print "$sp-> undef\n";
+ return;
+ }
print "$sp-> ";
DumpElem $$v, $s, $m-1;
- } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
+ } elsif ( $item_type eq 'REF' ) {
+ print "$sp-> $$v\n";
+ return unless defined $$v;
+ unwrap($$v, $s+3, $m-1);
+ } elsif ( $item_type eq 'CODE' ) {
+ # Code object or reference.
print "$sp-> ";
dumpsub (0, $v);
- } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
+ } elsif ( $item_type eq 'GLOB' ) {
+ # Glob object or reference.
print "$sp-> ",&stringify($$v,1),"\n";
if ($globPrint) {
$s += 3;
@@ -242,6 +277,7 @@
print( (' ' x ($s+3)) . "FileHandle({$$v}) => fileno($fileno)\n" );
}
} elsif (ref \$v eq 'GLOB') {
+ # Raw glob (again?)
if ($globPrint) {
dumpglob($s, "{$v}", $v, 1, $m-1) if $globPrint;
} elsif (defined ($fileno = fileno(\$v))) {
==== //depot/maint-5.8/perl/op.c#40 (text) ====
Index: perl/op.c
--- perl/op.c#39~21004~ Tue Sep 2 12:10:18 2003
+++ perl/op.c Wed Sep 3 00:06:08 2003
@@ -4447,6 +4447,9 @@
CvCONST_on(cv);
sv_setpv((SV*)cv, ""); /* prototype is "" */
+ if (stash)
+ CopSTASH_free(PL_curcop);
+
LEAVE;
return cv;
==== //depot/maint-5.8/perl/t/run/fresh_perl.t#8 (text) ====
Index: perl/t/run/fresh_perl.t
--- perl/t/run/fresh_perl.t#7~20991~ Mon Sep 1 21:39:23 2003
+++ perl/t/run/fresh_perl.t Wed Sep 3 00:06:08 2003
@@ -824,18 +824,32 @@
foo at - line 1.
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <[EMAIL PROTECTED]>
-lw
+if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
+print <<__EOF__;
+./"TEST"
+./"TEST"
+__EOF__
+} else {
print glob(q(./"TEST"));
use File::Glob;
print glob(q(./"TEST"));
+}
EXPECT
./"TEST"
./"TEST"
######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <[EMAIL PROTECTED]>
-lw
+if ($^O eq 'VMS') { # VMS is not *that* kind of a glob.
+print <<__EOF__;
+./"TEST"
+./"TEST"
+__EOF__
+} else {
use File::Glob;
print glob(q(./"TEST"));
use File::Glob;
print glob(q(./"TEST"));
+}
EXPECT
./"TEST"
./"TEST"
End of Patch.
