develooper Front page | perl.perl5.porters | Postings from January 2003

[perl #20613] Perl_magic_setsig/clearsig problems (patch included)

Thread Previous | Thread Next
From:
Anders Johnson
Date:
January 29, 2003 19:44
Subject:
[perl #20613] Perl_magic_setsig/clearsig problems (patch included)
Message ID:
rt-20613-49896.11.6328062813677@bugs6.perl.org
# New Ticket Created by  "Anders Johnson" 
# Please include the string:  [perl #20613]
# in the subject line of all future correspondence about this issue. 
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=20613 >


I discovered a few problems with setting and clearing %SIG entries in
the Perl 5.8.0 production release (currently the same as the development
release). To wit:
 
+ Deleting a %SIG entry does not restore the default signal/hook
disposition.
+ The previous disposition SV refcount is decremented (possibly
resulting in its deallocation) *before* the new disposition is in place,
and while the handler is in an inconsistent state. If it's a coderef
with closures, then just about anything can happen at that point, which
is bad because DESTROY might need the new handler to be in place.
+ A signal can arrive while it's being dispositioned, which could, for
example, cause the program to terminate immediately while we're
switching from one handler to another.
+ There are a couple of apparently redundant "*svp=0" statements. (I
commented them, but I was too chicken to remove them.)
 
The patch includes a test case for the first 2 items. Here are a couple
of items that I might have screwed up and should be reviewed by a more
experienced Perl hacker:
 
+ The test case uses "$? & 0xFF" to see if the closed pipe exited from a
signal. Is this portable?
+ Is there any way (e.g. exception?) that Perl_magic_setsig() might
escape without restoring the sigprocmask? (If so, we could maybe use the
trick from POSIX::sigaction to get around that.) This could also result
in a memory leak (because "to_dec" would get ignored).
 
Here is the patch:
 
diff -Naur perl-5.8.0/mg.c perl-5.8.0-sig2/mg.c
--- perl-5.8.0/mg.c          Sat Jun 15 13:16:44 2002
+++ perl-5.8.0-sig2/mg.c            Wed Jan 29 13:27:34 2003
@@ -1061,19 +1061,48 @@
 int
 Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
 {
-    I32 i;
+    /* XXX Some of this code was copied from Perl_magic_setsig. A
little
+     * refactoring might be in order.
+     */
+    register char *s;
     STRLEN n_a;
-    /* Are we clearing a signal entry? */
-    i = whichsig(MgPV(mg,n_a));
-    if (i) {
-           if(PL_psig_ptr[i]) {
-               SvREFCNT_dec(PL_psig_ptr[i]);
-               PL_psig_ptr[i]=0;
-           }
-           if(PL_psig_name[i]) {
-               SvREFCNT_dec(PL_psig_name[i]);
-               PL_psig_name[i]=0;
-           }
+    SV* to_dec;
+    s = MgPV(mg,n_a);
+    if (*s == '_') {
+          SV** svp;
+          if (strEQ(s,"__DIE__"))
+              svp = &PL_diehook;
+          else if (strEQ(s,"__WARN__"))
+              svp = &PL_warnhook;
+          else
+              Perl_croak(aTHX_ "No such hook: %s", s);
+          if (*svp) {
+              to_dec = *svp;
+              *svp = 0;
+              SvREFCNT_dec(to_dec);
+          }
+    }
+    else {
+          I32 i;
+          /* Are we clearing a signal entry? */
+          i = whichsig(s);
+          if (i) {
+#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
+              sig_defaulting[i] = 1;
+              (void)rsignal(i, &Perl_csighandler);
+#else
+              (void)rsignal(i, SIG_DFL);
+#endif
+              if(PL_psig_name[i]) {
+                      SvREFCNT_dec(PL_psig_name[i]);
+                      PL_psig_name[i]=0;
+              }
+              if(PL_psig_ptr[i]) {
+                      to_dec=PL_psig_ptr[i];
+                      PL_psig_ptr[i]=0;
+                      SvREFCNT_dec(to_dec);
+              }
+          }
     }
     return 0;
 }
@@ -1156,7 +1185,15 @@
     register char *s;
     I32 i;
     SV** svp = 0;
+    /* Need to be careful with SvREFCNT_dec(), because that can have
side
+     * effects (due to closures). We must make sure that the new
disposition
+     * is in place before it is called.
+     */
+    SV* to_dec = 0;
     STRLEN len;
+#ifdef HAS_SIGPROCMASK
+    sigset_t set, save;
+#endif
 
     s = MgPV(mg,len);
     if (*s == '_') {
@@ -1168,7 +1205,7 @@
                Perl_croak(aTHX_ "No such hook: %s", s);
            i = 0;
            if (*svp) {
-               SvREFCNT_dec(*svp);
+              to_dec = *svp;
                *svp = 0;
            }
     }
@@ -1179,6 +1216,12 @@
                        Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No
such signal: SIG%s", s);
                return 0;
            }
+#ifdef HAS_SIGPROCMASK
+          /* Avoid having the signal arrive at a bad time, if possible.
*/
+          sigemptyset(&set);
+          sigaddset(&set,i);
+          sigprocmask(SIG_BLOCK, &set, &save);
+#endif
 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) ||
defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
            if (!sig_handlers_initted) Perl_csighandler_init();
 #endif
@@ -1189,17 +1232,23 @@
              sig_defaulting[i] = 0;
 #endif
            SvREFCNT_dec(PL_psig_name[i]);
-           SvREFCNT_dec(PL_psig_ptr[i]);
+          to_dec = PL_psig_ptr[i];
            PL_psig_ptr[i] = SvREFCNT_inc(sv);
            SvTEMP_off(sv); /* Make sure it doesn't go away on us */
            PL_psig_name[i] = newSVpvn(s, len);
            SvREADONLY_on(PL_psig_name[i]);
     }
     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
-           if (i)
+          if (i) {
                (void)rsignal(i, &Perl_csighandler);
+#ifdef HAS_SIGPROCMASK
+              sigprocmask(SIG_SETMASK, &save, NULL);
+#endif
+          }
            else
                *svp = SvREFCNT_inc(sv);
+          if(to_dec)
+              SvREFCNT_dec(to_dec);
            return 0;
     }
     s = SvPV_force(sv,len);
@@ -1212,7 +1261,7 @@
                (void)rsignal(i, SIG_IGN);
 #endif
            } else
-               *svp = 0;
+              *svp = 0; /* XXX: Redundant? */
     }
     else if (strEQ(s,"DEFAULT") || !*s) {
            if (i)
@@ -1225,7 +1274,7 @@
                (void)rsignal(i, SIG_DFL);
 #endif
            else
-               *svp = 0;
+              *svp = 0; /* XXX: Redundant? */
     }
     else {
            /*
@@ -1240,6 +1289,12 @@
            else
                *svp = SvREFCNT_inc(sv);
     }
+#ifdef HAS_SIGPROCMASK
+    if(i)
+          sigprocmask(SIG_SETMASK, &save, NULL);
+#endif
+    if(to_dec)
+          SvREFCNT_dec(to_dec);
     return 0;
 }
 #endif /* !PERL_MICRO */
diff -Naur perl-5.8.0/t/op/magic.t perl-5.8.0-sig2/t/op/magic.t
--- perl-5.8.0/t/op/magic.t            Wed Jul 10 17:18:07 2002
+++ perl-5.8.0-sig2/t/op/magic.t  Wed Jan 29 13:00:40 2003
@@ -36,7 +36,7 @@
     return 1;
 }
 
-print "1..46\n";
+print "1..48\n";
 
 $Is_MSWin32 = $^O eq 'MSWin32';
 $Is_NetWare = $^O eq 'NetWare';
@@ -67,7 +67,7 @@
 close FOO; # just mention it, squelch used-only-once
 
 if ($Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE || $Is_MacOS) {
-    skip('SIGINT not safe on this platform') for 1..2;
+    skip('SIGINT not safe on this platform') for 1..4;
 }
 else {
   # the next tests are done in a subprocess because sh spits out a
@@ -98,7 +98,35 @@
 
     close CMDPIPE;
 
-    $test += 2;
+    open( CMDPIPE, "| $PERL");
+    print CMDPIPE <<'END';
+
+    { package X;
+          sub DESTROY {
+              kill "INT",$$;
+          }
+    }
+    sub x {
+          my $x=bless [], 'X';
+          return sub { $x };
+    }
+    $| = 1;                     # command buffering
+    $SIG{"INT"} = "ok5";
+    {
+          local $SIG{"INT"}=x();
+          print ""; # Needed to expose failure in 5.8.0 (why?)
+    }
+    sleep 1;
+    delete $SIG{"INT"};
+    kill "INT",$$; sleep 1;
+    sub ok5 {
+          print "ok 5\n";
+    }
+END
+    close CMDPIPE;
+    print $? & 0xFF ? "ok 6\n" : "not ok 6\n";
+
+    $test += 4;
 }
 
 # can we slice ENV?
 
Here is the output from "perlbug -d":
 
---
Flags:
    category=
    severity=
---
Site configuration information for perl v5.8.0:
 
Configured by anders at Fri Nov 15 12:33:55 PST 2002.
 
Summary of my perl5 (revision 5.0 version 8 subversion 0) configuration:
  Platform:
    osname=linux, osvers=2.4.18, archname=i686-linux
    uname='linux wolf12 2.4.18 #1 mon jul 8 14:56:03 pdt 2002 i686
unknown '
    config_args='-de'
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=undef use5005threads=undef useithreads=undef
usemultiplicity=undef
    useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
    use64bitint=undef use64bitall=undef uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-fno-strict-aliasing -I/usr/local/include
-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -I/usr/include/gdbm',
    optimize='-O2',
    cppflags='-fno-strict-aliasing -I/usr/local/include
-I/usr/include/gdbm'
    ccversion='', gccversion='2.96 20000731 (Red Hat Linux 7.1
2.96-98)', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t',
lseeksize=8
    alignbytes=4, prototype=define
  Linker and Libraries:
    ld='cc', ldflags =' -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib
    libs=-lnsl -lndbm -lgdbm -ldl -lm -lc -lcrypt -lutil
    perllibs=-lnsl -ldl -lm -lc -lcrypt -lutil
    libc=/lib/libc-2.2.4.so, so=so, useshrplib=false, libperl=libperl.a
    gnulibc_version='2.2.4'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'
 
Locally applied patches:
    
 
---
@INC for perl v5.8.0:
    /tools/By-Install/perl/5.8.0/i686-linux2.4/1/lib/5.8.0/i686-linux
    /tools/By-Install/perl/5.8.0/i686-linux2.4/1/lib/5.8.0
    /tools/By-Install/cpan/living/i686-linux2.4/1/lib/cpan/i686-linux
    /tools/By-Install/cpan/living/i686-linux2.4/1/lib/cpan
    /tools/By-Install/cpan/living/i686-linux2.4/1/lib/cpan
    .
 
---
Environment for perl v5.8.0:
    HOME=/home1/anders
    LANG=en_US
    LANGUAGE (unset)
 
LD_LIBRARY_PATH=/opt/cadence/linux/ldv-3.4/tools/lib:/opt/cadence/linux/
ldv-3.4/tools/inca/lib:/usr/local/lib
    LOGDIR (unset)
 
PATH=/home1/anders/bin:/tools/bin:/opt/cadence/linux/ldv-3.4/tools/bin:/
opt/cadence/linux/ldv-3.4/tools/inca/bin:/opt/synopsys/linux/vcs/bin:/op
t/synopsys/linux/vcs/virsimdir/bin:/usr/local/vnc:/opt/synopsys/linux/sc
l/linux/bin:/usr/local/bin:/bin:/usr/bin:/usr/X11R6/bin:.
    PERLDOC_PAGER=less -Cr
    PERL_BADLANG (unset)
    SHELL=/bin/csh
 




Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About