scope.c - add mortal_destructor_sv() and mortal_destructor_x()

This implements a mortal version of SAVEDESTRUCTOR_X() which executes
at the end of the current statement instead of the end of the current
psuedo block. This requires implementing a mortal SV with free magic
that triggers the destructor behavior.  There is a version for executing
a Perl function or a C function, and relevant additional macros that
correspond to the existing SAVEDESTRUCTOR_X() save SAVEMORTALSV() type
naming convention.  Documentation is provided.

This is cribbed from Leon's Variable-OnDestruct. See:

https://metacpan.org/dist/Variable-OnDestruct/source/lib/Variable/OnDestruct.xs#L6-17

I am very grateful to him for his help on this.

Author: demerphq

embed.fnc

@@ -1808,6 +1808,9 @@ p	|int	|magic_existspack					\
 p	|int	|magic_freearylen_p					\
 				|NN SV *sv				\
 				|NN MAGIC *mg
+p	|int	|magic_freedestruct					\
+				|NN SV *sv				\
+				|NN MAGIC *mg
 p	|int	|magic_freemglob|NN SV *sv				\
 				|NN MAGIC *mg
 p	|int	|magic_freeovrld|NN SV *sv				\
@@ -1970,6 +1973,12 @@ Cop	|void * |more_bodies	|const svtype sv_type			\
 				|const size_t arena_size
 Cp	|const char *|moreswitches					\
 				|NN const char *s
+Ap	|void	|mortal_destructor_sv					\
+				|NN SV *coderef 			\
+				|NULLOK SV *args
+Cp	|void	|mortal_destructor_x					\
+				|DESTRUCTORFUNC_t f			\
+				|NULLOK void *p
 CRTXip	|char * |mortal_getenv	|NN const char *str
 Adop	|const struct mro_alg *|mro_get_from_name			\
 				|NN SV *name

embed.h

@@ -359,6 +359,8 @@
 # define mg_size(a)                             Perl_mg_size(aTHX_ a)
 # define mini_mktime                            Perl_mini_mktime
 # define moreswitches(a)                        Perl_moreswitches(aTHX_ a)
+# define mortal_destructor_sv(a,b)              Perl_mortal_destructor_sv(aTHX_ a,b)
+# define mortal_destructor_x(a,b)               Perl_mortal_destructor_x(aTHX_ a,b)
 # define mortal_getenv                          Perl_mortal_getenv
 # define mro_get_linear_isa(a)                  Perl_mro_get_linear_isa(aTHX_ a)
 # define mro_method_changed_in(a)               Perl_mro_method_changed_in(aTHX_ a)
@@ -961,6 +963,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_freedestruct(a,b)              Perl_magic_freedestruct(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)

mg_names.inc

@@ -44,6 +44,7 @@
 	{ PERL_MAGIC_vstring,        "vstring(V)" },
 	{ PERL_MAGIC_vec,            "vec(v)" },
 	{ PERL_MAGIC_utf8,           "utf8(w)" },
+	{ PERL_MAGIC_destruct,       "destruct(X)" },
 	{ PERL_MAGIC_substr,         "substr(x)" },
 	{ PERL_MAGIC_nonelem,        "nonelem(Y)" },
 	{ PERL_MAGIC_defelem,        "defelem(y)" },

mg_raw.h

@@ -76,6 +76,8 @@
       "/* vec 'v' vec() lvalue */" },
     { 'w', "want_vtbl_utf8 | PERL_MAGIC_VALUE_MAGIC",
       "/* utf8 'w' Cached UTF-8 information */" },
+    { 'X', "want_vtbl_destruct | PERL_MAGIC_VALUE_MAGIC",
+      "/* destruct 'X' destruct callback */" },
     { 'x', "want_vtbl_substr | PERL_MAGIC_VALUE_MAGIC",
       "/* substr 'x' substr() lvalue */" },
     { 'Y', "want_vtbl_nonelem | PERL_MAGIC_VALUE_MAGIC",

mg_vtable.h

@@ -51,6 +51,7 @@
 #define PERL_MAGIC_vstring        'V' /* SV was vstring literal */
 #define PERL_MAGIC_vec            'v' /* vec() lvalue */
 #define PERL_MAGIC_utf8           'w' /* Cached UTF-8 information */
+#define PERL_MAGIC_destruct       'X' /* destruct callback */
 #define PERL_MAGIC_substr         'x' /* substr() lvalue */
 #define PERL_MAGIC_nonelem        'Y' /* Array element that does not exist */
 #define PERL_MAGIC_defelem        'y' /* Shadow "foreach" iterator variable /
@@ -69,6 +70,7 @@ enum {		/* pass one of these to get_vtbl */
     want_vtbl_dbline,
     want_vtbl_debugvar,
     want_vtbl_defelem,
+    want_vtbl_destruct,
     want_vtbl_env,
     want_vtbl_envelem,
     want_vtbl_hints,
@@ -107,6 +109,7 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
     "dbline",
     "debugvar",
     "defelem",
+    "destruct",
     "env",
     "envelem",
     "hints",
@@ -168,6 +171,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { 0, Perl_magic_setdbline, 0, 0, 0, 0, 0, 0 },
   { Perl_magic_getdebugvar, Perl_magic_setdebugvar, 0, 0, 0, 0, 0, 0 },
   { Perl_magic_getdefelem, Perl_magic_setdefelem, 0, 0, 0, 0, 0, 0 },
+  { 0, 0, 0, 0, Perl_magic_freedestruct, 0, 0, 0 },
   { 0, Perl_magic_set_all_env, 0, Perl_magic_clear_all_env, 0, 0, 0, 0 },
   { 0, Perl_magic_setenv, 0, Perl_magic_clearenv, 0, 0, 0, 0 },
   { 0, 0, 0, Perl_magic_clearhints, 0, 0, 0, 0 },
@@ -214,6 +218,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 #define PL_vtbl_dbline PL_magic_vtables[want_vtbl_dbline]
 #define PL_vtbl_debugvar PL_magic_vtables[want_vtbl_debugvar]
 #define PL_vtbl_defelem PL_magic_vtables[want_vtbl_defelem]
+#define PL_vtbl_destruct PL_magic_vtables[want_vtbl_destruct]
 #define PL_vtbl_env PL_magic_vtables[want_vtbl_env]
 #define PL_vtbl_envelem PL_magic_vtables[want_vtbl_envelem]
 #define PL_vtbl_fm PL_magic_vtables[want_vtbl_fm]

pod/perldiag.pod

@@ -832,6 +832,14 @@ a C<given> block.  You probably meant to use C<next> or C<last>.
 
 (F) You called C<break>, but you're not inside a C<given> block.
 
+=item Can't call destructor for 0x%p in global destruction
+
+(S) This should not happen. Internals code has set up a destructor
+using C<mortal_destructor_sv> or C<mortal_destructor_x> which is firing
+during global destruction. Please attempt to reduce the code that triggers
+this warning down to a small an example as possible and then report the
+problem to L<https://github.com/Perl/perl5/issues/new/choose>
+
 =item Can't call method "%s" on an undefined value
 
 (F) You used the syntax of a method call, but the slot filled by the

pod/perlguts.pod

@@ -1510,17 +1510,17 @@ will be lost.
                                              tables
  <  PERL_MAGIC_backref        vtbl_backref   For weak ref data
  @  PERL_MAGIC_arylen_p       (none)         To move arylen out of XPVAV
- B  PERL_MAGIC_bm             vtbl_regexp    Boyer-Moore 
+ B  PERL_MAGIC_bm             vtbl_regexp    Boyer-Moore
                                              (fast string search)
- c  PERL_MAGIC_overload_table vtbl_ovrld     Holds overload table 
+ c  PERL_MAGIC_overload_table vtbl_ovrld     Holds overload table
                                              (AMT) on stash
- D  PERL_MAGIC_regdata        vtbl_regdata   Regex match position data 
+ D  PERL_MAGIC_regdata        vtbl_regdata   Regex match position data
                                              (@+ and @- vars)
  d  PERL_MAGIC_regdatum       vtbl_regdatum  Regex match position data
                                              element
  E  PERL_MAGIC_env            vtbl_env       %ENV hash
  e  PERL_MAGIC_envelem        vtbl_envelem   %ENV hash element
- f  PERL_MAGIC_fm             vtbl_regexp    Formline 
+ f  PERL_MAGIC_fm             vtbl_regexp    Formline
                                              ('compiled' format)
  g  PERL_MAGIC_regex_global   vtbl_mglob     m//g target
  H  PERL_MAGIC_hints          vtbl_hints     %^H hash
@@ -1548,6 +1548,7 @@ will be lost.
  V  PERL_MAGIC_vstring        (none)         SV was vstring literal
  v  PERL_MAGIC_vec            vtbl_vec       vec() lvalue
  w  PERL_MAGIC_utf8           vtbl_utf8      Cached UTF-8 information
+ X  PERL_MAGIC_destruct       vtbl_destruct  destruct callback
  x  PERL_MAGIC_substr         vtbl_substr    substr() lvalue
  Y  PERL_MAGIC_nonelem        vtbl_nonelem   Array element that does not
                                              exist
@@ -1575,6 +1576,7 @@ will be lost.
 =for apidoc_item ||PERL_MAGIC_dbline
 =for apidoc_item ||PERL_MAGIC_debugvar
 =for apidoc_item ||PERL_MAGIC_defelem
+=for apidoc_item ||PERL_MAGIC_destruct
 =for apidoc_item ||PERL_MAGIC_env
 =for apidoc_item ||PERL_MAGIC_envelem
 =for apidoc_item ||PERL_MAGIC_ext
@@ -1978,19 +1980,49 @@ this:
 =item C<SAVEDESTRUCTOR(DESTRUCTORFUNC_NOCONTEXT_t f, void *p)>
 
 At the end of I<pseudo-block> the function C<f> is called with the
-only argument C<p>.
+only argument C<p> which may be NULL.
 
 =for apidoc Ayh||DESTRUCTORFUNC_NOCONTEXT_t
 =for apidoc Amh||SAVEDESTRUCTOR|DESTRUCTORFUNC_NOCONTEXT_t f|void *p
 
 =item C<SAVEDESTRUCTOR_X(DESTRUCTORFUNC_t f, void *p)>
 
 At the end of I<pseudo-block> the function C<f> is called with the
-implicit context argument (if any), and C<p>.
+implicit context argument (if any), and C<p> which may be NULL.
+
+Note the I<end of the current pseudo-block> may occur much later than
+the the I<end of the current statement>. You may wish to look at the
+C<SAVEMORTALDESTRUCTOR_X()> macro instead.
 
 =for apidoc Ayh||DESTRUCTORFUNC_t
 =for apidoc Amh||SAVEDESTRUCTOR_X|DESTRUCTORFUNC_t f|void *p
 
+=item C<SAVEMORTALDESTRUCTOR_X(DESTRUCTORFUNC_t f, void *p)>
+
+At the end of I<the current statement> the function C<f> is called with
+the implicit context argument (if any), and C<p> which may be NULL.
+
+Note the I<end of the current statement> may occur much before the
+the I<end of the current pseudo-block>.  You may wish to look at the
+C<SAVEDESTRUCTOR_X()> macro instead.
+
+=for apidoc Amh||SAVEMORTALDESTRUCTOR_X|DESTRUCTORFUNC_t f|void *p
+
+=item C<SAVEMORTALDESTRUCTOR_SV(SV *coderef, SV *args)>
+
+At the end of I<the current statement> the Perl function contained in
+C<coderef> is called with the arguments provided (if any) in C<args>.
+See the documentation for C<mortal_destructor_sv()> for details on
+the C<args> parameter is handled.
+
+Note the I<end of the current statement> may occur much before the
+the I<end of the current pseudo-block>.  If you wish to call a perl
+function at the end of the current pseudo block you should use the
+C<SAVEDESTRUCTOR_X()> API instead, which will require you create a
+C wrapper to call the Perl function.
+
+=for apidoc Amh||SAVEMORTALDESTRUCTOR_X|DESTRUCTORFUNC_t f|void *p
+
 =item C<SAVESTACK_POS()>
 
 The current offset on the Perl internal stack (cf. C<SP>) is restored

proto.h

@@ -212,6 +212,12 @@ BEGIN
                    vtable => 'debugvar' },
      lvref => { char => '\\', vtable => 'lvref',
                   desc => "Lvalue reference constructor" },
+     destruct => {
+        char        => "X",
+        vtable      => 'destruct',
+        desc        => "destruct callback",
+        value_magic => 1,
+     },
 );
 
 
@@ -288,6 +294,7 @@ BEGIN
      'checkcall' => {copy => 'copycallchecker'},
      'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
      'lvref' => {set => 'setlvref'},
+     'destruct' => {free => 'freedestruct'},
 );
 
 
@@ -428,6 +435,7 @@ BEGIN
                     ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g
                 }
             }
+            s/\s+\z// for $desc, @cont;
             printf $format, $type, $vtbl, $desc;
             printf $format, '', '', $_ foreach @cont;
         }