develooper 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


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About