/*}}}*/
#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
+
+unsigned int
+Perl_sig_to_vmscondition(int sig)
+{
+ static unsigned int 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 (sig < _SIG_MIN) return 0;
+ if (sig > _MY_SIG_MAX) return 0;
+ return sig_code[sig];
+}
+
+
+int
+Perl_my_kill(int pid, int sig)
+{
+ dTHX;
+ int iss;
+ unsigned int code;
+ int sys$sigprc(unsigned int *pidadr,
+ struct dsc$descriptor_s *prcname,
+ unsigned int code);
+
+ code = Perl_sig_to_vmscondition(sig);
+
+ if (!pid || !code) {
+ return -1;
+ }
+
+ iss = sys$sigprc((unsigned int *)&pid,0,code);
+ 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
}
-static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote);
-static void vms_execfree(pTHX);
+static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
+static void vms_execfree(struct dsc$descriptor_s *vmscmd);
/*
we actually differ from vmstrnenv since we use this to
STRLEN n_a;
if (head_PLOC)
- free_pipelocs(&head_PLOC);
+ free_pipelocs(aTHX_ &head_PLOC);
/* the . directory from @INC comes last */
/* get the directory from $^X */
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
+#else
if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
+#endif
strcpy(temp, PL_origargv[0]);
x = strrchr(temp,']');
if (x) x[1] = '\0';
/* reverse order of @INC entries, skip "." since entered above */
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX)
+#endif
if (PL_incgv) av = GvAVn(PL_incgv);
for (i = 0; av && i <= AvFILL(av); i++) {
p->dir[NAM$C_MAXRSS] = '\0';
}
#endif
- Perl_call_atexit(aTHX_ &free_pipelocs, &head_PLOC);
}
DSC$K_CLASS_S, 0};
struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, cmd_sym_name};
+ struct dsc$descriptor_s *vmscmd;
$DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
$DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
$DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
vmspipedsc.dsc$a_pointer = tfilebuf;
vmspipedsc.dsc$w_length = strlen(tfilebuf);
- sts = setup_cmddsc(aTHX_ cmd,0,0);
+ sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
if (!(sts & 1)) {
switch (sts) {
case RMS$_FNF: case RMS$_DNF:
d_symbol.dsc$w_length = strlen(symbol);
_ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
- p = VMSCMD.dsc$a_pointer;
+ p = vmscmd->dsc$a_pointer;
while (*p && *p != '\n') p++;
*p = '\0'; /* truncate on \n */
- p = VMSCMD.dsc$a_pointer;
+ p = vmscmd->dsc$a_pointer;
while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
if (*p == '$') p++; /* remove leading $ */
while (*p == ' ' || *p == '\t') p++;
_ckvmssts(lib$delete_symbol(&d_sym_in, &table));
_ckvmssts(lib$delete_symbol(&d_sym_err, &table));
_ckvmssts(lib$delete_symbol(&d_sym_out, &table));
- vms_execfree(aTHX);
+ vms_execfree(vmscmd);
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX)
+#endif
PL_forkprocess = info->pid;
+
if (wait) {
int done = 0;
while (!done) {
pipe_and_fork(pTHX_ char **cmargv)
{
PerlIO *fp;
+ struct dsc$descriptor_s *vmscmd;
char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
int sts, j, l, ismcr, quote, tquote = 0;
- sts = setup_cmddsc(cmargv[0],0,"e);
+ sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
+ vms_execfree(vmscmd);
j = l = 0;
p = subcmd;
}
*p = '\0';
- fp = safe_popen(subcmd,"wbF",&sts);
+ fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
if (fp == Nullfp) {
PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
}
{ sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
{ 0, 0, 0, 0} };
+#ifdef KILL_BY_SIGPRC
+ (void) Perl_csighandler_init();
+#endif
+
_ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
_ckvmssts_noperl(iosb[0]);
for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
static void
-vms_execfree(pTHX) {
- if (PL_Cmd) {
- if (PL_Cmd != VMSCMD.dsc$a_pointer) Safefree(PL_Cmd);
- PL_Cmd = Nullch;
- }
- if (VMSCMD.dsc$a_pointer) {
- Safefree(VMSCMD.dsc$a_pointer);
- VMSCMD.dsc$w_length = 0;
- VMSCMD.dsc$a_pointer = Nullch;
+vms_execfree(struct dsc$descriptor_s *vmscmd)
+{
+ if (vmscmd) {
+ if (vmscmd->dsc$a_pointer) {
+ Safefree(vmscmd->dsc$a_pointer);
+ }
+ Safefree(vmscmd);
}
}
static unsigned long int
-setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote)
+setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
+ struct dsc$descriptor_s **pvmscmd)
{
char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
$DESCRIPTOR(defdsc,".EXE");
$DESCRIPTOR(defdsc2,".");
$DESCRIPTOR(resdsc,resspec);
+ struct dsc$descriptor_s *vmscmd;
struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
register char *s, *rest, *cp, *wordbreak;
register int isdcl;
+ New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
+ vmscmd->dsc$a_pointer = NULL;
+ vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
+ vmscmd->dsc$b_class = DSC$K_CLASS_S;
+ vmscmd->dsc$w_length = 0;
+ if (pvmscmd) *pvmscmd = vmscmd;
+
if (suggest_quote) *suggest_quote = 0;
if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
if (check_img && isdcl) return RMS$_FNF;
if (cando_by_name(S_IXUSR,0,resspec)) {
- New(402,VMSCMD.dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
+ New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
if (!isdcl) {
- strcpy(VMSCMD.dsc$a_pointer,"$ MCR ");
+ strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
if (suggest_quote) *suggest_quote = 1;
} else {
- strcpy(VMSCMD.dsc$a_pointer,"@");
+ strcpy(vmscmd->dsc$a_pointer,"@");
if (suggest_quote) *suggest_quote = 1;
}
- strcat(VMSCMD.dsc$a_pointer,resspec);
- if (rest) strcat(VMSCMD.dsc$a_pointer,rest);
- VMSCMD.dsc$w_length = strlen(VMSCMD.dsc$a_pointer);
- return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
+ strcat(vmscmd->dsc$a_pointer,resspec);
+ if (rest) strcat(vmscmd->dsc$a_pointer,rest);
+ vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
+ return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
}
else retsts = RMS$_PRV;
}
}
/* It's either a DCL command or we couldn't find a suitable image */
- VMSCMD.dsc$w_length = strlen(cmd);
- if (cmd == PL_Cmd) {
- VMSCMD.dsc$a_pointer = PL_Cmd;
+ vmscmd->dsc$w_length = strlen(cmd);
+/* if (cmd == PL_Cmd) {
+ vmscmd->dsc$a_pointer = PL_Cmd;
if (suggest_quote) *suggest_quote = 1;
}
- else VMSCMD.dsc$a_pointer = savepvn(cmd,VMSCMD.dsc$w_length);
+ else */
+ vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
/* check if it's a symbol (for quoting purposes) */
if (suggest_quote && !*suggest_quote) {
struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
eqvdsc.dsc$a_pointer = equiv;
- iss = lib$get_symbol(&VMSCMD,&eqvdsc);
+ iss = lib$get_symbol(vmscmd,&eqvdsc);
if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
}
if (!(retsts & 1)) {
else { _ckvmssts(retsts); }
}
- return (VMSCMD.dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
+ return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
} /* end of setup_cmddsc() */
bool
Perl_vms_do_exec(pTHX_ char *cmd)
{
+ struct dsc$descriptor_s *vmscmd;
if (vfork_called) { /* this follows a vfork - act Unixish */
vfork_called--;
TAINT_ENV();
TAINT_PROPER("exec");
- if ((retsts = setup_cmddsc(aTHX_ cmd,1,0)) & 1)
- retsts = lib$do_command(&VMSCMD);
+ if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
+ retsts = lib$do_command(vmscmd);
switch (retsts) {
case RMS$_FNF: case RMS$_DNF:
set_vaxc_errno(retsts);
if (ckWARN(WARN_EXEC)) {
Perl_warner(aTHX_ WARN_EXEC,"Can't exec \"%*s\": %s",
- VMSCMD.dsc$w_length, VMSCMD.dsc$a_pointer, Strerror(errno));
+ vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
}
- vms_execfree(aTHX);
+ vms_execfree(vmscmd);
}
return FALSE;
sts = substs;
}
else {
- (void) safe_popen(cmd, "nW", (int *)&sts);
+ (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
}
return sts;
} /* end of do_spawn() */
void
Perl_sys_intern_init(pTHX)
{
- int ix = RAND_MAX;
- float x;
+ unsigned int ix = RAND_MAX;
+ double x;
VMSISH_HUSHED = 0;
x = (float)ix;
MY_INV_RAND_MAX = 1./x;
-
- VMSCMD.dsc$a_pointer = NULL;
- VMSCMD.dsc$w_length = 0;
- VMSCMD.dsc$b_dtype = DSC$K_DTYPE_T;
- VMSCMD.dsc$b_class = DSC$K_CLASS_S;
}
void
https://perl5.git.perl.org / perl5.git / blobdiff