add Perl_magic_freemglob() magic vtable method

S_mg_free_struct() has a workaround to never free mg->mg_ptr for
PERL_MAGIC_regex_global.

Move this logic into a new magic vtable free method instead, so that
S_mg_free_struct() (which gets called for every type of magic) doesn't
have the overhead of checking every time for mg->mg_type ==
PERL_MAGIC_regex_global.

[ No, I don't know why PERL_MAGIC_regex_global's vtable and methods
  are suffixed mglob rather than regex_global or vice versa ]

Author: iabyn

embed.fnc

@@ -1319,6 +1319,7 @@ dp	|int	|magic_sethint	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setisa	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setlvref	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setmglob	|NN SV* sv|NN MAGIC* mg
+p	|int	|magic_freemglob|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setnkeys	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setpack	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setpos	|NN SV* sv|NN MAGIC* mg

embed.h

@@ -1339,6 +1339,7 @@
 #define magic_copycallchecker(a,b,c,d,e)	Perl_magic_copycallchecker(aTHX_ a,b,c,d,e)
 #define magic_existspack(a,b)	Perl_magic_existspack(aTHX_ a,b)
 #define magic_freearylen_p(a,b)	Perl_magic_freearylen_p(aTHX_ a,b)
+#define magic_freemglob(a,b)	Perl_magic_freemglob(aTHX_ a,b)
 #define magic_freeovrld(a,b)	Perl_magic_freeovrld(aTHX_ a,b)
 #define magic_freeutf8(a,b)	Perl_magic_freeutf8(aTHX_ a,b)
 #define magic_get(a,b)		Perl_magic_get(aTHX_ a,b)

mg.c

@@ -554,12 +554,10 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
     if (vtbl && vtbl->svt_free)
 	vtbl->svt_free(aTHX_ sv, mg);
 
-    if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
-	if (mg->mg_len > 0)
-	    Safefree(mg->mg_ptr);
-	else if (mg->mg_len == HEf_SVKEY)
-	    SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
-    }
+    if (mg->mg_len > 0)
+        Safefree(mg->mg_ptr);
+    else if (mg->mg_len == HEf_SVKEY)
+        SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
 
     if (mg->mg_flags & MGf_REFCOUNTED)
 	SvREFCNT_dec(mg->mg_obj);
@@ -2600,6 +2598,23 @@ Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+
+int
+Perl_magic_freemglob(pTHX_ SV *sv, MAGIC *mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_FREEMGLOB;
+    PERL_UNUSED_ARG(sv);
+
+    /* glob magic uses mg_len as a string length rather than a buffer
+     * length, so we need to free even with mg_len == 0: hence we can't
+     * rely on standard magic free handling */
+    assert(mg->mg_type == PERL_MAGIC_regex_global && mg->mg_len >= -1);
+    Safefree(mg->mg_ptr);
+    mg->mg_ptr = NULL;
+    return 0;
+}
+
+
 int
 Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
 {

mg_vtable.h

@@ -172,7 +172,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { 0, Perl_magic_setisa, 0, Perl_magic_clearisa, 0, 0, 0, 0 },
   { 0, Perl_magic_setisa, 0, 0, 0, 0, 0, 0 },
   { 0, Perl_magic_setlvref, 0, 0, 0, 0, 0, 0 },
-  { 0, Perl_magic_setmglob, 0, 0, 0, 0, 0, 0 },
+  { 0, Perl_magic_setmglob, 0, 0, Perl_magic_freemglob, 0, 0, 0 },
   { Perl_magic_getnkeys, Perl_magic_setnkeys, 0, 0, 0, 0, 0, 0 },
   { 0, Perl_magic_setnonelem, 0, 0, 0, 0, 0, 0 },
   { 0, 0, 0, 0, Perl_magic_freeovrld, 0, 0, 0 },

proto.h

@@ -1857,6 +1857,9 @@ PERL_CALLCONV int	Perl_magic_existspack(pTHX_ SV* sv, const MAGIC* mg);
 PERL_CALLCONV int	Perl_magic_freearylen_p(pTHX_ SV* sv, MAGIC* mg);
 #define PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P	\
 	assert(sv); assert(mg)
+PERL_CALLCONV int	Perl_magic_freemglob(pTHX_ SV* sv, MAGIC* mg);
+#define PERL_ARGS_ASSERT_MAGIC_FREEMGLOB	\
+	assert(sv); assert(mg)
 PERL_CALLCONV int	Perl_magic_freeovrld(pTHX_ SV* sv, MAGIC* mg);
 #define PERL_ARGS_ASSERT_MAGIC_FREEOVRLD	\
 	assert(sv); assert(mg)

regen/mg_vtable.pl

@@ -260,7 +260,8 @@ BEGIN
      'isaelem' => {set => 'setisa'},
      'arylen' => {get => 'getarylen', set => 'setarylen', const => 1},
      'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'},
-     'mglob' => {set => 'setmglob'},
+     'mglob'    => {set   => 'setmglob',
+                    free  => 'freemglob' },
      'nkeys' => {get => 'getnkeys', set => 'setnkeys'},
      'taint' => {get => 'gettaint', set => 'settaint'},
      'substr' => {get => 'getsubstr', set => 'setsubstr'},