Front page | perl.perl5.porters |
Postings from July 2009
[PATCH] Implement @{^COMPILE_SCOPE_CONTAINER}
Thread Previous
|
Thread Next
From:
Florian Ragwitz
Date:
July 15, 2009 10:18
Subject:
[PATCH] Implement @{^COMPILE_SCOPE_CONTAINER}
Message ID:
1247678199-27002-2-git-send-email-rafl@debian.org
This is a new special variable, that's localized to a dynamic scope during
compile time. It guarantees to destroy its contents at the end of compile time
of a given scope, unless a COMPILE_SCOPE_CONTAINER of an outer scope still
holds a reference to a contained value.
---
embed.fnc | 1 +
embed.h | 2 +
embedvar.h | 2 +
intrpvar.h | 1 +
op.c | 1 +
perl.c | 3 +
perlapi.h | 2 +
proto.h | 1 +
scope.c | 25 ++++++++++++
scope.h | 3 +
t/comp/compile_scope.t | 96 ++++++++++++++++++++++++++++++++++++++++++++++++
11 files changed, 137 insertions(+), 0 deletions(-)
create mode 100644 t/comp/compile_scope.t
diff --git a/embed.fnc b/embed.fnc
index 0001d1f..613a8ed 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -902,6 +902,7 @@ Ap |void |save_shared_pvref|NN char** str
Ap |void |save_gp |NN GV* gv|I32 empty
Ap |HV* |save_hash |NN GV* gv
p |void |save_hints
+p |void |save_compscope
Amp |void |save_helem |NN HV *hv|NN SV *key|NN SV **sptr
Ap |void |save_helem_flags|NN HV *hv|NN SV *key|NN SV **sptr|const U32 flags
Ap |void |save_hptr |NN HV** hptr
diff --git a/embed.h b/embed.h
index e702d32..c5f88c1 100644
--- a/embed.h
+++ b/embed.h
@@ -790,6 +790,7 @@
#define save_hash Perl_save_hash
#ifdef PERL_CORE
#define save_hints Perl_save_hints
+#define save_compscope Perl_save_compscope
#endif
#define save_helem_flags Perl_save_helem_flags
#define save_hptr Perl_save_hptr
@@ -3130,6 +3131,7 @@
#define save_hash(a) Perl_save_hash(aTHX_ a)
#ifdef PERL_CORE
#define save_hints() Perl_save_hints(aTHX)
+#define save_compscope() Perl_save_compscope(aTHX)
#endif
#define save_helem_flags(a,b,c,d) Perl_save_helem_flags(aTHX_ a,b,c,d)
#define save_hptr(a) Perl_save_hptr(aTHX_ a)
diff --git a/embedvar.h b/embedvar.h
index 024b6c1..63d9d4c 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -92,6 +92,7 @@
#define PL_comppad_name (vTHX->Icomppad_name)
#define PL_comppad_name_fill (vTHX->Icomppad_name_fill)
#define PL_comppad_name_floor (vTHX->Icomppad_name_floor)
+#define PL_compscopegv (vTHX->Icompscopegv)
#define PL_cop_seqmax (vTHX->Icop_seqmax)
#define PL_cryptseen (vTHX->Icryptseen)
#define PL_curcop (vTHX->Icurcop)
@@ -406,6 +407,7 @@
#define PL_Icomppad_name PL_comppad_name
#define PL_Icomppad_name_fill PL_comppad_name_fill
#define PL_Icomppad_name_floor PL_comppad_name_floor
+#define PL_Icompscopegv PL_compscopegv
#define PL_Icop_seqmax PL_cop_seqmax
#define PL_Icryptseen PL_cryptseen
#define PL_Icurcop PL_curcop
diff --git a/intrpvar.h b/intrpvar.h
index fe3f07f..f9e009b 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -206,6 +206,7 @@ PERLVAR(Iorigargv, char **)
PERLVAR(Ienvgv, GV *)
PERLVAR(Iincgv, GV *)
PERLVAR(Ihintgv, GV *)
+PERLVAR(Icompscopegv, GV *)
PERLVAR(Iorigfilename, char *)
PERLVAR(Idiehook, SV *)
PERLVAR(Iwarnhook, SV *)
diff --git a/op.c b/op.c
index d7ef32c..a1010b3 100644
--- a/op.c
+++ b/op.c
@@ -2264,6 +2264,7 @@ Perl_block_start(pTHX_ int full)
const int retval = PL_savestack_ix;
pad_block_start(full);
SAVEHINTS();
+ SAVECOMPSCOPE();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
diff --git a/perl.c b/perl.c
index d9ebaca..2738f41 100644
--- a/perl.c
+++ b/perl.c
@@ -934,6 +934,7 @@ perl_destruct(pTHXx)
PL_envgv = NULL;
PL_incgv = NULL;
PL_hintgv = NULL;
+ PL_compscopegv = NULL;
PL_errgv = NULL;
PL_argvgv = NULL;
PL_argvoutgv = NULL;
@@ -3441,6 +3442,8 @@ S_init_main_stash(pTHX)
GvMULTI_on(PL_incgv);
PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */
GvMULTI_on(PL_hintgv);
+ PL_compscopegv = gv_fetchpvs("\003OMPILE_SCOPE_CONTAINER", GV_ADD|GV_NOTQUAL, SVt_PVAV); /* ^COMPILE_SCOPE_CONTAINER */
+ GvMULTI_on(PL_compscopegv);
PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV);
SvREFCNT_inc_simple_void(PL_defgv);
PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV));
diff --git a/perlapi.h b/perlapi.h
index 3c0df25..907ca7e 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -220,6 +220,8 @@ END_EXTERN_C
#define PL_comppad_name_fill (*Perl_Icomppad_name_fill_ptr(aTHX))
#undef PL_comppad_name_floor
#define PL_comppad_name_floor (*Perl_Icomppad_name_floor_ptr(aTHX))
+#undef PL_compscopegv
+#define PL_compscopegv (*Perl_Icompscopegv_ptr(aTHX))
#undef PL_cop_seqmax
#define PL_cop_seqmax (*Perl_Icop_seqmax_ptr(aTHX))
#undef PL_cryptseen
diff --git a/proto.h b/proto.h
index b2e9e90..272c574 100644
--- a/proto.h
+++ b/proto.h
@@ -2819,6 +2819,7 @@ PERL_CALLCONV HV* Perl_save_hash(pTHX_ GV* gv)
assert(gv)
PERL_CALLCONV void Perl_save_hints(pTHX);
+PERL_CALLCONV void Perl_save_compscope(pTHX);
/* PERL_CALLCONV void Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2)
diff --git a/scope.c b/scope.c
index 20e027f..3d43ff4 100644
--- a/scope.c
+++ b/scope.c
@@ -560,6 +560,25 @@ Perl_save_hints(pTHX)
}
}
+void
+Perl_save_compscope(pTHX)
+{
+ AV *const cur = GvAV(PL_compscopegv);
+
+ if (cur) {
+ I32 i;
+ AV *const new = newAV();
+
+ for (i = 0; i <= av_len(cur); i++) {
+ av_store(new, i, newSVsv(*av_fetch(cur, i, 0)));
+ }
+
+ GvAV(PL_compscopegv) = new;
+ }
+
+ save_pushptr(cur, SAVEt_COMPSCOPE);
+}
+
static void
S_save_pushptri32ptr(pTHX_ void *const ptr1, const I32 i, void *const ptr2,
const int type)
@@ -973,6 +992,12 @@ Perl_leave_scope(pTHX_ I32 base)
}
assert(GvHV(PL_hintgv));
break;
+ case SAVEt_COMPSCOPE:
+ if (GvAV(PL_compscopegv)) {
+ SvREFCNT_dec(MUTABLE_SV(GvAV(PL_compscopegv)));
+ }
+ GvAV(PL_compscopegv) = MUTABLE_AV(SSPOPPTR);
+ break;
case SAVEt_COMPPAD:
PL_comppad = (PAD*)SSPOPPTR;
if (PL_comppad)
diff --git a/scope.h b/scope.h
index 2b57fc6..25f6298 100644
--- a/scope.h
+++ b/scope.h
@@ -55,6 +55,7 @@
#define SAVEt_STACK_CXPOS 44
#define SAVEt_PARSER 45
#define SAVEt_ADELETE 46
+#define SAVEt_COMPSCOPE 47
#define SAVEf_SETMAGIC 1
@@ -162,6 +163,8 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>.
#define SAVEHINTS() save_hints()
+#define SAVECOMPSCOPE() save_compscope()
+
#define SAVECOMPPAD() save_pushptr(MUTABLE_SV(PL_comppad), SAVEt_COMPPAD)
#define SAVESWITCHSTACK(f,t) \
diff --git a/t/comp/compile_scope.t b/t/comp/compile_scope.t
new file mode 100644
index 0000000..81acc02
--- /dev/null
+++ b/t/comp/compile_scope.t
@@ -0,0 +1,96 @@
+#!./perl
+
+# Tests for @{^COMPILE_SCOPE_CONTAINER}
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+}
+
+use strict;
+use warnings;
+use Test::More tests => 12;
+
+my %destroyed;
+
+BEGIN {
+ package CounterObject;
+
+ sub new {
+ my ($class, $name) = @_;
+ return bless { name => $name }, $class;
+ }
+
+ sub name {
+ my ($self) = @_;
+ return $self->{name};
+ }
+
+ sub DESTROY {
+ my ($self) = @_;
+ $destroyed{ $self->name }++;
+ }
+
+
+ package ReplaceCounter;
+ $INC{'ReplaceCounter.pm'} = __FILE__;
+
+ sub import {
+ my ($self, $counter) = @_;
+ ${^COMPILE_SCOPE_CONTAINER}[-1] = CounterObject->new($counter);
+ }
+
+ package InstallCounter;
+ $INC{'InstallCounter.pm'} = __FILE__;
+
+ sub import {
+ my ($class, $counter) = @_;
+ push @{^COMPILE_SCOPE_CONTAINER}, CounterObject->new($counter);
+ }
+
+ package TestCounter;
+ $INC{'TestCounter.pm'} = __FILE__;
+
+ sub import {
+ my ($class, $counter, $number, $message) = @_;
+
+ $number = 1
+ unless defined $number;
+ $message = "counter $counter is found $number times"
+ unless defined $message;
+
+ ::is scalar(grep { $_->name eq $counter } @{^COMPILE_SCOPE_CONTAINER}),
+ $number,
+ $message;
+ }
+}
+
+{
+ use InstallCounter 'root';
+ use InstallCounter '3rd-party';
+
+ {
+ BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
+
+ use ReplaceCounter 'replace';
+
+ BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
+
+ use TestCounter '3rd-party', 0, '3rd-party no longer visible';
+ use TestCounter 'replace', 1, 'replacement now visible';
+ use TestCounter 'root';
+
+ BEGIN { ok(!keys %destroyed, 'nothing destroyed yet'); }
+ }
+
+ BEGIN {
+ ok $destroyed{replace}, 'replacement has been destroyed after end of outer scope';
+ }
+
+ use TestCounter 'root', 1, 'root visible again';
+ use TestCounter 'replace', 0, 'lower replacement no longer visible';
+ use TestCounter '3rd-party';
+}
+
+ok $destroyed{ $_ }, "$_ has been destroyed after end of outer scope"
+ for 'root', '3rd-party';
--
1.6.3.3
Thread Previous
|
Thread Next