Skip to content
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

Open
p5pRT opened this issue Oct 23, 2004 · 36 comments
Open

Perl doesn't support RAII, part 1 [patch included] #7556

p5pRT opened this issue Oct 23, 2004 · 36 comments

Comments

@p5pRT
Copy link

p5pRT commented Oct 23, 2004

Migrated from rt.perl.org#32103 (status was 'open')

Searchable as RT32103$

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

From ajohnson@nvidia.com

Created by ajohnson@nvidia.com

This is a bug report for perl from ajohnson@​nvidia.com,
generated with the help of perlbug 1.35 running under perl v5.9.1.

-----------------------------------------------------------------
[This is the first of 4 related bug reports.
This patch is expected to be the least controversial of the 4.
Copying Nick because the remaining 3 patches touch his stuff.]

The behavior of Perl when a DESTROY method dies is non-obvious and
undocumented.

It also prevents doing RAII in Perl. (Over the past few years, I have
pointed this issue out to a number of experts, including Nick, and
nobody has presented to me a satisfactory way of doing it.)

The following patch should address the documentation problem​:

Inline Patch
diff -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

Flags:
    category=docs
    severity=low

Site configuration information for perl v5.9.1:

Configured by ajohnson at Fri Oct 22 16:25:05 PDT 2004.

Summary of my perl5 (revision 5 version 9 subversion 1) configuration:
  Platform:
    osname=linux, osvers=2.4.25, archname=i686-linux
    uname='linux l-sim-13-137 2.4.25 #1 smp tue apr 13 08:54:55 pdt 2004 i686 unknown '
    config_args='-Dusedevel -Dversiononly -Dprefix=/home/ajohnson/tools -de'
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=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 -lcrypt -lutil -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
    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='-Wl,-E'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    


@INC for perl v5.9.1:
    /home/ajohnson/tools/lib/perl5/5.9.1/i686-linux
    /home/ajohnson/tools/lib/perl5/5.9.1
    /home/ajohnson/tools/lib/perl5/site_perl/5.9.1/i686-linux
    /home/ajohnson/tools/lib/perl5/site_perl/5.9.1
    /home/ajohnson/tools/lib/perl5/site_perl
    .


Environment for perl v5.9.1:
    HOME=/home/ajohnson
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH=.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:/home/lsf_linux/6.0/linux2.4-glibc2.2-x86/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/usr/lib
    LOGDIR (unset)
    PATH=/home/nc4.42/tools/bin:/home/nc4.42/tools/dfII/bin:.:/home/ajohnson/bin:/home/gnu/bin:/usr/bin:/usr/openwin/bin:/sbin:/usr/sbin:/usr/ucb:/usr/ccs/bin:/usr/dt/bin:/bin:/usr/lib:/etc:/home/nv/bin:/home/gnu/X11R6.3/lib:/usr/bin/X11:/usr/local/lsf/bin:/usr/local/wp/wpbin:/usr/local/lsf/bin:/home/tools/td/td5303/linux/bin:/home/synopsys/2000.11/linux/syn/bin:/home/synopsys/pt_2000.11/linux/syn/bin:/home/synopsys/2000.11/linux/mc/bin:/home/synopsys/fm_2001.08/linux/fm/bin:/home/frame/bin:/home/tools/verilint/2001.4.10-linux2.2:/home/tools/vcs/vcs_latest/virsimdir//bin:/home/xl_98/tools/verilog/bin:/home/xl_98/tools/bin:/home/tools/vcs/vcs_latest/bin:/home/powerview:/home/powerview/standard:/home/tools/debussy/latest/bin:/home/tools/debussy/verdi_latest/bin:/home/imodl/p6/bin/i686-linux2.4.25
    PERL_BADLANG (unset)
    SHELL=/home/gnu/bin/tcsh

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

From ajohnson@nvidia.com

Created by ajohnson@nvidia.com

This is a bug report for perl from ajohnson@​nvidia.com,
generated with the help of perlbug 1.35 running under perl v5.9.1.

-----------------------------------------------------------------
[This is the second of 4 related bug reports. ([perl #32103])
This patch is expected to be relatively uncontroversial.
Copying Nick because it touches his stuff.]

Perl doesn't support (I can't figure out a way to do) RAII.
I need to be able to respond to a signal by terminating the process
ASAP after deallocating all outstanding resources (such as temporary files).

The OO way to do this is to have every outstanding resource represented
by an object whose DESTROY method deallocates the object.
If the signal handler terminates the process, then this doesn't happen.
If the signal handler dies, then the signal gets lost if it happens to
arrive while the interpreter is inside a DESTROY method.

Also, it should be possible to respond to a signal by jumping out to the
end of some outer scope without terminating the process at all, so it's
not good enough for the handler to somehow know about all the objects,
destroy them, and then terminate the process.

This patch addresses the problem by adding a new special variable to the
Perl core. Please refer to the POD changes in the patch for details.
Patch is relative to the 5.9.1 release.

Inline Patch
diff -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

Flags:
    category=core
    severity=low

Site configuration information for perl v5.9.1:

Configured by ajohnson at Fri Oct 22 16:25:05 PDT 2004.

Summary of my perl5 (revision 5 version 9 subversion 1) configuration:
  Platform:
    osname=linux, osvers=2.4.25, archname=i686-linux
    uname='linux l-sim-13-137 2.4.25 #1 smp tue apr 13 08:54:55 pdt 2004 i686 unknown '
    config_args='-Dusedevel -Dversiononly -Dprefix=/home/ajohnson/tools -de'
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=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 -lcrypt -lutil -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
    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='-Wl,-E'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    


@INC for perl v5.9.1:
    /home/ajohnson/tools/lib/perl5/5.9.1/i686-linux
    /home/ajohnson/tools/lib/perl5/5.9.1
    /home/ajohnson/tools/lib/perl5/site_perl/5.9.1/i686-linux
    /home/ajohnson/tools/lib/perl5/site_perl/5.9.1
    /home/ajohnson/tools/lib/perl5/site_perl
    .


Environment for perl v5.9.1:
    HOME=/home/ajohnson
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH=.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:/home/lsf_linux/6.0/linux2.4-glibc2.2-x86/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/usr/lib
    LOGDIR (unset)
    PATH=/home/nc4.42/tools/bin:/home/nc4.42/tools/dfII/bin:.:/home/ajohnson/bin:/home/gnu/bin:/usr/bin:/usr/openwin/bin:/sbin:/usr/sbin:/usr/ucb:/usr/ccs/bin:/usr/dt/bin:/bin:/usr/lib:/etc:/home/nv/bin:/home/gnu/X11R6.3/lib:/usr/bin/X11:/usr/local/lsf/bin:/usr/local/wp/wpbin:/usr/local/lsf/bin:/home/tools/td/td5303/linux/bin:/home/synopsys/2000.11/linux/syn/bin:/home/synopsys/pt_2000.11/linux/syn/bin:/home/synopsys/2000.11/linux/mc/bin:/home/synopsys/fm_2001.08/linux/fm/bin:/home/frame/bin:/home/tools/verilint/2001.4.10-linux2.2:/home/tools/vcs/vcs_latest/virsimdir//bin:/home/xl_98/tools/verilog/bin:/home/xl_98/tools/bin:/home/tools/vcs/vcs_latest/bin:/home/powerview:/home/powerview/standard:/home/tools/debussy/latest/bin:/home/tools/debussy/verdi_latest/bin:/home/imodl/p6/bin/i686-linux2.4.25
    PERL_BADLANG (unset)
    SHELL=/home/gnu/bin/tcsh

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

From ajohnson@nvidia.com

Created by ajohnson@nvidia.com

This is a bug report for perl from ajohnson@​nvidia.com,
generated with the help of perlbug 1.35 running under perl v5.9.1.

-----------------------------------------------------------------
[This is the third of 4 related bug reports. ([perl #32103], [perl #32104])
This patch is expected to be somewhat controversial.
Copying Nick because it touches his stuff.]

Even after applying the perl-5.9.1-blocksigs patch, there
are still a number of remaining signal-handling issues.

First, you can't do a critical section involving a blocking system
call without preventing interrupts from being ignored while the
system call is blocked. That's fixed by setting $^B to -1.

Second, it can call the handlers of pending but blocked signals,
so there is no reliable way to block individual signals. The patch also
addresses that problem.

The patch also cleans up a number of miscellaneous signal handling issues,
such as making sure that the window in which signals can get stuck as
small as possible (see new comment in perlio.c).

*** This patch has a compatibility issue for existing extensions that call
sigprocmask. See new comment in perl.h for details.

Please refer to the POD changes in the patch for details.
Patch is relative to the 5.9.1 release.

Inline Patch
diff -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

Flags:
    category=core
    severity=low

Site configuration information for perl v5.9.1:

Configured by ajohnson at Fri Oct 22 16:25:05 PDT 2004.

Summary of my perl5 (revision 5 version 9 subversion 1) configuration:
  Platform:
    osname=linux, osvers=2.4.25, archname=i686-linux
    uname='linux l-sim-13-137 2.4.25 #1 smp tue apr 13 08:54:55 pdt 2004 i686 unknown '
    config_args='-Dusedevel -Dversiononly -Dprefix=/home/ajohnson/tools -de'
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=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 -lcrypt -lutil -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
    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='-Wl,-E'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    


@INC for perl v5.9.1:
    /home/ajohnson/tools/lib/perl5/5.9.1/i686-linux
    /home/ajohnson/tools/lib/perl5/5.9.1
    /home/ajohnson/tools/lib/perl5/site_perl/5.9.1/i686-linux
    /home/ajohnson/tools/lib/perl5/site_perl/5.9.1
    /home/ajohnson/tools/lib/perl5/site_perl
    .


Environment for perl v5.9.1:
    HOME=/home/ajohnson
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH=.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:/home/lsf_linux/6.0/linux2.4-glibc2.2-x86/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/usr/lib
    LOGDIR (unset)
    PATH=/home/nc4.42/tools/bin:/home/nc4.42/tools/dfII/bin:.:/home/ajohnson/bin:/home/gnu/bin:/usr/bin:/usr/openwin/bin:/sbin:/usr/sbin:/usr/ucb:/usr/ccs/bin:/usr/dt/bin:/bin:/usr/lib:/etc:/home/nv/bin:/home/gnu/X11R6.3/lib:/usr/bin/X11:/usr/local/lsf/bin:/usr/local/wp/wpbin:/usr/local/lsf/bin:/home/tools/td/td5303/linux/bin:/home/synopsys/2000.11/linux/syn/bin:/home/synopsys/pt_2000.11/linux/syn/bin:/home/synopsys/2000.11/linux/mc/bin:/home/synopsys/fm_2001.08/linux/fm/bin:/home/frame/bin:/home/tools/verilint/2001.4.10-linux2.2:/home/tools/vcs/vcs_latest/virsimdir//bin:/home/xl_98/tools/verilog/bin:/home/xl_98/tools/bin:/home/tools/vcs/vcs_latest/bin:/home/powerview:/home/powerview/standard:/home/tools/debussy/latest/bin:/home/tools/debussy/verdi_latest/bin:/home/imodl/p6/bin/i686-linux2.4.25
    PERL_BADLANG (unset)
    SHELL=/home/gnu/bin/tcsh

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

From ajohnson@nvidia.com

Created by ajohnson@nvidia.com

This is a bug report for perl from ajohnson@​nvidia.com,
generated with the help of perlbug 1.35 running under perl v5.9.1.

-----------------------------------------------------------------
[This is the last of 4 related bug reports. ([perl #32103], [perl #32104],
[perl #32105]) This patch is expected to be the most controversial of the 4.
Copying Nick because it touches his stuff.]

Even after applying the perl-5.9.1-syssigs patch, one more remaining
issue is that there is no way for the process to terminate from a signal
after completing global destruction.

As a result, if you do RAII with global resources, you'll always get the
wrong termination status. The proposed solution is to allow an "END"
block to set $? in such a way as to reflect the signal. (The "END" block
can't kill the process, because it gets called before global destruction
even starts.)

*** This patch is almost certain to have porting issues for non-POSIX
systems. This will have to be fixed, but I'd like to determine that
it makes sense even under Linux before we worry about that.

Please refer to the POD changes in the patch for details.
Patch is relative to the 5.9.1 release.

Inline Patch
diff -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

Flags:
    category=core
    severity=low

Site configuration information for perl v5.9.1:

Configured by ajohnson at Fri Oct 22 16:25:05 PDT 2004.

Summary of my perl5 (revision 5 version 9 subversion 1) configuration:
  Platform:
    osname=linux, osvers=2.4.25, archname=i686-linux
    uname='linux l-sim-13-137 2.4.25 #1 smp tue apr 13 08:54:55 pdt 2004 i686 unknown '
    config_args='-Dusedevel -Dversiononly -Dprefix=/home/ajohnson/tools -de'
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=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 -lcrypt -lutil -lc
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lc
    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='-Wl,-E'
    cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'

Locally applied patches:
    


@INC for perl v5.9.1:
    /home/ajohnson/tools/lib/perl5/5.9.1/i686-linux
    /home/ajohnson/tools/lib/perl5/5.9.1
    /home/ajohnson/tools/lib/perl5/site_perl/5.9.1/i686-linux
    /home/ajohnson/tools/lib/perl5/site_perl/5.9.1
    /home/ajohnson/tools/lib/perl5/site_perl
    .


Environment for perl v5.9.1:
    HOME=/home/ajohnson
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH=.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:/home/lsf_linux/6.0/linux2.4-glibc2.2-x86/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/home/nc4.42/tools/lib:/usr/local/lsf/lib:.:/usr/lib
    LOGDIR (unset)
    PATH=/home/nc4.42/tools/bin:/home/nc4.42/tools/dfII/bin:.:/home/ajohnson/bin:/home/gnu/bin:/usr/bin:/usr/openwin/bin:/sbin:/usr/sbin:/usr/ucb:/usr/ccs/bin:/usr/dt/bin:/bin:/usr/lib:/etc:/home/nv/bin:/home/gnu/X11R6.3/lib:/usr/bin/X11:/usr/local/lsf/bin:/usr/local/wp/wpbin:/usr/local/lsf/bin:/home/tools/td/td5303/linux/bin:/home/synopsys/2000.11/linux/syn/bin:/home/synopsys/pt_2000.11/linux/syn/bin:/home/synopsys/2000.11/linux/mc/bin:/home/synopsys/fm_2001.08/linux/fm/bin:/home/frame/bin:/home/tools/verilint/2001.4.10-linux2.2:/home/tools/vcs/vcs_latest/virsimdir//bin:/home/xl_98/tools/verilog/bin:/home/xl_98/tools/bin:/home/tools/vcs/vcs_latest/bin:/home/powerview:/home/powerview/standard:/home/tools/debussy/latest/bin:/home/tools/debussy/verdi_latest/bin:/home/imodl/p6/bin/i686-linux2.4.25
    PERL_BADLANG (unset)
    SHELL=/home/gnu/bin/tcsh

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

From @JohnPeacock

ajohnson@​nvidia.com (via RT) wrote​:

As a result, if you do RAII with global resources, you'll always get the
wrong termination status. The proposed solution is to allow an "END"
block to set $? in such a way as to reflect the signal. (The "END" block
can't kill the process, because it gets called before global destruction
even starts.)

Just to save some else a trip to Google, this seems to be a concise description
of the RAII (Resource Acquisition Is Initialisation) technique​:

  http​://www.hackcraft.net/raii/

since I was not familiar with this term. I have no immediate opinion on the
patches...

John

--
John Peacock
Director of Information Research and Technology
Rowman & Littlefield Publishing Group
4720 Boston Way
Lanham, MD 20706
301-459-3366 x.5010
fax 301-429-5747

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

From perl5-porters@ton.iguana.be

In article <rt-3.0.11-32104-98306.15.1628489111989@​perl.org>,
  "ajohnson@​nvidia.com (via RT)" <perlbug-followup@​perl.org> writes​:

mm, you add a variable lookup to every DESTROY, meaning DESTROY gets
slower for everybody even if they are totally uninterested in this
functionality (which for the moment I think is almost everyone,
certainly it includes me).

The "attach text" thing is not just DESTROY though, it's the G_KEEPERR
flag in call_sv. So unless you change them all in XS code, you still
will have problems. If you're going to do this, I think it should be
a generic patch to G_KEEPERR.

(I also notice that the "message collapsing" of "\t(in cleanup)" isn't
documented anywhere that I found, and is an actual mess in implementation
anyways (you can lose messages if they look like certain substrings))

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Oct 23, 2004

From gp@familiehaase.de

ajohnson@​nvidia.com (via RT) wrote​:

As a result, if you do RAII with global resources, you'll always get the
wrong termination status. The proposed solution is to allow an "END"
block to set $? in such a way as to reflect the signal. (The "END" block
can't kill the process, because it gets called before global destruction
even starts.)

Just to save some else a trip to Google, this seems to be a concise
description
of the RAII (Resource Acquisition Is Initialisation) technique​:

  http​://www.hackcraft.net/raii/

since I was not familiar with this term. I have no immediate opinion on
the
patches...

John

--
John Peacock
Director of Information Research and Technology
Rowman & Littlefield Publishing Group
4720 Boston Way
Lanham, MD 20706
301-459-3366 x.5010
fax 301-429-5747

!DSPAM​:417a441612951183914076!

@p5pRT
Copy link
Author

p5pRT commented Oct 24, 2004

From nick@ing-simmons.net

Ajohnson @​ Nvidia . Com <perl5-porters@​perl.org> writes​:

# New Ticket Created by ajohnson@​nvidia.com
# Please include the string​: [perl #32104]
# in the subject line of all future correspondence about this issue.
# <URL​: http​://rt.perl.org​:80/rt3/Ticket/Display.html?id=32104 >

This is a bug report for perl from ajohnson@​nvidia.com,
generated with the help of perlbug 1.35 running under perl v5.9.1.

-----------------------------------------------------------------
[This is the second of 4 related bug reports. ([perl #32103])
This patch is expected to be relatively uncontroversial.
Copying Nick because it touches his stuff.]

Perl doesn't support (I can't figure out a way to do) RAII.

What the heck is 'RAII' ?

I need to be able to respond to a signal by terminating the process
ASAP after deallocating all outstanding resources (such as temporary files).

Using perl for something that needs 'as soon as possible' may be the
wrong idea.

The OO way to do this is to have every outstanding resource represented
by an object whose DESTROY method deallocates the object.
If the signal handler terminates the process, then this doesn't happen.
If the signal handler dies, then the signal gets lost if it happens to
arrive while the interpreter is inside a DESTROY method.

Also, it should be possible to respond to a signal by jumping out to the
end of some outer scope without terminating the process at all, so it's
not good enough for the handler to somehow know about all the objects,
destroy them, and then terminate the process.

This patch addresses the problem by adding a new special variable to the
Perl core. Please refer to the POD changes in the patch for details.
Patch is relative to the 5.9.1 release.

I have no particular axe to grind on the signal stuff.
All my patches did was to make signals which occured in malloc() or
other non-re-entrant bits of C library non catastrophic.
Downside is indeterminate delay in when signal is "seen".

While complete patches are welcome, radical ideas which introduce
new special variables should be discussed - we need to figure out
how they map to perl6.

Signals are also very UNIXy (Win32 doesn't have them) and even in UNIX
world not every UNIXy platform that runs perl is up to latest POSIX
standard.

Can you tell us which systems this works on?

+=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​:

I very much doubt that this level of hackery is sufficient to
produce a critcal section in a threaded perl.

@p5pRT
Copy link
Author

p5pRT commented Oct 24, 2004

From nick@ing-simmons.net

Ton Hospel <perl5-porters@​ton.iguana.be> writes​:

In article <rt-3.0.11-32104-98306.15.1628489111989@​perl.org>,
"ajohnson@​nvidia.com (via RT)" <perlbug-followup@​perl.org> writes​:

mm, you add a variable lookup to every DESTROY, meaning DESTROY gets
slower for everybody

Not good.

even if they are totally uninterested in this
functionality (which for the moment I think is almost everyone,
certainly it includes me).

I didn't even know what RAII meant till John P. posted the link,
and I still haven't read it.

The "attach text" thing is not just DESTROY though, it's the G_KEEPERR
flag in call_sv. So unless you change them all in XS code, you still
will have problems. If you're going to do this, I think it should be
a generic patch to G_KEEPERR.

(I also notice that the "message collapsing" of "\t(in cleanup)" isn't
documented anywhere that I found, and is an actual mess in implementation
anyways (you can lose messages if they look like certain substrings))

@p5pRT
Copy link
Author

p5pRT commented Oct 25, 2004

From ajohnson@nvidia.com

This works on Linux 2.4.26 i686. I do not expect these patches to port
everywhere out of the box, because they touch platform-specific things
and I have a limited number of platforms on which I can test. And as
multiple people have pointed out, it's not even clear that the patch
makes sense for Linux, so there may be no point in worrying about other
platforms just yet.

In case anyone hasn't seen it yet, the link posted by John Peacock gives
a good explanation of RAII​: http​://www.hackcraft.net/raii/

"ASAP" just means that the program shouldn't just keep going as if the
signal had not been received. I did not mean to imply a performance
requirement. As long as the signal doesn't get stuck waiting for a
system call to unblock or a loop to terminate, that's probably good
enough.

It is almost certainly true that this won't do a bona-fide critical
section in threaded Perl. It applies only to signals with user-assigned
handlers.

With regard to the performance hit in calling DESTROY, that can be dealt
with by turning it off globally or something. Again, this is a minor
issue in comparison with whether the proposed behavior makes sense at
all (but one that would have to be dealt with should the change be
accepted).

WHY *SOMETHING* NEEDS TO BE DONE​:

I think that it is deplorable that Perl doesn't do RAII, an idiom that
many C++ programmers use extensively. In particular, not supporting it
implies that temporary files get left behind when a Perl script is
interrupted. In general, there are many applications for which Perl is
otherwise well-suited that would be enabled by supporting RAII.

Submitting this patch is my attempt to get the issue taken seriously and
to prove that a solution is possible. If RAII can be supported in some
completely different and less obtrusive way, then that's fine by me.

Thanks,
&ers

-----Original Message-----
From​: Nick Ing-Simmons via RT [mailto​:perlbug-followup@​perl.org]
Sent​: Sunday, October 24, 2004 11​:34 AM
To​: Anders Johnson
Subject​: Re​: [perl #32104] Perl doesn't support RAII, part 2 [patch
included]

Ajohnson @​ Nvidia . Com <perl5-porters@​perl.org> writes​:

# New Ticket Created by ajohnson@​nvidia.com
# Please include the string​: [perl #32104]
# in the subject line of all future correspondence about this issue.
# <URL​: http​://rt.perl.org​:80/rt3/Ticket/Display.html?id=32104 >

This is a bug report for perl from ajohnson@​nvidia.com,
generated with the help of perlbug 1.35 running under perl v5.9.1.

-----------------------------------------------------------------
[This is the second of 4 related bug reports. ([perl #32103])
This patch is expected to be relatively uncontroversial.
Copying Nick because it touches his stuff.]

Perl doesn't support (I can't figure out a way to do) RAII.

What the heck is 'RAII' ?

I need to be able to respond to a signal by terminating the process
ASAP after deallocating all outstanding resources (such as temporary
files).

Using perl for something that needs 'as soon as possible' may be the
wrong idea.

The OO way to do this is to have every outstanding resource represented
by an object whose DESTROY method deallocates the object.
If the signal handler terminates the process, then this doesn't happen.
If the signal handler dies, then the signal gets lost if it happens to
arrive while the interpreter is inside a DESTROY method.

Also, it should be possible to respond to a signal by jumping out to
the
end of some outer scope without terminating the process at all, so it's
not good enough for the handler to somehow know about all the objects,
destroy them, and then terminate the process.

This patch addresses the problem by adding a new special variable to
the
Perl core. Please refer to the POD changes in the patch for details.
Patch is relative to the 5.9.1 release.

I have no particular axe to grind on the signal stuff.
All my patches did was to make signals which occured in malloc() or
other non-re-entrant bits of C library non catastrophic.
Downside is indeterminate delay in when signal is "seen".

While complete patches are welcome, radical ideas which introduce
new special variables should be discussed - we need to figure out
how they map to perl6.

Signals are also very UNIXy (Win32 doesn't have them) and even in UNIX
world not every UNIXy platform that runs perl is up to latest POSIX
standard.

Can you tell us which systems this works on?

+=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​:

I very much doubt that this level of hackery is sufficient to
produce a critcal section in a threaded perl.

@p5pRT
Copy link
Author

p5pRT commented Oct 26, 2004

From ajohnson@nvidia.com

Yes, perhaps it's better to document this by describing the behavior in
more detail in L<perlcall/"G_KEEPERR">, and adding a pointer from
L<perlobj/"Destructors"> to it.

However, from my point of view (of which anyone is welcome to disabuse
me) trying to fix the problem in call_sv is a dead end, because the
whole notion of multiple simultaneous outstanding errors is
fundamentally unsound. (See http​://www.gotw.ca/gotw/047.htm for an
explanation as it relates to C++; allegedly the basic concepts are the
same in Perl.) That's why the proposed documentation suggests taking
measures to simply prevent it ever from happening.

In other words, if you get an "(in cleanup)" message at all, then the
perl script is broken. That's a somewhat draconian statement, but it's
the only reasonable way that I know of to manage the issue.

Thanks,
&ers

-----Original Message-----
From​: (Ton Hospel) via RT [mailto​:perlbug-followup@​perl.org]
Sent​: Saturday, October 23, 2004 10​:22 AM
To​: Anders Johnson
Subject​: Re​: [perl #32104] Perl doesn't support RAII, part 2 [patch
included]

In article <rt-3.0.11-32104-98306.15.1628489111989@​perl.org>,
  "ajohnson@​nvidia.com (via RT)" <perlbug-followup@​perl.org>
writes​:

mm, you add a variable lookup to every DESTROY, meaning DESTROY gets
slower for everybody even if they are totally uninterested in this
functionality (which for the moment I think is almost everyone,
certainly it includes me).

The "attach text" thing is not just DESTROY though, it's the G_KEEPERR
flag in call_sv. So unless you change them all in XS code, you still
will have problems. If you're going to do this, I think it should be
a generic patch to G_KEEPERR.

(I also notice that the "message collapsing" of "\t(in cleanup)" isn't
documented anywhere that I found, and is an actual mess in
implementation
anyways (you can lose messages if they look like certain substrings))

@p5pRT
Copy link
Author

p5pRT commented Oct 26, 2004

From nick@ing-simmons.net

Anders Johnson <AJohnson@​nvidia.com> writes​:

WHY *SOMETHING* NEEDS TO BE DONE​:

I think that it is deplorable that Perl doesn't do RAII, an idiom that
many C++ programmers use extensively.

I think is deplorable that C++ doesn't do END blocks or support
anonymous temporary files natively, idioms that Perl programmers
use extensively ;-)

In particular, not supporting them it
implies that temporary files get left behind when a C++ program
is interrupted.

The perl idiom is different.

@p5pRT
Copy link
Author

p5pRT commented Oct 26, 2004

From ajohnson@nvidia.com

It's not clear to me that this is ultimately a question of idiom,
because I don't know of *any* way for a Perl program to reliably
deallocate resources promptly after receiving a signal. If anyone can
demonstrate how to do this using existing Perl idioms, then I would
consider the issue resolved.

As I understand it, the philosophy of Perl is "easy things are easy, and
hard things are possible." Resource management may be hard, but so far
as I can tell, it's not possible in Perl today.

(At the risk of degenerating into a language war, the deficiencies of
C++ that you mention are things that are hard even though they should be
easy, but at least they're *possible*.)

Perhaps I'm the only person in the world who cares that Perl can't do
this, but that proposition seems at odds with the widespread use of RAII
in languages that support it. Furthermore, there is already a
perception that Perl supports it (for example, see
http​://c2.com/cgi/wiki?ResourceAcquisitionIsInitialization), and
neglecting signals, this perception would be accurate.

&ers

-----Original Message-----
From​: Nick Ing-Simmons [mailto​:nick@​ing-simmons.net]
Sent​: Tuesday, October 26, 2004 5​:32 AM
To​: Anders Johnson
Cc​: perlbug-followup@​perl.org
Subject​: RE​: [perl #32104] Perl doesn't support RAII, part 2 [patch
included]

Anders Johnson <AJohnson@​nvidia.com> writes​:

WHY *SOMETHING* NEEDS TO BE DONE​:

I think that it is deplorable that Perl doesn't do RAII, an idiom that
many C++ programmers use extensively.

I think is deplorable that C++ doesn't do END blocks or support
anonymous temporary files natively, idioms that Perl programmers
use extensively ;-)

In particular, not supporting them it
implies that temporary files get left behind when a C++ program
is interrupted.

The perl idiom is different.

@p5pRT
Copy link
Author

p5pRT commented Oct 27, 2004

From dm.list@math2.org

Anders Johnson wrote​:

Perhaps I'm the only person in the world who cares that Perl can't do
this, but that proposition seems at odds with the widespread use of RAII
in languages that support it.

I was actually just thinking tonight about how to implement RAII in
Perl, I did some google searches, and found this thread.

My immediate reason for wanting RAII in Perl is for a clean way to
deallocate table locks in MySQL. Consider​:

sub modify
{
  $db->do("LOCK TABLES mytable, yourtable");
  $db->do("...");
  $db->do("...");
  $db->do("UNLOCK TABLES");
}
<<<

Obviously, if the second or third statement throws an exception, the
unlock is incorrectly skipped. A Java-ish solution is to put the unlock
in a "finally" clause as in this​:

use Error qw(​:try);
sub modify
{
  $db->do("LOCK TABLES mytable, yourtable");
  try {
  $db->do("...");
  $db->do("...");
  }
  finally {
  $db->do("UNLOCK TABLES");
  };
}
<<<

The Perlish form is similarly ugly​:

sub modify
{
  $db->do("LOCK TABLES mytable, yourtable");
  eval {
  $db->do("...");
  $db->do("...");
  };
  $db->do("UNLOCK TABLES");
  die if $@​;
}
<<<

The nesting and exception handling of both forms distract from the
problem domain. I'd prefer an RAII approach​:

use MyLockClass;
sub modify
{
  my $lock = new MyLockClass($db, 'mytable', 'yourtable');
  $db->do("...");
  $db->do("...");
}
<<<

where the MyLockClass's constructors and finalizers contain the generic
LOCK and UNLOCK code respectively. Note that the code is devoid of
exception handling blocks. However, this doesn't work that well as is
because Perl does not called DESTROY at the end of scope (like in C++
and some other languages).

Syntactic sugar may be preferred as well if it can be made to work​:

use MyLockPackage qw(lock);
sub modify
{
  lock('table', 'yourtable');
  $db->do("...");
  $db->do("...");
}
<<<

The following CPAN module does take an RAII-like approach on a related
problem​:

  http​://search.cpan.org/~cmanley/Mysql-Locker/lib/Mysql/Locker.pm

However, it requires an undesirable explicit call the "undef" function
to get DESTROY to be called promptly.

-david manura

Anders Johnson wrote​:

It's not clear to me that this is ultimately a question of idiom,
because I don't know of *any* way for a Perl program to reliably
deallocate resources promptly after receiving a signal. If anyone can
demonstrate how to do this using existing Perl idioms, then I would
consider the issue resolved.

As I understand it, the philosophy of Perl is "easy things are easy, and
hard things are possible." Resource management may be hard, but so far
as I can tell, it's not possible in Perl today.

(At the risk of degenerating into a language war, the deficiencies of
C++ that you mention are things that are hard even though they should be
easy, but at least they're *possible*.)

Perhaps I'm the only person in the world who cares that Perl can't do
this, but that proposition seems at odds with the widespread use of RAII
in languages that support it. Furthermore, there is already a
perception that Perl supports it (for example, see
http​://c2.com/cgi/wiki?ResourceAcquisitionIsInitialization), and
neglecting signals, this perception would be accurate.

&ers

-----Original Message-----
From​: Nick Ing-Simmons [mailto​:nick@​ing-simmons.net]
Sent​: Tuesday, October 26, 2004 5​:32 AM
To​: Anders Johnson
Cc​: perlbug-followup@​perl.org
Subject​: RE​: [perl #32104] Perl doesn't support RAII, part 2 [patch
included]

Anders Johnson <AJohnson@​nvidia.com> writes​:

WHY *SOMETHING* NEEDS TO BE DONE​:

I think that it is deplorable that Perl doesn't do RAII, an idiom that
many C++ programmers use extensively.

I think is deplorable that C++ doesn't do END blocks or support
anonymous temporary files natively, idioms that Perl programmers
use extensively ;-)

In particular, not supporting them it
implies that temporary files get left behind when a C++ program
is interrupted.

The perl idiom is different.

@p5pRT
Copy link
Author

p5pRT commented Oct 28, 2004

From dm.list@math2.org

I'll need to revise my below post. On doing additional searching, I
found a patch in late 2000 that supposedly makes DESTROY deterministic
as provided in the following example.

http​://www.perl.com/pub/a/2000/12/p5pdigest/THISWEEK-20001210.html

  sub x​::DESTROY {print shift->[0]}
  { my $a1 = bless [1],"x";
  my $a2 = bless [2],"x";
  { my $a3 = bless [3],"x";
  my $a4 = bless [4],"x";
  567;
  }
  }
  print "outside block";
  my $a5 = bless [5],"x";
  my $a6 = bless [6],"x";
  567;
<<<
This outputs "4321outside block65".

Where I got confused is that this type of code does not work intuitively
if the additional lines (567) are omitted (as case that is unlikely in
practice but did occur in my test code). With these lines removed, it
outputs "3214outside block56". So, with that in mind, I suppose RAII
can be made to work at least in the way I had in mind.

-david manura

dm.list wrote​:

Anders Johnson wrote​:

Perhaps I'm the only person in the world who cares that Perl can't do
this, but that proposition seems at odds with the widespread use of
RAII
in languages that support it.

I was actually just thinking tonight about how to implement RAII in
Perl, I did some google searches, and found this thread.

My immediate reason for wanting RAII in Perl is for a clean way to
deallocate table locks in MySQL. Consider​:

sub modify
{
$db->do("LOCK TABLES mytable, yourtable");
$db->do("...");
$db->do("...");
$db->do("UNLOCK TABLES");
}
<<<

Obviously, if the second or third statement throws an exception, the
unlock is incorrectly skipped. A Java-ish solution is to put the
unlock in a "finally" clause as in this​:

use Error qw(​:try);
sub modify
{
$db->do("LOCK TABLES mytable, yourtable");
try {
$db->do("...");
$db->do("...");
}
finally {
$db->do("UNLOCK TABLES");
};
}
<<<

The Perlish form is similarly ugly​:

sub modify
{
$db->do("LOCK TABLES mytable, yourtable");
eval {
$db->do("...");
$db->do("...");
};
$db->do("UNLOCK TABLES");
die if $@​;
}
<<<

The nesting and exception handling of both forms distract from the
problem domain. I'd prefer an RAII approach​:

use MyLockClass;
sub modify
{
my $lock = new MyLockClass($db, 'mytable', 'yourtable');
$db->do("...");
$db->do("...");
}
<<<

where the MyLockClass's constructors and finalizers contain the
generic LOCK and UNLOCK code respectively. Note that the code is
devoid of exception handling blocks. However, this doesn't work that
well as is because Perl does not called DESTROY at the end of scope
(like in C++ and some other languages).

Syntactic sugar may be preferred as well if it can be made to work​:

use MyLockPackage qw(lock);
sub modify
{
lock('table', 'yourtable');
$db->do("...");
$db->do("...");
}
<<<

The following CPAN module does take an RAII-like approach on a related
problem​:

http​://search.cpan.org/~cmanley/Mysql-Locker/lib/Mysql/Locker.pm

However, it requires an undesirable explicit call the "undef" function
to get DESTROY to be called promptly.

-david manura

Anders Johnson wrote​:

It's not clear to me that this is ultimately a question of idiom,
because I don't know of *any* way for a Perl program to reliably
deallocate resources promptly after receiving a signal. If anyone can
demonstrate how to do this using existing Perl idioms, then I would
consider the issue resolved.

As I understand it, the philosophy of Perl is "easy things are easy, and
hard things are possible." Resource management may be hard, but so far
as I can tell, it's not possible in Perl today.

(At the risk of degenerating into a language war, the deficiencies of
C++ that you mention are things that are hard even though they should be
easy, but at least they're *possible*.)

Perhaps I'm the only person in the world who cares that Perl can't do
this, but that proposition seems at odds with the widespread use of RAII
in languages that support it. Furthermore, there is already a
perception that Perl supports it (for example, see
http​://c2.com/cgi/wiki?ResourceAcquisitionIsInitialization), and
neglecting signals, this perception would be accurate.

&ers

-----Original Message-----
From​: Nick Ing-Simmons [mailto​:nick@​ing-simmons.net] Sent​: Tuesday,
October 26, 2004 5​:32 AM
To​: Anders Johnson
Cc​: perlbug-followup@​perl.org
Subject​: RE​: [perl #32104] Perl doesn't support RAII, part 2 [patch
included]

Anders Johnson <AJohnson@​nvidia.com> writes​:

WHY *SOMETHING* NEEDS TO BE DONE​:

I think that it is deplorable that Perl doesn't do RAII, an idiom that
many C++ programmers use extensively.

I think is deplorable that C++ doesn't do END blocks or support
anonymous temporary files natively, idioms that Perl programmers
use extensively ;-)

In particular, not supporting them it
implies that temporary files get left behind when a C++ program is
interrupted.
The perl idiom is different.

@p5pRT
Copy link
Author

p5pRT commented Oct 28, 2004

From nick@ing-simmons.net

Yves Orton <yves.orton@​de.mci.com> writes​:

dm.list said on 27 October 2004 08​:19​:

where the MyLockClass's constructors and finalizers contain
the generic LOCK and UNLOCK code respectively. Note that the code is
devoid of
exception handling blocks. However, this doesn't work that
well as is because Perl does not called DESTROY at the end of scope (like
in C++
and some other languages).

Im probably missing the point here, but this seems to work​:

#!perl
package ExecAtScopeLeave;

sub new {
my ($class,$sub)=@​_;
return bless sub { goto &$sub },$class;
}

There has been a recent thread to the effect that blessing subs
does not work as expected. Try adding a level of indirection
so you bless say a scalar which holds the subref.

sub DESTROY {
my $self=shift;
$self->();
}

sub on_scope_leave(&){
__PACKAGE__->new(@​_);
}

If all we want is a way to execute some code on scope exot
(however exited) then we can use the C level scope hooks
to ensure that without "clever" objrefcount and DESTROY hooks.

package main;
sub on_scope_leave(&);

*on_scope_leave=*ExecAtScopeLeave​::on_scope_leave;

{
my $cleanup=on_scope_leave { print "hello there dude!\n" };
print "last statement!\n";
}
__END__

@p5pRT
Copy link
Author

p5pRT commented Oct 28, 2004

From @demerphq

sub new {
my ($class,$sub)=@​_;
return bless sub { goto &$sub },$class;
}

There has been a recent thread to the effect that blessing subs
does not work as expected. Try adding a level of indirection
so you bless say a scalar which holds the subref.

Yeah good point.

If all we want is a way to execute some code on scope exot
(however exited) then we can use the C level scope hooks
to ensure that without "clever" objrefcount and DESTROY hooks.

Can this be done from Perl though?

Yves

@p5pRT
Copy link
Author

p5pRT commented Oct 28, 2004

From perl5-porters@ton.iguana.be

In article <FEE662BF3FC168428F3C828EBB8D86DA01BC1AF7@​hqemmail05.nvidia.com>,
  "Anders Johnson" <AJohnson@​nvidia.com> writes​:

Yes, perhaps it's better to document this by describing the behavior in
more detail in L<perlcall/"G_KEEPERR">, and adding a pointer from
L<perlobj/"Destructors"> to it.

However, from my point of view (of which anyone is welcome to disabuse
me) trying to fix the problem in call_sv is a dead end, because the
whole notion of multiple simultaneous outstanding errors is
fundamentally unsound. (See http​://www.gotw.ca/gotw/047.htm for an
explanation as it relates to C++; allegedly the basic concepts are the
same in Perl.) That's why the proposed documentation suggests taking
measures to simply prevent it ever from happening.

But this isn't about multiple outstanding error. See the example I give below
which never has multiple errors and still shows the cleanup. As far as I
understood, your problem is an exception (raised inderectly through an
interrupt) arriving while a destructor is running. The same thing would
however for any perl code that's called through call_sv with G_EVAL and
G_KEEPERR, where DESTROY is just a special (and common) case, so I still
think call_sv is the proper place to fix it if that's what you decide to do.

I also don't see why you want to make the setting per class. An interrupt
can come in at any time, so I'd think you would want to catch ALL cases.

About the "expensive code" issue, how about making the variable that turns
the behaviour on or off into a magic variable, and let it get/set a (thread
local?) integer. In the C code you can then check the value of that integer
very fast. That way only people using the feature will see a noticable
slowdown (the simple int check hopefully will not appear on the speed radar)

In other words, if you get an "(in cleanup)" message at all, then the
perl script is broken. That's a somewhat draconian statement, but it's
the only reasonable way that I know of to manage the issue.

Mm, interesting read (even though I think the argumentation is sloppy and
I don't agree with it). Notice however that perl actually enforces what is
described there​: A destructor can't raise an exception that goes all the way​:

#!/usr/bin/perl -wl
sub DESTROY {
  die "Aargh";
}
my $a = bless [];
$a = undef;
print "We got here and \$\@​ is​: $@​"

Which will print​:
We got here and $@​ is​: (in cleanup) Aargh at - line 3.

It only looks like a double exception issue if the DESTROY happened while an
exception was already propagating, but the behaviour in fact always occurs​:
exceptions in G_KEEPERR code don't propagate, but get accumulated in $@​.

@p5pRT
Copy link
Author

p5pRT commented Oct 29, 2004

From dm.list@math2.org

A quite different way is to do something like the below. This approach
can also be easily modified, if need be, to not rely at all on the
behavior of garbage collection.

==== test.pl ====
use strict;
use Scope qw(​:all);
use MyLock qw(​:all);

scope {
  acquire my_lock(1);
  acquire my_lock(2);
  cleanup { print "some code\n" };
  # die;
  scope {
  acquire my_lock(3);
  acquire my_lock(4);
  print "end inner block\n";
  };
  # $_ = 123; # this will trigger an assertion
  acquire my_lock(5);
  print "end outer block\n";
};
print "done\n";

==== Scope.pm ====
package Scope;
use strict;
use Exporter;
use base 'Exporter';

our %EXPORT_TAGS = (all => [qw(scope acquire cleanup)]);
our @​EXPORT_OK = @​{$EXPORT_TAGS{'all'}};

sub scope(&)
{
  my $sub = shift;
  my $scope = new Scope();
  local $_ = $scope;
  eval {
  $sub->();
  };
  for (reverse @​$scope) {
  if(ref($_) eq 'CODE') { $_->(); }
  else { undef $_; }
  }
  if($@​) { die; }
}
sub new
{
  return bless [], shift;
}
sub add
{
  my($self, $obj) = @​_;
  push @​$self, $obj;
}
sub acquire
{
  die 'ASSERT' if ref($_) ne 'Scope';
  $_->add(@​_);
}
sub cleanup(&)
{
  die 'ASSERT' if ref($_) ne 'Scope';
  $_->add(@​_);
}
1

==== MyLock.pm ====
package MyLock;
use strict;
use Exporter;
use base 'Exporter';

our %EXPORT_TAGS = (all => [qw(my_lock)]);
our @​EXPORT_OK = @​{$EXPORT_TAGS{'all'}};

sub new
{
  my($class, $val) = @​_;
  print "ACQUIRE $val\n";
  return bless {val => $val}, shift;
}
sub DESTROY
{
  my $self = shift;
  print "RELEASE $self->{val}\n";
}
sub my_lock { return new MyLock(@​_); }
1
==== END ====

Here's something related (using B)​:
http​://search.cpan.org/~abergman/Hook-Scope/.

-david manura

Orton, Yves wrote​:

package ExecAtScopeLeave;

sub new {
my ($class,$sub)=@​_;
#return bless sub{ goto &$sub },$class;
return bless \do{my $ref=$sub },$class;
}

sub DESTROY {
my $self=shift;
$$self->();
}

sub on_scope_leave(&){
__PACKAGE__->new(@​_);
}

package main;
sub on_scope_leave(&);

*on_scope_leave=*ExecAtScopeLeave​::on_scope_leave;

if(1){
my $cleanup=on_scope_leave { print "hello there dude!\n" };
print "last statement in block!\n";
}
print "last statement in file!\n";

Orton, Yves wrote​:

sub new {
my ($class,$sub)=@​_;
return bless sub { goto &$sub },$class;
}

There has been a recent thread to the effect that blessing subs
does not work as expected. Try adding a level of indirection
so you bless say a scalar which holds the subref.

Yeah good point.

If all we want is a way to execute some code on scope exot
(however exited) then we can use the C level scope hooks
to ensure that without "clever" objrefcount and DESTROY hooks.

Can this be done from Perl though?

Yves

@p5pRT
Copy link
Author

p5pRT commented Oct 30, 2004

From ajohnson@nvidia.com

At Nick's request, here is an explanation of the problem that the
patches associated with this bug address, so that you don't have to
extract the documentation from the patch itself​:

When a process receives an interrupt (e.g. ctrl-C), the usual desired
behavior is to deallocate all resources assigned to the process and
terminate the process (not necessarily in that order).

One way to achieve this behavior is to allocate to the process only
resources that the operating system will automatically deallocate when
the process terminates, such as file descriptors, anonymous temporary
files, memory, etc. If this is the case, then signal handlers are not
required.

However, there are many types of resources of which this is not true,
such as temporary files that you want another process to access (other
than through a forked file descriptor), certain kinds of locks, child
processes, and resources that have been allocated on behalf of the
process by a server that does not automatically deallocate resources
when the pipe to the client is closed. In order to deallocate those
types of resources when a signal is received, a different approach is
required.

Another way to achieve this behavior is for every outstanding resource
to be represented by a live object whose destructor (or an END block)
deallocates the resource. The signal handler calls exit() (*not*
POSIX​::_exit) when a signal is received, and then the object destructors
and END blocks clean up before the process terminates.

There are a few problems with this approach. First and foremost is that
it is not possible for a signal both to interrupt the normal flow of
control and result in some action other than immediately terminating the
process after cleaning up. This precludes using ctrl-C to interrupt the
current operation and then return to a main control loop.

Second, assuming that an immediate exit is desired, there is no way to
set the termination status properly on a POSIX system, such that the
parent process will evaluate POSIX​::WIFSIGNALED($?) to true after
waiting on the terminated process. (This particular issue is addressed
by the patch submitted with bug #32106.) It's not good enough for the
first END block (the last one executed) to disable the handler and kill
the process again, because this happens before global destruction, which
might be necessary to complete cleanup.

Finally, if the signal arrives in the middle of a DESTROY method or an
END block, then funny things can happen. For example, if the object is
already partially destructed when the signal arrives, then the DESTROY
method is aborted, and (depending on the version of Perl you're using)
may get restarted while the object is in an invalid state. If the
signal arrives in an END block, then the process terminates immediately
without finishing cleanup.

The other way to interrupt the normal flow of control in Perl is to
die() rather than to exit(). This solves the first problem, because you
can use eval() to catch the signal at the appropriate point in the code,
if necessary. However, if the signal arrives in a DESTROY call, then it
gets consumed because of G_KEEPERR. That's *really* bad, because it
makes the program unresponsive to signals.

The central idea of the patches that I submitted is to block (defer)
signal handlers inside the DESTROY call. That way, you can arrange for
signal handlers to die() without having to worry that the exception
won't get propagated.

The patch further provides a way to re-enable signal handlers so that if
your DESTROY method has an eval() block to process signals that arrive
within it, then you can interrupt the method and re-raise the signal
after it's been blocked again. That way, you can write DESTROY methods
that might take a noticeable amount of time and still respond to
signals.

The patches also contain a certain amount of miscellaneous signal
handling clean-up that probably ought to get incorporated into mainline
Perl even if we decide that messing with DESTROY methods is
fundamentally a bad idea. I'll be happy to factor this stuff out and
re-submit it in that event.

Thanks,
&ers

@p5pRT
Copy link
Author

p5pRT commented Oct 31, 2004

From @ysth

On Thu, Oct 28, 2004 at 12​:19​:37PM +0100, Nick Ing-Simmons wrote​:

Yves Orton <yves.orton@​de.mci.com> writes​:

dm.list said on 27 October 2004 08​:19​:

where the MyLockClass's constructors and finalizers contain
the generic LOCK and UNLOCK code respectively. Note that the code is
devoid of
exception handling blocks. However, this doesn't work that
well as is because Perl does not called DESTROY at the end of scope (like
in C++
and some other languages).

Im probably missing the point here, but this seems to work​:

#!perl
package ExecAtScopeLeave;

sub new {
my ($class,$sub)=@​_;
return bless sub { goto &$sub },$class;
}

There has been a recent thread to the effect that blessing subs
does not work as expected. Try adding a level of indirection
so you bless say a scalar which holds the subref.

AIUI, that problem only applies to non-closures, and this is a closure.

@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From nick@ing-simmons.net

Dm.List <dm.list@​math2.org> writes​:

The nesting and exception handling of both forms distract from the
problem domain. I'd prefer an RAII approach​:

use MyLockClass;
sub modify
{
my $lock = new MyLockClass($db, 'mytable', 'yourtable');
$db->do("...");
$db->do("...");
}
<<<

How does my example between the lines no do what you want it to do?


#!perl
{package MyLockClass;
sub new
{
  my ($class,$subref) = @​_;
  my $obj = bless \$subref,$class;
}

sub DESTROY
{
  my ($self) = @​_;
  print "DESTROY​:\n";
  &$$self;
}
}
 
sub inner
{
foreach (1..1000)
  {
  sleep(1);
  }
}
 

$SIG{INT} = sub { die "Killed" };

sub modify
{
my $lock = MyLockClass->new(sub { print "Cleanup\n" });
inner();
}

eval { modify(); };
warn $@​ if $@​;
print "Returned\n";

__END__


where the MyLockClass's constructors and finalizers contain the generic
LOCK and UNLOCK code respectively. Note that the code is devoid of
exception handling blocks. However, this doesn't work that well as is
because Perl does not called DESTROY at the end of scope (like in C++
and some other languages).

Syntactic sugar may be preferred as well if it can be made to work​:

use MyLockPackage qw(lock);
sub modify
{
lock('table', 'yourtable');
$db->do("...");
$db->do("...");
}
<<<

The following CPAN module does take an RAII-like approach on a related
problem​:

http​://search.cpan.org/~cmanley/Mysql-Locker/lib/Mysql/Locker.pm

However, it requires an undesirable explicit call the "undef" function
to get DESTROY to be called promptly.

-david manura

Anders Johnson wrote​:

It's not clear to me that this is ultimately a question of idiom,
because I don't know of *any* way for a Perl program to reliably
deallocate resources promptly after receiving a signal. If anyone can
demonstrate how to do this using existing Perl idioms, then I would
consider the issue resolved.

As I understand it, the philosophy of Perl is "easy things are easy, and
hard things are possible." Resource management may be hard, but so far
as I can tell, it's not possible in Perl today.

(At the risk of degenerating into a language war, the deficiencies of
C++ that you mention are things that are hard even though they should be
easy, but at least they're *possible*.)

Perhaps I'm the only person in the world who cares that Perl can't do
this, but that proposition seems at odds with the widespread use of RAII
in languages that support it. Furthermore, there is already a
perception that Perl supports it (for example, see
http​://c2.com/cgi/wiki?ResourceAcquisitionIsInitialization), and
neglecting signals, this perception would be accurate.

&ers

-----Original Message-----
From​: Nick Ing-Simmons [mailto​:nick@​ing-simmons.net]
Sent​: Tuesday, October 26, 2004 5​:32 AM
To​: Anders Johnson
Cc​: perlbug-followup@​perl.org
Subject​: RE​: [perl #32104] Perl doesn't support RAII, part 2 [patch
included]

Anders Johnson <AJohnson@​nvidia.com> writes​:

WHY *SOMETHING* NEEDS TO BE DONE​:

I think that it is deplorable that Perl doesn't do RAII, an idiom that
many C++ programmers use extensively.

I think is deplorable that C++ doesn't do END blocks or support
anonymous temporary files natively, idioms that Perl programmers
use extensively ;-)

In particular, not supporting them it
implies that temporary files get left behind when a C++ program
is interrupted.

The perl idiom is different.

1 similar comment
@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From nick@ing-simmons.net

Dm.List <dm.list@​math2.org> writes​:

The nesting and exception handling of both forms distract from the
problem domain. I'd prefer an RAII approach​:

use MyLockClass;
sub modify
{
my $lock = new MyLockClass($db, 'mytable', 'yourtable');
$db->do("...");
$db->do("...");
}
<<<

How does my example between the lines no do what you want it to do?


#!perl
{package MyLockClass;
sub new
{
  my ($class,$subref) = @​_;
  my $obj = bless \$subref,$class;
}

sub DESTROY
{
  my ($self) = @​_;
  print "DESTROY​:\n";
  &$$self;
}
}
 
sub inner
{
foreach (1..1000)
  {
  sleep(1);
  }
}
 

$SIG{INT} = sub { die "Killed" };

sub modify
{
my $lock = MyLockClass->new(sub { print "Cleanup\n" });
inner();
}

eval { modify(); };
warn $@​ if $@​;
print "Returned\n";

__END__


where the MyLockClass's constructors and finalizers contain the generic
LOCK and UNLOCK code respectively. Note that the code is devoid of
exception handling blocks. However, this doesn't work that well as is
because Perl does not called DESTROY at the end of scope (like in C++
and some other languages).

Syntactic sugar may be preferred as well if it can be made to work​:

use MyLockPackage qw(lock);
sub modify
{
lock('table', 'yourtable');
$db->do("...");
$db->do("...");
}
<<<

The following CPAN module does take an RAII-like approach on a related
problem​:

http​://search.cpan.org/~cmanley/Mysql-Locker/lib/Mysql/Locker.pm

However, it requires an undesirable explicit call the "undef" function
to get DESTROY to be called promptly.

-david manura

Anders Johnson wrote​:

It's not clear to me that this is ultimately a question of idiom,
because I don't know of *any* way for a Perl program to reliably
deallocate resources promptly after receiving a signal. If anyone can
demonstrate how to do this using existing Perl idioms, then I would
consider the issue resolved.

As I understand it, the philosophy of Perl is "easy things are easy, and
hard things are possible." Resource management may be hard, but so far
as I can tell, it's not possible in Perl today.

(At the risk of degenerating into a language war, the deficiencies of
C++ that you mention are things that are hard even though they should be
easy, but at least they're *possible*.)

Perhaps I'm the only person in the world who cares that Perl can't do
this, but that proposition seems at odds with the widespread use of RAII
in languages that support it. Furthermore, there is already a
perception that Perl supports it (for example, see
http​://c2.com/cgi/wiki?ResourceAcquisitionIsInitialization), and
neglecting signals, this perception would be accurate.

&ers

-----Original Message-----
From​: Nick Ing-Simmons [mailto​:nick@​ing-simmons.net]
Sent​: Tuesday, October 26, 2004 5​:32 AM
To​: Anders Johnson
Cc​: perlbug-followup@​perl.org
Subject​: RE​: [perl #32104] Perl doesn't support RAII, part 2 [patch
included]

Anders Johnson <AJohnson@​nvidia.com> writes​:

WHY *SOMETHING* NEEDS TO BE DONE​:

I think that it is deplorable that Perl doesn't do RAII, an idiom that
many C++ programmers use extensively.

I think is deplorable that C++ doesn't do END blocks or support
anonymous temporary files natively, idioms that Perl programmers
use extensively ;-)

In particular, not supporting them it
implies that temporary files get left behind when a C++ program
is interrupted.

The perl idiom is different.

@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From nick@ing-simmons.net

Yves Orton <yves.orton@​de.mci.com> writes​:

sub new {
my ($class,$sub)=@​_;
return bless sub { goto &$sub },$class;
}

There has been a recent thread to the effect that blessing subs
does not work as expected. Try adding a level of indirection
so you bless say a scalar which holds the subref.

Yeah good point.

If all we want is a way to execute some code on scope exot
(however exited) then we can use the C level scope hooks
to ensure that without "clever" objrefcount and DESTROY hooks.

Can this be done from Perl though?

Not directly. But adding a hook to existing XS utilities seems prefereable
to wholesale patching of fragile bits of core.

Yves

@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From @demerphq

If all we want is a way to execute some code on scope exot
(however exited) then we can use the C level scope hooks
to ensure that without "clever" objrefcount and DESTROY hooks.

Can this be done from Perl though?

Not directly. But adding a hook to existing XS utilities
seems prefereable
to wholesale patching of fragile bits of core.

I havent the foggiest what this would look like. Do you mean something along
the lines of a Scalar​::Util type extension or what? Having a "normalized"
way to do this would be very useful, Ive seen lots of hand rolled
implementations over the years so a "proper" way to do it would be nice.

Yves

@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From nick@ing-simmons.net

Yves Orton <yves.orton@​de.mci.com> writes​:

If all we want is a way to execute some code on scope exot
(however exited) then we can use the C level scope hooks
to ensure that without "clever" objrefcount and DESTROY hooks.

Can this be done from Perl though?

Not directly. But adding a hook to existing XS utilities
seems prefereable
to wholesale patching of fragile bits of core.

I havent the foggiest what this would look like. Do you mean something along
the lines of a Scalar​::Util type extension or what?

Exactly, may be as good a place to put it as any ;-)
Could have a prototype of (&) so expected a coderef
one could then write​:

sub modify
{
on_scope_exit { ... };

}

Having a "normalized"
way to do this would be very useful, Ive seen lots of hand rolled
implementations over the years so a "proper" way to do it would be nice.

Yves

The attached seems to suffice to demonstrate the mechanics.

@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From nick@ing-simmons.net

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

static void
call_it(pTHX_ void *arg)
{
SV *subref = (SV *) arg;
sv_2mortal(subref);
call_sv(subref,G_VOID);
}

MODULE = Scope PACKAGE = Scope

void on_scope_exit(SV *subref)
PROTOTYPE​: &
CODE​:
{
SvREFCNT_inc(subref);
SAVEDESTRUCTOR_X(call_it,subref);
XSRETURN(0);
}

@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From nick@ing-simmons.net

test.pl

@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From nick@ing-simmons.net

Scope.pm

@p5pRT
Copy link
Author

p5pRT commented Nov 1, 2004

From nick@ing-simmons.net

Makefile.PL

@p5pRT
Copy link
Author

p5pRT commented Nov 5, 2004

From @davidnicol

Does anyone feel a need for some perl modules to facilitate locking against a
centralized lock management service?

@p5pRT
Copy link
Author

p5pRT commented Nov 5, 2004

From kstar@cpan.org

On Fri, 5 Nov 2004 00​:43​:28 -0600, David Nicol <davidnicol@​gmail.com> wrote​:

Does anyone feel a need for some perl modules to facilitate locking against a
centralized lock management service?

  Could you say more about that? Perhaps with a couple of specific examples?

  - Kurt

@p5pRT
Copy link
Author

p5pRT commented Nov 7, 2004

From @davidnicol

a distributed lock manager written entirely in Perl. I proposed
writing one to the
YAS grants committee last year and was told that "more research is required."

Building one as a web service atop HTTP​::Server​::Singlethreaded would be really
easy and due to the singlethreaded nature of the server, locking
within the server(s)
would be mostly unnecessary.

Googling for "distributed lock manager semantics" gives a pile of
situations where
such things are used.

It is my belief that flock semantics (SH,EX,UN,NB) plus a way to
specify timeouts
are all that is needed, as more complesx semantics such as "wait pools" or
"lock requested states" can be built from multiple flocks as needed by
the application.

Would anyone use the system, if the distributed lock manager client locking
worked like this​:

  # initialize DLM to refer to the DLM server
  use DLM central => 'http​://dlm.example.com​:4002/dlmroot/';

  ...

  # During resource acquisition, tie something to DLM to obtain a lock
  tie my $sharedlock, DLM, mode=>'shared', timeout=>3, key=>$docname;
  # we now have up three seconds to access the $docname resource
  # without worry that it will be corrupted by writing done
under exclusive lock

when $sharedlock is destroyed, a message would go to the DLM server to release
the lock.

If a lock address can be build from a resource address, perhaps by
appending ".LOCK"
to the URI, and all participating resource servers (like WikiWiki
servers or something)
ran DRM handlers for the extension, we could prevent WikiPage editing
collisions by
marking pages Locked as soon as someone checks them out for editing.
Although in
that instance there are simpler ways to do that that do not involve
distribting special
DRM-aware software for editing wiki pages.

Or is there a problem with doing networking in DESTROY blocks that I
don't know about?

On Fri, 5 Nov 2004 16​:03​:01 -0500, Kurt Starsinic <kstarsinic@​gmail.com> wrote​:

On Fri, 5 Nov 2004 00​:43​:28 -0600, David Nicol <davidnicol@​gmail.com> wrote​:

Does anyone feel a need for some perl modules to facilitate locking against a
centralized lock management service?

Could you say more about that?  Perhaps with a couple of specific examples?

\- Kurt

--
David L Nicol
"How cool is that?" -- Elgie

@p5pRT
Copy link
Author

p5pRT commented Dec 3, 2011

@jkeenan - Status changed from 'new' to 'open'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

2 participants