New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Perl doesn't support RAII, part 1 [patch included] #7556
Comments
From ajohnson@nvidia.comCreated by ajohnson@nvidia.comThis is a bug report for perl from ajohnson@nvidia.com, ----------------------------------------------------------------- The behavior of Perl when a DESTROY method dies is non-obvious and It also prevents doing RAII in Perl. (Over the past few years, I have The following patch should address the documentation problem: Inline Patchdiff -Naur perl-5.9.1/AUTHORS perl-5.9.1-destroydoc/AUTHORS
--- perl-5.9.1/AUTHORS Thu Feb 26 07:26:02 2004
+++ perl-5.9.1-destroydoc/AUTHORS Fri Oct 22 14:53:05 2004
@@ -42,7 +42,7 @@
Alain Barbet <alian@cpan.org>
Ambrose Kofi Laing
Ananth Kesari <HYanantha@novell.com>
-Anders Jonhson
+Anders Johnson <anders@ieee.org>
Andreas Klussmann <andreas@infosys.heitec.de>
Andreas König <a.koenig@mind.de>
Andreas Schwab <schwab@suse.de>
diff -Naur perl-5.9.1/pod/perlobj.pod perl-5.9.1-destroydoc/pod/perlobj.pod
--- perl-5.9.1/pod/perlobj.pod Fri Feb 20 07:30:57 2004
+++ perl-5.9.1-destroydoc/pod/perlobj.pod Fri Oct 22 14:27:44 2004
@@ -455,6 +455,51 @@
when the current object is freed, provided no other references to them exist
elsewhere.
+=head2 Destructors that Die
+
+If the DESTROY method dies, then the error is caught in the perl core where
+the method was called.
+The message is prefixed with the string "\t(in cleanup)", and if C<$^W> is set,
+then it is printed to STDERR.
+The message is then appended to the existing value of $@, if any.
+This is usually a good thing, because there may be some other error that
+caused the object to go out of scope to begin with, and it would be bad to
+discard either that error or the destructor error.
+
+Although reporting the errors in the order that they occurred is intuitive,
+modifying $@ during the propagation of the error can interfere with code that
+attempts to catch the original error outside an eval (especially if $@
+originally contains a reference, in which case the reference is discarded
+completely when the destructor error is appended.)
+For this reason, it is usually best for the DESTROY method to promise never
+to die at all, and furthermore not to spoil $@, $!, $^E and $?:
+
+ sub DESTROY {
+ my $self = shift;
+ # Without the 'local', the DESTROY error is printed twice,
+ # the first error is lost, and the exit status is wrong.
+ local ($@, $!, $^E, $?);
+ eval {
+ $! = 1;
+ die "failed because $!";
+ };
+ warn "Destroying $self: $@" if $@;
+ }
+
+ eval {
+ my $a = bless [];
+ $! = 2;
+ die "Oops!";
+ };
+ die if $@;
+
+An unfortunate side-effect of catching errors in destructors is that
+a signal handler that dies won't necessarily terminate the program, because
+it might get called within a destructor.
+This effectively prevents use of the RAII (resource acquisition is
+initialization) idiom if you want the program to reliably deallocate the
+resources represented by objects after a signal arrives.
+
=head2 Summary
That's about all there is to it. Now you need just to go off and buy a Perl Info
|
From ajohnson@nvidia.comCreated by ajohnson@nvidia.comThis is a bug report for perl from ajohnson@nvidia.com, ----------------------------------------------------------------- Perl doesn't support (I can't figure out a way to do) RAII. The OO way to do this is to have every outstanding resource represented Also, it should be possible to respond to a signal by jumping out to the This patch addresses the problem by adding a new special variable to the Inline Patchdiff -Naur perl-5.9.1/AUTHORS perl-5.9.1-blocksigs/AUTHORS
--- perl-5.9.1/AUTHORS Thu Feb 26 07:26:02 2004
+++ perl-5.9.1-blocksigs/AUTHORS Fri Oct 22 14:53:01 2004
@@ -42,7 +42,7 @@
Alain Barbet <alian@cpan.org>
Ambrose Kofi Laing
Ananth Kesari <HYanantha@novell.com>
-Anders Jonhson
+Anders Johnson <anders@ieee.org>
Andreas Klussmann <andreas@infosys.heitec.de>
Andreas König <a.koenig@mind.de>
Andreas Schwab <schwab@suse.de>
diff -Naur perl-5.9.1/embedvar.h perl-5.9.1-blocksigs/embedvar.h
--- perl-5.9.1/embedvar.h Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-blocksigs/embedvar.h Tue Oct 19 15:17:58 2004
@@ -378,6 +378,7 @@
#define PL_sh_path_compat (vTHX->Ish_path_compat)
#define PL_sharehook (vTHX->Isharehook)
#define PL_sig_pending (vTHX->Isig_pending)
+#define PL_sig_blocked (vTHX->Isig_blocked)
#define PL_sighandlerp (vTHX->Isighandlerp)
#define PL_signals (vTHX->Isignals)
#define PL_sort_RealCmp (vTHX->Isort_RealCmp)
@@ -679,6 +680,7 @@
#define PL_Ish_path_compat PL_sh_path_compat
#define PL_Isharehook PL_sharehook
#define PL_Isig_pending PL_sig_pending
+#define PL_Isig_blocked PL_sig_blocked
#define PL_Isighandlerp PL_sighandlerp
#define PL_Isignals PL_signals
#define PL_Isort_RealCmp PL_sort_RealCmp
diff -Naur perl-5.9.1/gv.c perl-5.9.1-blocksigs/gv.c
--- perl-5.9.1/gv.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-blocksigs/gv.c Tue Oct 19 15:19:41 2004
@@ -963,6 +963,7 @@
case '\011': /* $^I, NOT \t in EBCDIC */
case '\016': /* $^N */
case '\020': /* $^P */
+ case '\002': /* $^B */
if (len > 1)
break;
goto magicalize;
@@ -1882,6 +1883,7 @@
case '\020': /* $^P */
case '\023': /* $^S */
case '\026': /* $^V */
+ case '\002': /* $^B */
if (len == 1)
goto yes;
break;
diff -Naur perl-5.9.1/intrpvar.h perl-5.9.1-blocksigs/intrpvar.h
--- perl-5.9.1/intrpvar.h Sun Feb 29 14:26:05 2004
+++ perl-5.9.1-blocksigs/intrpvar.h Tue Oct 19 15:18:32 2004
@@ -441,7 +441,8 @@
/* 5.6.0 stopped here */
PERLVAR(Ipsig_pend, int *) /* per-signal "count" of pending */
-PERLVARI(Isig_pending, int,0) /* Number if highest signal pending */
+PERLVARI(Isig_pending, int,0) /* Nonzero if any signal pending */
+PERLVARI(Isig_blocked, int,0) /* Nonzero if signals blocked */
#ifdef USE_LOCALE_NUMERIC
diff -Naur perl-5.9.1/lib/English.pm perl-5.9.1-blocksigs/lib/English.pm
--- perl-5.9.1/lib/English.pm Fri Feb 20 07:26:54 2004
+++ perl-5.9.1-blocksigs/lib/English.pm Fri Oct 22 11:33:55 2004
@@ -219,6 +219,7 @@
*WARNING = *^W ;
*EXECUTABLE_NAME = *^X ;
*OSNAME = *^O ;
+ *BLOCK_SIGNAL_HANDLERS = *^B ;
# Deprecated.
diff -Naur perl-5.9.1/mg.c perl-5.9.1-blocksigs/mg.c
--- perl-5.9.1/mg.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-blocksigs/mg.c Tue Oct 19 15:19:25 2004
@@ -683,6 +683,9 @@
? (PL_taint_warn || PL_unsafe ? -1 : 1)
: 0);
break;
+ case '\002': /* ^B */
+ sv_setiv(sv, PL_sig_blocked);
+ break;
case '\025': /* $^UNICODE */
if (strEQ(mg->mg_ptr, "\025NICODE"))
sv_setuv(sv, (UV) PL_unicode);
@@ -1175,11 +1178,15 @@
if(PL_psig_ptr[i]) {
to_dec=PL_psig_ptr[i];
PL_psig_ptr[i]=0;
+#ifdef HAS_SIGPROCMASK
LEAVE;
+#endif
SvREFCNT_dec(to_dec);
}
+#ifdef HAS_SIGPROCMASK
else
LEAVE;
+#endif
}
}
return 0;
@@ -2122,6 +2129,9 @@
PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
#endif
break;
+ case '\002': /* ^B */
+ PL_sig_blocked = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ break;
case '\027': /* ^W & $^WARNING_BITS */
if (*(mg->mg_ptr+1) == '\0') {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
diff -Naur perl-5.9.1/perl.h perl-5.9.1-blocksigs/perl.h
--- perl-5.9.1/perl.h Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-blocksigs/perl.h Tue Oct 19 19:24:57 2004
@@ -4007,7 +4007,12 @@
#ifndef PERL_MICRO
# ifndef PERL_ASYNC_CHECK
-# define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+ /*
+ * XXX: This is used often enough that it might improve
+ * performance noticably to cache a copy of
+ * PL_sig_pending && !PL_sig_blocked
+ */
+# define PERL_ASYNC_CHECK() if (PL_sig_pending && !PL_sig_blocked) despatch_signals()
# endif
#endif
diff -Naur perl-5.9.1/pod/perlipc.pod perl-5.9.1-blocksigs/pod/perlipc.pod
--- perl-5.9.1/pod/perlipc.pod Fri Feb 20 07:30:51 2004
+++ perl-5.9.1-blocksigs/pod/perlipc.pod Fri Oct 22 11:30:57 2004
@@ -388,7 +388,7 @@
"loop". In future Perl's signal mechanism may be changed to avoid this
- perhaps by simply disallowing %SIG handlers on signals of that
type. Until then the work-round is not to set a %SIG handler on those
-signals. (Which signals they are is operating system dependant.)
+signals. (Which signals they are is operating system dependent.)
=item Signals triggered by operating system state
@@ -407,6 +407,77 @@
memory corruption, set the environment variable C<PERL_SIGNALS> to
C<"unsafe"> (a new feature since Perl 5.8.1).
+=head1 Using $^B to Block Signals
+
+As of Perl 5.9.2, you can set C<$^B> to block trapped signals completely if
+safe signals are in use.
+This is obviously dangerous, so you should do this only locally
+inside a block that will be exited within a reasonable period of time.
+
+For example, you can use it to implement a critical section so that
+signal handlers always see a self-consistent program state:
+
+ my ($a, $b) = (2, 3);
+ $SIG{HUP} = sub { die unless $a + $b == 5 };
+ {
+ local $^B = 1;
+ $a++;
+ # A signal won't be handled here.
+ $b--;
+ }
+
+Since C<$^B> is set automatically before calling the DESTROY method of
+an object whose package has $BLOCK_SIGNALS_IN_DESTROY set, you can
+reliably convert signals to exceptions, because the signal won't arrive
+in a destructor, from which exceptions are caught by the perl core.
+(See L<perlobj/"Destructors that Die">).
+
+Typically, you would do something like this in your main program:
+
+ sub catch { die "SIG$_[0]\n" }
+ eval {
+ # Signals that otherwise would cause the process to
+ # terminate immediately *without* a core dump. If a core
+ # dump is left behind for debugging, then you probably
+ # want to leave resources behind for debugging too.
+ local (
+ $SIG{HUP}, $SIG{INT}, $SIG{PIPE}, $SIG{ALRM},
+ $SIG{TERM}, $SIG{USR1}, $SIG{USR2}
+ ) = (\&catch) x 7;
+
+ # Now do what you want to do. Each resource to
+ # deallocate is represented by an object whose DESTROY
+ # method deallocates it.
+ };
+ if($@) {
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ die; # or 'die $@;' if you don't like "...propagated at"
+ }
+
+And your DESTROY methods would look like this:
+
+ BEGIN { $BLOCK_SIGNALS_IN_DESTROY = 1 }
+ sub DESTROY {
+ local ($@, $!, $?);
+
+ # Actions that can't die and won't be interrupted go here.
+
+ eval {
+ local $^B = 0;
+
+ # Actions that can die or may be interrupted go here.
+ };
+ warn "Failed to destroy $_[0] because $@" if $@;
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ }
+
+The main advantage of converting signals to exceptions is that it allows
+the program a chance to clean up resources allocated to the process, such
+as temporary files, that the operating system doesn't deallocate
+automatically when the program terminates.
+This is commonly known as the RAII (resource allocation is initialization)
+idiom.
+
=head1 Using open() for IPC
Perl's basic open() statement can also be used for unidirectional
diff -Naur perl-5.9.1/pod/perlobj.pod perl-5.9.1-blocksigs/pod/perlobj.pod
--- perl-5.9.1/pod/perlobj.pod Fri Feb 20 07:30:57 2004
+++ perl-5.9.1-blocksigs/pod/perlobj.pod Fri Oct 22 14:28:03 2004
@@ -455,6 +455,49 @@
when the current object is freed, provided no other references to them exist
elsewhere.
+=head2 Destructors that Die
+
+If the DESTROY method dies, then the error is caught in the perl core where
+the method was called.
+The message is prefixed with the string "\t(in cleanup)", and if C<$^W> is set,
+then it is printed to STDERR.
+The message is then appended to the existing value of $@, if any.
+This is usually a good thing, because there may be some other error that
+caused the object to go out of scope to begin with, and it would be bad to
+discard either that error or the destructor error.
+
+Although reporting the errors in the order that they occurred is intuitive,
+modifying $@ during the propagation of the error can interfere with code that
+attempts to catch the original error outside an eval (especially if $@
+originally contains a reference, in which case the reference is discarded
+completely when the destructor error is appended.)
+For this reason, it is usually best for the DESTROY method to promise never
+to die at all, and furthermore not to spoil $@, $!, $^E and $?:
+
+ sub DESTROY {
+ my $self = shift;
+ # Without the 'local', the DESTROY error is printed twice,
+ # the first error is lost, and the exit status is wrong.
+ local ($@, $!, $^E, $?);
+ eval {
+ $! = 1;
+ die "failed because $!";
+ };
+ warn "Destroying $self: $@" if $@;
+ }
+
+ eval {
+ my $a = bless [];
+ $! = 2;
+ die "Oops!";
+ };
+ die if $@;
+
+An unfortunate side-effect of catching errors in destructors is that
+a signal handler that dies won't terminate the program if gets called
+within a destructor.
+See L<perlipc/"Using $^B to Block Signals"> for a way to avoid that.
+
=head2 Summary
That's about all there is to it. Now you need just to go off and buy a
diff -Naur perl-5.9.1/pod/perlvar.pod perl-5.9.1-blocksigs/pod/perlvar.pod
--- perl-5.9.1/pod/perlvar.pod Fri Feb 20 07:31:27 2004
+++ perl-5.9.1-blocksigs/pod/perlvar.pod Fri Oct 22 11:28:14 2004
@@ -1221,6 +1221,23 @@
{$secure_perl_path .= $Config{_exe}
unless $secure_perl_path =~ m/$Config{_exe}$/i;}
+=item $BLOCK_SIGNAL_HANDLERS
+
+=item $^B
+
+If set to a nonzero integer, then don't sample signals that are
+dispositioned to a handler.
+Signals are still accumulated.
+Has no effect if unsafe signals are in use
+(see L<perlipc/"Deferred Signals (Safe Signals)">).
+
+This can be used to block all such signals without the overhead of a system call.
+It is automatically set locally before calling the DESTROY method of an object
+that is going out of scope, but only if the object's package has
+$BLOCK_SIGNALS_IN_DESTROY set.
+
+See L<perlipc/"Using $^B to Block Signals">.
+
=item ARGV
The special filehandle that iterates over command-line filenames in
diff -Naur perl-5.9.1/sv.c perl-5.9.1-blocksigs/sv.c
--- perl-5.9.1/sv.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-blocksigs/sv.c Wed Oct 20 10:48:21 2004
@@ -5376,6 +5376,12 @@
=cut
*/
+static void
+restore_sig_blocked(pTHX_ SV *save_sv)
+{
+ PL_sig_blocked = SvIV( save_sv );
+}
+
void
Perl_sv_clear(pTHX_ register SV *sv)
{
@@ -5394,9 +5400,26 @@
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
+ /*
+ * XXX: Maybe we should look in the package containing
+ * the DESTROY method, instead of the object's package.
+ */
+ GV** gvp = (GV**)hv_fetch(stash, "BLOCK_SIGNALS_IN_DESTROY", 24, FALSE);
+ SV* block_sig_class = (gvp && *gvp != (GV*)&PL_sv_undef) ? GvSV(*gvp) : Nullsv;
SV* tmpref = newRV(sv);
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
ENTER;
+ /*
+ * XXX: There probably ought to be some way to globally
+ * opt for this to default active
+ * ('block_sig_class == Nullsv || SvTRUE(block_sig_class').
+ */
+ if(SvTRUE(block_sig_class)) {
+ SV* save_sv = newSViv(PL_sig_blocked);
+ SAVEFREESV(save_sv);
+ SAVEDESTRUCTOR_X(restore_sig_blocked, save_sv);
+ PL_sig_blocked = 1;
+ }
PUSHSTACKi(PERLSI_DESTROY);
EXTEND(SP, 2);
PUSHMARK(SP);
diff -Naur perl-5.9.1/t/op/blocksig.t perl-5.9.1-blocksigs/t/op/blocksig.t
--- perl-5.9.1/t/op/blocksig.t Wed Dec 31 16:00:00 1969
+++ perl-5.9.1-blocksigs/t/op/blocksig.t Fri Oct 22 14:26:43 2004
@@ -0,0 +1,120 @@
+#!./perl
+
+use strict;
+BEGIN { $^W = 1 }
+
+BEGIN {
+ $| = 1;
+ chdir 't' if -d 't';
+ $SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
+}
+
+print "1..22\n";
+
+my ($a, $b) = (2, 3);
+my $c;
+$SIG{INT} = sub { $c = ($a + $b == 5); };
+
+if(defined($^B) && !$^B) {print "ok 1\n";} else {print "not ok 1\n";}
+
+{
+ # Check basic critical section
+ local $^B = 1;
+ $a++;
+ kill "INT", $$;
+ $b--;
+ if($^B) {print "ok 2\n";} else {print "not ok 2\n";}
+}
+
+if(defined($^B) && !$^B) {print "ok 3\n";} else {print "not ok 3\n";}
+if(defined $c) {print "ok 4\n";} else {print "not ok 4\n";}
+if($c) {print "ok 5\n";} else {print "not ok 5\n";}
+
+our $BLOCK_SIGNALS_IN_DESTROY = 1;
+my $testnum = 6;
+sub DESTROY {
+ my $ok = $^B;
+ $ok = !$ok if $testnum == 10;
+ if($ok) {print "ok $testnum\n";} else {print "not ok $testnum\n";}
+ kill "INT", $$;
+ $b--;
+}
+
+# Check that $^B is set in destructor if $BLOCK_SIGNALS_IN_DESTROY
+{
+ my $obj = bless [];
+ $a++;
+ undef $c;
+ # DESTROY gets called here
+}
+if(defined($^B) && !$^B) {print "ok 7\n";} else {print "not ok 7\n";}
+if(defined $c) {print "ok 8\n";} else {print "not ok 8\n";}
+if($c) {print "ok 9\n";} else {print "not ok 9\n";}
+
+# Check that $^B is *not* set in destructor unless $BLOCK_SIGNALS_IN_DESTROY
+$BLOCK_SIGNALS_IN_DESTROY = 0;
+{
+ my $obj = bless [];
+ $a++;
+ undef $c;
+ $testnum = 10;
+ # DESTROY gets called here
+}
+if(defined $c) {print "ok 11\n";} else {print "not ok 11\n";}
+if(!$c) {print "ok 12\n";} else {print "not ok 12\n";}
+
+# Check that $^B is reset in this scope
+undef $c;
+kill "INT", $$;
+if($c) {print "ok 13\n";} else {print "not ok 13\n";}
+
+# Check the typical RAII behavior
+{ package Class;
+
+ our $BLOCK_SIGNALS_IN_DESTROY = 1;
+ sub DESTROY {
+ local($@, $!, $^E, $?);
+ kill "INT", $$;
+ my $x;
+ eval {
+ $? = 256;
+ $! = 1;
+ local $^B = 0;
+ $x = 1;
+ };
+ if($@ eq "SIGINT\n") {print "ok 14\n";} else {print "not ok 14\n";}
+ if(!$x) {print "ok 15\n";} else {print "not ok 15\n";}
+ if($! == 1) {print "ok 16\n";} else {print "not ok 16\n";}
+ if($? == 256) {print "ok 17\n";} else {print "not ok 17\n";}
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ }
+
+ sub catch { die "SIG$_[0]\n" }
+
+ eval {
+ local ($SIG{INT}) = (\&catch);
+ {
+ my $obj = bless [];
+ $! = 2;
+ $? = 512;
+ }
+ # Before we get here, the signal propagated by the destuctor takes
+ # effect.
+ $! = 3;
+ $? = 768;
+ };
+ if($@ eq "SIGINT\n") {print "ok 18\n";} else {print "not ok 18\n";}
+ if($! == 2) {print "ok 19\n";} else {print "not ok 19\n";}
+ if($? == 512) {print "ok 20\n";} else {print "not ok 20\n";}
+}
+
+# Check that interrupts are sampled merely by { local $^B = 0; }.
+{
+ local $^B = 1;
+ undef $c;
+ kill "INT", $$;
+ if(!defined $c) {print "ok 21\n";} else {print "not ok 21\n";}
+ { local $^B = 0; }
+ if($c) {print "ok 22\n";} else {print "not ok 22\n";}
+}
+ Perl Info
|
From ajohnson@nvidia.comCreated by ajohnson@nvidia.comThis is a bug report for perl from ajohnson@nvidia.com, ----------------------------------------------------------------- Even after applying the perl-5.9.1-blocksigs patch, there First, you can't do a critical section involving a blocking system Second, it can call the handlers of pending but blocked signals, The patch also cleans up a number of miscellaneous signal handling issues, *** This patch has a compatibility issue for existing extensions that call Please refer to the POD changes in the patch for details. Inline Patchdiff -Naur perl-5.9.1/AUTHORS perl-5.9.1-syssigs/AUTHORS
--- perl-5.9.1/AUTHORS Thu Feb 26 07:26:02 2004
+++ perl-5.9.1-syssigs/AUTHORS Fri Oct 22 14:53:12 2004
@@ -42,7 +42,7 @@
Alain Barbet <alian@cpan.org>
Ambrose Kofi Laing
Ananth Kesari <HYanantha@novell.com>
-Anders Jonhson
+Anders Johnson <anders@ieee.org>
Andreas Klussmann <andreas@infosys.heitec.de>
Andreas König <a.koenig@mind.de>
Andreas Schwab <schwab@suse.de>
diff -Naur perl-5.9.1/embedvar.h perl-5.9.1-syssigs/embedvar.h
--- perl-5.9.1/embedvar.h Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-syssigs/embedvar.h Tue Oct 19 15:17:58 2004
@@ -378,6 +378,7 @@
#define PL_sh_path_compat (vTHX->Ish_path_compat)
#define PL_sharehook (vTHX->Isharehook)
#define PL_sig_pending (vTHX->Isig_pending)
+#define PL_sig_blocked (vTHX->Isig_blocked)
#define PL_sighandlerp (vTHX->Isighandlerp)
#define PL_signals (vTHX->Isignals)
#define PL_sort_RealCmp (vTHX->Isort_RealCmp)
@@ -679,6 +680,7 @@
#define PL_Ish_path_compat PL_sh_path_compat
#define PL_Isharehook PL_sharehook
#define PL_Isig_pending PL_sig_pending
+#define PL_Isig_blocked PL_sig_blocked
#define PL_Isighandlerp PL_sighandlerp
#define PL_Isignals PL_signals
#define PL_Isort_RealCmp PL_sort_RealCmp
diff -Naur perl-5.9.1/ext/POSIX/POSIX.xs perl-5.9.1-syssigs/ext/POSIX/POSIX.xs
--- perl-5.9.1/ext/POSIX/POSIX.xs Fri Mar 5 01:13:25 2004
+++ perl-5.9.1-syssigs/ext/POSIX/POSIX.xs Fri Oct 22 13:32:43 2004
@@ -555,6 +555,7 @@
*/
sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+ PERL_ASYNC_UNBLOCKED();
}
MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
@@ -1273,6 +1274,9 @@
* signal handler invoked during a sigaction() call should
* see either the old or the new disposition, and not something
* in between. We use sigprocmask() to make it so.
+ * XXX To be safe, we should block only the present signal and
+ * signals that are currently trapped, because blocking things
+ * like SIGSEGV is evil.
*/
sigfillset(&sset);
RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
@@ -1405,6 +1409,10 @@
sigemptyset(oldsigset);
sv_setref_pv(ST(2), "POSIX::SigSet", (void*)oldsigset);
}
+CLEANUP:
+ if(how != SIG_BLOCK) {
+ PERL_ASYNC_UNBLOCKED();
+ }
SysRet
sigsuspend(signal_mask)
diff -Naur perl-5.9.1/gv.c perl-5.9.1-syssigs/gv.c
--- perl-5.9.1/gv.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-syssigs/gv.c Tue Oct 19 15:19:41 2004
@@ -963,6 +963,7 @@
case '\011': /* $^I, NOT \t in EBCDIC */
case '\016': /* $^N */
case '\020': /* $^P */
+ case '\002': /* $^B */
if (len > 1)
break;
goto magicalize;
@@ -1882,6 +1883,7 @@
case '\020': /* $^P */
case '\023': /* $^S */
case '\026': /* $^V */
+ case '\002': /* $^B */
if (len == 1)
goto yes;
break;
diff -Naur perl-5.9.1/intrpvar.h perl-5.9.1-syssigs/intrpvar.h
--- perl-5.9.1/intrpvar.h Sun Feb 29 14:26:05 2004
+++ perl-5.9.1-syssigs/intrpvar.h Tue Oct 19 15:18:32 2004
@@ -441,7 +441,8 @@
/* 5.6.0 stopped here */
PERLVAR(Ipsig_pend, int *) /* per-signal "count" of pending */
-PERLVARI(Isig_pending, int,0) /* Number if highest signal pending */
+PERLVARI(Isig_pending, int,0) /* Nonzero if any signal pending */
+PERLVARI(Isig_blocked, int,0) /* Nonzero if signals blocked */
#ifdef USE_LOCALE_NUMERIC
diff -Naur perl-5.9.1/lib/English.pm perl-5.9.1-syssigs/lib/English.pm
--- perl-5.9.1/lib/English.pm Fri Feb 20 07:26:54 2004
+++ perl-5.9.1-syssigs/lib/English.pm Fri Oct 22 11:32:51 2004
@@ -219,6 +219,7 @@
*WARNING = *^W ;
*EXECUTABLE_NAME = *^X ;
*OSNAME = *^O ;
+ *BLOCK_SIGNAL_HANDLERS = *^B ;
# Deprecated.
diff -Naur perl-5.9.1/mg.c perl-5.9.1-syssigs/mg.c
--- perl-5.9.1/mg.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-syssigs/mg.c Thu Oct 21 16:40:49 2004
@@ -683,6 +683,9 @@
? (PL_taint_warn || PL_unsafe ? -1 : 1)
: 0);
break;
+ case '\002': /* ^B */
+ sv_setiv(sv, PL_sig_blocked);
+ break;
case '\025': /* $^UNICODE */
if (strEQ(mg->mg_ptr, "\025NICODE"))
sv_setuv(sv, (UV) PL_unicode);
@@ -1085,6 +1088,7 @@
{
sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+ PERL_ASYNC_UNBLOCKED();
}
#endif
int
@@ -1175,11 +1179,15 @@
if(PL_psig_ptr[i]) {
to_dec=PL_psig_ptr[i];
PL_psig_ptr[i]=0;
+#ifdef HAS_SIGPROCMASK
LEAVE;
+#endif
SvREFCNT_dec(to_dec);
}
+#ifdef HAS_SIGPROCMASK
else
LEAVE;
+#endif
}
}
return 0;
@@ -1246,19 +1254,53 @@
void
Perl_despatch_signals(pTHX)
{
- int sig;
- PL_sig_pending = 0;
- for (sig = 1; sig < SIG_SIZE; sig++) {
- if (PL_psig_pend[sig]) {
- PERL_BLOCKSIG_ADD(set, sig);
- PL_psig_pend[sig] = 0;
- PERL_BLOCKSIG_BLOCK(set);
- (*PL_sighandlerp)(sig);
- PERL_BLOCKSIG_UNBLOCK(set);
+#ifdef HAS_SIGPROCMASK
+ sigset_t oldset;
+ int oldset_valid = 0;
+#endif
+ while(PL_sig_pending) {
+ int sig;
+ PL_sig_pending = 0;
+ for (sig = 1; sig < SIG_SIZE; sig++) {
+ if (PL_psig_pend[sig]) {
+ /*
+ * Because we leave the signal outstanding if it's pending but
+ * currently blocked, anything that unblocks a signal must
+ * then call PERL_ASYNC_UNBLOCKED() if the signal may have
+ * been blocked while PERL_ASYNC_CHECK() was called.
+ */
+ PERL_BLOCKSIG_ADD(set, sig);
+ PL_psig_pend[sig] = 0;
+#ifdef HAS_SIGPROCMASK
+ if(oldset_valid && sigismember(&oldset, sig)) {
+ PL_psig_pend[sig] = 1;
+ continue;
+ }
+ sigprocmask(SIG_BLOCK, &set, &oldset);
+ oldset_valid = sigismember(&oldset, sig);
+ if(oldset_valid) {
+ sigprocmask(SIG_SETMASK, &oldset, NULL);
+ PL_psig_pend[sig] = 1;
+ continue;
+ }
+#else
+ PERL_BLOCKSIG_BLOCK(set);
+#endif
+ (*PL_sighandlerp)(sig);
+ PERL_BLOCKSIG_UNBLOCK(set);
+ }
}
}
}
+static void reraise_pending_signal(I32 sig)
+{
+ if(PL_psig_pend[sig]) {
+ PL_psig_pend[sig] = 0;
+ PerlProc_kill(PerlProc_getpid(), sig);
+ }
+}
+
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
@@ -1345,6 +1387,7 @@
(void)rsignal(i, PL_csighandlerp);
#else
(void)rsignal(i, SIG_IGN);
+ reraise_pending_signal(i);
#endif
}
}
@@ -1357,6 +1400,7 @@
}
#else
(void)rsignal(i, SIG_DFL);
+ reraise_pending_signal(i);
#endif
}
else {
@@ -2122,6 +2166,9 @@
PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
#endif
break;
+ case '\002': /* ^B */
+ PL_sig_blocked = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ break;
case '\027': /* ^W & $^WARNING_BITS */
if (*(mg->mg_ptr+1) == '\0') {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
diff -Naur perl-5.9.1/perl.h perl-5.9.1-syssigs/perl.h
--- perl-5.9.1/perl.h Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-syssigs/perl.h Fri Oct 22 11:23:44 2004
@@ -4007,12 +4007,21 @@
#ifndef PERL_MICRO
# ifndef PERL_ASYNC_CHECK
-# define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+ /*
+ * XXX: This is used often enough that it might improve
+ * performance noticably to cache a copy of
+ * PL_sig_pending && !PL_sig_blocked
+ */
+# define PERL_ASYNC_CHECK() if (PL_sig_pending && !PL_sig_blocked) despatch_signals()
+# define PERL_ASYNC_CHECK_EINTR() if (PL_sig_pending && PL_sig_blocked <= 0) despatch_signals()
+# define PERL_ASYNC_UNBLOCKED() (PL_sig_pending = 1)
# endif
#endif
#ifndef PERL_ASYNC_CHECK
# define PERL_ASYNC_CHECK() NOOP
+# define PERL_ASYNC_CHECK_EINTR() NOOP
+# define PERL_ASYNC_UNBLOCKED() NOOP
#endif
/*
@@ -4373,8 +4382,14 @@
sigset_t set; sigemptyset(&(set)); sigaddset(&(set), sig)
# define PERL_BLOCKSIG_BLOCK(set) \
sigprocmask(SIG_BLOCK, &(set), NULL)
+/*
+ * XXX Maybe there should be a macro here that maps sigprocmask to a function
+ * that calls the real sigprocmask, followed by PERL_ASYNC_UNBLOCK() unless
+ * how == SIG_BLOCK. That way, existing extensions will be ported to do the
+ * right thing automatically.
+ */
# define PERL_BLOCKSIG_UNBLOCK(set) \
- sigprocmask(SIG_UNBLOCK, &(set), NULL)
+ STMT_START { sigprocmask(SIG_UNBLOCK, &(set), NULL); PERL_ASYNC_UNBLOCKED(); } STMT_END
#endif /* HAS_SIGPROCMASK && PERL_BLOCK_SIGNALS */
/* How about the old style of sigblock()? */
diff -Naur perl-5.9.1/perlio.c perl-5.9.1-syssigs/perlio.c
--- perl-5.9.1/perlio.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-syssigs/perlio.c Wed Oct 20 18:18:24 2004
@@ -14,6 +14,20 @@
* at the dispatch tables, even when we do not need it for other reasons.
* Invent a dSYS macro to abstract this out
*/
+
+ /*
+ * XXX In a number of places, this tries to avoid getting stuck in a system
+ * call soon after a signal arrives, by calling PERL_ASYNC_CHECK() just before
+ * the system call. There is still a narrow window in which this could
+ * happen, although it is relatively unlikely. Ditto for pp_sys.c and util.c.
+ * The "correct" way to do this is always to do nonblocking calls, and if
+ * the caller wanted a blocking call, then spin in a select loop with a
+ * timeout of 250ms or so. That way, in the rare case that a signal arrives
+ * just before the select call, it gets stuck only for one timeout.
+ * Unfortunately, this prevents the OS from swapping out the process if it
+ * is legitimately blocked for a long time (e.g. waiting for tty input while
+ * the user is having lunch), so it's not a good thing to do by default.
+ */
#ifdef PERL_IMPLICIT_SYS
#define dSYS dTHX
#else
@@ -2478,6 +2492,7 @@
PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
return 0;
}
+ PERL_ASYNC_CHECK();
while (1) {
SSize_t len = PerlLIO_read(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
@@ -2492,7 +2507,7 @@
}
return len;
}
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
}
@@ -2500,6 +2515,7 @@
PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+ PERL_ASYNC_CHECK();
while (1) {
SSize_t len = PerlLIO_write(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
@@ -2510,7 +2526,7 @@
}
return len;
}
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
}
@@ -2536,12 +2552,13 @@
SETERRNO(EBADF,SS_IVCHAN);
return -1;
}
+ PERL_ASYNC_CHECK();
while (PerlLIO_close(fd) != 0) {
if (errno != EINTR) {
code = -1;
break;
}
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
if (code == 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
@@ -2986,6 +3003,7 @@
{
FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
SSize_t got = 0;
+ PERL_ASYNC_CHECK();
for (;;) {
if (count == 1) {
STDCHAR *buf = (STDCHAR *) vbuf;
@@ -3005,7 +3023,7 @@
got = -1;
if (got >= 0 || errno != EINTR)
break;
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
SETERRNO(0,0); /* just in case */
}
return got;
@@ -3073,12 +3091,13 @@
PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
SSize_t got;
+ PERL_ASYNC_CHECK();
for (;;) {
got = PerlSIO_fwrite(vbuf, 1, count,
PerlIOSelf(f, PerlIOStdio)->stdio);
if (got >= 0 || errno != EINTR)
break;
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
SETERRNO(0,0); /* just in case */
}
return got;
diff -Naur perl-5.9.1/pod/perlipc.pod perl-5.9.1-syssigs/pod/perlipc.pod
--- perl-5.9.1/pod/perlipc.pod Fri Feb 20 07:30:51 2004
+++ perl-5.9.1-syssigs/pod/perlipc.pod Fri Oct 22 11:39:19 2004
@@ -388,7 +388,7 @@
"loop". In future Perl's signal mechanism may be changed to avoid this
- perhaps by simply disallowing %SIG handlers on signals of that
type. Until then the work-round is not to set a %SIG handler on those
-signals. (Which signals they are is operating system dependant.)
+signals. (Which signals they are is operating system dependent.)
=item Signals triggered by operating system state
@@ -407,6 +407,132 @@
memory corruption, set the environment variable C<PERL_SIGNALS> to
C<"unsafe"> (a new feature since Perl 5.8.1).
+=head1 Using $^B to Block Signals
+
+As of Perl 5.9.2, you can set C<$^B> to a positive integer in order
+to block trapped signals completely, if safe signals are in use.
+This is obviously dangerous, so you should do this only locally
+inside a block that will be exited within a reasonable period of time.
+
+For example, you can use it to implement a critical section so that
+signal handlers always see a self-consistent program state:
+
+ my ($a, $b) = (2, 3);
+ $SIG{HUP} = sub { die unless $a + $b == 5 };
+ {
+ local $^B = 1;
+ $a++;
+ # A signal won't be handled here.
+ $b--;
+ }
+
+Since C<$^B> is set automatically before calling the DESTROY method of
+an object whose package has $BLOCK_SIGNALS_IN_DESTROY set, you can
+reliably convert signals to exceptions, because the signal won't arrive
+in a destructor, from which exceptions are caught by the perl core.
+(See L<perlobj/"Destructors that Die">).
+
+Typically, you would do something like this in your main program:
+
+ sub catch { die "SIG$_[0]\n" }
+ eval {
+ # Signals that otherwise would cause the process to
+ # terminate immediately *without* a core dump. If a core
+ # dump is left behind for debugging, then you probably
+ # want to leave resources behind for debugging too.
+ local (
+ $SIG{HUP}, $SIG{INT}, $SIG{PIPE}, $SIG{ALRM},
+ $SIG{TERM}, $SIG{USR1}, $SIG{USR2}
+ ) = (\&catch) x 7;
+
+ # Now do what you want to do. Each resource to
+ # deallocate is represented by an object whose DESTROY
+ # method deallocates it.
+ };
+ if($@) {
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ die; # or 'die $@;' if you don't like "...propagated at"
+ }
+
+And your DESTROY methods would look like this:
+
+ BEGIN { $BLOCK_SIGNALS_IN_DESTROY = 1 }
+ sub DESTROY {
+ local ($@, $!, $?);
+
+ # Actions that can't die and won't be interrupted go here.
+
+ eval {
+ local $^B = 0;
+
+ # Actions that can die or may be interrupted go here.
+ };
+ warn "Failed to destroy $_[0] because $@" if $@;
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ }
+
+The main advantage of converting signals to exceptions is that it allows
+the program a chance to clean up resources allocated to the process, such
+as temporary files, that the operating system doesn't deallocate
+automatically when the program terminates.
+This is commonly known as the RAII (resource allocation is initialization)
+idiom.
+
+By setting C<$^B> to a negative integer, you can block interrupts
+I<except> for just after a system call fails with an interrupt, and
+the call would otherwise have been restarted by the Perl core.
+This provides a way to ensure that some action is reliably taken after
+a system call succeeds, while still allowing the call to be interrupted.
+Generally, you'll want to set C<$^B> back to a positive integer just after
+the system call succeeds, or else some subsequent system call could wind
+up calling a signal handler before you've finished with your critical section:
+
+ {
+ local $^B = -1;
+ my $pid = wait or die "wait failed because $!";
+ $^B = 1;
+
+ # We are guaranteed to get here if the wait succeeds.
+ delete $pids{$pid};
+ my $result{$pid} = <$fh{$pid}>;
+ }
+
+Because a signal that is blocked by the process signal mask is never handled
+(even if it arrived after the last sampling of signals before its bit in the
+mask was set), you can reliably unblock selected signals while C<$^B> is set:
+
+ use POSIX qw/:signal_h/;
+
+ my $interrupts = 0;
+ sub catch_cleanup {
+ if(++$interrupts == 2) {
+ print STDERR "One more interrupt to abort cleanup\n";
+ }
+ elsif($interrupts > 2) {
+ $SIG{INT} = 'DEFAULT';
+ kill "INT", $$;
+ }
+ }
+
+ BEGIN { $BLOCK_SIGNALS_IN_DESTROY = 1 }
+ sub DESTROY {
+ my $sigset = POSIX::SigSet->new();
+ for(qw/HUP PIPE ALRM TERM USR1 USR2/) {
+ $sigset->addset($signo{$_});
+ }
+ my $osset = POSIX::SigSet->new();
+ local $SIG{INT} = \&catch_cleanup;
+ sigprocmask(SIG_BLOCK, $sigset, $osset);
+ {
+ local $^B = 0;
+
+ # Now do real cleanup work
+ }
+ sigprocmask(SIG_SETMASK, $osset);
+ }
+
+See L</"Signals"> for how to initialize %signo.
+
=head1 Using open() for IPC
Perl's basic open() statement can also be used for unidirectional
diff -Naur perl-5.9.1/pod/perlobj.pod perl-5.9.1-syssigs/pod/perlobj.pod
--- perl-5.9.1/pod/perlobj.pod Fri Feb 20 07:30:57 2004
+++ perl-5.9.1-syssigs/pod/perlobj.pod Fri Oct 22 14:28:14 2004
@@ -455,6 +455,49 @@
when the current object is freed, provided no other references to them exist
elsewhere.
+=head2 Destructors that Die
+
+If the DESTROY method dies, then the error is caught in the perl core where
+the method was called.
+The message is prefixed with the string "\t(in cleanup)", and if C<$^W> is set,
+then it is printed to STDERR.
+The message is then appended to the existing value of $@, if any.
+This is usually a good thing, because there may be some other error that
+caused the object to go out of scope to begin with, and it would be bad to
+discard either that error or the destructor error.
+
+Although reporting the errors in the order that they occurred is intuitive,
+modifying $@ during the propagation of the error can interfere with code that
+attempts to catch the original error outside an eval (especially if $@
+originally contains a reference, in which case the reference is discarded
+completely when the destructor error is appended.)
+For this reason, it is usually best for the DESTROY method to promise never
+to die at all, and furthermore not to spoil $@, $!, $^E and $?:
+
+ sub DESTROY {
+ my $self = shift;
+ # Without the 'local', the DESTROY error is printed twice,
+ # the first error is lost, and the exit status is wrong.
+ local ($@, $!, $^E, $?);
+ eval {
+ $! = 1;
+ die "failed because $!";
+ };
+ warn "Destroying $self: $@" if $@;
+ }
+
+ eval {
+ my $a = bless [];
+ $! = 2;
+ die "Oops!";
+ };
+ die if $@;
+
+An unfortunate side-effect of catching errors in destructors is that
+a signal handler that dies won't terminate the program if gets called
+within a destructor.
+See L<perlipc/"Using $^B to Block Signals"> for a way to avoid that.
+
=head2 Summary
That's about all there is to it. Now you need just to go off and buy a
diff -Naur perl-5.9.1/pod/perlvar.pod perl-5.9.1-syssigs/pod/perlvar.pod
--- perl-5.9.1/pod/perlvar.pod Fri Feb 20 07:31:27 2004
+++ perl-5.9.1-syssigs/pod/perlvar.pod Fri Oct 22 11:27:22 2004
@@ -1221,6 +1221,27 @@
{$secure_perl_path .= $Config{_exe}
unless $secure_perl_path =~ m/$Config{_exe}$/i;}
+=item $BLOCK_SIGNAL_HANDLERS
+
+=item $^B
+
+If set to a nonzero integer, then don't sample signals that are
+dispositioned to a handler.
+Signals are still accumulated.
+Has no effect if unsafe signals are in use
+(see L<perlipc/"Deferred Signals (Safe Signals)">).
+
+This can be used to block all such signals without the overhead of a system call.
+It is automatically set locally before calling the DESTROY method of an object
+that is going out of scope, but only if the object's package has
+$BLOCK_SIGNALS_IN_DESTROY set.
+
+If set to a negative integer, then signals are checked I<only> immediately
+after a system call returns EINTR, and would otherwise be restarted by the
+Perl core.
+
+See L<perlipc/"Using $^B to Block Signals">.
+
=item ARGV
The special filehandle that iterates over command-line filenames in
diff -Naur perl-5.9.1/pp_sys.c perl-5.9.1-syssigs/pp_sys.c
--- perl-5.9.1/pp_sys.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-syssigs/pp_sys.c Wed Oct 20 14:17:46 2004
@@ -4083,9 +4083,10 @@
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
childpid = wait4pid(-1, &argflags, 0);
else {
+ PERL_ASYNC_CHECK();
while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
errno == EINTR) {
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
@@ -4115,9 +4116,10 @@
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
result = wait4pid(pid, &argflags, optype);
else {
+ PERL_ASYNC_CHECK();
while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
errno == EINTR) {
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
diff -Naur perl-5.9.1/sv.c perl-5.9.1-syssigs/sv.c
--- perl-5.9.1/sv.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-syssigs/sv.c Wed Oct 20 10:48:21 2004
@@ -5376,6 +5376,12 @@
=cut
*/
+static void
+restore_sig_blocked(pTHX_ SV *save_sv)
+{
+ PL_sig_blocked = SvIV( save_sv );
+}
+
void
Perl_sv_clear(pTHX_ register SV *sv)
{
@@ -5394,9 +5400,26 @@
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
+ /*
+ * XXX: Maybe we should look in the package containing
+ * the DESTROY method, instead of the object's package.
+ */
+ GV** gvp = (GV**)hv_fetch(stash, "BLOCK_SIGNALS_IN_DESTROY", 24, FALSE);
+ SV* block_sig_class = (gvp && *gvp != (GV*)&PL_sv_undef) ? GvSV(*gvp) : Nullsv;
SV* tmpref = newRV(sv);
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
ENTER;
+ /*
+ * XXX: There probably ought to be some way to globally
+ * opt for this to default active
+ * ('block_sig_class == Nullsv || SvTRUE(block_sig_class').
+ */
+ if(SvTRUE(block_sig_class)) {
+ SV* save_sv = newSViv(PL_sig_blocked);
+ SAVEFREESV(save_sv);
+ SAVEDESTRUCTOR_X(restore_sig_blocked, save_sv);
+ PL_sig_blocked = 1;
+ }
PUSHSTACKi(PERLSI_DESTROY);
EXTEND(SP, 2);
PUSHMARK(SP);
diff -Naur perl-5.9.1/t/op/blocksig.t perl-5.9.1-syssigs/t/op/blocksig.t
--- perl-5.9.1/t/op/blocksig.t Wed Dec 31 16:00:00 1969
+++ perl-5.9.1-syssigs/t/op/blocksig.t Fri Oct 22 14:26:52 2004
@@ -0,0 +1,208 @@
+#!./perl
+
+use strict;
+BEGIN { $^W = 1 }
+
+BEGIN {
+ $| = 1;
+ chdir 't' if -d 't';
+ $SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
+}
+
+print "1..30\n";
+
+my ($a, $b) = (2, 3);
+my $c;
+$SIG{INT} = sub { $c = defined($c) ? undef : ($a + $b == 5); };
+
+if(defined($^B) && !$^B) {print "ok 1\n";} else {print "not ok 1\n";}
+
+{
+ # Check basic critical section
+ local $^B = 1;
+ $a++;
+ kill "INT", $$;
+ $b--;
+ if($^B) {print "ok 2\n";} else {print "not ok 2\n";}
+}
+
+if(defined($^B) && !$^B) {print "ok 3\n";} else {print "not ok 3\n";}
+if(defined $c) {print "ok 4\n";} else {print "not ok 4\n";}
+if($c) {print "ok 5\n";} else {print "not ok 5\n";}
+
+our $BLOCK_SIGNALS_IN_DESTROY = 1;
+my $testnum = 6;
+sub DESTROY {
+ my $ok = $^B;
+ $ok = !$ok if $testnum == 10;
+ if($ok) {print "ok $testnum\n";} else {print "not ok $testnum\n";}
+ kill "INT", $$;
+ $b--;
+}
+
+# Check that $^B is set in destructor if $BLOCK_SIGNALS_IN_DESTROY
+{
+ my $obj = bless [];
+ $a++;
+ undef $c;
+ # DESTROY gets called here
+}
+if(defined($^B) && !$^B) {print "ok 7\n";} else {print "not ok 7\n";}
+if(defined $c) {print "ok 8\n";} else {print "not ok 8\n";}
+if($c) {print "ok 9\n";} else {print "not ok 9\n";}
+
+# Check that $^B is *not* set in destructor unless $BLOCK_SIGNALS_IN_DESTROY
+$BLOCK_SIGNALS_IN_DESTROY = 0;
+{
+ my $obj = bless [];
+ $a++;
+ undef $c;
+ $testnum = 10;
+ # DESTROY gets called here
+}
+if(defined $c) {print "ok 11\n";} else {print "not ok 11\n";}
+if(!$c) {print "ok 12\n";} else {print "not ok 12\n";}
+
+# Check that $^B is reset in this scope
+undef $c;
+kill "INT", $$;
+if($c) {print "ok 13\n";} else {print "not ok 13\n";}
+
+# Check the typical RAII behavior
+{ package Class;
+
+ our $BLOCK_SIGNALS_IN_DESTROY = 1;
+ sub DESTROY {
+ local($@, $!, $^E, $?);
+ kill "INT", $$;
+ my $x;
+ eval {
+ $? = 256;
+ $! = 1;
+ local $^B = 0;
+ $x = 1;
+ };
+ if($@ eq "SIGINT\n") {print "ok 14\n";} else {print "not ok 14\n";}
+ if(!$x) {print "ok 15\n";} else {print "not ok 15\n";}
+ if($! == 1) {print "ok 16\n";} else {print "not ok 16\n";}
+ if($? == 256) {print "ok 17\n";} else {print "not ok 17\n";}
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ }
+
+ sub catch { die "SIG$_[0]\n" }
+
+ eval {
+ local ($SIG{INT}) = (\&catch);
+ {
+ my $obj = bless [];
+ $! = 2;
+ $? = 512;
+ }
+ # Before we get here, the signal propagated by the destuctor takes
+ # effect.
+ $! = 3;
+ $? = 768;
+ };
+ if($@ eq "SIGINT\n") {print "ok 18\n";} else {print "not ok 18\n";}
+ if($! == 2) {print "ok 19\n";} else {print "not ok 19\n";}
+ if($? == 512) {print "ok 20\n";} else {print "not ok 20\n";}
+}
+
+# Check that interrupts are sampled merely by { local $^B = 0; }.
+{
+ local $^B = 1;
+ undef $c;
+ kill "INT", $$;
+ if(!defined $c) {print "ok 21\n";} else {print "not ok 21\n";}
+ { local $^B = 0; }
+ if($c) {print "ok 22\n";} else {print "not ok 22\n";}
+}
+
+# Check that we can interrupt a system call only
+undef $c;
+# XXX: Figure out a way to do this without fork, which doesn't work everywhere
+my $ppid = $$;
+my $pid = open(KID_TO_READ, "-|");
+defined $pid or die;
+unless($pid) {
+ $SIG{INT} = "DEFAULT";
+ sleep 1;
+ kill "INT", $ppid;
+ print "x";
+ sleep 1;
+ kill "INT", $ppid;
+ exit(0);
+}
+
+{
+ my $x;
+ local $^B = -1;
+ my $ret = read(KID_TO_READ, $x, 1);
+ $^B = 1;
+ if($x eq "x") {print "ok 23\n";} else {print "not ok 23\n";}
+ if($c) {print "ok 24\n";} else {print "not ok 24\n";}
+
+ # Now make sure that the signal got consumed
+ undef $c;
+ { local $^B = 0; print ""; }
+ if(!defined $c) {print "ok 25\n";} else {print "not ok 25\n";}
+
+ # Now make sure that syscalls do *not* call handler if $^B > 0
+ undef $c;
+ $ret = read(KID_TO_READ, $x, 1);
+ close(KID_TO_READ);
+ if(!defined $c) {print "ok 26\n";} else {print "not ok 26\n";}
+
+ undef $c;
+}
+# Make sure that the signal wasn't consumed until $^B was reset
+if($c) {print "ok 27\n";} else {print "not ok 27\n";}
+
+my %signo;
+{
+ use Config;
+ my $i;
+ foreach my $name (split(' ', $Config{sig_name})) {
+ $signo{$name} = $i++;
+ }
+}
+
+{ package Class2;
+ use POSIX qw/:signal_h/;
+
+ my $interrupts = 0;
+ sub catch_cleanup {
+ ++$interrupts;
+ }
+
+ $SIG{TERM} = \&catch_cleanup;
+
+ our $BLOCK_SIGNALS_IN_DESTROY = 1;
+ sub DESTROY {
+ my $sigset = POSIX::SigSet->new();
+ for(qw/HUP PIPE ALRM TERM USR1 USR2/) {
+ $sigset->addset($signo{$_});
+ }
+ my $osset = POSIX::SigSet->new();
+ local $SIG{INT} = \&catch_cleanup;
+ sigprocmask(SIG_BLOCK, $sigset, $osset);
+ {
+ local $^B = 0;
+ kill "INT", $$;
+ kill "TERM", $$;
+ kill "INT", $$;
+ }
+ sigprocmask(SIG_SETMASK, $osset);
+ if($interrupts == 2) {print "ok 28\n";} else {print "not ok 28\n";}
+ }
+ bless [];
+ if($interrupts == 3) {print "ok 29\n";} else {print "not ok 29\n";}
+
+ {
+ local $^B = 1;
+ kill "TERM", $$;
+ $SIG{TERM} = 'IGNORE';
+ }
+ if($interrupts == 3) {print "ok 30\n";} else {print "not ok 30\n";}
+}
+
diff -Naur perl-5.9.1/util.c perl-5.9.1-syssigs/util.c
--- perl-5.9.1/util.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-syssigs/util.c Wed Oct 20 14:23:27 2004
@@ -2457,6 +2457,7 @@
}
}
#endif
+ PERL_ASYNC_CHECK();
#ifdef HAS_WAITPID
# ifdef HAS_WAITPID_RUNTIME
if (!HAS_WAITPID_RUNTIME)
@@ -2484,7 +2485,7 @@
#endif
finish:
if (result < 0 && errno == EINTR) {
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
return result;
} Perl Info
|
From ajohnson@nvidia.comCreated by ajohnson@nvidia.comThis is a bug report for perl from ajohnson@nvidia.com, ----------------------------------------------------------------- Even after applying the perl-5.9.1-syssigs patch, one more remaining As a result, if you do RAII with global resources, you'll always get the *** This patch is almost certain to have porting issues for non-POSIX Please refer to the POD changes in the patch for details. Inline Patchdiff -Naur perl-5.9.1/AUTHORS perl-5.9.1-sigexit/AUTHORS
--- perl-5.9.1/AUTHORS Thu Feb 26 07:26:02 2004
+++ perl-5.9.1-sigexit/AUTHORS Fri Oct 22 14:53:09 2004
@@ -42,7 +42,7 @@
Alain Barbet <alian@cpan.org>
Ambrose Kofi Laing
Ananth Kesari <HYanantha@novell.com>
-Anders Jonhson
+Anders Johnson <anders@ieee.org>
Andreas Klussmann <andreas@infosys.heitec.de>
Andreas König <a.koenig@mind.de>
Andreas Schwab <schwab@suse.de>
diff -Naur perl-5.9.1/embedvar.h perl-5.9.1-sigexit/embedvar.h
--- perl-5.9.1/embedvar.h Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/embedvar.h Tue Oct 19 15:17:58 2004
@@ -378,6 +378,7 @@
#define PL_sh_path_compat (vTHX->Ish_path_compat)
#define PL_sharehook (vTHX->Isharehook)
#define PL_sig_pending (vTHX->Isig_pending)
+#define PL_sig_blocked (vTHX->Isig_blocked)
#define PL_sighandlerp (vTHX->Isighandlerp)
#define PL_signals (vTHX->Isignals)
#define PL_sort_RealCmp (vTHX->Isort_RealCmp)
@@ -679,6 +680,7 @@
#define PL_Ish_path_compat PL_sh_path_compat
#define PL_Isharehook PL_sharehook
#define PL_Isig_pending PL_sig_pending
+#define PL_Isig_blocked PL_sig_blocked
#define PL_Isighandlerp PL_sighandlerp
#define PL_Isignals PL_signals
#define PL_Isort_RealCmp PL_sort_RealCmp
diff -Naur perl-5.9.1/ext/POSIX/POSIX.xs perl-5.9.1-sigexit/ext/POSIX/POSIX.xs
--- perl-5.9.1/ext/POSIX/POSIX.xs Fri Mar 5 01:13:25 2004
+++ perl-5.9.1-sigexit/ext/POSIX/POSIX.xs Fri Oct 22 13:32:57 2004
@@ -555,6 +555,7 @@
*/
sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+ PERL_ASYNC_UNBLOCKED();
}
MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
@@ -1273,6 +1274,9 @@
* signal handler invoked during a sigaction() call should
* see either the old or the new disposition, and not something
* in between. We use sigprocmask() to make it so.
+ * XXX To be safe, we should block only the present signal and
+ * signals that are currently trapped, because blocking things
+ * like SIGSEGV is evil.
*/
sigfillset(&sset);
RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
@@ -1405,6 +1409,10 @@
sigemptyset(oldsigset);
sv_setref_pv(ST(2), "POSIX::SigSet", (void*)oldsigset);
}
+CLEANUP:
+ if(how != SIG_BLOCK) {
+ PERL_ASYNC_UNBLOCKED();
+ }
SysRet
sigsuspend(signal_mask)
diff -Naur perl-5.9.1/gv.c perl-5.9.1-sigexit/gv.c
--- perl-5.9.1/gv.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/gv.c Tue Oct 19 15:19:41 2004
@@ -963,6 +963,7 @@
case '\011': /* $^I, NOT \t in EBCDIC */
case '\016': /* $^N */
case '\020': /* $^P */
+ case '\002': /* $^B */
if (len > 1)
break;
goto magicalize;
@@ -1882,6 +1883,7 @@
case '\020': /* $^P */
case '\023': /* $^S */
case '\026': /* $^V */
+ case '\002': /* $^B */
if (len == 1)
goto yes;
break;
diff -Naur perl-5.9.1/intrpvar.h perl-5.9.1-sigexit/intrpvar.h
--- perl-5.9.1/intrpvar.h Sun Feb 29 14:26:05 2004
+++ perl-5.9.1-sigexit/intrpvar.h Tue Oct 19 15:18:32 2004
@@ -441,7 +441,8 @@
/* 5.6.0 stopped here */
PERLVAR(Ipsig_pend, int *) /* per-signal "count" of pending */
-PERLVARI(Isig_pending, int,0) /* Number if highest signal pending */
+PERLVARI(Isig_pending, int,0) /* Nonzero if any signal pending */
+PERLVARI(Isig_blocked, int,0) /* Nonzero if signals blocked */
#ifdef USE_LOCALE_NUMERIC
diff -Naur perl-5.9.1/lib/English.pm perl-5.9.1-sigexit/lib/English.pm
--- perl-5.9.1/lib/English.pm Fri Feb 20 07:26:54 2004
+++ perl-5.9.1-sigexit/lib/English.pm Fri Oct 22 11:36:32 2004
@@ -219,6 +219,7 @@
*WARNING = *^W ;
*EXECUTABLE_NAME = *^X ;
*OSNAME = *^O ;
+ *BLOCK_SIGNAL_HANDLERS = *^B ;
# Deprecated.
diff -Naur perl-5.9.1/mg.c perl-5.9.1-sigexit/mg.c
--- perl-5.9.1/mg.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/mg.c Thu Oct 21 17:09:32 2004
@@ -683,6 +683,9 @@
? (PL_taint_warn || PL_unsafe ? -1 : 1)
: 0);
break;
+ case '\002': /* ^B */
+ sv_setiv(sv, PL_sig_blocked);
+ break;
case '\025': /* $^UNICODE */
if (strEQ(mg->mg_ptr, "\025NICODE"))
sv_setuv(sv, (UV) PL_unicode);
@@ -1085,6 +1088,7 @@
{
sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+ PERL_ASYNC_UNBLOCKED();
}
#endif
int
@@ -1175,11 +1179,15 @@
if(PL_psig_ptr[i]) {
to_dec=PL_psig_ptr[i];
PL_psig_ptr[i]=0;
+#ifdef HAS_SIGPROCMASK
LEAVE;
+#endif
SvREFCNT_dec(to_dec);
}
+#ifdef HAS_SIGPROCMASK
else
LEAVE;
+#endif
}
}
return 0;
@@ -1246,19 +1254,53 @@
void
Perl_despatch_signals(pTHX)
{
- int sig;
- PL_sig_pending = 0;
- for (sig = 1; sig < SIG_SIZE; sig++) {
- if (PL_psig_pend[sig]) {
- PERL_BLOCKSIG_ADD(set, sig);
- PL_psig_pend[sig] = 0;
- PERL_BLOCKSIG_BLOCK(set);
- (*PL_sighandlerp)(sig);
- PERL_BLOCKSIG_UNBLOCK(set);
+#ifdef HAS_SIGPROCMASK
+ sigset_t oldset;
+ int oldset_valid = 0;
+#endif
+ while(PL_sig_pending) {
+ int sig;
+ PL_sig_pending = 0;
+ for (sig = 1; sig < SIG_SIZE; sig++) {
+ if (PL_psig_pend[sig]) {
+ /*
+ * Because we leave the signal outstanding if it's pending but
+ * currently blocked, anything that unblocks a signal must
+ * then call PERL_ASYNC_UNBLOCKED() if the signal may have
+ * been blocked while PERL_ASYNC_CHECK() was called.
+ */
+ PERL_BLOCKSIG_ADD(set, sig);
+ PL_psig_pend[sig] = 0;
+#ifdef HAS_SIGPROCMASK
+ if(oldset_valid && sigismember(&oldset, sig)) {
+ PL_psig_pend[sig] = 1;
+ continue;
+ }
+ sigprocmask(SIG_BLOCK, &set, &oldset);
+ oldset_valid = sigismember(&oldset, sig);
+ if(oldset_valid) {
+ sigprocmask(SIG_SETMASK, &oldset, NULL);
+ PL_psig_pend[sig] = 1;
+ continue;
+ }
+#else
+ PERL_BLOCKSIG_BLOCK(set);
+#endif
+ (*PL_sighandlerp)(sig);
+ PERL_BLOCKSIG_UNBLOCK(set);
+ }
}
}
}
+static void reraise_pending_signal(I32 sig)
+{
+ if(PL_psig_pend[sig]) {
+ PL_psig_pend[sig] = 0;
+ PerlProc_kill(PerlProc_getpid(), sig);
+ }
+}
+
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
@@ -1345,6 +1387,7 @@
(void)rsignal(i, PL_csighandlerp);
#else
(void)rsignal(i, SIG_IGN);
+ reraise_pending_signal(i);
#endif
}
}
@@ -1357,6 +1400,7 @@
}
#else
(void)rsignal(i, SIG_DFL);
+ reraise_pending_signal(i);
#endif
}
else {
@@ -2122,6 +2166,9 @@
PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
#endif
break;
+ case '\002': /* ^B */
+ PL_sig_blocked = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ break;
case '\027': /* ^W & $^WARNING_BITS */
if (*(mg->mg_ptr+1) == '\0') {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
@@ -2256,7 +2303,7 @@
STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
else
#endif
- STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ STATUS_POSIX_SET_KILL(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '!':
{
diff -Naur perl-5.9.1/miniperlmain.c perl-5.9.1-sigexit/miniperlmain.c
--- perl-5.9.1/miniperlmain.c Fri Feb 20 07:29:31 2004
+++ perl-5.9.1-sigexit/miniperlmain.c Fri Oct 22 13:27:13 2004
@@ -91,7 +91,7 @@
PERL_SYS_TERM();
- exit(exitstatus);
+ PERL_EXIT_OR_KILL_SELF(exitstatus);
return exitstatus;
}
diff -Naur perl-5.9.1/perl.h perl-5.9.1-sigexit/perl.h
--- perl-5.9.1/perl.h Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/perl.h Fri Oct 22 14:35:46 2004
@@ -2080,6 +2080,10 @@
} \
else PL_statusvalue_vms = -1; \
} STMT_END
+/*
+ * XXX How do you propagate a signal in VMS? At the moment, it just exits 255.
+ */
+# define STATUS_POSIX_SET_KILL(n) STATUS_POSIX_SET(n)
# define STATUS_ALL_SUCCESS (PL_statusvalue = 0, PL_statusvalue_vms = 1)
# define STATUS_ALL_FAILURE (PL_statusvalue = 1, PL_statusvalue_vms = 44)
#else
@@ -2093,6 +2097,7 @@
if (PL_statusvalue != -1) \
PL_statusvalue &= 0xFFFF; \
} STMT_END
+# define STATUS_POSIX_SET_KILL(n) (PL_statusvalue = (n))
# define STATUS_CURRENT STATUS_POSIX
# define STATUS_ALL_SUCCESS (PL_statusvalue = 0)
# define STATUS_ALL_FAILURE (PL_statusvalue = 1)
@@ -2102,6 +2107,19 @@
#define PERL_EXIT_EXPECTED 0x01
#define PERL_EXIT_DESTRUCT_END 0x02 /* Run END in perl_destruct */
+/* how to terminate the process */
+#define PERL_EXIT_OR_KILL_SELF(n) \
+ STMT_START { \
+ U32 code = (n); \
+ U32 sig = code>>16; \
+ if(sig && !(sig & 0xFF80) && (code & 0xFFFF) == 0xFF) { \
+ (void)rsignal(sig, SIG_DFL); \
+ PerlProc_kill(PerlProc_getpid(), sig); \
+ PerlProc_exit(255); \
+ } \
+ PerlProc_exit(code); \
+ } STMT_END
+
#ifndef MEMBER_TO_FPTR
# define MEMBER_TO_FPTR(name) name
#endif
@@ -4007,12 +4025,21 @@
#ifndef PERL_MICRO
# ifndef PERL_ASYNC_CHECK
-# define PERL_ASYNC_CHECK() if (PL_sig_pending) despatch_signals()
+ /*
+ * XXX: This is used often enough that it might improve
+ * performance noticably to cache a copy of
+ * PL_sig_pending && !PL_sig_blocked
+ */
+# define PERL_ASYNC_CHECK() if (PL_sig_pending && !PL_sig_blocked) despatch_signals()
+# define PERL_ASYNC_CHECK_EINTR() if (PL_sig_pending && PL_sig_blocked <= 0) despatch_signals()
+# define PERL_ASYNC_UNBLOCKED() (PL_sig_pending = 1)
# endif
#endif
#ifndef PERL_ASYNC_CHECK
# define PERL_ASYNC_CHECK() NOOP
+# define PERL_ASYNC_CHECK_EINTR() NOOP
+# define PERL_ASYNC_UNBLOCKED() NOOP
#endif
/*
@@ -4373,8 +4400,14 @@
sigset_t set; sigemptyset(&(set)); sigaddset(&(set), sig)
# define PERL_BLOCKSIG_BLOCK(set) \
sigprocmask(SIG_BLOCK, &(set), NULL)
+/*
+ * XXX Maybe there should be a macro here that maps sigprocmask to a function
+ * that calls the real sigprocmask, followed by PERL_ASYNC_UNBLOCK() unless
+ * how == SIG_BLOCK. That way, existing extensions will be ported to do the
+ * right thing automatically.
+ */
# define PERL_BLOCKSIG_UNBLOCK(set) \
- sigprocmask(SIG_UNBLOCK, &(set), NULL)
+ STMT_START { sigprocmask(SIG_UNBLOCK, &(set), NULL); PERL_ASYNC_UNBLOCKED(); } STMT_END
#endif /* HAS_SIGPROCMASK && PERL_BLOCK_SIGNALS */
/* How about the old style of sigblock()? */
diff -Naur perl-5.9.1/perlio.c perl-5.9.1-sigexit/perlio.c
--- perl-5.9.1/perlio.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/perlio.c Wed Oct 20 18:18:24 2004
@@ -14,6 +14,20 @@
* at the dispatch tables, even when we do not need it for other reasons.
* Invent a dSYS macro to abstract this out
*/
+
+ /*
+ * XXX In a number of places, this tries to avoid getting stuck in a system
+ * call soon after a signal arrives, by calling PERL_ASYNC_CHECK() just before
+ * the system call. There is still a narrow window in which this could
+ * happen, although it is relatively unlikely. Ditto for pp_sys.c and util.c.
+ * The "correct" way to do this is always to do nonblocking calls, and if
+ * the caller wanted a blocking call, then spin in a select loop with a
+ * timeout of 250ms or so. That way, in the rare case that a signal arrives
+ * just before the select call, it gets stuck only for one timeout.
+ * Unfortunately, this prevents the OS from swapping out the process if it
+ * is legitimately blocked for a long time (e.g. waiting for tty input while
+ * the user is having lunch), so it's not a good thing to do by default.
+ */
#ifdef PERL_IMPLICIT_SYS
#define dSYS dTHX
#else
@@ -2478,6 +2492,7 @@
PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) {
return 0;
}
+ PERL_ASYNC_CHECK();
while (1) {
SSize_t len = PerlLIO_read(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
@@ -2492,7 +2507,7 @@
}
return len;
}
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
}
@@ -2500,6 +2515,7 @@
PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+ PERL_ASYNC_CHECK();
while (1) {
SSize_t len = PerlLIO_write(fd, vbuf, count);
if (len >= 0 || errno != EINTR) {
@@ -2510,7 +2526,7 @@
}
return len;
}
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
}
@@ -2536,12 +2552,13 @@
SETERRNO(EBADF,SS_IVCHAN);
return -1;
}
+ PERL_ASYNC_CHECK();
while (PerlLIO_close(fd) != 0) {
if (errno != EINTR) {
code = -1;
break;
}
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
if (code == 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
@@ -2986,6 +3003,7 @@
{
FILE *s = PerlIOSelf(f, PerlIOStdio)->stdio;
SSize_t got = 0;
+ PERL_ASYNC_CHECK();
for (;;) {
if (count == 1) {
STDCHAR *buf = (STDCHAR *) vbuf;
@@ -3005,7 +3023,7 @@
got = -1;
if (got >= 0 || errno != EINTR)
break;
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
SETERRNO(0,0); /* just in case */
}
return got;
@@ -3073,12 +3091,13 @@
PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
SSize_t got;
+ PERL_ASYNC_CHECK();
for (;;) {
got = PerlSIO_fwrite(vbuf, 1, count,
PerlIOSelf(f, PerlIOStdio)->stdio);
if (got >= 0 || errno != EINTR)
break;
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
SETERRNO(0,0); /* just in case */
}
return got;
diff -Naur perl-5.9.1/pod/perlipc.pod perl-5.9.1-sigexit/pod/perlipc.pod
--- perl-5.9.1/pod/perlipc.pod Fri Feb 20 07:30:51 2004
+++ perl-5.9.1-sigexit/pod/perlipc.pod Fri Oct 22 14:37:02 2004
@@ -388,7 +388,7 @@
"loop". In future Perl's signal mechanism may be changed to avoid this
- perhaps by simply disallowing %SIG handlers on signals of that
type. Until then the work-round is not to set a %SIG handler on those
-signals. (Which signals they are is operating system dependant.)
+signals. (Which signals they are is operating system dependent.)
=item Signals triggered by operating system state
@@ -407,6 +407,154 @@
memory corruption, set the environment variable C<PERL_SIGNALS> to
C<"unsafe"> (a new feature since Perl 5.8.1).
+=head1 Using $^B to Block Signals
+
+As of Perl 5.9.2, you can set C<$^B> to a positive integer in order
+to block trapped signals completely, if safe signals are in use.
+This is obviously dangerous, so you should do this only locally
+inside a block that will be exited within a reasonable period of time.
+
+For example, you can use it to implement a critical section so that
+signal handlers always see a self-consistent program state:
+
+ my ($a, $b) = (2, 3);
+ $SIG{HUP} = sub { die unless $a + $b == 5 };
+ {
+ local $^B = 1;
+ $a++;
+ # A signal won't be handled here.
+ $b--;
+ }
+
+Since C<$^B> is set automatically before calling the DESTROY method of
+an object whose package has $BLOCK_SIGNALS_IN_DESTROY set, you can
+reliably convert signals to exceptions, because the signal won't arrive
+in a destructor, from which exceptions are caught by the perl core.
+(See L<perlobj/"Destructors that Die">).
+
+Typically, you would do something like this in your main program:
+
+ sub catch { die "SIG$_[0]\n" }
+ eval {
+ # Signals that otherwise would cause the process to
+ # terminate immediately *without* a core dump. If a core
+ # dump is left behind for debugging, then you probably
+ # want to leave resources behind for debugging too.
+ local (
+ $SIG{HUP}, $SIG{INT}, $SIG{PIPE}, $SIG{ALRM},
+ $SIG{TERM}, $SIG{USR1}, $SIG{USR2}
+ ) = (\&catch) x 7;
+
+ # Now do what you want to do. Each resource to
+ # deallocate is represented by an object whose DESTROY
+ # method deallocates it.
+ };
+ if($@) {
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ die; # or 'die $@;' if you don't like "...propagated at"
+ }
+
+And your DESTROY methods would look like this:
+
+ BEGIN { $BLOCK_SIGNALS_IN_DESTROY = 1 }
+ sub DESTROY {
+ local ($@, $!, $?);
+
+ # Actions that can't die and won't be interrupted go here.
+
+ eval {
+ local $^B = 0;
+
+ # Actions that can die or may be interrupted go here.
+ };
+ warn "Failed to destroy $_[0] because $@" if $@;
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ }
+
+The main advantage of converting signals to exceptions is that it allows
+the program a chance to clean up resources allocated to the process, such
+as temporary files, that the operating system doesn't deallocate
+automatically when the program terminates.
+This is commonly known as the RAII (resource allocation is initialization)
+idiom.
+
+Actually, this isn't quite complete, because it kills the process before
+it has a chance to do global destruction.
+To fix that, you can instead set C<$?> to the signal number left-shifted by 16
+and or'ed with 0xFF in an END block:
+
+ # This goes before loading modules, so that it runs last
+ my $term_signal;
+ END { $? = $term_signal << 16 | 0xFF if $term_signal }
+
+ sub catch { die "SIG$_[0]\n" }
+ eval {
+ # eval body is the same as before
+ # ...
+ };
+ if($@) {
+ if($@=~/^SIG(\w+)$/) {
+ $term_signal = $signo{$1};
+ exit(-1);
+ }
+ die;
+ }
+
+See L</"Signals"> for how to initialize %signo.
+
+By setting C<$^B> to a negative integer, you can block interrupts
+I<except> for just after a system call fails with an interrupt, and
+the call would otherwise have been restarted by the Perl core.
+This provides a way to ensure that some action is reliably taken after
+a system call succeeds, while still allowing the call to be interrupted.
+Generally, you'll want to set C<$^B> back to a positive integer just after
+the system call succeeds, or else some subsequent system call could wind
+up calling a signal handler before you've finished with your critical section:
+
+ {
+ local $^B = -1;
+ my $pid = wait or die "wait failed because $!";
+ $^B = 1;
+
+ # We are guaranteed to get here if the wait succeeds.
+ delete $pids{$pid};
+ my $result{$pid} = <$fh{$pid}>;
+ }
+
+Because a signal that is blocked by the process signal mask is never handled
+(even if it arrived after the last sampling of signals before its bit in the
+mask was set), you can reliably unblock selected signals while C<$^B> is set:
+
+ use POSIX qw/:signal_h/;
+
+ my $interrupts = 0;
+ sub catch_cleanup {
+ if(++$interrupts == 2) {
+ print STDERR "One more interrupt to abort cleanup\n";
+ }
+ elsif($interrupts > 2) {
+ $SIG{INT} = 'DEFAULT';
+ kill "INT", $$;
+ }
+ }
+
+ BEGIN { $BLOCK_SIGNALS_IN_DESTROY = 1 }
+ sub DESTROY {
+ my $sigset = POSIX::SigSet->new();
+ for(qw/HUP PIPE ALRM TERM USR1 USR2/) {
+ $sigset->addset($signo{$_});
+ }
+ my $osset = POSIX::SigSet->new();
+ local $SIG{INT} = \&catch_cleanup;
+ sigprocmask(SIG_BLOCK, $sigset, $osset);
+ {
+ local $^B = 0;
+
+ # Now do real cleanup work
+ }
+ sigprocmask(SIG_SETMASK, $osset);
+ }
+
=head1 Using open() for IPC
Perl's basic open() statement can also be used for unidirectional
diff -Naur perl-5.9.1/pod/perlobj.pod perl-5.9.1-sigexit/pod/perlobj.pod
--- perl-5.9.1/pod/perlobj.pod Fri Feb 20 07:30:57 2004
+++ perl-5.9.1-sigexit/pod/perlobj.pod Fri Oct 22 14:28:23 2004
@@ -455,6 +455,49 @@
when the current object is freed, provided no other references to them exist
elsewhere.
+=head2 Destructors that Die
+
+If the DESTROY method dies, then the error is caught in the perl core where
+the method was called.
+The message is prefixed with the string "\t(in cleanup)", and if C<$^W> is set,
+then it is printed to STDERR.
+The message is then appended to the existing value of $@, if any.
+This is usually a good thing, because there may be some other error that
+caused the object to go out of scope to begin with, and it would be bad to
+discard either that error or the destructor error.
+
+Although reporting the errors in the order that they occurred is intuitive,
+modifying $@ during the propagation of the error can interfere with code that
+attempts to catch the original error outside an eval (especially if $@
+originally contains a reference, in which case the reference is discarded
+completely when the destructor error is appended.)
+For this reason, it is usually best for the DESTROY method to promise never
+to die at all, and furthermore not to spoil $@, $!, $^E and $?:
+
+ sub DESTROY {
+ my $self = shift;
+ # Without the 'local', the DESTROY error is printed twice,
+ # the first error is lost, and the exit status is wrong.
+ local ($@, $!, $^E, $?);
+ eval {
+ $! = 1;
+ die "failed because $!";
+ };
+ warn "Destroying $self: $@" if $@;
+ }
+
+ eval {
+ my $a = bless [];
+ $! = 2;
+ die "Oops!";
+ };
+ die if $@;
+
+An unfortunate side-effect of catching errors in destructors is that
+a signal handler that dies won't terminate the program if gets called
+within a destructor.
+See L<perlipc/"Using $^B to Block Signals"> for a way to avoid that.
+
=head2 Summary
That's about all there is to it. Now you need just to go off and buy a
diff -Naur perl-5.9.1/pod/perlvar.pod perl-5.9.1-sigexit/pod/perlvar.pod
--- perl-5.9.1/pod/perlvar.pod Fri Feb 20 07:31:27 2004
+++ perl-5.9.1-sigexit/pod/perlvar.pod Fri Oct 22 13:56:01 2004
@@ -637,6 +637,13 @@
$? = 1 if $? == 255; # die would make it 255
}
+If at the end of an C<END> subroutine, C<$? E<gt>E<gt> 16> is a signal number
+between 1 and 127, inclusive, and C<$? & 0xFFFF> is C<0x00FF>, then
+the process will terminate with the signal (if possible) after global
+destruction.
+If the signal's default action doesn't result in the termination of the
+process, then the exit value is 255.
+
Under VMS, the pragma C<use vmsish 'status'> makes C<$?> reflect the
actual VMS exit status, instead of the default emulation of POSIX
status; see L<perlvms/$?> for details.
@@ -1221,6 +1228,27 @@
{$secure_perl_path .= $Config{_exe}
unless $secure_perl_path =~ m/$Config{_exe}$/i;}
+=item $BLOCK_SIGNAL_HANDLERS
+
+=item $^B
+
+If set to a nonzero integer, then don't sample signals that are
+dispositioned to a handler.
+Signals are still accumulated.
+Has no effect if unsafe signals are in use
+(see L<perlipc/"Deferred Signals (Safe Signals)">).
+
+This can be used to block all such signals without the overhead of a system call.
+It is automatically set locally before calling the DESTROY method of an object
+that is going out of scope, but only if the object's package has
+$BLOCK_SIGNALS_IN_DESTROY set.
+
+If set to a negative integer, then signals are checked I<only> immediately
+after a system call returns EINTR, and would otherwise be restarted by the
+Perl core.
+
+See L<perlipc/"Using $^B to Block Signals">.
+
=item ARGV
The special filehandle that iterates over command-line filenames in
diff -Naur perl-5.9.1/pp_sys.c perl-5.9.1-sigexit/pp_sys.c
--- perl-5.9.1/pp_sys.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/pp_sys.c Wed Oct 20 14:17:46 2004
@@ -4083,9 +4083,10 @@
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
childpid = wait4pid(-1, &argflags, 0);
else {
+ PERL_ASYNC_CHECK();
while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
errno == EINTR) {
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
@@ -4115,9 +4116,10 @@
if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
result = wait4pid(pid, &argflags, optype);
else {
+ PERL_ASYNC_CHECK();
while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
errno == EINTR) {
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
}
# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
diff -Naur perl-5.9.1/scope.h perl-5.9.1-sigexit/scope.h
--- perl-5.9.1/scope.h Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/scope.h Thu Oct 21 17:43:15 2004
@@ -355,7 +355,7 @@
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
} \
if ((v) == 2) \
- PerlProc_exit(STATUS_NATIVE_EXPORT); \
+ PERL_EXIT_OR_KILL_SELF(STATUS_NATIVE_EXPORT); \
PerlIO_printf(Perl_error_log, "panic: top_env\n"); \
PerlProc_exit(1); \
} STMT_END
@@ -391,7 +391,7 @@
if (PL_top_env->je_prev) \
PerlProc_longjmp(PL_top_env->je_buf, (v)); \
if ((v) == 2) \
- PerlProc_exit(STATUS_NATIVE_EXPORT); \
+ PERL_EXIT_OR_KILL_SELF(STATUS_NATIVE_EXPORT); \
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
PerlProc_exit(1); \
} STMT_END
diff -Naur perl-5.9.1/sv.c perl-5.9.1-sigexit/sv.c
--- perl-5.9.1/sv.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/sv.c Wed Oct 20 10:48:21 2004
@@ -5376,6 +5376,12 @@
=cut
*/
+static void
+restore_sig_blocked(pTHX_ SV *save_sv)
+{
+ PL_sig_blocked = SvIV( save_sv );
+}
+
void
Perl_sv_clear(pTHX_ register SV *sv)
{
@@ -5394,9 +5400,26 @@
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
+ /*
+ * XXX: Maybe we should look in the package containing
+ * the DESTROY method, instead of the object's package.
+ */
+ GV** gvp = (GV**)hv_fetch(stash, "BLOCK_SIGNALS_IN_DESTROY", 24, FALSE);
+ SV* block_sig_class = (gvp && *gvp != (GV*)&PL_sv_undef) ? GvSV(*gvp) : Nullsv;
SV* tmpref = newRV(sv);
SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
ENTER;
+ /*
+ * XXX: There probably ought to be some way to globally
+ * opt for this to default active
+ * ('block_sig_class == Nullsv || SvTRUE(block_sig_class').
+ */
+ if(SvTRUE(block_sig_class)) {
+ SV* save_sv = newSViv(PL_sig_blocked);
+ SAVEFREESV(save_sv);
+ SAVEDESTRUCTOR_X(restore_sig_blocked, save_sv);
+ PL_sig_blocked = 1;
+ }
PUSHSTACKi(PERLSI_DESTROY);
EXTEND(SP, 2);
PUSHMARK(SP);
diff -Naur perl-5.9.1/t/op/blocksig.t perl-5.9.1-sigexit/t/op/blocksig.t
--- perl-5.9.1/t/op/blocksig.t Wed Dec 31 16:00:00 1969
+++ perl-5.9.1-sigexit/t/op/blocksig.t Fri Oct 22 14:25:35 2004
@@ -0,0 +1,221 @@
+#!./perl
+
+use strict;
+BEGIN { $^W = 1 }
+
+BEGIN {
+ $| = 1;
+ chdir 't' if -d 't';
+ $SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
+}
+
+print "1..31\n";
+
+my ($a, $b) = (2, 3);
+my $c;
+$SIG{INT} = sub { $c = defined($c) ? undef : ($a + $b == 5); };
+
+if(defined($^B) && !$^B) {print "ok 1\n";} else {print "not ok 1\n";}
+
+{
+ # Check basic critical section
+ local $^B = 1;
+ $a++;
+ kill "INT", $$;
+ $b--;
+ if($^B) {print "ok 2\n";} else {print "not ok 2\n";}
+}
+
+if(defined($^B) && !$^B) {print "ok 3\n";} else {print "not ok 3\n";}
+if(defined $c) {print "ok 4\n";} else {print "not ok 4\n";}
+if($c) {print "ok 5\n";} else {print "not ok 5\n";}
+
+our $BLOCK_SIGNALS_IN_DESTROY = 1;
+my $testnum = 6;
+sub DESTROY {
+ my $ok = $^B;
+ $ok = !$ok if $testnum == 10;
+ if($ok) {print "ok $testnum\n";} else {print "not ok $testnum\n";}
+ kill "INT", $$;
+ $b--;
+}
+
+# Check that $^B is set in destructor if $BLOCK_SIGNALS_IN_DESTROY
+{
+ my $obj = bless [];
+ $a++;
+ undef $c;
+ # DESTROY gets called here
+}
+if(defined($^B) && !$^B) {print "ok 7\n";} else {print "not ok 7\n";}
+if(defined $c) {print "ok 8\n";} else {print "not ok 8\n";}
+if($c) {print "ok 9\n";} else {print "not ok 9\n";}
+
+# Check that $^B is *not* set in destructor unless $BLOCK_SIGNALS_IN_DESTROY
+$BLOCK_SIGNALS_IN_DESTROY = 0;
+{
+ my $obj = bless [];
+ $a++;
+ undef $c;
+ $testnum = 10;
+ # DESTROY gets called here
+}
+if(defined $c) {print "ok 11\n";} else {print "not ok 11\n";}
+if(!$c) {print "ok 12\n";} else {print "not ok 12\n";}
+
+# Check that $^B is reset in this scope
+undef $c;
+kill "INT", $$;
+if($c) {print "ok 13\n";} else {print "not ok 13\n";}
+
+# Check the typical RAII behavior
+{ package Class;
+
+ our $BLOCK_SIGNALS_IN_DESTROY = 1;
+ sub DESTROY {
+ local($@, $!, $^E, $?);
+ kill "INT", $$;
+ my $x;
+ eval {
+ $? = 256;
+ $! = 1;
+ local $^B = 0;
+ $x = 1;
+ };
+ if($@ eq "SIGINT\n") {print "ok 14\n";} else {print "not ok 14\n";}
+ if(!$x) {print "ok 15\n";} else {print "not ok 15\n";}
+ if($! == 1) {print "ok 16\n";} else {print "not ok 16\n";}
+ if($? == 256) {print "ok 17\n";} else {print "not ok 17\n";}
+ kill $1, $$ if $@=~/^SIG(\w+)$/;
+ }
+
+ sub catch { die "SIG$_[0]\n" }
+
+ eval {
+ local ($SIG{INT}) = (\&catch);
+ {
+ my $obj = bless [];
+ $! = 2;
+ $? = 512;
+ }
+ # Before we get here, the signal propagated by the destuctor takes
+ # effect.
+ $! = 3;
+ $? = 768;
+ };
+ if($@ eq "SIGINT\n") {print "ok 18\n";} else {print "not ok 18\n";}
+ if($! == 2) {print "ok 19\n";} else {print "not ok 19\n";}
+ if($? == 512) {print "ok 20\n";} else {print "not ok 20\n";}
+}
+
+# Check that interrupts are sampled merely by { local $^B = 0; }.
+{
+ local $^B = 1;
+ undef $c;
+ kill "INT", $$;
+ if(!defined $c) {print "ok 21\n";} else {print "not ok 21\n";}
+ { local $^B = 0; }
+ if($c) {print "ok 22\n";} else {print "not ok 22\n";}
+}
+
+# Check that we can interrupt a system call only
+undef $c;
+# XXX: Figure out a way to do this without fork, which doesn't work everywhere
+my $ppid = $$;
+my $pid = open(KID_TO_READ, "-|");
+defined $pid or die;
+unless($pid) {
+ $SIG{INT} = "DEFAULT";
+ sleep 1;
+ kill "INT", $ppid;
+ print "x";
+ sleep 1;
+ kill "INT", $ppid;
+ exit(0);
+}
+
+{
+ my $x;
+ local $^B = -1;
+ my $ret = read(KID_TO_READ, $x, 1);
+ $^B = 1;
+ if($x eq "x") {print "ok 23\n";} else {print "not ok 23\n";}
+ if($c) {print "ok 24\n";} else {print "not ok 24\n";}
+
+ # Now make sure that the signal got consumed
+ undef $c;
+ { local $^B = 0; print ""; }
+ if(!defined $c) {print "ok 25\n";} else {print "not ok 25\n";}
+
+ # Now make sure that syscalls do *not* call handler if $^B > 0
+ undef $c;
+ $ret = read(KID_TO_READ, $x, 1);
+ close(KID_TO_READ);
+ if(!defined $c) {print "ok 26\n";} else {print "not ok 26\n";}
+
+ undef $c;
+}
+# Make sure that the signal wasn't consumed until $^B was reset
+if($c) {print "ok 27\n";} else {print "not ok 27\n";}
+
+my %signo;
+{
+ use Config;
+ my $i;
+ foreach my $name (split(' ', $Config{sig_name})) {
+ $signo{$name} = $i++;
+ }
+}
+
+{ package Class2;
+ use POSIX qw/:signal_h/;
+
+ my $interrupts = 0;
+ sub catch_cleanup {
+ ++$interrupts;
+ }
+
+ $SIG{TERM} = \&catch_cleanup;
+
+ our $BLOCK_SIGNALS_IN_DESTROY = 1;
+ sub DESTROY {
+ my $sigset = POSIX::SigSet->new();
+ for(qw/HUP PIPE ALRM TERM USR1 USR2/) {
+ $sigset->addset($signo{$_});
+ }
+ my $osset = POSIX::SigSet->new();
+ local $SIG{INT} = \&catch_cleanup;
+ sigprocmask(SIG_BLOCK, $sigset, $osset);
+ {
+ local $^B = 0;
+ kill "INT", $$;
+ kill "TERM", $$;
+ kill "INT", $$;
+ }
+ sigprocmask(SIG_SETMASK, $osset);
+ if($interrupts == 2) {print "ok 28\n";} else {print "not ok 28\n";}
+ }
+ bless [];
+ if($interrupts == 3) {print "ok 29\n";} else {print "not ok 29\n";}
+
+ {
+ local $^B = 1;
+ kill "TERM", $$;
+ $SIG{TERM} = 'IGNORE';
+ }
+ if($interrupts == 3) {print "ok 30\n";} else {print "not ok 30\n";}
+}
+
+my $termsig;
+END {
+ $? = $termsig << 16 | 0xFF if $termsig;
+}
+
+defined($pid = fork) or die;
+unless($pid) {
+ $termsig = $signo{"INT"};
+ exit(-1);
+}
+waitpid($pid,0) or die;
+if($? == $signo{INT}) {print "ok 31\n";} else {print "not ok 31\n";}
+
diff -Naur perl-5.9.1/util.c perl-5.9.1-sigexit/util.c
--- perl-5.9.1/util.c Tue Mar 16 10:36:08 2004
+++ perl-5.9.1-sigexit/util.c Wed Oct 20 14:23:27 2004
@@ -2457,6 +2457,7 @@
}
}
#endif
+ PERL_ASYNC_CHECK();
#ifdef HAS_WAITPID
# ifdef HAS_WAITPID_RUNTIME
if (!HAS_WAITPID_RUNTIME)
@@ -2484,7 +2485,7 @@
#endif
finish:
if (result < 0 && errno == EINTR) {
- PERL_ASYNC_CHECK();
+ PERL_ASYNC_CHECK_EINTR();
}
return result;
} Perl Info
|
From @JohnPeacockajohnson@nvidia.com (via RT) wrote:
Just to save some else a trip to Google, this seems to be a concise description http://www.hackcraft.net/raii/ since I was not familiar with this term. I have no immediate opinion on the John -- |
The RT System itself - Status changed from 'new' to 'open' |
From perl5-porters@ton.iguana.beIn article <rt-3.0.11-32104-98306.15.1628489111989@perl.org>, mm, you add a variable lookup to every DESTROY, meaning DESTROY gets The "attach text" thing is not just DESTROY though, it's the G_KEEPERR (I also notice that the "message collapsing" of "\t(in cleanup)" isn't |
The RT System itself - Status changed from 'new' to 'open' |
From gp@familiehaase.deajohnson@nvidia.com (via RT) wrote:
Just to save some else a trip to Google, this seems to be a concise http://www.hackcraft.net/raii/ since I was not familiar with this term. I have no immediate opinion on John -- !DSPAM:417a441612951183914076! |
From nick@ing-simmons.netAjohnson @ Nvidia . Com <perl5-porters@perl.org> writes:
What the heck is 'RAII' ?
Using perl for something that needs 'as soon as possible' may be the
I have no particular axe to grind on the signal stuff. While complete patches are welcome, radical ideas which introduce Signals are also very UNIXy (Win32 doesn't have them) and even in UNIX Can you tell us which systems this works on?
I very much doubt that this level of hackery is sufficient to |
From nick@ing-simmons.netTon Hospel <perl5-porters@ton.iguana.be> writes:
Not good.
I didn't even know what RAII meant till John P. posted the link,
|
From ajohnson@nvidia.comThis works on Linux 2.4.26 i686. I do not expect these patches to port In case anyone hasn't seen it yet, the link posted by John Peacock gives "ASAP" just means that the program shouldn't just keep going as if the It is almost certainly true that this won't do a bona-fide critical With regard to the performance hit in calling DESTROY, that can be dealt WHY *SOMETHING* NEEDS TO BE DONE: I think that it is deplorable that Perl doesn't do RAII, an idiom that Submitting this patch is my attempt to get the issue taken seriously and Thanks, -----Original Message----- Ajohnson @ Nvidia . Com <perl5-porters@perl.org> writes:
What the heck is 'RAII' ?
Using perl for something that needs 'as soon as possible' may be the
I have no particular axe to grind on the signal stuff. While complete patches are welcome, radical ideas which introduce Signals are also very UNIXy (Win32 doesn't have them) and even in UNIX Can you tell us which systems this works on?
I very much doubt that this level of hackery is sufficient to |
From ajohnson@nvidia.comYes, perhaps it's better to document this by describing the behavior in However, from my point of view (of which anyone is welcome to disabuse In other words, if you get an "(in cleanup)" message at all, then the Thanks, -----Original Message----- In article <rt-3.0.11-32104-98306.15.1628489111989@perl.org>, mm, you add a variable lookup to every DESTROY, meaning DESTROY gets The "attach text" thing is not just DESTROY though, it's the G_KEEPERR (I also notice that the "message collapsing" of "\t(in cleanup)" isn't |
From nick@ing-simmons.netAnders Johnson <AJohnson@nvidia.com> writes:
I think is deplorable that C++ doesn't do END blocks or support In particular, not supporting them it The perl idiom is different. |
From ajohnson@nvidia.comIt's not clear to me that this is ultimately a question of idiom, As I understand it, the philosophy of Perl is "easy things are easy, and (At the risk of degenerating into a language war, the deficiencies of Perhaps I'm the only person in the world who cares that Perl can't do &ers -----Original Message----- Anders Johnson <AJohnson@nvidia.com> writes:
I think is deplorable that C++ doesn't do END blocks or support In particular, not supporting them it The perl idiom is different. |
From dm.list@math2.orgAnders Johnson wrote:
I was actually just thinking tonight about how to implement RAII in My immediate reason for wanting RAII in Perl is for a clean way to sub modify Obviously, if the second or third statement throws an exception, the use Error qw(:try); The Perlish form is similarly ugly: sub modify The nesting and exception handling of both forms distract from the use MyLockClass; where the MyLockClass's constructors and finalizers contain the generic Syntactic sugar may be preferred as well if it can be made to work: use MyLockPackage qw(lock); The following CPAN module does take an RAII-like approach on a related http://search.cpan.org/~cmanley/Mysql-Locker/lib/Mysql/Locker.pm However, it requires an undesirable explicit call the "undef" function -david manura Anders Johnson wrote:
|
From dm.list@math2.orgI'll need to revise my below post. On doing additional searching, I http://www.perl.com/pub/a/2000/12/p5pdigest/THISWEEK-20001210.html sub x::DESTROY {print shift->[0]} Where I got confused is that this type of code does not work intuitively -david manura dm.list wrote:
|
From nick@ing-simmons.netYves Orton <yves.orton@de.mci.com> writes:
There has been a recent thread to the effect that blessing subs
If all we want is a way to execute some code on scope exot
|
From @demerphq
Yeah good point.
Can this be done from Perl though? Yves |
From perl5-porters@ton.iguana.beIn article <FEE662BF3FC168428F3C828EBB8D86DA01BC1AF7@hqemmail05.nvidia.com>,
But this isn't about multiple outstanding error. See the example I give below I also don't see why you want to make the setting per class. An interrupt About the "expensive code" issue, how about making the variable that turns
Mm, interesting read (even though I think the argumentation is sloppy and #!/usr/bin/perl -wl Which will print: It only looks like a double exception issue if the DESTROY happened while an |
From dm.list@math2.orgA quite different way is to do something like the below. This approach ==== test.pl ==== scope { ==== Scope.pm ==== our %EXPORT_TAGS = (all => [qw(scope acquire cleanup)]); sub scope(&) ==== MyLock.pm ==== our %EXPORT_TAGS = (all => [qw(my_lock)]); sub new Here's something related (using B): -david manura Orton, Yves wrote:
Orton, Yves wrote:
|
From ajohnson@nvidia.comAt Nick's request, here is an explanation of the problem that the When a process receives an interrupt (e.g. ctrl-C), the usual desired One way to achieve this behavior is to allocate to the process only However, there are many types of resources of which this is not true, Another way to achieve this behavior is for every outstanding resource There are a few problems with this approach. First and foremost is that Second, assuming that an immediate exit is desired, there is no way to Finally, if the signal arrives in the middle of a DESTROY method or an The other way to interrupt the normal flow of control in Perl is to The central idea of the patches that I submitted is to block (defer) The patch further provides a way to re-enable signal handlers so that if The patches also contain a certain amount of miscellaneous signal Thanks, |
From @ysthOn Thu, Oct 28, 2004 at 12:19:37PM +0100, Nick Ing-Simmons wrote:
AIUI, that problem only applies to non-closures, and this is a closure. |
From nick@ing-simmons.netDm.List <dm.list@math2.org> writes:
How does my example between the lines no do what you want it to do? #!perl sub DESTROY $SIG{INT} = sub { die "Killed" }; sub modify eval { modify(); }; __END__
|
1 similar comment
From nick@ing-simmons.netDm.List <dm.list@math2.org> writes:
How does my example between the lines no do what you want it to do? #!perl sub DESTROY $SIG{INT} = sub { die "Killed" }; sub modify eval { modify(); }; __END__
|
From nick@ing-simmons.netYves Orton <yves.orton@de.mci.com> writes:
Not directly. But adding a hook to existing XS utilities seems prefereable
|
From @demerphq
I havent the foggiest what this would look like. Do you mean something along Yves |
From nick@ing-simmons.netYves Orton <yves.orton@de.mci.com> writes:
Exactly, may be as good a place to put it as any ;-) sub modify }
The attached seems to suffice to demonstrate the mechanics. |
From nick@ing-simmons.net#include <EXTERN.h> static void MODULE = Scope PACKAGE = Scope void on_scope_exit(SV *subref) |
From @davidnicolDoes anyone feel a need for some perl modules to facilitate locking against a |
From kstar@cpan.orgOn Fri, 5 Nov 2004 00:43:28 -0600, David Nicol <davidnicol@gmail.com> wrote:
Could you say more about that? Perhaps with a couple of specific examples? - Kurt |
From @davidnicola distributed lock manager written entirely in Perl. I proposed Building one as a web service atop HTTP::Server::Singlethreaded would be really Googling for "distributed lock manager semantics" gives a pile of It is my belief that flock semantics (SH,EX,UN,NB) plus a way to Would anyone use the system, if the distributed lock manager client locking # initialize DLM to refer to the DLM server ... # During resource acquisition, tie something to DLM to obtain a lock when $sharedlock is destroyed, a message would go to the DLM server to release If a lock address can be build from a resource address, perhaps by Or is there a problem with doing networking in DESTROY blocks that I On Fri, 5 Nov 2004 16:03:01 -0500, Kurt Starsinic <kstarsinic@gmail.com> wrote:
-- |
@jkeenan - Status changed from 'new' to 'open' |
Migrated from rt.perl.org#32103 (status was 'open')
Searchable as RT32103$
The text was updated successfully, but these errors were encountered: