From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 16 Dec 2006 23:03:42 +0000 (+0000)
Subject: Add a new flag SVprv_PCS_IMPORTED (which is a pseudonym for SVf_SCREAM)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1ccdb7301362000755034d5e6a7e73f566973104;p=p5sagit%2Fp5-mst-13.2.git
Add a new flag SVprv_PCS_IMPORTED (which is a pseudonym for SVf_SCREAM)
to note when a proxy constant subroutine is copied. This allows us to
correctly set GvIMPORTED_CV_on() if the symbol is ever turned into a
real GV.
p4raw-id: //depot/perl@29566
---
diff --git a/MANIFEST b/MANIFEST
index 390e026..0a57c58 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3362,6 +3362,7 @@ t/lib/Math/BigRat/Test.pm Math::BigRat test helper
t/lib/mypragma.pm An example user pragma
t/lib/mypragma.t Test the example user pragma
t/lib/NoExporter.pm Part of Test-Simple
+t/lib/proxy_constant_subs.t Test that Proxy Constant Subs behave correctly
t/lib/sample-tests/bailout Test data for Test::Harness
t/lib/sample-tests/bignum Test data for Test::Harness
t/lib/sample-tests/bignum_many Test data for Test::Harness
diff --git a/dump.c b/dump.c
index 4622fb9..eefa477 100644
--- a/dump.c
+++ b/dump.c
@@ -1385,8 +1385,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
if (flags & SVp_POK) sv_catpv(d, "pPOK,");
- if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv))
+ if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
+ if (SvPCS_IMPORTED(sv))
+ sv_catpv(d, "PCS_IMPORTED,");
+ else
sv_catpv(d, "SCREAM,");
+ }
switch (type) {
case SVt_PVCV:
diff --git a/gv.c b/gv.c
index fc22aeb..394e684 100644
--- a/gv.c
+++ b/gv.c
@@ -191,6 +191,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
const bool doproto = old_type > SVt_NULL;
const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
+ const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
assert (!(proto && has_constant));
@@ -239,6 +240,11 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
if (has_constant) {
/* newCONSTSUB takes ownership of the reference from us. */
GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+ /* If this reference was a copy of another, then the subroutine
+ must have been "imported", by a Perl space assignment to a GV
+ from a reference to CV. */
+ if (exported_constant)
+ GvIMPORTED_CV_on(gv);
} else {
/* XXX unsafe for threads if eval_owner isn't held */
(void) start_subparse(0,0); /* Create empty CV in compcv. */
diff --git a/pp_hot.c b/pp_hot.c
index 9fe7c70..4038629 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -150,7 +150,7 @@ PP(pp_sassign)
SV *const value = SvRV(cv);
SvUPGRADE((SV *)gv, SVt_RV);
- SvROK_on(gv);
+ SvPCS_IMPORTED_on(gv);
SvRV_set(gv, value);
SvREFCNT_inc_simple_void(value);
SETs(right);
diff --git a/sv.h b/sv.h
index a8e7a2e..9265197 100644
--- a/sv.h
+++ b/sv.h
@@ -294,6 +294,10 @@ perform the upgrade if necessary. See C<svtype>.
#define SVp_SCREAM 0x00008000 /* has been studied? */
#define SVphv_CLONEABLE SVp_SCREAM /* PVHV (stashes) clone its objects */
#define SVpgv_GP SVp_SCREAM /* GV has a valid GP */
+#define SVprv_PCS_IMPORTED SVp_SCREAM /* RV is a proxy for a constant
+ subroutine in another package. Set the
+ CvIMPORTED_CV_ON() if it needs to be
+ expanded to a real GV */
#define SVs_PADSTALE 0x00010000 /* lexical has gone out of scope */
#define SVpad_STATE 0x00010000 /* pad name is a "state" var */
@@ -1013,6 +1017,11 @@ the scalar's value cannot change unless written to.
#define SvWEAKREF_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_WEAKREF))
#define SvWEAKREF_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_WEAKREF))
+#define SvPCS_IMPORTED(sv) ((SvFLAGS(sv) & (SVf_ROK|SVprv_PCS_IMPORTED)) \
+ == (SVf_ROK|SVprv_PCS_IMPORTED))
+#define SvPCS_IMPORTED_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_PCS_IMPORTED))
+#define SvPCS_IMPORTED_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_PCS_IMPORTED))
+
#define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST)
#define SvPADSTALE(sv) (SvFLAGS(sv) & SVs_PADSTALE)
diff --git a/t/lib/proxy_constant_subs.t b/t/lib/proxy_constant_subs.t
new file mode 100644
index 0000000..4af73d3
--- /dev/null
+++ b/t/lib/proxy_constant_subs.t
@@ -0,0 +1,41 @@
+my @symbols;
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require Config;
+ if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+ print "1..0 # Skip -- Perl configured without B module\n";
+ exit 0;
+ }
+ if ($Config::Config{'extensions'} !~ /\bPOSIX\b/) {
+ print "1..0 # Skip -- Perl configured without POSIX\n";
+ exit 0;
+ }
+ # errno is a real subroutine, and acts as control
+ # SEEK_SET is a proxy constant subroutine.
+ @symbols = qw(errno SEEK_SET);
+}
+
+use strict;
+use warnings;
+use Test::More tests => 4 * @symbols;
+use B qw(svref_2object GVf_IMPORTED_CV);
+use POSIX @symbols;
+
+# GVf_IMPORTED_CV should not be set on the original, but should be set on the
+# imported GV.
+
+foreach my $symbol (@symbols) {
+ my ($ps, $ms);
+ {
+ no strict 'refs';
+ $ps = svref_2object(\*{"POSIX::$symbol"});
+ $ms = svref_2object(\*{"::$symbol"});
+ }
+ isa_ok($ps, 'B::GV');
+ is($ps->GvFLAGS() & GVf_IMPORTED_CV, 0,
+ "GVf_IMPORTED_CV not set on original");
+ isa_ok($ms, 'B::GV');
+ is($ms->GvFLAGS() & GVf_IMPORTED_CV, GVf_IMPORTED_CV,
+ "GVf_IMPORTED_CV set on imported GV");
+}