A not-so-lethal kill() for VMS pre-7.0

Message-Id: <011127153734.62182@DUPHY4.Physics.Drexel.Edu>

p4raw-id: //depot/perl@13329

2 files changed, 107 insertions, 0 deletions

diff --git a/vms/vms.c b/vms/vms.c
index 43c81d80a4..7ecb29fed5 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -1093,6 +1093,106 @@ Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
 /*}}}*/
 #endif
 
+#ifdef KILL_BY_SIGPRC
+#include <errnodef.h>
+
+/* okay, this is some BLATENT hackery ... 
+   we use this if the kill() in the CRTL uses sys$forcex, causing the
+   target process to do a sys$exit, which usually can't be handled 
+   gracefully...certainly not by Perl and the %SIG{} mechanism.
+
+   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.
+
+   Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
+   on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
+   provide.  On VMS 7.0+ this is taken care of by doing sys$sigprc
+   with condition codes C$_SIG0+nsig*8, catching the exception on the 
+   target process and resignaling with appropriate arguments.
+
+   But we don't have that VMS 7.0+ exception handler, so if you
+   Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS.  Oh well.
+
+   Also note that SIGTERM is listed in the docs as being "unimplemented",
+   yet always seems to be signaled with a VMS condition code of 4 (and
+   correctly handled for that code).  So we hardwire it in.
+
+   Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
+   number to see if it's valid.  So Perl_my_kill(pid,0) returns -1 rather
+   than signalling with an unrecognized (and unhandled by CRTL) code.
+*/
+
+#define _MY_SIG_MAX 17
+
+int
+Perl_my_kill(int pid, int sig)
+{
+    int iss;
+    int sys$sigprc(unsigned int *pidadr,
+                     struct dsc$descriptor_s *prcname,
+                     unsigned int code);
+    static unsigned long sig_code[_MY_SIG_MAX+1] = 
+    {
+        0,                  /*  0 ZERO     */
+        SS$_HANGUP,         /*  1 SIGHUP   */
+        SS$_CONTROLC,       /*  2 SIGINT   */
+        SS$_CONTROLY,       /*  3 SIGQUIT  */
+        SS$_RADRMOD,        /*  4 SIGILL   */
+        SS$_BREAK,          /*  5 SIGTRAP  */
+        SS$_OPCCUS,         /*  6 SIGABRT  */
+        SS$_COMPAT,         /*  7 SIGEMT   */
+#ifdef __VAX                      
+        SS$_FLTOVF,         /*  8 SIGFPE VAX */
+#else                             
+        SS$_HPARITH,        /*  8 SIGFPE AXP */
+#endif                            
+        SS$_ABORT,          /*  9 SIGKILL  */
+        SS$_ACCVIO,         /* 10 SIGBUS   */
+        SS$_ACCVIO,         /* 11 SIGSEGV  */
+        SS$_BADPARAM,       /* 12 SIGSYS   */
+        SS$_NOMBX,          /* 13 SIGPIPE  */
+        SS$_ASTFLT,         /* 14 SIGALRM  */
+        4,                  /* 15 SIGTERM  */
+        0,                  /* 16 SIGUSR1  */
+        0                   /* 17 SIGUSR2  */
+    };
+
+#if __VMS_VER >= 60200000
+    static int initted = 0;
+    if (!initted) {
+        initted = 1;
+        sig_code[16] = C$_SIGUSR1;
+        sig_code[17] = C$_SIGUSR2;
+    }
+#endif
+
+    if (!pid || sig < _SIG_MIN || sig > _SIG_MAX || sig > _MY_SIG_MAX || !sig_code[sig]) {
+        return -1;
+    }
+
+    iss = sys$sigprc((unsigned int *)&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 --git a/vms/vmsish.h b/vms/vmsish.h
index 182758fa57..a21c9e3982 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -511,6 +511,10 @@ struct utimbuf {
 #    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 @@ FILE *	Perl_my_tmpfile ();
 #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 *);