I've run across the problem a number of times, primarily in the test suite,
where:
kill 'HUP', $$;
will blow away the whole Perl image...setting $SIG doesn't help, no real
way to catch it.
On VMS 6.2, the reason is simple: the CRTL kill() is implemented with
SYS$FORCEX, which causes a SYS$EXIT to be called rather than raising an
exception.
Later versions of VMS (7.1, for example) have a rather nicer kill(), where
signals are actually delivered.
I did some checking into this, and found a way to implement a gentler
kill() using an undocumented system service: SYS$SIGPRC. Doing some
assembly-level stepping through kill() on VMS 7.1 gives some hint that
SYS$SIGPRC is indeed what is being used.
Here's a patch to:
CONFIGURE.COM:
check if kill is doing a SYS$FORCEX
check if SYS$SIGPRC will work as a kill() substitute
--> #define KILL_BY_SIGPRC in config.h
[.VMS]VMSISH.H
if KILL_BY_SIGPRC defines kill -> Perl_my_kill
[.VMS]VMS.C
On first call to Perl_my_kill we:
set a temp exception handler
run through the signals and store the VMS exception status produced
Then check if the signal is in valid range, call SYS$SIGPRC with the
correct VMS status, handle errors, etc.
I found that on VMS 7.1, kill() was throwing an exception with code:
0x10000000 + 0x3DF00 + (signal*8)
While VMS 6.2 was a whole gamut of more "normal" codes (ACCVIO, etc.)
There didn't seem to be an obvious source of the mapping of
signal#->VMS_status, so it looked like a dynamic mapping would be best...
and should still work if you take your .EXE from VMS 6.2 to 7.1, for example.
Okay, you can all flame me now for proposing to insert an undocumented
system service (gasp!) call in Perl. But note that this would only affect
VMS versions earlier than current, where the system software is presumably
static.
For (a tiny bit) more info on SYS$SIGPRC, see:
http://www.openvms.compaq.com/wizard/wiz_2889.html
diff -uBb configure.com-orig configure.com
--- configure.com-orig Mon Nov 19 14:27:56 2001
+++ configure.com Mon Nov 19 16:02:52 2001
@@ -4914,9 +4914,51 @@
$ WS " printf(""%d\n"", i);"
$ WS " exit(0);"
$ WS "}"
+$ CS
$ GOSUB compile
$ d_nv_preserves_uv_bits = tmp
$ ENDIF
+$!
+$ echo4 "Checking whether your kill() uses SYS$FORCEX..."
+$ kill_by_sigprc = "undef"
+$ OS
+$ WS "#include <stdio.h>"
+$ WS "#include <signal.h>"
+$ WS "void handler(int s) { printf(""%d\n"",s); } "
+$ WS "main(){"
+$ WS " printf(""0"");"
+$ WS " signal(1,handler); kill(0,1);"
+$ WS "}"
+$ CS
+$ ON ERROR THEN CONTINUE
+$ GOSUB compile
+$ IF tmp .NES. "01"
+$ THEN
+$ echo "Yes, it does."
+$ echo4 "Checking whether we can use SYS$SIGPRC instead"
+$ OS
+$ WS "#include <stdio.h>"
+$ WS "#include <lib$routines.h>"
+$ WS "unsigned long code = 0;"
+$ WS "int handler(unsigned long *args) {"
+$ WS " code = args[1];"
+$ WS " return 1;"
+$ WS "}"
+$ WS "main() { "
+$ WS " int iss, sys$sigprc();"
+$ WS " lib$establish(handler);"
+$ WS " iss = sys$sigprc(0,0,0x1234);"
+$ WS " iss = ((iss&1)==1 && code == 0x1234);"
+$ WS " printf(""%d\n"",iss);"
+$ WS "}"
+$ CS
+$ GOSUB compile
+$ IF tmp .EQS. "1"
+$ THEN
+$ echo "looks like we can"
+$ kill_by_sigprc = "define"
+$ ENDIF
+$ ENDIF
$ DELETE/SYMBOL tmp
$!
$! Finally the composite ones. All config
@@ -5748,6 +5790,7 @@
$! Alas this does not help to build Fcntl
$! WC "#define PERL_IGNORE_FPUSIG SIGFPE"
$ ENDIF
+$ IF kill_by_sigprc .EQS. "define" then WC "#define KILL_BY_SIGPRC"
$ CLOSE CONFIG
$!
$ echo4 "Doing variable substitutions on .SH files..."
diff -uBb vms/vms.c-orig vms/vms.c
--- vms/vms.c-orig Mon Nov 19 17:19:14 2001
+++ vms/vms.c Mon Nov 19 17:19:10 2001
@@ -1093,6 +1093,75 @@
/*}}}*/
#endif
+#ifdef KILL_BY_SIGPRC
+/* okay, this is some blatent hackery ...
+ we use this if the kill() in the CRTL uses sys$forcex. So, instead
+ we use the (undocumented) system service sys$sigprc. It has the same
+ parameters as sys$forcex, but throws an exception in the target process
+ rather than calling sys$exit.
+
+ The tricky bit is to go from unixoid signal#'s to VMS condition codes.
+ And to do that, we run through the signals and make a table of the VMS
+ codes that are actually thrown.
+*/
+
+static unsigned long sig_code[_SIG_MAX+1];
+static int sig_code_ndx = -1;
+
+static int
+temp_handler(unsigned long *args)
+{
+ sig_code[sig_code_ndx] = args[1];
+ return SS$_CONTINUE;
+}
+
+static void
+get_sigcodes(void)
+{
+ int iss;
+ if (sig_code_ndx != -1) return;
+
+ lib$establish(temp_handler);
+ for (sig_code_ndx = _SIG_MIN; sig_code_ndx < _SIG_MAX+1; sig_code_ndx++) {
+ iss = raise(sig_code_ndx);
+ }
+}
+
+
+int
+Perl_my_kill(int pid, int sig)
+{
+ int iss;
+ int sys$sigprc();
+
+ get_sigcodes();
+ if (sig < _SIG_MIN || sig > _SIG_MAX) {
+ return -1;
+ }
+
+ iss = sys$sigprc(&pid,0,sig_code[sig]);
+ if (iss&1) return 0;
+
+ switch (iss) {
+ case SS$_NOPRIV:
+ set_errno(EPERM); break;
+ case SS$_NONEXPR:
+ case SS$_NOSUCHNODE:
+ case SS$_UNREACHABLE:
+ set_errno(ESRCH); break;
+ case SS$_INSFMEM:
+ set_errno(ENOMEM); break;
+ default:
+ _ckvmssts(iss);
+ set_errno(EVMSERR);
+ }
+ set_vaxc_errno(iss);
+
+ return -1;
+}
+#endif
+
+
/* default piping mailbox size */
#define PERL_BUFSIZ 512
diff -uBb vms/vmsish.h-orig vms/vmsish.h
--- vms/vmsish.h-orig Mon Nov 19 14:28:12 2001
+++ vms/vmsish.h Mon Nov 19 13:38:28 2001
@@ -511,6 +511,10 @@
# define sigaction(a,b,c) Perl_my_sigaction(a,b,c)
# endif
#endif
+#ifdef KILL_BY_SIGPRC
+# define kill Perl_my_kill
+#endif
+
/* VMS doesn't use a real sys_nerr, but we need this when scanning for error
* messages in text strings . . .
@@ -768,6 +772,9 @@
#ifndef HOMEGROWN_POSIX_SIGNALS
int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);
#endif
+#ifdef KILL_BY_SIGPRC
+int Perl_my_kill (int, int);
+#endif
int Perl_my_utime (pTHX_ char *, struct utimbuf *);
void Perl_vms_image_init (int *, char ***);
struct dirent * Perl_readdir (pTHX_ DIR *);
--
Drexel University \V --Chuck Lane
======]---------->--------*------------<-------[===========
(215) 895-1545 _/ \ Particle Physics
FAX: (215) 895-5934 /\ /~~~~~~~~~~~ [EMAIL PROTECTED]
