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.)

3 files changed, 49 insertions, 2 deletions

diff --git a/ext/File-DosGlob/DosGlob.xs b/ext/File-DosGlob/DosGlob.xs
index b8a061255f..ce59830831 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 792944b045..8a85d04796 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 1e4f7f3dab..b3302b8390 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';
+}