In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/d2f13afb5844a212a93826c15ebfd8f309693cdb?hp=a21a75c8b50f9fa1a0642bac43a6e51ed8083f0f>
- Log ----------------------------------------------------------------- commit d2f13afb5844a212a93826c15ebfd8f309693cdb Author: Father Chrysostomos <[email protected]> Date: Tue Dec 11 05:33:36 2012 -0800 Glob.xs: PL_opfreehook is an interpreter variable Hence, there is no need to lock a mutex; also storing the old value in a C static is bad. It needs to be in a spot local to the current interpreter, which MY_CXT provides. M ext/File-Glob/Glob.xs commit 7fddb138e6bbaa0efbb2096d3d3cc5a0ee34d546 Author: Father Chrysostomos <[email protected]> Date: Mon Dec 10 16:43:12 2012 -0800 DosGlob: Donât leak when callerâs op tree is freed File::DosGlob keeps its own hash of arrays of file names. Each array corresponds to one call site. When iteration finishes, it deletes the array. But if iteration never finishes, and the op at the call site is freed, the array remains. So eval "scalar<*>" will cause a memory leak under the scope of âuse File::DosGlob "glob"â. We already have a mechanism for hooking the freeing of ops. So File::DosGlob can use that. This is similar to 11ddfebc6e which fixed up File::Glob, but that com- mit mistakenly used a C static for storing the old hook, even though PL_opfreehook is an interpreter variable, not a global. (The next commit will fix that.) M ext/File-DosGlob/DosGlob.xs M ext/File-DosGlob/lib/File/DosGlob.pm M ext/File-DosGlob/t/DosGlob.t ----------------------------------------------------------------------- Summary of changes: ext/File-DosGlob/DosGlob.xs | 29 +++++++++++++++++++++++++++++ ext/File-DosGlob/lib/File/DosGlob.pm | 2 +- ext/File-DosGlob/t/DosGlob.t | 20 +++++++++++++++++++- ext/File-Glob/Glob.xs | 11 ++++------- 4 files changed, 53 insertions(+), 9 deletions(-) diff --git a/ext/File-DosGlob/DosGlob.xs b/ext/File-DosGlob/DosGlob.xs index b8a0612..ce59830 100644 --- a/ext/File-DosGlob/DosGlob.xs +++ b/ext/File-DosGlob/DosGlob.xs @@ -4,10 +4,39 @@ #include "perl.h" #include "XSUB.h" +#define MY_CXT_KEY "File::Glob::_guts" XS_VERSION + +typedef struct { + HV * x_DG_ENTRIES; + Perl_ophook_t x_DG_OLD_OPHOOK; +} my_cxt_t; + +START_MY_CXT + +static void +glob_ophook(pTHX_ OP *o) +{ + dMY_CXT; + if (!MY_CXT.x_DG_ENTRIES) + MY_CXT.x_DG_ENTRIES = get_hv("File::DosGlob::entries", 0); + if (MY_CXT.x_DG_ENTRIES) + hv_delete(MY_CXT.x_DG_ENTRIES, (char *)&o, sizeof(OP *),G_DISCARD); + if (MY_CXT.x_DG_OLD_OPHOOK) MY_CXT.x_DG_OLD_OPHOOK(aTHX_ o); +} + MODULE = File::DosGlob PACKAGE = File::DosGlob PROTOTYPES: DISABLE +BOOT: + MY_CXT_INIT; + { + dMY_CXT; + MY_CXT.x_DG_ENTRIES = NULL; + MY_CXT.x_DG_OLD_OPHOOK = PL_opfreehook; + PL_opfreehook = glob_ophook; + } + SV * _callsite(...) CODE: diff --git a/ext/File-DosGlob/lib/File/DosGlob.pm b/ext/File-DosGlob/lib/File/DosGlob.pm index 792944b..8a85d04 100644 --- a/ext/File-DosGlob/lib/File/DosGlob.pm +++ b/ext/File-DosGlob/lib/File/DosGlob.pm @@ -103,7 +103,7 @@ sub doglob { # # context (keyed by second cxix arg provided by core) -my %entries; +our %entries; sub glob { my($pat,$cxix) = ($_[0], _callsite()); diff --git a/ext/File-DosGlob/t/DosGlob.t b/ext/File-DosGlob/t/DosGlob.t index 1e4f7f3..b3302b8 100644 --- a/ext/File-DosGlob/t/DosGlob.t +++ b/ext/File-DosGlob/t/DosGlob.t @@ -14,7 +14,7 @@ BEGIN { @INC = '../lib'; } -use Test::More tests => 20; +use Test::More tests => 21; # override it in main:: use File::DosGlob 'glob'; @@ -135,3 +135,21 @@ if ($cwd =~ /^([a-zA-Z]:)/) { } else { pass(); } + +# Test that our internal data are freed when the callerâs op tree is freed, +# even if iteration has not finished. +# Using XS::APItest is the only simple way to test this. Since this is a +# core-only module, this should be OK. +SKIP: { + require Config; + skip "no XS::APItest" + unless eval { require XS::APItest; import XS::APItest "sv_count"; 1 }; + # Use a random number of ops, so that the glob op does not reuse the + # same address each time, giving us false passes. + my($count,$count2); + eval '$x+'x(rand() * 100) . '<*>'; + $count = sv_count(); + eval '$x+'x(rand() * 100) . '<*>'; + $count2 = sv_count(); + is $count2, $count, 'no leak when partly iterated caller is freed'; +} diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs index 4c08776..ea8930c 100644 --- a/ext/File-Glob/Glob.xs +++ b/ext/File-Glob/Glob.xs @@ -11,6 +11,7 @@ typedef struct { int x_GLOB_ERROR; HV * x_GLOB_ENTRIES; + Perl_ophook_t x_GLOB_OLD_OPHOOK; } my_cxt_t; START_MY_CXT @@ -312,8 +313,6 @@ doglob_iter_wrapper(pTHX_ AV *entries, SV *patsv) return FALSE; } -static Perl_ophook_t old_ophook; - static void glob_ophook(pTHX_ OP *o) { @@ -322,7 +321,7 @@ glob_ophook(pTHX_ OP *o) && (o->op_type == OP_GLOB || o->op_type == OP_ENTERSUB)) hv_delete(MY_CXT.x_GLOB_ENTRIES, (char *)&o, sizeof(OP *), G_DISCARD); - if (old_ophook) old_ophook(aTHX_ o); + if (MY_CXT.x_GLOB_OLD_OPHOOK) MY_CXT.x_GLOB_OLD_OPHOOK(aTHX_ o); } MODULE = File::Glob PACKAGE = File::Glob @@ -397,11 +396,9 @@ BOOT: { dMY_CXT; MY_CXT.x_GLOB_ENTRIES = NULL; + MY_CXT.x_GLOB_OLD_OPHOOK = PL_opfreehook; + PL_opfreehook = glob_ophook; } - OP_REFCNT_LOCK; - old_ophook = PL_opfreehook; - PL_opfreehook = glob_ophook; - OP_REFCNT_UNLOCK; } INCLUDE: const-xs.inc -- Perl5 Master Repository
