Call magic on all elements on %SIG delocalization

Author: Leont

embed.fnc

@@ -1331,6 +1331,7 @@ 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
 p	|int	|magic_setregexp|NN SV* sv|NN MAGIC* mg
+p	|int	|magic_setsigall|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_setsig	|NULLOK SV* sv|NN MAGIC* mg
 p	|int	|magic_setsubstr|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_settaint	|NN SV* sv|NN MAGIC* mg

embed.h

@@ -1388,6 +1388,7 @@
 #define magic_setpos(a,b)	Perl_magic_setpos(aTHX_ a,b)
 #define magic_setregexp(a,b)	Perl_magic_setregexp(aTHX_ a,b)
 #define magic_setsig(a,b)	Perl_magic_setsig(aTHX_ a,b)
+#define magic_setsigall(a,b)	Perl_magic_setsigall(aTHX_ a,b)
 #define magic_setsubstr(a,b)	Perl_magic_setsubstr(aTHX_ a,b)
 #define magic_settaint(a,b)	Perl_magic_settaint(aTHX_ a,b)
 #define magic_setutf8(a,b)	Perl_magic_setutf8(aTHX_ a,b)

mg.c

@@ -1826,6 +1826,24 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 }
 #endif /* !PERL_MICRO */
 
+int
+Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_SETSIGALL;
+    PERL_UNUSED_ARG(mg);
+
+    if (PL_localizing == 2) {
+        HV* hv = (HV*)sv;
+        HE* current;
+        hv_iterinit(hv);
+        while ((current = hv_iternext(hv))) {
+            SV* sigelem = hv_iterval(hv, current);
+            mg_set(sigelem);
+        }
+    }
+    return 0;
+}
+
 int
 Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
 {

mg_raw.h

@@ -62,7 +62,7 @@
       "/* tiedscalar 'q' Tied scalar or handle */" },
     { 'r', "want_vtbl_regexp | PERL_MAGIC_READONLY_ACCEPTABLE | PERL_MAGIC_VALUE_MAGIC",
       "/* qr 'r' Precompiled qr// regex */" },
-    { 'S', "magic_vtable_max",
+    { 'S', "want_vtbl_sig",
       "/* sig 'S' %SIG hash */" },
     { 's', "want_vtbl_sigelem",
       "/* sigelem 's' %SIG hash element */" },

mg_vtable.h

@@ -85,6 +85,7 @@ enum {		/* pass one of these to get_vtbl */
     want_vtbl_regdata,
     want_vtbl_regdatum,
     want_vtbl_regexp,
+    want_vtbl_sig,
     want_vtbl_sigelem,
     want_vtbl_substr,
     want_vtbl_sv,
@@ -122,6 +123,7 @@ EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
     "regdata",
     "regdatum",
     "regexp",
+    "sig",
     "sigelem",
     "substr",
     "sv",
@@ -182,6 +184,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { 0, 0, Perl_magic_regdata_cnt, 0, 0, 0, 0, 0 },
   { Perl_magic_regdatum_get, Perl_magic_regdatum_set, 0, 0, 0, 0, 0, 0 },
   { 0, Perl_magic_setregexp, 0, 0, 0, 0, 0, 0 },
+  { 0, Perl_magic_setsigall, 0, 0, 0, 0, 0, 0 },
 #ifndef PERL_MICRO
   { Perl_magic_getsig, Perl_magic_setsig, 0, Perl_magic_clearsig, 0, 0, 0, 0 },
 #else
@@ -228,6 +231,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 #define PL_vtbl_regdata PL_magic_vtables[want_vtbl_regdata]
 #define PL_vtbl_regdatum PL_magic_vtables[want_vtbl_regdatum]
 #define PL_vtbl_regexp PL_magic_vtables[want_vtbl_regexp]
+#define PL_vtbl_sig PL_magic_vtables[want_vtbl_sig]
 #define PL_vtbl_sigelem PL_magic_vtables[want_vtbl_sigelem]
 #define PL_vtbl_substr PL_magic_vtables[want_vtbl_substr]
 #define PL_vtbl_sv PL_magic_vtables[want_vtbl_sv]

pod/perlguts.pod

@@ -1415,7 +1415,7 @@ will be lost.
  p  PERL_MAGIC_tiedelem       vtbl_packelem  Tied array or hash element
  q  PERL_MAGIC_tiedscalar     vtbl_packelem  Tied scalar or handle
  r  PERL_MAGIC_qr             vtbl_regexp    Precompiled qr// regex
- S  PERL_MAGIC_sig            (none)         %SIG hash
+ S  PERL_MAGIC_sig            vtbl_sig       %SIG hash
  s  PERL_MAGIC_sigelem        vtbl_sigelem   %SIG hash element
  t  PERL_MAGIC_taint          vtbl_taint     Taintedness
  U  PERL_MAGIC_uvar           vtbl_uvar      Available for use by

proto.h

@@ -1998,6 +1998,9 @@ PERL_CALLCONV int	Perl_magic_setregexp(pTHX_ SV* sv, MAGIC* mg);
 PERL_CALLCONV int	Perl_magic_setsig(pTHX_ SV* sv, MAGIC* mg);
 #define PERL_ARGS_ASSERT_MAGIC_SETSIG	\
 	assert(mg)
+PERL_CALLCONV int	Perl_magic_setsigall(pTHX_ SV* sv, MAGIC* mg);
+#define PERL_ARGS_ASSERT_MAGIC_SETSIGALL	\
+	assert(sv); assert(mg)
 PERL_CALLCONV int	Perl_magic_setsubstr(pTHX_ SV* sv, MAGIC* mg);
 #define PERL_ARGS_ASSERT_MAGIC_SETSUBSTR	\
 	assert(sv); assert(mg)

regen/mg_vtable.pl

@@ -168,7 +168,8 @@ BEGIN
                      desc => 'Tied scalar or handle' },
      qr => { char => 'r', vtable => 'regexp', value_magic => 1, 
              readonly_acceptable => 1, desc => 'Precompiled qr// regex' },
-     sig => { char => 'S', desc => '%SIG hash' },
+     sig => { char => 'S', vtable => 'sig',
+		      desc => '%SIG hash' },
      sigelem => { char => 's', vtable => 'sigelem',
                   desc => '%SIG hash element' },
      taint => { char => 't', vtable => 'taint', value_magic => 1,
@@ -251,6 +252,7 @@ BEGIN
      'sv' => {get => 'get', set => 'set'},
      'env' => {set => 'set_all_env', clear => 'clear_all_env'},
      'envelem' => {set => 'setenv', clear => 'clearenv'},
+     'sig' => { set => 'setsigall' },
      'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig',
                    cond => '#ifndef PERL_MICRO'},
      'pack' => {len => 'sizepack', clear => 'wipepack'},

t/op/magic.t

@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     require './test.pl';
     set_up_inc( '../lib' );
-    plan (tests => 196); # some tests are run in BEGIN block
+    plan (tests => 197); # some tests are run in BEGIN block
 }
 
 # Test that defined() returns true for magic variables created on the fly,
@@ -852,6 +852,11 @@ SKIP: {
     }
 }
 
+{
+	local %SIG = (%SIG, ALRM => sub {})
+};
+is $SIG{ALRM}, undef;
+
 # test case-insignificance of %ENV (these tests must be enabled only
 # when perl is compiled with -DENV_IS_CASELESS)
 SKIP: {