/* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
#define PERL_LNM_MAX_ALLOWED_INDEX 127
-#define MAX_DCL_LINE_LENGTH 255
+#define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
+#define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
static char *__mystrtolower(char *str)
{
/*}}}*/
#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)
+{
+ 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
return ifi; /* this is the RMS internal file id */
}
-#define MAX_DCL_SYMBOL 255
static void pipe_infromchild_ast(pPipe p);
/*
fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
- fprintf(fp,"$ cmd = perl_popen_cmd\n");
+ fprintf(fp,"$! --- build command line to get max possible length\n");
+ fprintf(fp,"$c=perl_popen_cmd0\n");
+ fprintf(fp,"$c=c+perl_popen_cmd1\n");
+ fprintf(fp,"$c=c+perl_popen_cmd2\n");
+ fprintf(fp,"$x=perl_popen_cmd3\n");
+ fprintf(fp,"$c=c+x\n");
fprintf(fp,"$! --- get rid of global symbols\n");
fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
- fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd\n");
+ fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
+ fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
+ fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
+ fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
fprintf(fp,"$ perl_on\n");
- fprintf(fp,"$ 'cmd\n");
+ fprintf(fp,"$ 'c\n");
fprintf(fp,"$ perl_status = $STATUS\n");
fprintf(fp,"$ perl_del 'perl_cfile'\n");
fprintf(fp,"$ perl_exit 'perl_status'\n");
static int handler_set_up = FALSE;
unsigned long int sts, flags=1; /* nowait - gnu c doesn't allow &1 */
unsigned int table = LIB$K_CLI_GLOBAL_SYM;
- int wait = 0;
+ int j, wait = 0;
char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
char in[512], out[512], err[512], mbx[512];
FILE *tpipe = 0;
char tfilebuf[NAM$C_MAXRSS+1];
pInfo info;
+ char cmd_sym_name[20];
struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, symbol};
struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
DSC$K_CLASS_S, 0};
-
- $DESCRIPTOR(d_sym_cmd,"PERL_POPEN_CMD");
+ struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
+ DSC$K_CLASS_S, cmd_sym_name};
$DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
$DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
$DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
+ if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
+
/* once-per-program initialization...
note that the SETAST calls and the dual test of pipe_ef
makes sure that only the FIRST thread through here does
while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
if (*p == '$') p++; /* remove leading $ */
while (*p == ' ' || *p == '\t') p++;
+
+ for (j = 0; j < 4; j++) {
+ sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
+ d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
+
strncpy(symbol, p, MAX_DCL_SYMBOL);
d_symbol.dsc$w_length = strlen(symbol);
_ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
+ if (strlen(p) > MAX_DCL_SYMBOL) {
+ p += MAX_DCL_SYMBOL;
+ } else {
+ p += strlen(p);
+ }
+ }
_ckvmssts(sys$setast(0));
info->next=open_pipes; /* prepend to list */
open_pipes=info;
/* once the subprocess is spawned, it has copied the symbols and
we can get rid of ours */
+ for (j = 0; j < 4; j++) {
+ sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
+ d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
_ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
+ }
_ckvmssts(lib$delete_symbol(&d_sym_in, &table));
_ckvmssts(lib$delete_symbol(&d_sym_err, &table));
_ckvmssts(lib$delete_symbol(&d_sym_out, &table));
}
*p = '\0';
- store_pipelocs(); /* gets redone later */
fp = safe_popen(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++) {
unsigned long int
Perl_do_spawn(pTHX_ char *cmd)
{
- unsigned long int sts, substs, hadcmd = 1;
+ unsigned long int sts, substs;
TAINT_ENV();
TAINT_PROPER("spawn");
if (!cmd || !*cmd) {
- hadcmd = 0;
sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
+ if (!(sts & 1)) {
+ switch (sts) {
+ case RMS$_FNF: case RMS$_DNF:
+ set_errno(ENOENT); break;
+ case RMS$_DIR:
+ set_errno(ENOTDIR); break;
+ case RMS$_DEV:
+ set_errno(ENODEV); break;
+ case RMS$_PRV:
+ set_errno(EACCES); break;
+ case RMS$_SYN:
+ set_errno(EINVAL); break;
+ case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
+ set_errno(E2BIG); break;
+ case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
+ _ckvmssts(sts); /* fall through */
+ default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
+ set_errno(EVMSERR);
+ }
+ set_vaxc_errno(sts);
+ if (ckWARN(WARN_EXEC)) {
+ Perl_warner(aTHX_ WARN_EXEC,"Can't spawn: %s",
+ Strerror(errno));
+ }
+ }
+ sts = substs;
}
else {
(void) safe_popen(cmd, "nW", (int *)&sts);
- substs = sts;
- }
-
- if (!(sts & 1)) {
- switch (sts) {
- case RMS$_FNF: case RMS$_DNF:
- set_errno(ENOENT); break;
- case RMS$_DIR:
- set_errno(ENOTDIR); break;
- case RMS$_DEV:
- set_errno(ENODEV); break;
- case RMS$_PRV:
- set_errno(EACCES); break;
- case RMS$_SYN:
- set_errno(EINVAL); break;
- case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
- set_errno(E2BIG); break;
- case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
- _ckvmssts(sts); /* fall through */
- default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
- set_errno(EVMSERR);
- }
- set_vaxc_errno(sts);
- if (ckWARN(WARN_EXEC)) {
- Perl_warner(aTHX_ WARN_EXEC,"Can't spawn \"%s\": %s",
- hadcmd ? cmd : "",
- Strerror(errno));
- }
}
- vms_execfree(aTHX);
- return substs;
-
+ return sts;
} /* end of do_spawn() */
/*}}}*/
int my_sigismember(sigset_t *set, int sig) {
if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
- *set & (1 << (sig - 1));
+ return *set & (1 << (sig - 1));
}
/*}}}*/
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
- store_pipelocs(aTHX);
+ store_pipelocs(aTHX); /* will redo any earlier attempts */
return;
}
https://perl5.git.perl.org / perl5.git / blobdiff