The most common cause of test failures on VMS is the insertion of extra
newlines in pipes. For more details, see the archives, but the gist of
it is that you never know whether
print 'a', 'b', 'c', "\n";
will give you the same thing as
print "abc\n";
when the output device is a pipe and autoflushing is enabled (which it
typically needs to be for inter-process communication). The first
example might well give you an extra newline somewhere in the middle.
So I took a swing at replacing our mailbox-based pipe implementation
with a socketpair-based implementation. Since sockets are
stream-oriented devices (unlike mailboxes, which are record-oriented),
it seemed like this at least had the potential to solve our problems.
There is a diff attached to this message that shows what I did. The
experiment failed, for reasons that I'll attempt to summarize. I used
the socketpair that came with the CRTL in v8.2, but if other obstacles
can be overcome, a homegrown socketpair might well work on older
versions of VMS.
I borrowed some infrastructure from the existing pipe implementation but
left it intact, protected by #ifdefs. I did get communication happening
through the socket-based pipes, but all carriage control was stripped.
Instead of getting the occasional spurious newline, I got none at all.
Somehow the sockets need to be convinced to leave the carriage control
information alone, but I was not able to come up with a way to do that.
Aside from the obvious fact that I didn't get it working, the main
drawbacks to using sockets come down to:
-- The TCP/IP Services documentation says that standard I/O is not
supported on sockets, and specifically fdopen() is not supported. Since
popen() returns a FILE pointer, you absolutely have to have that. The
calls to fdopen() succeed, but if the other stdio functions don't
properly handle the resulting FILE pointers, that may explain the loss
of carriage control.
-- Modifying the buffer size on a socket cannot be done without
privileges; you're stuck with 256 bytes, which is likely to be a serious
performance drag.
I'm not sure I've gained anything except a better understanding of the
challenge. I think the next thing to try is turning off all the
home-grown piping code and seeing if the new DECC$STREAM_PIPE feature
does us any good, though that unfortunately requires 8.2 and later.
BTW, as I understand it, most modern unices use shared memory for pipes.
Is there any particular reason we couldn't use global sections on VMS?
--- vms/vms.c;-0 Wed Dec 14 16:04:57 2005
+++ vms/vms.c Mon Jan 2 18:51:41 2006
@@ -2105,10 +2105,22 @@ int test_unix_status;
return SS$_ABORT; /* Should not get here */
}
+static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img,
int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
+static void vms_execfree(struct dsc$descriptor_s *vmscmd);
+
+struct exit_control_block
+{
+ struct exit_control_block *flink;
+ unsigned long int (*exit_routine)();
+ unsigned long int arg_count;
+ unsigned long int *status_address;
+ unsigned long int exit_status;
+};
/* default piping mailbox size */
#define PERL_BUFSIZ 512
+#ifdef USE_PERL_MAILBOX_PIPES
static void
create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
@@ -2227,15 +2239,6 @@ struct pipe_details
int err_done;
};
-struct exit_control_block
-{
- struct exit_control_block *flink;
- unsigned long int (*exit_routine)();
- unsigned long int arg_count;
- unsigned long int *status_address;
- unsigned long int exit_status;
-};
-
typedef struct _closed_pipes Xpipe;
typedef struct _closed_pipes* pXpipe;
@@ -2444,9 +2447,6 @@ popen_completion_ast(pInfo info)
}
-static unsigned long int setup_cmddsc(pTHX_ const 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
get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
@@ -3478,6 +3478,219 @@ safe_popen(pTHX_ const char *cmd, const
return info->fp;
} /* end of safe_popen */
+#elif defined (USE_PERL_SOCKPAIR_PIPES)
+
+
+typedef struct pipe_details Info;
+typedef struct pipe_details* pInfo;
+static pInfo open_pipes = NULL;
+
+struct pipe_details
+{
+ pInfo next;
+ FILE *fp; /* file pointer to pipe */
+ int pid; /* PID of subprocess */
+ int done; /* subprocess has completed */
+ unsigned int completion; /* termination status of subprocess */
+};
+
+static int pipe_ef = 0;
+
+static void
+popen_completion_ast(pInfo info)
+{
+ pInfo i = open_pipes;
+
+ info->completion &= 0x0FFFFFFF; /* strip off "control" field */
+
+ while (i) {
+ if (i == info) break;
+ i = i->next;
+ }
+ if (!i) return; /* unlinked, probably freed too */
+
+ info->done = TRUE;
+ _ckvmssts_noperl(sys$setef(pipe_ef));
+}
+
+FILE *
+vms_sockpair_popen(const char *command, const char *mode)
+{
+ unsigned short int pd0chan, pd1chan;
+ int pd[2];
+ FILE *parent_return_fd;
+ unsigned int dviitm = DVI$_DEVNAM;
+ char pd0_devnam[LNM$C_NAMLENGTH+1], pd1_devnam[LNM$C_NAMLENGTH+1];
+ struct dsc$descriptor_s pd0_devnam_dsc
+ = { LNM$C_NAMLENGTH, DSC$K_DTYPE_T, DSC$K_CLASS_S, pd0_devnam };
+ struct dsc$descriptor_s pd1_devnam_dsc
+ = { LNM$C_NAMLENGTH, DSC$K_DTYPE_T, DSC$K_CLASS_S, pd1_devnam };
+ struct dsc$descriptor_s *command_dsc;
+ char bidirectional = 0;
+ unsigned int flags = CLI$M_NOWAIT;
+ struct dsc$descriptor_s *child_in = NULL, *child_out = NULL;
+ int info_size, status, i;
+ pInfo info;
+ char mymode[6] = "\0";
+ const char *c;
+
+ if (command == NULL || mode == NULL) {
+ SETERRNO(EINVAL, LIB$_INVARG);
+ return NULL;
+ }
+
+ status = setup_cmddsc(aTHX_ command, 0, 0, &command_dsc);
+ if (!(status & 1)) {
+ switch (status) {
+ 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(status); /* fall through */
+ default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
+ set_errno(EVMSERR);
+ }
+ set_vaxc_errno(status);
+ if (ckWARN(WARN_PIPE)) {
+ Perl_warner(aTHX_ packWARN(WARN_PIPE),
+ "Can't pipe \"%*s\": %s",
+ strlen(command),
+ command,
+ Strerror(errno));
+ }
+ return NULL;
+ }
+
+ if (!pipe_ef) {
+ status = lib$get_ef(&pipe_ef);
+ if (!(status & 1)) {
+ SETERRNO(EVMSERR, status);
+ return NULL;
+ }
+ }
+
+ if (socketpair(AF_INET, SOCK_STREAM, 0, pd) < 0) {
+ return NULL;
+ }
+
+ pd0chan = decc$get_sdc( pd[0] );
+ pd1chan = decc$get_sdc( pd[1] );
+
+ status = lib$getdvi(&dviitm, &pd0chan, NULL, NULL,
+ &pd0_devnam_dsc, &pd0_devnam_dsc.dsc$w_length);
+
+ if (status & 1) {
+ status = lib$getdvi(&dviitm, &pd1chan, NULL, NULL,
+ &pd1_devnam_dsc, &pd1_devnam_dsc.dsc$w_length);
+ }
+
+ if (!(status & 1)) {
+ SETERRNO(EVMSERR, status);
+ (void) close(pd[0]);
+ (void) close(pd[1]);
+ return NULL;
+ }
+
+ pd0_devnam_dsc.dsc$a_pointer[pd0_devnam_dsc.dsc$w_length] = '\0';
+ pd1_devnam_dsc.dsc$a_pointer[pd1_devnam_dsc.dsc$w_length] = '\0';
+
+ info_size = sizeof(Info);
+ status = lib$get_vm(&info_size, &info);
+ if (!(status & 1)) {
+ SETERRNO(ENOMEM, status);
+ (void) close(pd[0]);
+ (void) close(pd[1]);
+ return NULL;
+ }
+
+ info->done = 0;
+ info->pid = 0;
+ info->completion = 0;
+
+ /* throw away invalid mode specifiers */
+ c = mode;
+ while (*c) {
+ if (strchr("rwb+\0", *c)) {
+ strncat(mymode, c, 1);
+ }
+ c++;
+ }
+
+ if (strchr(mymode, '+')) {
+ bidirectional = 1;
+ strcpy(mymode, "r+");
+ }
+/**
+ if (!strchr(mymode, 'b'))
+ strncat(mymode, "b", 1);
+**/
+ if (mymode[0] == 'r') {
+ child_out = &pd1_devnam_dsc;
+ if (bidirectional)
+ child_in = &pd1_devnam_dsc;
+ }
+ else {
+ child_in = &pd0_devnam_dsc;
+ }
+
+ (void) sys$setast(0);
+
+ status = lib$spawn(command_dsc,
+ child_in,
+ child_out,
+ &flags,
+ 0,
+ &info->pid,
+ &info->completion,
+ 0,
+ popen_completion_ast,
+ info,
+ 0,0,0);
+
+ vms_execfree(command_dsc);
+ if (!(status & 1)) {
+ SETERRNO(EVMSERR, status);
+ (void) close(pd[0]);
+ (void) close(pd[1]);
+ (void) lib$free_vm(&info_size, &info);
+ (void) sys$setast(1);
+ return NULL;
+ }
+
+ if (mymode[0] == 'r') {
+ parent_return_fd = fdopen(pd[0], mymode);
+ (void) close(pd[1]);
+ }
+ else {
+ parent_return_fd = fdopen(pd[1], mymode);
+ (void) close(pd[0]);
+ }
+
+ info->next=open_pipes; /* prepend to list */
+ open_pipes=info;
+ info->fp = parent_return_fd;
+
+#ifdef PERL_IMPLICIT_CONTEXT
+ if (aTHX)
+#endif
+ PL_forkprocess = info->pid;
+
+ (void) sys$setast(1);
+
+ return parent_return_fd;
+
+} /* end of vms_sockpair_popen */
+
+#endif /* USE_PERL_MAILBOX_PIPES elif USE_PERL_SOCKPAIR_PIPES */
/*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
PerlIO *
@@ -3487,7 +3700,13 @@ Perl_my_popen(pTHX_ const char *cmd, con
TAINT_ENV();
TAINT_PROPER("popen");
PERL_FLUSHALL_FOR_CHILD;
+#if USE_PERL_MAILBOX_PIPES
return safe_popen(aTHX_ cmd,mode,&sts);
+#elif defined(USE_PERL_SOCKPAIR_PIPES)
+ return PerlIO_importFILE(vms_sockpair_popen(cmd, mode), mode);
+#else
+ return popen(cmd, mode);
+#endif /* USE_PERL_MAILBOX_PIPES */
}
/*}}}*/
@@ -3496,14 +3715,25 @@ Perl_my_popen(pTHX_ const char *cmd, con
I32 Perl_my_pclose(pTHX_ PerlIO *fp)
{
pInfo info, last = NULL;
- unsigned long int retsts;
- int done, iss, n;
+ int retsts;
+ int done, iss, n, pid;
+
+#if !defined(USE_PERL_SOCKPAIR_PIPES) && !defined(USE_PERL_MAILBOX_PIPES)
+
+ FILE *stdio = PerlIO_exportFILE(fp, 0);
+ retsts = pclose(stdio);
+ PerlIO_releaseFILE(fp, stdio);
+ return retsts;
+
+#endif
+
+#ifdef USE_PERL_MAILBOX_PIPES
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
if (info == NULL) { /* no such pipe open */
- set_errno(ECHILD); /* quoth POSIX */
+ set_errno(ECHILD);
set_vaxc_errno(SS$_NONEXPR);
return -1;
}
@@ -3559,6 +3789,30 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp)
}
retsts = info->completion;
+#elif defined(USE_PERL_SOCKPAIR_PIPES)
+
+ FILE *stdio = PerlIO_exportFILE(fp, 0);
+
+ for (info = open_pipes; info != NULL; last = info, info = info->next)
+ if (info->fp == stdio) break;
+
+ if (info == NULL) { /* no such pipe open */
+ SETERRNO(ECHILD, SS$_NONEXPR);
+ return -1;
+ }
+
+ (void) fclose((FILE *)info->fp);
+
+ PerlIO_releaseFILE(fp, stdio);
+
+ do {
+ pid = my_waitpid(info->pid, &retsts, 0);
+ } while (pid == -1 && errno == EINTR);
+
+ if (pid == -1) retsts == -1;
+
+#endif
+
/* remove from list of open pipes */
_ckvmssts(sys$setast(0));
if (last) last->next = info->next;
@@ -3567,6 +3821,8 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp)
/* free buffers and structures */
+#ifdef USE_PERL_MAILBOX_PIPES
+
if (info->in) {
if (info->in->buf) {
n = info->in->bufsize * sizeof(char);
@@ -3591,6 +3847,9 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp)
n = sizeof(Pipe);
_ckvmssts(lib$free_vm(&n, &info->err));
}
+
+#endif
+
n = sizeof(Info);
_ckvmssts(lib$free_vm(&n, &info));
@@ -3620,6 +3879,8 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *st
if (statusp) *statusp = 0;
+#if defined(USE_PERL_SOCKPAIR_PIPES) || defined(USE_PERL_MAILBOX_PIPES)
+
for (info = open_pipes; info != NULL; info = info->next)
if (info->pid == pid) break;
@@ -3635,6 +3896,9 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *st
if (statusp) *statusp = info->completion;
return pid;
}
+#endif
+
+#ifdef USE_PERL_MAILBOX_PIPES
/* child that already terminated? */
@@ -3645,6 +3909,8 @@ Perl_my_waitpid(pTHX_ Pid_t pid, int *st
}
}
+#endif
+
/* fall through if this child is not one of our own pipe children */
#if defined(__CRTL_VER) && __CRTL_VER >= 70200000
@@ -5640,7 +5906,7 @@ int quoted;
else {
if (dotdir_seen) {
/* Perl wants an empty directory here to tell the difference
- * between a DCL commmand and a filename
+ * between a DCL command and a filename
*/
*vmsptr++ = '[';
*vmsptr++ = ']';
@@ -7003,9 +7269,9 @@ pipe_and_fork(pTHX_ char **cmargv)
}
*p = '\0';
- fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
+ fp = my_popen(aTHX_ subcmd,"wbF");
if (fp == Nullfp) {
- PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
+ PerlIO_printf(Perl_debug_log,"Can't open output pipe (status
%d)",vaxc$errno);
}
}
@@ -8268,7 +8534,11 @@ Perl_do_spawn(pTHX_ const char *cmd)
}
else {
PerlIO * fp;
+#ifdef USE_PERL_MAILBOX_PIPES
fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
+#else
+ fp = my_popen(aTHX_ cmd, "r+");
+#endif
if (fp != NULL)
my_pclose(fp);
}
@@ -10733,7 +11003,9 @@ init_os_extras(void)
newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
#endif
+#ifdef USE_PERL_MAILBOX_PIPES
store_pipelocs(aTHX); /* will redo any earlier attempts */
+#endif
return;
}
