From f2610a60660dc5fbebc67120bf8fe194b8ff585c Mon Sep 17 00:00:00 2001 From: Charles Lane Date: Tue, 27 Nov 2001 10:38:02 -0500 Subject: [PATCH] A not-so-lethal kill() for VMS pre-7.0 Message-Id: <011127153734.62182@DUPHY4.Physics.Drexel.Edu> p4raw-id: //depot/perl@13329 --- configure.com | 65 ++++++++++++++++++++++++++++++++++++++ vms/vms.c | 100 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ vms/vmsish.h | 7 ++++ 3 files changed, 172 insertions(+) diff --git a/configure.com b/configure.com index d8323ea..cdce92e 100644 --- a/configure.com +++ b/configure.com @@ -4915,9 +4915,73 @@ $ WS " }" $ 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 " +$ WS "#include " +$ 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 " +$ WS "#include " +$ 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" +$! +$! since SIGBUS and SIGSEGV indistinguishable, make them the same here. +$! sigusr1 and sigusr2 show up in VMS6.2 and later +$! +$ if vms_ver .GES. "6.2" +$ then +$ sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT USR1 USR2"",0" +$ psnwc1="""ZERO"",""HUP"",""INT"",""QUIT"",""ILL"",""TRAP"",""IOT"",""EMT"",""FPE"",""KILL"",""BUS"",""SEGV"",""SYS""," +$ psnwc2="""PIPE"",""ALRM"",""TERM"",""ABRT"",""USR1"",""USR2"",0" +$ sig_name_init = psnwc1 + psnwc2 +$ sig_num="0 1 2 3 4 5 6 7 8 9 10 10 12 13 14 15 6 16 17"",0" +$ sig_num_init="0,1,2,3,4,5,6,7,8,9,10,10,12,13,14,15,6,16,17,0" +$ sig_size="19" +$ else +$ sig_name="ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM ABRT"",0" +$ psnwc1="""ZERO"",""HUP"",""INT"",""QUIT"",""ILL"",""TRAP"",""IOT"",""EMT"",""FPE"",""KILL"",""BUS"",""SEGV"",""SYS""," +$ psnwc2="""PIPE"",""ALRM"",""TERM"",""ABRT"",0" +$ sig_name_init = psnwc1 + psnwc2 +$ sig_num="0 1 2 3 4 5 6 7 8 9 10 10 12 13 14 15 6"",0" +$ sig_num_init="0,1,2,3,4,5,6,7,8,9,10,10,12,13,14,15,6,0" +$ sig_size="17" +$ endif +$ ENDIF +$ ENDIF $ DELETE/SYMBOL tmp $! $! Finally the composite ones. All config @@ -5752,6 +5816,7 @@ $ THEN $! 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 --git a/vms/vms.c b/vms/vms.c index 43c81d8..7ecb29f 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 + +/* 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 182758f..a21c9e3 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 *); -- 2.7.4