1 /*
2 * Copyright (C) 2004-2014, Parrot Foundation.
3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
4 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others
5 */
6
7 /*
8
9 =head1 NAME
10
11 src/platform/vms/exec.c
12
13 =head1 DESCRIPTION
14
15 Parrot functions to run VMS operating system commands.
16
17 =head2 Functions
18
19 =over 4
20
21 =cut
22
23 */
24
25 #include "parrot/parrot.h"
26
27 #include <clidef.h>
28
29 #include <unistd.h>
30 #include <sys/types.h>
31 #include <sys/wait.h>
32
33 static FILE* safe_popen(const char *cmd, const char *in_mode, int *psts);
34 static int do_spawn2(const char *cmd, int flags);
35 static void vms_get_subproc_handles(int pid, PIOHANDLE *handles);
36
37 /* HEADERIZER HFILE: none */
38
39 /*
40
41 =item C<INTVAL Parrot_Run_OS_Command(PARROT_INTERP, STRING *command)>
42
43 Spawn off a subprocess provided in a string. Wait for it to complete,
44 returning the return value of the process.
45
46 =cut
47
48 */
49
50 INTVAL
Parrot_Run_OS_Command(PARROT_INTERP,STRING * command)51 Parrot_Run_OS_Command(PARROT_INTERP, STRING *command)
52 {
53 char * const cmd = Parrot_str_to_cstring(interp, command);
54 int status = do_spawn2(cmd, 0);
55 return (status&1) ? 0 : 1;
56 }
57
58 /*
59
60 =item C<INTVAL Parrot_Run_OS_Command_Argv(PARROT_INTERP, PMC *cmdargs)>
61
62 Spawn off a subprocess provided in command-line arguments. Wait for it to
63 complete, returning the return value of the process.
64
65 =cut
66
67 */
68
69 INTVAL
Parrot_Run_OS_Command_Argv(PARROT_INTERP,PMC * cmdargs)70 Parrot_Run_OS_Command_Argv(PARROT_INTERP, PMC *cmdargs)
71 {
72 int len = VTABLE_elements(interp, cmdargs);
73 char **argv = mem_gc_allocate_n_typed(interp, (len+1), char*);
74 char *cmd, *p;
75 int status, i, cmdlen = 0, arglen;
76
77 if (len == 0)
78 Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN,
79 "Empty argument array for Run_OS_Command_Argv");
80
81 for (i = 0; i < len; ++i) {
82 STRING *s = VTABLE_get_string_keyed_int(interp, cmdargs, i);
83 argv[i] = Parrot_str_to_cstring(interp, s);
84 cmdlen += strlen(argv[i]);
85 }
86 p = cmd = mem_gc_allocate_n_typed(interp, (cmdlen+len), char);
87 for (i = 0; i < len; ++i) {
88 if (i != 0) *p++ = ' ';
89 arglen = strlen(argv[i]);
90 mem_copy_n_typed(p, argv[i], arglen, char);
91 p += arglen;
92 }
93
94 status = do_spawn2(cmd, 0);
95
96 mem_gc_free(interp, cmd);
97 mem_gc_free(interp, argv);
98
99 return (status&1) ? 0 : 1;
100 }
101
102 /*
103
104 =item C<UINTVAL Parrot_getpid(void)>
105
106 Parrot wrapper around standard library C<getpid()> function, returning an UINTVAL.
107
108 =cut
109
110 */
111
112 UINTVAL
Parrot_getpid(void)113 Parrot_getpid(void)
114 {
115 return getpid();
116 }
117
118 /*
119
120 =item C<INTVAL Parrot_proc_exec(PARROT_INTERP, STRING *command, INTVAL flags,
121 PIOHANDLE *handles)>
122
123 Execute an external process.
124
125 =cut
126
127 */
128
129 PARROT_WARN_UNUSED_RESULT
130 INTVAL
Parrot_proc_exec(PARROT_INTERP,ARGIN (STRING * command),INTVAL flags,ARGMOD (PIOHANDLE * handles))131 Parrot_proc_exec(PARROT_INTERP, ARGIN(STRING *command), INTVAL flags,
132 ARGMOD(PIOHANDLE *handles))
133 {
134 int pid = 0;
135 char * const cmd = Parrot_str_to_cstring(interp, command);
136
137 pid = do_spawn2(cmd, CLI$M_NOWAIT);
138 vms_get_subproc_handles(pid, handles);
139
140 return pid;
141 }
142
143 /*
144
145 =item C<INTVAL Parrot_proc_waitpid(PARROT_INTERP, INTVAL pid)>
146
147 Wait for process with C<pid> to exit.
148
149 =cut
150
151 */
152
153 INTVAL
Parrot_proc_waitpid(SHIM_INTERP,INTVAL pid)154 Parrot_proc_waitpid(SHIM_INTERP, INTVAL pid)
155 {
156 int status;
157
158 waitpid(pid, &status, 0);
159
160 if (WIFEXITED(status)) {
161 status = WEXITSTATUS(status);
162 }
163 else {
164 /* abnormal termination means non-zero exit status */
165 status = 1;
166 }
167
168 return status;
169 }
170
171 /*
172
173 =back
174
175 =cut
176
177 */
178
179 /* Stolen by Martin Vorlaender <mvorl@cpan.org> from: */
180 /* vms.c
181 *
182 * VMS-specific routines for perl5
183 *
184 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
185 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
186 *
187 * You may distribute under the terms of either the GNU General Public
188 * License or the Artistic License, as specified in the README file.
189 *
190 * Please see Changes*.* or the Perl Repository Browser for revision history.
191 */
192
193 /*
194
195 =head2 VMS-specific functions from perl5
196
197 =over
198
199 =cut
200
201 */
202
203
204 #include <stdio.h>
205 #include <string.h>
206 #include <stat.h>
207 #include <errno.h>
208 #include <unistd.h>
209 #include <unixio.h>
210
211 #define __NEW_STARLET 1
212 #include ssdef
213 #include shrdef
214 #include stsdef
215 #include iodef
216 #include dcdef
217 #include clidef
218 #include dvidef
219 #include jpidef
220 #include syidef
221 #include libdef
222 #include lnmdef
223 #include devdef
224 #include psldef
225 #include rmsdef
226 #include namdef
227 #include descrip
228 #include efndef
229 #include libclidef
230 #include climsgdef
231 #include lib$routines
232 #include starlet
233
234 /* Define the don't-care event flag.
235 * Use the system definition where possible
236 */
237 #ifndef __VAX
238 # if __VMS_VER >= 70000000
239 # include efndef
240 # endif
241 #endif
242
243 #ifndef EFN$C_ENF
244 # define EFN$C_ENF 0
245 #endif
246
247 /* Set the maximum filespec size here as it is larger for EFS file
248 * specifications.
249 */
250 #ifndef __VAX
251 # ifndef VMS_MAXRSS
252 # ifdef NAML$C_MAXRSS
253 # define VMS_MAXRSS (NAML$C_MAXRSS+1)
254 # ifndef VMS_LONGNAME_SUPPORT
255 # define VMS_LONGNAME_SUPPORT 1
256 # endif /* VMS_LONGNAME_SUPPORT */
257 # endif /* NAML$C_MAXRSS */
258 # endif /* VMS_MAXRSS */
259 #endif
260
261 #ifndef VMS_MAXRSS
262 # define VMS_MAXRSS (NAM$C_MAXRSS + 1)
263 #endif
264
265 /* New values with 7.3-2*/
266 /* why does max DCL have 4 byte subtracted from it? */
267 #if __CRTL_VER >= 70302000 && !defined(__VAX)
268 # define MAX_DCL_SYMBOL (8192)
269 # define MAX_DCL_LINE_LENGTH (4096 - 4)
270 #else
271 # define MAX_DCL_SYMBOL (1024)
272 # define MAX_DCL_LINE_LENGTH (1024 - 4)
273 #endif
274
275
276 /* Macros to set errno using the VAX thread-safe calls, if present */
277 #if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA)
278 # define set_errno(v) (cma$tis_errno_set_value(v))
279 void cma$tis_errno_set_value(int __value); /* missing in some errno.h */
280 # define set_vaxc_errno(v) (vaxc$errno = (v))
281 #else
282 # define set_errno(v) (errno = (v))
283 # define set_vaxc_errno(v) (vaxc$errno = (v))
284 #endif
285
286 #define SETERRNO(errcode, vmserrcode) \
287 do { \
288 set_errno(errcode); \
289 set_vaxc_errno(vmserrcode); \
290 } while (0)
291
292 /* Handy way to vet calls to VMS system services and RTL routines. */
293 #define _ckvmssts(call) \
294 do { \
295 register unsigned long int __ckvms_sts; \
296 if (!((__ckvms_sts = (call))&1)) { \
297 SETERRNO(EVMSERR, __ckvms_sts); \
298 fprintf(stderr, "Fatal VMS error (status=%d) at %s, line %d", \
299 __ckvms_sts, __FILE__, __LINE__); \
300 lib$signal(__ckvms_sts); \
301 } \
302 } while (0)
303
304
305 #ifdef __VAX
306 typedef unsigned long QUAD_t[2];
307 # define QUAD_PTR(var) (var)
308 #else
309 # include gen64def
310 typedef struct _generic_64 QUAD_t;
311 # define QUAD_PTR(var) &(var)
312 #endif
313
314
315 /*{{{ my_popen and my_pclose*/
316
317 typedef struct _iosb IOSB;
318 typedef struct _iosb* pIOSB;
319 typedef struct _pipe Pipe;
320 typedef struct _pipe* pPipe;
321 typedef struct pipe_details Info;
322 typedef struct pipe_details* pInfo;
323 typedef struct _tochildbuf CBuf;
324 typedef struct _tochildbuf* pCBuf;
325
326 struct _iosb {
327 unsigned short status;
328 unsigned short count;
329 unsigned long dvispec;
330 };
331
332 #pragma member_alignment save
333 #pragma nomember_alignment quadword
334 #ifdef __VAX
335 typedef struct _srqp { /* VMS self-relative queue entry */
336 unsigned long qptr[2];
337 } RQE, *pRQE;
338 static RQE RQE_ZERO = {0, 0};
339 #else
340 typedef __int64 RQE, *pRQE;
341 static RQE RQE_ZERO = 0;
342 #endif
343 #pragma member_alignment restore
344
345 struct _tochildbuf {
346 RQE q;
347 int eof;
348 unsigned short size;
349 char *buf;
350 };
351
352 struct _pipe {
353 RQE free;
354 RQE wait;
355 int fd_out;
356 unsigned short chan_in;
357 unsigned short chan_out;
358 char *buf;
359 unsigned int bufsize;
360 IOSB iosb;
361 IOSB iosb2;
362 int *pipe_done;
363 int retry;
364 int type;
365 int shut_on_empty;
366 int need_wake;
367 pPipe *home;
368 pInfo info;
369 pCBuf curr;
370 pCBuf curr2;
371 };
372
373 struct pipe_details {
374 pInfo next;
375 FILE *fp; /* file pointer to pipe mailbox */
376 unsigned int pid; /* PID of subprocess */
377 int mode; /* == 'r' if pipe open for reading */
378 int done; /* subprocess has completed */
379 int waiting; /* waiting for completion/closure */
380 int closing; /* my_pclose is closing this pipe */
381 unsigned long completion; /* termination status of subprocess */
382 pPipe in; /* pipe in to sub */
383 pPipe out; /* pipe out of sub */
384 pPipe err; /* pipe of sub's sys$error */
385 int in_done; /* true when in pipe finished */
386 int out_done;
387 int err_done;
388 unsigned short xchan; /* channel to debug xterm */
389 unsigned short xchan_valid; /* channel is assigned */
390 };
391
392 struct exit_control_block {
393 struct exit_control_block *flink;
394 unsigned int (*exit_routine)(void);
395 unsigned int arg_count;
396 unsigned int *status_address;
397 unsigned int exit_status;
398 };
399
400 typedef struct _closed_pipes {
401 int pid; /* PID of subprocess */
402 unsigned long completion; /* termination status of subprocess */
403 } Xpipe, *pXpipe;
404 #define NKEEPCLOSED 50
405 static Xpipe closed_list[NKEEPCLOSED];
406 static int closed_index = 0;
407 static int closed_num = 0;
408
409 #define RETRY_DELAY "0 ::0.20"
410 #define MAX_RETRY 50
411
412 static unsigned int pipe_ef = 0; /* first call to safe_popen inits these*/
413 static unsigned long mypid;
414 static QUAD_t delaytime;
415
416 static pInfo open_pipes = NULL;
417 static $DESCRIPTOR(nl_desc, "NL:");
418
419 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
420
421
422 static int my_pclose(FILE *fp);
423
424 /*
425
426 =item C<static unsigned int pipe_exit_routine(void)>
427
428 Carefully exit any pending I/O on pipes.
429
430 =cut
431
432 */
433
434 static unsigned int
pipe_exit_routine(void)435 pipe_exit_routine(void)
436 {
437 pInfo info;
438 unsigned int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
439 int sts, did_stuff, j;
440
441 /*
442 * Flush any pending i/o, but since we are in process run-down, be
443 * careful about referencing PerlIO structures that may already have
444 * been deallocated. We may not even have an interpreter anymore.
445 */
446 info = open_pipes;
447 while (info) {
448 if (info->fp)
449 fflush((FILE *)info->fp);
450 info = info->next;
451 }
452
453 /*
454 next we try sending an EOF...ignore if doesn't work, make sure we
455 don't hang
456 */
457 did_stuff = 0;
458 info = open_pipes;
459
460 while (info) {
461 _ckvmssts(sys$setast(0));
462 if (info->in && !info->in->shut_on_empty) {
463 _ckvmssts(sys$qio(EFN$C_ENF, info->in->chan_in, IO$_WRITEOF,
464 0, 0, 0, 0, 0, 0, 0, 0, 0));
465 info->waiting = 1;
466 did_stuff = 1;
467 }
468 _ckvmssts(sys$setast(1));
469 info = info->next;
470 }
471
472 /* wait for EOF to have effect, up to ~ 30 sec [default] */
473
474 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
475 int nwait = 0;
476
477 info = open_pipes;
478 while (info) {
479 _ckvmssts(sys$setast(0));
480 if (info->waiting && info->done)
481 info->waiting = 0;
482 nwait += info->waiting;
483 _ckvmssts(sys$setast(1));
484 info = info->next;
485 }
486 if (!nwait) break;
487 sleep(1);
488 }
489
490 did_stuff = 0;
491 info = open_pipes;
492 while (info) {
493 _ckvmssts(sys$setast(0));
494 if (!info->done) { /* Tap them gently on the shoulder . . .*/
495 sts = sys$forcex(&info->pid, 0, abort);
496 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
497 did_stuff = 1;
498 }
499 _ckvmssts(sys$setast(1));
500 info = info->next;
501 }
502
503 /* again, wait for effect */
504
505 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
506 int nwait = 0;
507
508 info = open_pipes;
509 while (info) {
510 _ckvmssts(sys$setast(0));
511 if (info->waiting && info->done)
512 info->waiting = 0;
513 nwait += info->waiting;
514 _ckvmssts(sys$setast(1));
515 info = info->next;
516 }
517 if (!nwait) break;
518 sleep(1);
519 }
520
521 info = open_pipes;
522 while (info) {
523 _ckvmssts(sys$setast(0));
524 if (!info->done) { /* We tried to be nice . . . */
525 sts = sys$delprc(&info->pid, 0);
526 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
527 info->done = 1; /* sys$delprc is as done as we're going to get. */
528 }
529 _ckvmssts(sys$setast(1));
530 info = info->next;
531 }
532
533 while (open_pipes) {
534 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
535 else if (!(sts & 1)) retsts = sts;
536 }
537 return retsts;
538 }
539
540 static struct exit_control_block pipe_exitblock = {
541 (struct exit_control_block *) 0,
542 pipe_exit_routine,
543 0,
544 &pipe_exitblock.exit_status,
545 0
546 };
547
548 static void pipe_mbxtofd_ast(pPipe p);
549 static void pipe_tochild1_ast(pPipe p);
550 static void pipe_tochild2_ast(pPipe p);
551
552 #ifdef __VAX
553 typedef unsigned long ASTparm_t;
554 #else
555 typedef unsigned __int64 ASTparm_t;
556 #endif
557
558 /*
559
560 =item C<static void popen_completion_ast(pInfo info)>
561
562 ??
563
564 =cut
565
566 */
567
568 static void
popen_completion_ast(pInfo info)569 popen_completion_ast(pInfo info)
570 {
571 pInfo i = open_pipes;
572 int iss;
573
574 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
575 closed_list[closed_index].pid = info->pid;
576 closed_list[closed_index].completion = info->completion;
577 closed_index++;
578 if (closed_index == NKEEPCLOSED)
579 closed_index = 0;
580 closed_num++;
581
582 while (i) {
583 if (i == info) break;
584 i = i->next;
585 }
586 if (!i) return; /* unlinked, probably freed too */
587
588 info->done = TRUE;
589
590 /*
591 Writing to subprocess ...
592 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
593
594 chan_out may be waiting for "done" flag, or hung waiting
595 for i/o completion to child...cancel the i/o. This will
596 put it into "snarf mode" (done but no EOF yet) that discards
597 input.
598
599 Output from subprocess (stdout, stderr) needs to be flushed and
600 shut down. We try sending an EOF, but if the mbx is full the pipe
601 routine should still catch the "shut_on_empty" flag, telling it to
602 use immediate-style reads so that "mbx empty" -> EOF.
603 */
604 if (info->in && !info->in_done) { /* only for mode=w */
605 if (info->in->shut_on_empty && info->in->need_wake) {
606 info->in->need_wake = FALSE;
607 _ckvmssts(sys$dclast(pipe_tochild2_ast, (ASTparm_t)info->in, 0));
608 }
609 else {
610 _ckvmssts(sys$cancel(info->in->chan_out));
611 }
612 }
613
614 if (info->out && !info->out_done) { /* were we also piping output? */
615 info->out->shut_on_empty = TRUE;
616 iss = sys$qio(EFN$C_ENF, info->out->chan_in, IO$_WRITEOF|IO$M_NORSWAIT,
617 0, 0, 0, 0, 0, 0, 0, 0, 0);
618 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
619 _ckvmssts(iss);
620 }
621
622 if (info->err && !info->err_done) { /* we were piping stderr */
623 info->err->shut_on_empty = TRUE;
624 iss = sys$qio(EFN$C_ENF, info->err->chan_in, IO$_WRITEOF|IO$M_NORSWAIT,
625 0, 0, 0, 0, 0, 0, 0, 0, 0);
626 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
627 _ckvmssts(iss);
628 }
629 _ckvmssts(sys$setef(pipe_ef));
630
631 }
632
633 static unsigned long int setup_cmddsc(const char *cmd, int check_img,
634 int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
635 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
636 static void pipe_infromchild_ast(pPipe p);
637 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
638
639 /*
640
641 =item C<static pPipe pipe_tochild_setup(char *rmbx, char *wmbx)>
642
643 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
644 inside an AST routine without worrying about reentrancy and which Perl
645 memory allocator is being used.
646
647 We read data and queue up the buffers, then spit them out one at a
648 time to the output mailbox when the output mailbox is ready for one.
649
650 =cut
651
652 */
653
654 #define INITIAL_TOCHILDQUEUE 2
655
656 static pPipe
pipe_tochild_setup(char * rmbx,char * wmbx)657 pipe_tochild_setup(char *rmbx, char *wmbx)
658 {
659 pPipe p;
660 pCBuf b;
661 char mbx1[64], mbx2[64];
662 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx1};
663 struct dsc$descriptor_s d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx2};
664 int dviitm = DVI$_DEVBUFSIZ;
665 int j, n;
666
667 n = sizeof (Pipe);
668 _ckvmssts(lib$get_vm(&n, &p));
669
670 create_mbx(&p->chan_in , &d_mbx1);
671 create_mbx(&p->chan_out, &d_mbx2);
672 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
673
674 p->buf = 0;
675 p->shut_on_empty = FALSE;
676 p->need_wake = FALSE;
677 p->type = 0;
678 p->retry = 0;
679 p->iosb.status = SS$_NORMAL;
680 p->iosb2.status = SS$_NORMAL;
681 p->free = RQE_ZERO;
682 p->wait = RQE_ZERO;
683 p->curr = 0;
684 p->curr2 = 0;
685 p->info = 0;
686
687 n = sizeof (CBuf) + p->bufsize;
688
689 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
690 _ckvmssts(lib$get_vm(&n, &b));
691 b->buf = (char *) b + sizeof (CBuf);
692 _ckvmssts(lib$insqhi((unsigned int *)b, &p->free));
693 }
694
695 pipe_tochild2_ast(p);
696 pipe_tochild1_ast(p);
697 strcpy(wmbx, mbx1);
698 strcpy(rmbx, mbx2);
699 return p;
700 }
701
702 /*
703
704 =item C<static void pipe_tochild1_ast(pPipe p)>
705
706 Reads the MBX Perl is writing, and queues
707
708 =cut
709
710 */
711
712 static void
pipe_tochild1_ast(pPipe p)713 pipe_tochild1_ast(pPipe p)
714 {
715 pCBuf b = p->curr;
716 int iss = p->iosb.status;
717 int eof = (iss == SS$_ENDOFFILE);
718 int sts;
719
720 if (p->retry) {
721 if (eof) {
722 p->shut_on_empty = TRUE;
723 b->eof = TRUE;
724 _ckvmssts(sys$dassgn(p->chan_in));
725 }
726 else {
727 _ckvmssts(iss);
728 }
729
730 b->eof = eof;
731 b->size = p->iosb.count;
732 _ckvmssts(sts = lib$insqhi((unsigned int *)b, &p->wait));
733 if (p->need_wake) {
734 p->need_wake = FALSE;
735 _ckvmssts(sys$dclast(pipe_tochild2_ast, (ASTparm_t)p, 0));
736 }
737 }
738 else {
739 p->retry = 1; /* initial call */
740 }
741
742 if (eof) { /* flush the free queue, return when done */
743 int n = sizeof (CBuf) + p->bufsize;
744 while (1) {
745 iss = lib$remqti(&p->free, &b);
746 if (iss == LIB$_QUEWASEMP) return;
747 _ckvmssts(iss);
748 _ckvmssts(lib$free_vm(&n, &b));
749 }
750 }
751
752 iss = lib$remqti(&p->free, &b);
753 if (iss == LIB$_QUEWASEMP) {
754 int n = sizeof (CBuf) + p->bufsize;
755 _ckvmssts(lib$get_vm(&n, &b));
756 b->buf = (char *) b + sizeof (CBuf);
757 }
758 else {
759 _ckvmssts(iss);
760 }
761
762 p->curr = b;
763 iss = sys$qio(EFN$C_ENF, p->chan_in,
764 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
765 &p->iosb,
766 pipe_tochild1_ast, (ASTparm_t)p, b->buf, p->bufsize, 0, 0, 0, 0);
767 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
768 _ckvmssts(iss);
769 }
770
771
772 /*
773
774 =item C<static void pipe_tochild2_ast(pPipe p)>
775
776 Writes queued buffers to output, waits for each to complete before
777 doing the next.
778
779 =cut
780
781 */
782
783 static void
pipe_tochild2_ast(pPipe p)784 pipe_tochild2_ast(pPipe p)
785 {
786 pCBuf b = p->curr2;
787 int iss = p->iosb2.status;
788 int n = sizeof (CBuf) + p->bufsize;
789 int done = (p->info && p->info->done) || iss == SS$_CANCEL || iss == SS$_ABORT;
790
791 do {
792 if (p->type) { /* type=1 has old buffer, dispose */
793 if (p->shut_on_empty)
794 _ckvmssts(lib$free_vm(&n, &b));
795 else
796 _ckvmssts(lib$insqhi((unsigned int *)b, &p->free));
797 p->type = 0;
798 }
799
800 iss = lib$remqti(&p->wait, &b);
801 if (iss == LIB$_QUEWASEMP) {
802 if (p->shut_on_empty) {
803 if (done) {
804 _ckvmssts(sys$dassgn(p->chan_out));
805 *p->pipe_done = TRUE;
806 _ckvmssts(sys$setef(pipe_ef));
807 }
808 else {
809 _ckvmssts(sys$qio(EFN$C_ENF, p->chan_out, IO$_WRITEOF,
810 &p->iosb2,
811 pipe_tochild2_ast, (ASTparm_t)p, 0, 0, 0, 0, 0, 0));
812 }
813 return;
814 }
815 p->need_wake = TRUE;
816 return;
817 }
818 _ckvmssts(iss);
819 p->type = 1;
820 } while (done);
821
822
823 p->curr2 = b;
824 if (b->eof)
825 _ckvmssts(sys$qio(EFN$C_ENF, p->chan_out, IO$_WRITEOF, &p->iosb2,
826 pipe_tochild2_ast, (ASTparm_t)p, 0, 0, 0, 0, 0, 0));
827 else
828 _ckvmssts(sys$qio(EFN$C_ENF, p->chan_out, IO$_WRITEVBLK, &p->iosb2,
829 pipe_tochild2_ast, (ASTparm_t)p, b->buf, b->size, 0, 0, 0, 0));
830
831 return;
832 }
833
834 /*
835
836 =item C<static pPipe pipe_infromchild_setup(char *rmbx, char *wmbx)>
837
838 ??
839
840 =cut
841
842 */
843
844 static pPipe
pipe_infromchild_setup(char * rmbx,char * wmbx)845 pipe_infromchild_setup(char *rmbx, char *wmbx)
846 {
847 pPipe p;
848 char mbx1[64], mbx2[64];
849 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx1};
850 struct dsc$descriptor_s d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx2};
851 int dviitm = DVI$_DEVBUFSIZ;
852 int n;
853
854 n = sizeof (Pipe);
855 _ckvmssts(lib$get_vm(&n, &p));
856 create_mbx(&p->chan_in , &d_mbx1);
857 create_mbx(&p->chan_out, &d_mbx2);
858
859 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
860 n = p->bufsize * sizeof (char);
861 _ckvmssts(lib$get_vm(&n, &p->buf));
862 p->shut_on_empty = FALSE;
863 p->info = 0;
864 p->type = 0;
865 p->iosb.status = SS$_NORMAL;
866 pipe_infromchild_ast(p);
867
868 strcpy(wmbx, mbx1);
869 strcpy(rmbx, mbx2);
870 return p;
871 }
872
873 /*
874
875 =item C<static void pipe_infromchild_ast(pPipe p)>
876
877 ??
878
879 =cut
880
881 */
882
883 static void
pipe_infromchild_ast(pPipe p)884 pipe_infromchild_ast(pPipe p)
885 {
886 int iss = p->iosb.status;
887 int eof = (iss == SS$_ENDOFFILE);
888 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
889 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
890
891 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
892 _ckvmssts(sys$dassgn(p->chan_out));
893 p->chan_out = 0;
894 }
895
896 /* read completed:
897 input shutdown if EOF from self (done or shut_on_empty)
898 output shutdown if closing flag set (my_pclose)
899 send data/eof from child or eof from self
900 otherwise, re-read (snarf of data from child)
901 */
902
903 if (p->type == 1) {
904 p->type = 0;
905 if (myeof && p->chan_in) { /* input shutdown */
906 _ckvmssts(sys$dassgn(p->chan_in));
907 p->chan_in = 0;
908 }
909
910 if (p->chan_out) {
911 if (myeof || kideof) { /* pass EOF to parent */
912 _ckvmssts(sys$qio(EFN$C_ENF, p->chan_out, IO$_WRITEOF, &p->iosb,
913 pipe_infromchild_ast, (ASTparm_t)p,
914 0, 0, 0, 0, 0, 0));
915 return;
916 }
917 else if (eof) { /* eat EOF --- fall through to read*/
918 }
919 else { /* transmit data */
920 _ckvmssts(sys$qio(EFN$C_ENF, p->chan_out, IO$_WRITEVBLK, &p->iosb,
921 pipe_infromchild_ast, (ASTparm_t)p,
922 p->buf, p->iosb.count, 0, 0, 0, 0));
923 return;
924 }
925 }
926 }
927
928 /* everything shut? flag as done */
929
930 if (!p->chan_in && !p->chan_out) {
931 *p->pipe_done = TRUE;
932 _ckvmssts(sys$setef(pipe_ef));
933 return;
934 }
935
936 /* write completed (or read, if snarfing from child)
937 if still have input active,
938 queue read...immediate mode if shut_on_empty so we get EOF if empty
939 otherwise,
940 check if Perl reading, generate EOFs as needed
941 */
942
943 if (p->type == 0) {
944 p->type = 1;
945 if (p->chan_in) {
946 iss = sys$qio(EFN$C_ENF, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),
947 &p->iosb,
948 pipe_infromchild_ast, (ASTparm_t)p,
949 p->buf, p->bufsize, 0, 0, 0, 0);
950 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
951 _ckvmssts(iss);
952 }
953 else { /* send EOFs for extra reads */
954 p->iosb.status = SS$_ENDOFFILE;
955 p->iosb.dvispec = 0;
956 _ckvmssts(sys$qio(EFN$C_ENF, p->chan_out, IO$_SETMODE|IO$M_READATTN,
957 0, 0, 0,
958 pipe_infromchild_ast, (ASTparm_t)p, 0, 0, 0, 0));
959 }
960 }
961 }
962
963 #pragma member_alignment save
964 #pragma nomember_alignment longword
965 struct item_list_3 {
966 unsigned short len;
967 unsigned short code;
968 void * bufadr;
969 unsigned short * retadr;
970 };
971 #pragma member_alignment restore
972
973 /*
974
975 =item C<static pPipe pipe_mbxtofd_setup(int fd, char *out)>
976
977 Setup to send pipe data to file
978
979 =cut
980
981 */
982
983 static pPipe
pipe_mbxtofd_setup(int fd,char * out)984 pipe_mbxtofd_setup(int fd, char *out)
985 {
986 pPipe p;
987 char mbx[64];
988 int dviitm = DVI$_DEVBUFSIZ;
989 struct stat s;
990 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx};
991 int n = sizeof (Pipe);
992
993 /* things like terminals and mbx's don't need this filter */
994 if (fd && fstat(fd, &s) == 0) {
995 unsigned long devchar;
996 char device[65];
997 unsigned short dev_len;
998 struct dsc$descriptor_s d_dev;
999 char * cptr;
1000 struct item_list_3 items[] =
1001 {{sizeof (devchar) , DVI$_DEVCHAR , &devchar, NULL },
1002 {sizeof (device)-1, DVI$_FULLDEVNAM, device , &dev_len},
1003 { 0, 0, 0, 0}};
1004 int status;
1005 IOSB dvi_iosb;
1006
1007 cptr = getname(fd, out, 1);
1008 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
1009 d_dev.dsc$a_pointer = out;
1010 d_dev.dsc$w_length = strlen(out);
1011 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
1012 d_dev.dsc$b_class = DSC$K_CLASS_S;
1013
1014 status = sys$getdviw(EFN$C_ENF, 0, &d_dev, items, &dvi_iosb, NULL, 0, NULL);
1015 _ckvmssts(status);
1016 if ($VMS_STATUS_SUCCESS(dvi_iosb.status)) {
1017 device[dev_len] = 0;
1018
1019 if (!(devchar & DEV$M_DIR)) {
1020 strcpy(out, device);
1021 return 0;
1022 }
1023 }
1024 }
1025
1026 _ckvmssts(lib$get_vm(&n, &p));
1027 p->fd_out = dup(fd);
1028 create_mbx(&p->chan_in, &d_mbx);
1029 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1030 n = (p->bufsize+1) * sizeof (char);
1031 _ckvmssts(lib$get_vm(&n, &p->buf));
1032 p->shut_on_empty = FALSE;
1033 p->retry = 0;
1034 p->info = 0;
1035 strcpy(out, mbx);
1036
1037 _ckvmssts(sys$qio(EFN$C_ENF, p->chan_in, IO$_READVBLK, &p->iosb,
1038 pipe_mbxtofd_ast, (ASTparm_t)p,
1039 p->buf, p->bufsize, 0, 0, 0, 0));
1040
1041 return p;
1042 }
1043
1044 /*
1045
1046 =item C<static void pipe_mbxtofd_ast(pPipe p)>
1047
1048 Ready to send pipe data to file
1049
1050 =cut
1051
1052 */
1053
1054 static void
pipe_mbxtofd_ast(pPipe p)1055 pipe_mbxtofd_ast(pPipe p)
1056 {
1057 int iss = p->iosb.status;
1058 int done = p->info->done;
1059 int iss2;
1060 int eof = (iss == SS$_ENDOFFILE);
1061 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1062 int err = !(iss&1) && !eof;
1063
1064 if (done && myeof) { /* end piping */
1065 close(p->fd_out);
1066 sys$dassgn(p->chan_in);
1067 *p->pipe_done = TRUE;
1068 _ckvmssts(sys$setef(pipe_ef));
1069 return;
1070 }
1071
1072 if (!err && !eof) { /* good data to send to file */
1073 p->buf[p->iosb.count] = '\n';
1074 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1075 if (iss2 < 0) {
1076 p->retry++;
1077 if (p->retry < MAX_RETRY) {
1078 _ckvmssts(sys$setimr(EFN$C_ENF, QUAD_PTR(delaytime),
1079 pipe_mbxtofd_ast, (ASTparm_t)p, 0));
1080 return;
1081 }
1082 }
1083 p->retry = 0;
1084 }
1085 else if (err) {
1086 _ckvmssts(iss);
1087 }
1088
1089
1090 iss = sys$qio(EFN$C_ENF, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),
1091 &p->iosb,
1092 pipe_mbxtofd_ast, (ASTparm_t)p,
1093 p->buf, p->bufsize, 0, 0, 0, 0);
1094 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1095 _ckvmssts(iss);
1096 }
1097
1098
1099 #ifdef _USE_STD_STAT
1100 # define VMS_INO_T_COMPARE(__a, __b) ((__a) != (__b))
1101 # define VMS_INO_T_COPY(__a, __b) (__a) = (__b)
1102 #else
1103 # define VMS_INO_T_COMPARE(__a, __b) memcmp(&(__a), &(__b), 6)
1104 # define VMS_INO_T_COPY(__a, __b) memcpy(&(__a), &(__b), 6)
1105 #endif
1106
1107 /*
1108
1109 =item C<static FILE * vmspipe_tempfile(void)>
1110
1111 Create a tempfile
1112
1113 =cut
1114
1115 */
1116
1117 static FILE *
vmspipe_tempfile(void)1118 vmspipe_tempfile(void)
1119 {
1120 char file[VMS_MAXRSS];
1121 FILE *fp;
1122 static int index = 0;
1123 stat_t s0, s1;
1124 int cmp_result;
1125
1126 /* create a tempfile */
1127
1128 /* we can't go from W, shr=get to R, shr=get without
1129 an intermediate vulnerable state, so don't bother trying...
1130
1131 and lib$spawn doesn't shr=put, so have to close the write
1132
1133 So... match up the creation date/time and the FID to
1134 make sure we're dealing with the same file
1135 */
1136
1137 index++;
1138 if (1) { /* !decc_filename_unix_only */
1139 sprintf(file, "sys$scratch:parrotpipe_%08.8x_%d.com", mypid, index);
1140 fp = fopen(file, "w");
1141 if (!fp) {
1142 sprintf(file, "sys$login:parrotpipe_%08.8x_%d.com", mypid, index);
1143 fp = fopen(file, "w");
1144 if (!fp) {
1145 sprintf(file, "sys$disk:[]parrotpipe_%08.8x_%d.com", mypid, index);
1146 fp = fopen(file, "w");
1147 }
1148 }
1149 }
1150 else { /* XXX dead code */
1151 sprintf(file, "/tmp/parrotpipe_%08.8x_%d.com", mypid, index);
1152 fp = fopen(file, "w");
1153 if (!fp) {
1154 sprintf(file, "/sys$login/parrotpipe_%08.8x_%d.com", mypid, index);
1155 fp = fopen(file, "w");
1156 if (!fp) {
1157 sprintf(file, "./parrotpipe_%08.8x_%d.com", mypid, index);
1158 fp = fopen(file, "w");
1159 }
1160 }
1161 }
1162 if (!fp) return 0; /* we're hosed */
1163
1164 fprintf(fp, "$! 'f$verify(0)'\n");
1165 fprintf(fp, "$! --- protect against nonstandard definitions ---\n");
1166 fprintf(fp, "$ parrot_cfile = f$environment(\"procedure\")\n");
1167 fprintf(fp, "$ parrot_define = \"define/nolog\"\n");
1168 fprintf(fp, "$ parrot_on = \"set noon\"\n");
1169 fprintf(fp, "$ parrot_exit = \"exit\"\n");
1170 fprintf(fp, "$ parrot_del = \"delete\"\n");
1171 fprintf(fp, "$ pif = \"if\"\n");
1172 fprintf(fp, "$! --- define i/o redirection (sys$output set by lib$spawn)\n");
1173 fprintf(fp, "$ pif parrot_popen_in .nes. \"\" then parrot_define/user/name_attributes=confine"
1174 " sys$input 'parrot_popen_in'\n");
1175 fprintf(fp, "$ pif parrot_popen_err .nes. \"\" then parrot_define/user/name_attributes=confine"
1176 " sys$error 'parrot_popen_err'\n");
1177 fprintf(fp, "$ pif parrot_popen_out .nes. \"\" then parrot_define "
1178 " sys$output 'parrot_popen_out'\n");
1179 fprintf(fp, "$! --- build command line to get max possible length\n");
1180 fprintf(fp, "$ c=parrot_popen_cmd0\n");
1181 fprintf(fp, "$ c=c+parrot_popen_cmd1\n");
1182 fprintf(fp, "$ c=c+parrot_popen_cmd2\n");
1183 fprintf(fp, "$ x=parrot_popen_cmd3\n");
1184 fprintf(fp, "$ c=c+x\n");
1185 fprintf(fp, "$ parrot_on\n");
1186 fprintf(fp, "$ 'c'\n");
1187 fprintf(fp, "$ parrot_status = $STATUS\n");
1188 fprintf(fp, "$ parrot_del 'parrot_cfile'\n");
1189 fprintf(fp, "$ parrot_exit 'parrot_status'\n");
1190 fsync(fileno(fp));
1191
1192 fgetname(fp, file, 1);
1193 fstat(fileno(fp), &s0);
1194 fclose(fp);
1195
1196 #if 0
1197 if (decc_filename_unix_only)
1198 int_tounixspec(file, file, NULL);
1199 #endif
1200 fp = fopen(file, "r", "shr=get");
1201 if (!fp) return 0;
1202 fstat(fileno(fp), &s1);
1203
1204 cmp_result = VMS_INO_T_COMPARE(s0.st_ino, s1.st_ino);
1205 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
1206 fclose(fp);
1207 return 0;
1208 }
1209
1210 return fp;
1211 }
1212
1213 /*
1214
1215 =item C<static int vms_is_syscommand_xterm(void)>
1216
1217 Check if sys$command is a decterm or xterm
1218
1219 =cut
1220
1221 */
1222
1223 static int
vms_is_syscommand_xterm(void)1224 vms_is_syscommand_xterm(void)
1225 {
1226 $DESCRIPTOR(syscommand_dsc, "SYS$COMMAND");
1227 $DESCRIPTOR(decwdisplay_dsc, "DECW$DISPLAY");
1228 unsigned long devchar;
1229 unsigned long devclass;
1230 struct item_list_3 items[] =
1231 {{sizeof (devchar), DVI$_DEVCHAR, &devchar, NULL},
1232 { 0, 0, 0, 0}};
1233 IOSB dvi_iosb;
1234 int status;
1235
1236 /* Very simple check to guess if sys$command is a decterm? */
1237 /* First see if the DECW$DISPLAY: device exists */
1238
1239 status = sys$getdviw(EFN$C_ENF, 0, &decwdisplay_dsc, items, &dvi_iosb, NULL, 0, NULL);
1240 if ($VMS_STATUS_SUCCESS(status))
1241 status = dvi_iosb.status;
1242
1243 if (!$VMS_STATUS_SUCCESS(status)) {
1244 SETERRNO(EVMSERR, status);
1245 return -1;
1246 }
1247
1248 /* If it does, then for now assume that we are on a workstation */
1249 /* Now verify that SYS$COMMAND is a terminal */
1250 /* for creating the debugger DECTerm */
1251
1252 items[0].len = sizeof (devclass);
1253 items[0].code = DVI$_DEVCLASS;
1254 items[0].bufadr = &devclass;
1255 items[0].retadr = NULL;
1256 items[1].len = 0;
1257 items[1].code = 0;
1258
1259 status = sys$getdviw(EFN$C_ENF, 0, &syscommand_dsc, items, &dvi_iosb, NULL, 0, NULL);
1260 if ($VMS_STATUS_SUCCESS(status))
1261 status = dvi_iosb.status;
1262
1263 if (!$VMS_STATUS_SUCCESS(status)) {
1264 SETERRNO(EVMSERR, status);
1265 return -1;
1266 }
1267
1268 return (devclass == DC$_TERM) ? 0 : -1;
1269 }
1270
1271 /* Routine to create a decterm for use with the Perl debugger */
1272 /* No headers, this information was found in the Programming Concepts Manual */
1273 static int (*decw_term_port)
1274 (const struct dsc$descriptor_s * display,
1275 const struct dsc$descriptor_s * setup_file,
1276 const struct dsc$descriptor_s * customization,
1277 struct dsc$descriptor_s * result_device_name,
1278 unsigned short * result_device_name_length,
1279 void * controller,
1280 void * char_buffer,
1281 void * char_change_buffer) = 0;
1282
1283 /*
1284
1285 =item C<static FILE* create_forked_xterm(const char *cmd, const char *mode)>
1286
1287 If we are on a DECTerm, we can pretend to fork xterms when requested.
1288
1289 =cut
1290
1291 */
1292
1293 static FILE*
create_forked_xterm(const char * cmd,const char * mode)1294 create_forked_xterm(const char *cmd, const char *mode)
1295 {
1296 int status;
1297 int ret_stat;
1298 char * ret_char;
1299 char device_name[65];
1300 unsigned short device_name_len;
1301 struct dsc$descriptor_s customization_dsc;
1302 struct dsc$descriptor_s device_name_dsc;
1303 const char * cptr;
1304 char customization[200];
1305 char title[40];
1306 pInfo info = NULL;
1307 char mbx1[64];
1308 unsigned short p_chan;
1309 int n;
1310 IOSB iosb;
1311 const char * cust_str =
1312 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
1313 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, DSC$K_CLASS_S, mbx1};
1314
1315 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
1316 /*---------------------------------------*/
1317 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
1318
1319 /* Make sure that this is from the Perl debugger */
1320 ret_char = strstr(cmd, " xterm ");
1321 if (ret_char == NULL) return NULL;
1322 cptr = ret_char + 7;
1323 ret_char = strstr(cmd, "tty");
1324 if (ret_char == NULL) return NULL;
1325 ret_char = strstr(cmd, "sleep");
1326 if (ret_char == NULL) return NULL;
1327
1328 if (decw_term_port == 0) {
1329 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
1330 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
1331 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
1332
1333 status = lib$find_image_symbol
1334 (&filename1_dsc,
1335 &decw_term_port_dsc,
1336 (void *)&decw_term_port,
1337 NULL,
1338 0);
1339
1340 /* Try again with the other image name */
1341 if (!$VMS_STATUS_SUCCESS(status)) {
1342 status = lib$find_image_symbol
1343 (&filename2_dsc,
1344 &decw_term_port_dsc,
1345 (void *)&decw_term_port,
1346 NULL,
1347 0);
1348 }
1349 }
1350
1351 /* No decw$term_port, give it up */
1352 if (!$VMS_STATUS_SUCCESS(status))
1353 return NULL;
1354
1355 /* Are we on a workstation? */
1356 /* to do: capture the rows / columns and pass their properties */
1357 ret_stat = vms_is_syscommand_xterm();
1358 if (ret_stat < 0)
1359 return NULL;
1360
1361 /* Make the title: */
1362 ret_char = strstr(cptr, "-title");
1363 if (ret_char != NULL) {
1364 while ((*cptr != 0) && (*cptr != '\"')) {
1365 cptr++;
1366 }
1367 if (*cptr == '\"')
1368 cptr++;
1369 n = 0;
1370 while ((*cptr != 0) && (*cptr != '\"')) {
1371 title[n] = *cptr;
1372 if (++n == 39) {
1373 title[39] = 0;
1374 break;
1375 }
1376 cptr++;
1377 }
1378 title[n] = 0;
1379 }
1380 else {
1381 /* Default title */
1382 strcpy(title, "Perl Debug DECTerm");
1383 }
1384 sprintf(customization, cust_str, title);
1385
1386 customization_dsc.dsc$a_pointer = customization;
1387 customization_dsc.dsc$w_length = strlen(customization);
1388 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
1389 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
1390
1391 device_name_dsc.dsc$a_pointer = device_name;
1392 device_name_dsc.dsc$w_length = sizeof device_name -1;
1393 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
1394 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
1395
1396 device_name_len = 0;
1397
1398 /* Try to create the window */
1399 status = (*decw_term_port)
1400 (NULL,
1401 NULL,
1402 &customization_dsc,
1403 &device_name_dsc,
1404 &device_name_len,
1405 NULL,
1406 NULL,
1407 NULL);
1408 if (!$VMS_STATUS_SUCCESS(status)) {
1409 SETERRNO(EVMSERR, status);
1410 return NULL;
1411 }
1412
1413 device_name[device_name_len] = '\0';
1414
1415 /* Need to set this up to look like a pipe for cleanup */
1416 n = sizeof (Info);
1417 status = lib$get_vm(&n, &info);
1418 if (!$VMS_STATUS_SUCCESS(status)) {
1419 SETERRNO(ENOMEM, status);
1420 return NULL;
1421 }
1422
1423 info->mode = *mode;
1424 info->done = FALSE;
1425 info->completion = 0;
1426 info->closing = FALSE;
1427 info->in = 0;
1428 info->out = 0;
1429 info->err = 0;
1430 info->fp = NULL;
1431 info->waiting = 0;
1432 info->in_done = TRUE;
1433 info->out_done = TRUE;
1434 info->err_done = TRUE;
1435
1436 /* Assign a channel on this so that it will persist, and not login */
1437 /* We stash this channel in the info structure for reference. */
1438 /* The created xterm self destructs when the last channel is removed */
1439 /* and it appears that perl5db.pl (perl debugger) does this routinely */
1440 /* So leave this assigned. */
1441 device_name_dsc.dsc$w_length = device_name_len;
1442 status = sys$assign(&device_name_dsc, &info->xchan, 0, 0);
1443 if (!$VMS_STATUS_SUCCESS(status)) {
1444 SETERRNO(EVMSERR, status);
1445 return NULL;
1446 }
1447 info->xchan_valid = 1;
1448
1449 /* Now create a mailbox to be read by the application */
1450 create_mbx(&p_chan, &d_mbx1);
1451
1452 /* write the name of the created terminal to the mailbox */
1453 status = sys$qiow(EFN$C_ENF, p_chan, IO$_WRITEVBLK|IO$M_NOW,
1454 &iosb, NULL, 0, device_name, device_name_len, 0, 0, 0, 0);
1455
1456 if (!$VMS_STATUS_SUCCESS(status)) {
1457 SETERRNO(EVMSERR, status);
1458 return NULL;
1459 }
1460
1461 info->fp = fopen(mbx1, mode);
1462
1463 /* Done with this channel */
1464 sys$dassgn(p_chan);
1465
1466 /* If any errors, then clean up */
1467 if (!info->fp) {
1468 n = sizeof (Info);
1469 _ckvmssts(lib$free_vm(&n, &info));
1470 return NULL;
1471 }
1472
1473 /* All done */
1474 return info->fp;
1475 }
1476
1477 static void set_user_lnm(const char *name, const char *eqv);
1478 static int my_pclose_pinfo(pInfo info);
1479
1480 /*
1481
1482 =item C<static FILE * safe_popen(const char *cmd, const char *in_mode, int
1483 *psts)>
1484
1485 Open the pipes for an external call.
1486
1487 Check for special xterm requests on special filehandles.
1488
1489 =cut
1490
1491 */
1492
1493 static FILE *
safe_popen(const char * cmd,const char * in_mode,int * psts)1494 safe_popen(const char *cmd, const char *in_mode, int *psts)
1495 {
1496 static int handler_set_up = FALSE;
1497 FILE * ret_fp;
1498 unsigned long int sts, flags = CLI$M_NOWAIT;
1499 /* The use of a GLOBAL table (as was done previously) rendered
1500 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL>
1501 * DCL environment. Hence we've switched to LOCAL symbol table.
1502 */
1503 unsigned int table = LIB$K_CLI_LOCAL_SYM;
1504 int j, wait = 0, n;
1505 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1];
1506 char *in, *out, *err, mbx[512];
1507 FILE *tpipe = 0;
1508 char tfilebuf[VMS_MAXRSS];
1509 pInfo info = NULL;
1510 char cmd_sym_name[20];
1511 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, symbol};
1512 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1513 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, cmd_sym_name};
1514 struct dsc$descriptor_s *vmscmd;
1515 $DESCRIPTOR(d_sym_in , "PARROT_POPEN_IN");
1516 $DESCRIPTOR(d_sym_out, "PARROT_POPEN_OUT");
1517 $DESCRIPTOR(d_sym_err, "PARROT_POPEN_ERR");
1518
1519 /* Check here for Xterm create request. This means looking for
1520 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
1521 * is possible to create an xterm.
1522 */
1523 if (*in_mode == 'r') {
1524 FILE * xterm_fd = create_forked_xterm(cmd, in_mode);
1525 if (xterm_fd != NULL)
1526 return xterm_fd;
1527 }
1528
1529 /* once-per-program initialization...
1530 note that the SETAST calls and the dual test of pipe_ef
1531 makes sure that only the FIRST thread through here does
1532 the initialization...all other threads wait until it's
1533 done.
1534
1535 Yeah, uglier than a pthread call, it's got all the stuff inline
1536 rather than in a separate routine.
1537 */
1538
1539 if (!pipe_ef) {
1540 _ckvmssts(sys$setast(0));
1541 if (!pipe_ef) {
1542 int pidcode = JPI$_PID;
1543 $DESCRIPTOR(d_delay, RETRY_DELAY);
1544 _ckvmssts(lib$get_ef(&pipe_ef));
1545 _ckvmssts(lib$getjpi(&pidcode, 0, 0, &mypid, 0, 0));
1546 _ckvmssts(sys$bintim(&d_delay, QUAD_PTR(delaytime)));
1547 }
1548 if (!handler_set_up) {
1549 _ckvmssts(sys$dclexh(&pipe_exitblock));
1550 handler_set_up = TRUE;
1551 }
1552 _ckvmssts(sys$setast(1));
1553 }
1554
1555 /* see if we can find a VMSPIPE.COM */
1556
1557 tfilebuf[0] = '@';
1558 tpipe = vmspipe_tempfile();
1559 if (!tpipe) { /* a fish popular in Boston */
1560 #if 0
1561 if (ckWARN(WARN_PIPE)) {
1562 Perl_warner(packWARN(WARN_PIPE), "unable to find VMSPIPE.COM for i/o piping");
1563 }
1564 #endif
1565 return NULL;
1566 }
1567 fgetname(tpipe, tfilebuf+1, 1);
1568 vmspipedsc.dsc$w_length = strlen(tfilebuf);
1569
1570 vmspipedsc.dsc$a_pointer = tfilebuf;
1571
1572 sts = setup_cmddsc(cmd, 0, 0, &vmscmd);
1573 if (!(sts & 1)) {
1574 switch (sts) {
1575 case RMS$_FNF:
1576 case RMS$_DNF:
1577 set_errno(ENOENT); break;
1578 case RMS$_DIR:
1579 set_errno(ENOTDIR); break;
1580 case RMS$_DEV:
1581 set_errno(ENODEV); break;
1582 case RMS$_PRV:
1583 set_errno(EACCES); break;
1584 case RMS$_SYN:
1585 set_errno(EINVAL); break;
1586 case CLI$_BUFOVF:
1587 case RMS$_RTB:
1588 case CLI$_TKNOVF:
1589 case CLI$_RSLOVF:
1590 set_errno(E2BIG); break;
1591 case LIB$_INVARG:
1592 case LIB$_INVSTRDES:
1593 case SS$_ACCVIO: /* shouldn't happen */
1594 _ckvmssts(sts); /* fall through */
1595 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
1596 set_errno(EVMSERR);
1597 }
1598 set_vaxc_errno(sts);
1599 #if 0
1600 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
1601 Perl_warner(packWARN(WARN_PIPE), "Can't pipe \"%*s\": %s",
1602 strlen(cmd), cmd, Strerror(errno));
1603 }
1604 #endif
1605 *psts = sts;
1606 return NULL;
1607 }
1608 n = sizeof (Info);
1609 _ckvmssts(lib$get_vm(&n, &info));
1610
1611 strncpy(mode, in_mode, sizeof (mode));
1612 info->mode = *mode;
1613 info->done = FALSE;
1614 info->completion = 0;
1615 info->closing = FALSE;
1616 info->in = 0;
1617 info->out = 0;
1618 info->err = 0;
1619 info->fp = NULL;
1620 info->waiting = 0;
1621 info->in_done = TRUE;
1622 info->out_done = TRUE;
1623 info->err_done = TRUE;
1624 info->xchan = 0;
1625 info->xchan_valid = 0;
1626
1627 in = malloc(VMS_MAXRSS);
1628 if (in == NULL) _ckvmssts(SS$_INSFMEM);
1629 out = malloc(VMS_MAXRSS);
1630 if (out == NULL) _ckvmssts(SS$_INSFMEM);
1631 err = malloc(VMS_MAXRSS);
1632 if (err == NULL) _ckvmssts(SS$_INSFMEM);
1633
1634 in[0] = out[0] = err[0] = '\0';
1635
1636 if ((p = strchr(mode, 'F')) != NULL) { /* F -> use FILE* */
1637 strcpy(p, p+1);
1638 }
1639 if ((p = strchr(mode, 'W')) != NULL) { /* W -> wait for completion */
1640 wait = 1;
1641 strcpy(p, p+1);
1642 }
1643
1644 if (*mode == 'r') { /* piping from subroutine */
1645
1646 info->out = pipe_infromchild_setup(mbx, out);
1647 if (info->out) {
1648 info->out->pipe_done = &info->out_done;
1649 info->out_done = FALSE;
1650 info->out->info = info;
1651 }
1652 info->fp = freopen(mbx, mode, stdin);
1653 set_user_lnm("SYS$INPUT", mbx);
1654
1655 if (!info->fp && info->out) {
1656 sys$cancel(info->out->chan_out);
1657
1658 while (!info->out_done) {
1659 int done;
1660 _ckvmssts(sys$setast(0));
1661 done = info->out_done;
1662 if (!done) _ckvmssts(sys$clref(pipe_ef));
1663 _ckvmssts(sys$setast(1));
1664 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
1665 }
1666
1667 if (info->out->buf) {
1668 n = info->out->bufsize * sizeof (char);
1669 _ckvmssts(lib$free_vm(&n, &info->out->buf));
1670 }
1671 n = sizeof (Pipe);
1672 _ckvmssts(lib$free_vm(&n, &info->out));
1673 n = sizeof (Info);
1674 _ckvmssts(lib$free_vm(&n, &info));
1675 *psts = RMS$_FNF;
1676 return NULL;
1677 }
1678
1679 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
1680 if (info->err) {
1681 info->err->pipe_done = &info->err_done;
1682 info->err_done = FALSE;
1683 info->err->info = info;
1684 }
1685
1686 }
1687 else if (*mode == 'w') { /* piping to subroutine */
1688
1689 info->out = pipe_mbxtofd_setup(fileno(stdout), out);
1690 if (info->out) {
1691 info->out->pipe_done = &info->out_done;
1692 info->out_done = FALSE;
1693 info->out->info = info;
1694 }
1695
1696 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
1697 if (info->err) {
1698 info->err->pipe_done = &info->err_done;
1699 info->err_done = FALSE;
1700 info->err->info = info;
1701 }
1702
1703 info->in = pipe_tochild_setup(in, mbx);
1704 info->fp = freopen(mbx, mode, stdout);
1705 set_user_lnm("SYS$OUTPUT", mbx);
1706
1707 if (info->in) {
1708 info->in->pipe_done = &info->in_done;
1709 info->in_done = FALSE;
1710 info->in->info = info;
1711 }
1712
1713 /* error cleanup */
1714 if (!info->fp && info->in) {
1715 info->done = TRUE;
1716 _ckvmssts(sys$qiow(EFN$C_ENF, info->in->chan_in, IO$_WRITEOF,
1717 0, 0, 0, 0, 0, 0, 0, 0, 0));
1718
1719 while (!info->in_done) {
1720 int done;
1721 _ckvmssts(sys$setast(0));
1722 done = info->in_done;
1723 if (!done) _ckvmssts(sys$clref(pipe_ef));
1724 _ckvmssts(sys$setast(1));
1725 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
1726 }
1727
1728 if (info->in->buf) {
1729 n = info->in->bufsize * sizeof (char);
1730 _ckvmssts(lib$free_vm(&n, &info->in->buf));
1731 }
1732 n = sizeof (Pipe);
1733 _ckvmssts(lib$free_vm(&n, &info->in));
1734 n = sizeof (Info);
1735 _ckvmssts(lib$free_vm(&n, &info));
1736 *psts = RMS$_FNF;
1737 return NULL;
1738 }
1739
1740 }
1741 else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
1742
1743 info->out = pipe_mbxtofd_setup(fileno(stdout), out);
1744 if (info->out) {
1745 info->out->pipe_done = &info->out_done;
1746 info->out_done = FALSE;
1747 info->out->info = info;
1748 }
1749
1750 info->err = pipe_mbxtofd_setup(fileno(stderr), err);
1751 if (info->err) {
1752 info->err->pipe_done = &info->err_done;
1753 info->err_done = FALSE;
1754 info->err->info = info;
1755 }
1756 }
1757
1758 strncpy(symbol, in, sizeof (symbol));
1759 d_symbol.dsc$w_length = strlen(symbol);
1760 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
1761
1762 strncpy(symbol, err, sizeof (symbol));
1763 d_symbol.dsc$w_length = strlen(symbol);
1764 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
1765
1766 strncpy(symbol, out, sizeof (symbol));
1767 d_symbol.dsc$w_length = strlen(symbol);
1768 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
1769
1770 /* Done with the names for the pipes */
1771 free(err);
1772 free(out);
1773 free(in);
1774
1775 p = vmscmd->dsc$a_pointer;
1776 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
1777 if (*p == '$') p++; /* remove leading $ */
1778 while (*p == ' ' || *p == '\t') p++;
1779
1780 for (j = 0; j < 4; j++) {
1781 sprintf(cmd_sym_name, "PARROT_POPEN_CMD%d", j);
1782 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
1783
1784 strncpy(symbol, p, sizeof (symbol));
1785 d_symbol.dsc$w_length = strlen(symbol);
1786 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
1787
1788 if (strlen(p) > MAX_DCL_SYMBOL) {
1789 p += MAX_DCL_SYMBOL;
1790 }
1791 else {
1792 p += strlen(p);
1793 }
1794 }
1795 _ckvmssts(sys$setast(0));
1796 info->next = open_pipes; /* prepend to list */
1797 open_pipes = info;
1798 _ckvmssts(sys$setast(1));
1799 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
1800 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
1801 * have SYS$COMMAND if we need it.
1802 */
1803 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
1804 0, &info->pid, &info->completion,
1805 0, popen_completion_ast, info, 0, 0, 0));
1806
1807 /* if we were using a tempfile, close it now */
1808 if (tpipe) fclose(tpipe);
1809
1810 /* once the subprocess is spawned, it has copied the symbols and
1811 we can get rid of ours */
1812 for (j = 0; j < 4; j++) {
1813 sprintf(cmd_sym_name, "PARROT_POPEN_CMD%d", j);
1814 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
1815 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
1816 }
1817 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
1818 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
1819 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
1820 vms_execfree(vmscmd);
1821
1822 #if 0
1823 PL_forkprocess = info->pid;
1824 #endif
1825
1826 ret_fp = info->fp;
1827 if (wait) {
1828 int saved_errno; unsigned saved_vms_errno;
1829 int done = 0;
1830 while (!done) {
1831 _ckvmssts(sys$setast(0));
1832 done = info->done;
1833 if (!done) _ckvmssts(sys$clref(pipe_ef));
1834 _ckvmssts(sys$setast(1));
1835 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
1836 }
1837 *psts = info->completion;
1838 /* Caller thinks it is open and tries to close it. */
1839 /* This causes some problems, as it changes the error status */
1840 /* my_pclose(info->fp); */
1841
1842 /* If we did not have a file pointer open, then we have to */
1843 /* clean up here or eventually we will run out of something */
1844 saved_errno = errno; saved_vms_errno = vaxc$errno;
1845 if (info->fp == NULL)
1846 my_pclose_pinfo(info);
1847 SETERRNO(saved_errno, saved_vms_errno);
1848
1849 }
1850 else {
1851 *psts = info->pid;
1852 }
1853 return ret_fp;
1854 }
1855
1856 /*
1857
1858 =item C<static int my_pclose_pinfo(pInfo info)>
1859
1860 Routine to close and cleanup a pipe info structure.
1861
1862 =cut
1863
1864 */
1865
1866 static int
my_pclose_pinfo(pInfo info)1867 my_pclose_pinfo(pInfo info)
1868 {
1869 unsigned long int retsts;
1870 int done, n;
1871 pInfo next, last;
1872
1873 /* If we were writing to a subprocess, insure that someone reading from
1874 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
1875 * produce an EOF record in the mailbox.
1876 *
1877 * well, at least sometimes it *does*, so we have to watch out for
1878 * the first EOF closing the pipe (and DASSGN'ing the channel)...
1879 */
1880 if (info->fp)
1881 fflush(info->fp);
1882
1883 _ckvmssts(sys$setast(0));
1884 info->closing = TRUE;
1885 done = info->done && info->in_done && info->out_done && info->err_done;
1886 /* hanging on write to Perl's input? cancel it */
1887 if (info->mode == 'r' && info->out && !info->out_done) {
1888 if (info->out->chan_out) {
1889 _ckvmssts(sys$cancel(info->out->chan_out));
1890 if (!info->out->chan_in) { /* EOF generation, need AST */
1891 _ckvmssts(sys$dclast(pipe_infromchild_ast, (ASTparm_t)info->out, 0));
1892 }
1893 }
1894 }
1895 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
1896 _ckvmssts(sys$qio(EFN$C_ENF, info->in->chan_in, IO$_WRITEOF,
1897 0, 0, 0, 0, 0, 0, 0, 0, 0));
1898 _ckvmssts(sys$setast(1));
1899 if (info->fp)
1900 fclose(info->fp);
1901 /*
1902 we have to wait until subprocess completes, but ALSO wait until all
1903 the i/o completes...otherwise we'll be freeing the "info" structure
1904 that the i/o ASTs could still be using...
1905 */
1906
1907 while (!done) {
1908 _ckvmssts(sys$setast(0));
1909 done = info->done && info->in_done && info->out_done && info->err_done;
1910 if (!done) _ckvmssts(sys$clref(pipe_ef));
1911 _ckvmssts(sys$setast(1));
1912 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
1913 }
1914 retsts = info->completion;
1915
1916 /* remove from list of open pipes */
1917 _ckvmssts(sys$setast(0));
1918 last = NULL;
1919 for (next = open_pipes; next != NULL; last = next, next = next->next) {
1920 if (next == info)
1921 break;
1922 }
1923 if (last)
1924 last->next = info->next;
1925 else
1926 open_pipes = info->next;
1927 _ckvmssts(sys$setast(1));
1928
1929 /* free buffers and structures */
1930
1931 if (info->in) {
1932 if (info->in->buf) {
1933 n = info->in->bufsize * sizeof (char);
1934 _ckvmssts(lib$free_vm(&n, &info->in->buf));
1935 }
1936 n = sizeof (Pipe);
1937 _ckvmssts(lib$free_vm(&n, &info->in));
1938 }
1939 if (info->out) {
1940 if (info->out->buf) {
1941 n = info->out->bufsize * sizeof (char);
1942 _ckvmssts(lib$free_vm(&n, &info->out->buf));
1943 }
1944 n = sizeof (Pipe);
1945 _ckvmssts(lib$free_vm(&n, &info->out));
1946 }
1947 if (info->err) {
1948 if (info->err->buf) {
1949 n = info->err->bufsize * sizeof (char);
1950 _ckvmssts(lib$free_vm(&n, &info->err->buf));
1951 }
1952 n = sizeof (Pipe);
1953 _ckvmssts(lib$free_vm(&n, &info->err));
1954 }
1955 n = sizeof (Info);
1956 _ckvmssts(lib$free_vm(&n, &info));
1957
1958 return retsts;
1959 }
1960
1961 /*
1962
1963 =item C<static int my_pclose(FILE *fp)>
1964
1965 Close the pipe
1966
1967 =cut
1968
1969 */
1970
1971 static int
my_pclose(FILE * fp)1972 my_pclose(FILE *fp)
1973 {
1974 pInfo info, last = NULL;
1975 int ret_status;
1976
1977 /* Fixme - need ast and mutex protection here */
1978 for (info = open_pipes; info != NULL; last = info, info = info->next)
1979 if (info->fp == fp) break;
1980
1981 if (info == NULL) { /* no such pipe open */
1982 SETERRNO(ECHILD /* quoth POSIX */ , SS$_NONEXPR);
1983 return -1;
1984 }
1985
1986 ret_status = my_pclose_pinfo(info);
1987 return ret_status;
1988 }
1989
1990 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
1991 /* Roll our own prototype because we want this regardless of whether
1992 * _VMS_WAIT is defined.
1993 */
1994 __pid_t __vms_waitpid(__pid_t __pid, int *__stat_loc, int __options);
1995 #endif
1996
1997 /*
1998
1999 =item C<static pid_t my_waitpid(pid_t pid, int *statusp, int flags)>
2000
2001 sort-of waitpid; special handling of pipe clean-up for subprocesses
2002 created with popen(); otherwise partially emulate waitpid() unless
2003 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2004 Also check processes not considered by the CRTL waitpid().
2005
2006 =back
2007
2008 =cut
2009
2010 */
2011
2012 static pid_t
my_waitpid(pid_t pid,int * statusp,int flags)2013 my_waitpid(pid_t pid, int *statusp, int flags)
2014 {
2015 pInfo info;
2016 int done;
2017 int sts;
2018 int j;
2019
2020 if (statusp) *statusp = 0;
2021
2022 for (info = open_pipes; info != NULL; info = info->next)
2023 if (info->pid == pid)
2024 break;
2025
2026 if (info != NULL) { /* we know about this child */
2027 while (!info->done) {
2028 _ckvmssts(sys$setast(0));
2029 done = info->done;
2030 if (!done) _ckvmssts(sys$clref(pipe_ef));
2031 _ckvmssts(sys$setast(1));
2032 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2033 }
2034
2035 if (statusp) *statusp = info->completion;
2036 return pid;
2037 }
2038
2039 /* child that already terminated? */
2040 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2041 if (closed_list[j].pid == pid) {
2042 if (statusp) *statusp = closed_list[j].completion;
2043 return pid;
2044 }
2045 }
2046
2047 /* fall through if this child is not one of our own pipe children */
2048
2049 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
2050
2051 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2052 * in 7.2 did we get a version that fills in the VMS completion
2053 * status as Perl has always tried to do.
2054 */
2055
2056 sts = __vms_waitpid(pid, statusp, flags);
2057
2058 if (sts == 0 || !(sts == -1 && errno == ECHILD))
2059 return sts;
2060
2061 /* If the real waitpid tells us the child does not exist, we
2062 * fall through here to implement waiting for a child that
2063 * was created by some means other than exec() (say, spawned
2064 * from DCL) or to wait for a process that is not a subprocess
2065 * of the current process.
2066 */
2067
2068 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
2069
2070 {
2071 $DESCRIPTOR(intdsc, "0 00:00:01");
2072 int ownercode = JPI$_OWNER, pidcode = JPI$_PID;
2073 unsigned long int ownerpid, mypid;
2074 QUAD_t interval;
2075 IOSB jpi_iosb;
2076 struct item_list_3 jpilist[] = {
2077 {sizeof (ownerpid), JPI$_OWNER, &ownerpid, 0},
2078 { 0, 0, 0, 0}
2079 };
2080
2081 if (pid <= 0) {
2082 /* Sorry folks, we don't presently implement rooting around for
2083 the first child we can find, and we definitely don't want to
2084 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2085 */
2086 set_errno(ENOTSUP);
2087 return -1;
2088 }
2089
2090 /* Get the owner of the child so I can warn if it's not mine. If the
2091 * process doesn't exist or I don't have the privs to look at it,
2092 * I can go home early.
2093 */
2094 sts = sys$getjpiw(EFN$C_ENF, (unsigned int *)&pid, NULL, &jpilist,
2095 &jpi_iosb, NULL, 0);
2096 if (sts & 1) sts = jpi_iosb.status;
2097 if (!(sts & 1)) {
2098 switch (sts) {
2099 case SS$_NONEXPR:
2100 set_errno(ECHILD); break;
2101 case SS$_NOPRIV:
2102 set_errno(EACCES); break;
2103 default:
2104 _ckvmssts(sts);
2105 }
2106 set_vaxc_errno(sts);
2107 return -1;
2108 }
2109
2110 #if 0
2111 if (ckWARN(WARN_EXEC)) {
2112 /* remind folks they are asking for non-standard waitpid behavior */
2113 _ckvmssts(lib$getjpi(&pidcode, 0, 0, &mypid, 0, 0));
2114 if (ownerpid != mypid)
2115 Perl_warner(packWARN(WARN_EXEC),
2116 "waitpid: process %x is not a child of process %x",
2117 pid, mypid);
2118 }
2119 #endif
2120
2121 /* simply check on it once a second until it's not there anymore. */
2122 _ckvmssts(sys$bintim(&intdsc, QUAD_PTR(interval)));
2123 while ((sts=lib$getjpi(&ownercode, &pid, 0, &ownerpid, 0, 0)) & 1) {
2124 _ckvmssts(sys$schdwk(0, 0, QUAD_PTR(interval), 0));
2125 _ckvmssts(sys$hiber());
2126 }
2127 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2128
2129 _ckvmssts(sts);
2130 return pid;
2131 }
2132 }
2133
2134 /*
2135
2136 =head3 VMS subprocess management
2137
2138 C<my_vfork()> - just a C<vfork()>, after setting a flag to record that
2139 the current script is trying a Unix-style fork/exec.
2140
2141 C<vms_do_aexec()> and C<vms_do_exec()> are called in response to the
2142 perl I<'exec'> function. If this follows a vfork call, then they
2143 call out the regular perl routines in F<doio.c> which do an
2144 C<execvp> (for those who really want to try this under VMS).
2145 Otherwise, they do exactly what the perl docs say exec should
2146 do - terminate the current script and invoke a new command
2147 (See below for notes on command syntax.)
2148
2149 C<do_aspawn()> and C<do_spawn()> implement the VMS side of the perl
2150 I<'system'> function.
2151
2152 Note on command arguments to perl I<'exec'> and I<'system'>: When handled
2153 in 'VMSish fashion' (i.e. not after a call to vfork) The args
2154 are concatenated to form a DCL command string. If the first non-numeric
2155 arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
2156 the command string is handed off to DCL directly. Otherwise,
2157 the first token of the command is taken as the filespec of an image
2158 to run. The filespec is expanded using a default type of '.EXE' and
2159 the process defaults for device, directory, etc., and if found, the resultant
2160 filespec is invoked using the DCL verb 'MCR', and passed the rest of
2161 the command string as parameters. This is perhaps a bit complicated,
2162 but I hope it will form a happy medium between what VMS folks expect
2163 from C<lib$spawn> and what Unix folks expect from C<exec>.
2164
2165 */
2166
2167 /*
2168
2169 =over
2170
2171 =item C<static void vms_execfree(struct dsc$descriptor_s *vmscmd)>
2172
2173 Free command descriptor
2174
2175 =cut
2176
2177 */
2178
2179 static void
vms_execfree(struct dsc$descriptor_s * vmscmd)2180 vms_execfree(struct dsc$descriptor_s *vmscmd)
2181 {
2182 if (vmscmd) {
2183 if (vmscmd->dsc$a_pointer) {
2184 free(vmscmd->dsc$a_pointer);
2185 }
2186 free(vmscmd);
2187 }
2188 }
2189
2190 /* Cons up a 'delete' bit for testing access */
2191 #define S_IDUSR (S_IWUSR | S_IXUSR)
2192 #define S_IDGRP (S_IWGRP | S_IXGRP)
2193 #define S_IDOTH (S_IWOTH | S_IXOTH)
2194
2195 /*
2196
2197 =item C<static int cando_by_name_int(int bit, int effective, const char *fname,
2198 int opts)>
2199
2200 Check file permissions.
2201
2202 =cut
2203
2204 */
2205
2206 static int
cando_by_name_int(int bit,int effective,const char * fname,int opts)2207 cando_by_name_int(int bit, int effective, const char *fname, int opts)
2208 {
2209 /* TODO: Replace by the full-blown perl implementation */
2210 int access_mode = 0;
2211
2212 switch (bit) {
2213 case S_IXUSR: case S_IXGRP: case S_IXOTH:
2214 access_mode = X_OK; break;
2215 case S_IRUSR: case S_IRGRP: case S_IROTH:
2216 access_mode = R_OK; break;
2217 case S_IWUSR: case S_IWGRP: case S_IWOTH:
2218 case S_IDUSR: case S_IDGRP: case S_IDOTH:
2219 access_mode = W_OK; break;
2220 default:
2221 return FALSE;
2222 }
2223 return access(fname, access_mode);
2224 }
2225
2226 /* RMSEXPAND options */
2227 #define RMSEXPAND_M_VMS 0x02 /* Force output to VMS format */
2228 #define RMSEXPAND_M_LONG 0x04 /* Expand to long name format */
2229 #define RMSEXPAND_M_VMS_IN 0x08 /* Assume input is VMS already */
2230 #define RMSEXPAND_M_SYMLINK 0x20 /* Use symbolic link, not target */
2231
2232 /*
2233
2234 =item C<static char * int_rmsexpand (const char *filespec, char *outbuf, const
2235 char *defspec, unsigned opts, int * fs_utf8, int * dfs_utf8)>
2236
2237 Expansion not yet implemented. It only does a copy.
2238
2239 =cut
2240
2241 */
2242
2243 static char *
int_rmsexpand(const char * filespec,char * outbuf,const char * defspec,unsigned opts,int * fs_utf8,int * dfs_utf8)2244 int_rmsexpand
2245 (const char *filespec,
2246 char *outbuf,
2247 const char *defspec,
2248 unsigned opts,
2249 int * fs_utf8,
2250 int * dfs_utf8)
2251 {
2252 /* TODO: Replace by the full-blown perl implementation */
2253 strcpy(outbuf, filespec);
2254 return outbuf;
2255 }
2256
2257 /*
2258
2259 =item C<static unsigned long int setup_cmddsc(const char *incmd, int check_img,
2260 int *suggest_quote, struct dsc$descriptor_s **pvmscmd)>
2261
2262 Setup a command descriptor to call a DCL command or excutable image.
2263
2264 =cut
2265
2266 */
2267
2268 static unsigned long int
setup_cmddsc(const char * incmd,int check_img,int * suggest_quote,struct dsc$descriptor_s ** pvmscmd)2269 setup_cmddsc(const char *incmd, int check_img, int *suggest_quote,
2270 struct dsc$descriptor_s **pvmscmd)
2271 {
2272 char * vmsspec;
2273 char * resspec;
2274 char image_name[VMS_MAXRSS];
2275 char image_argv[VMS_MAXRSS];
2276 $DESCRIPTOR(defdsc, ".EXE");
2277 $DESCRIPTOR(defdsc2, ".");
2278 struct dsc$descriptor_s resdsc;
2279 struct dsc$descriptor_s *vmscmd;
2280 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2281 unsigned int cxt = 0, flags = 1, retsts = SS$_NORMAL;
2282 register char *s, *rest, *cp, *wordbreak;
2283 char * cmd;
2284 int cmdlen;
2285 register int isdcl;
2286
2287 vmscmd = malloc(sizeof (struct dsc$descriptor_s));
2288 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
2289
2290 /* vmsspec is a DCL command buffer, not just a filename */
2291 vmsspec = malloc(MAX_DCL_LINE_LENGTH + 1);
2292 if (vmsspec == NULL) _ckvmssts(SS$_INSFMEM);
2293
2294 resspec = malloc(VMS_MAXRSS);
2295 if (resspec == NULL) _ckvmssts(SS$_INSFMEM);
2296
2297 /* Make a copy for modification */
2298 cmdlen = strlen(incmd);
2299 cmd = malloc(cmdlen+1);
2300 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
2301 strncpy(cmd, incmd, cmdlen + 1);
2302 image_name[0] = 0;
2303 image_argv[0] = 0;
2304
2305 resdsc.dsc$a_pointer = resspec;
2306 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
2307 resdsc.dsc$b_class = DSC$K_CLASS_S;
2308 resdsc.dsc$w_length = VMS_MAXRSS - 1;
2309
2310 vmscmd->dsc$a_pointer = NULL;
2311 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
2312 vmscmd->dsc$b_class = DSC$K_CLASS_S;
2313 vmscmd->dsc$w_length = 0;
2314 if (pvmscmd) *pvmscmd = vmscmd;
2315
2316 if (suggest_quote) *suggest_quote = 0;
2317
2318 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
2319 free(cmd);
2320 free(vmsspec);
2321 free(resspec);
2322 return CLI$_BUFOVF; /* continuation lines currently unsupported */
2323 }
2324
2325 s = cmd;
2326
2327 while (*s && isspace((unsigned char)*s)) s++;
2328
2329 if (*s == '@' || *s == '$') {
2330 vmsspec[0] = *s; rest = s + 1;
2331 for (cp = &vmsspec[1]; *rest && isspace((unsigned char)*rest); rest++, cp++) *cp = *rest;
2332 }
2333 else {
2334 cp = vmsspec; rest = s;
2335 }
2336 if (*rest == '.' || *rest == '/') {
2337 #if 1
2338 free(cmd);
2339 free(vmsspec);
2340 free(resspec);
2341 return CLI$_BUFOVF; /* unixoid filespecs currently unsupported */
2342 #else
2343 char *cp2;
2344 for (cp2 = resspec;
2345 *rest && !isspace((unsigned char)*rest)
2346 && cp2 - resspec < (VMS_MAXRSS - 1); rest++, cp2++) {
2347 *cp2 = *rest;
2348 }
2349 *cp2 = '\0';
2350 if (int_tovmsspec(resspec, cp, 0, NULL)) {
2351 s = vmsspec;
2352
2353 /* When a UNIX spec with no file type is translated to VMS, */
2354 /* A trailing '.' is appended under ODS-5 rules. */
2355 /* Here we do not want that trailing "." as it prevents */
2356 /* Looking for a implied ".exe" type. */
2357 if (decc_efs_charset) {
2358 int i;
2359 i = strlen(vmsspec);
2360 if (vmsspec[i-1] == '.') {
2361 vmsspec[i-1] = '\0';
2362 }
2363 }
2364
2365 if (*rest) {
2366 for (cp2 = vmsspec + strlen(vmsspec);
2367 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH; rest++, cp2++) {
2368 *cp2 = *rest;
2369 }
2370 *cp2 = '\0';
2371 }
2372 }
2373 #endif
2374 }
2375 /* Intuit whether verb (first word of cmd) is a DCL command:
2376 * - if first nonspace char is '@', it's a DCL indirection
2377 * otherwise
2378 * - if verb contains a filespec separator, it's not a DCL command
2379 * - if it doesn't, caller tells us whether to default to a DCL
2380 * command, or to a local image unless told it's DCL (by leading '$')
2381 */
2382 if (*s == '@') {
2383 isdcl = 1;
2384 if (suggest_quote) *suggest_quote = 1;
2385 }
2386 else {
2387 register char *filespec = strpbrk(s, ":<[.;");
2388 rest = wordbreak = strpbrk(s, " \"\t/");
2389 if (!wordbreak) wordbreak = s + strlen(s);
2390 if (*s == '$') check_img = 0;
2391 isdcl = (filespec && (filespec < wordbreak)) ? 0 : !check_img;
2392 }
2393
2394 if (!isdcl) {
2395 int rsts;
2396 imgdsc.dsc$a_pointer = s;
2397 imgdsc.dsc$w_length = wordbreak - s;
2398 retsts = lib$find_file(&imgdsc, &resdsc, &cxt, &defdsc, 0, &rsts, &flags);
2399 if (!(retsts&1)) {
2400 _ckvmssts(lib$find_file_end(&cxt));
2401 retsts = lib$find_file(&imgdsc, &resdsc, &cxt, &defdsc2, 0, &rsts, &flags);
2402 if (!(retsts & 1) && *s == '$') {
2403 _ckvmssts(lib$find_file_end(&cxt));
2404 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
2405 retsts = lib$find_file(&imgdsc, &resdsc, &cxt, &defdsc, 0, &rsts, &flags);
2406 if (!(retsts&1)) {
2407 _ckvmssts(lib$find_file_end(&cxt));
2408 retsts = lib$find_file(&imgdsc, &resdsc, &cxt, &defdsc2, 0, &rsts, &flags);
2409 }
2410 }
2411 }
2412 _ckvmssts(lib$find_file_end(&cxt));
2413
2414 if (retsts & 1) {
2415 FILE *fp;
2416 s = resspec;
2417 while (*s && !isspace((unsigned char)*s)) s++;
2418 *s = '\0';
2419
2420 /* check that it's really not DCL with no file extension */
2421 fp = fopen(resspec, "r", "ctx=bin", "ctx=rec", "shr=get");
2422 if (fp) {
2423 unsigned char b[256] = {0, 0, 0, 0};
2424
2425 read(fileno(fp), (char*)b, 256);
2426 isdcl = isprint(b[0]) && isprint(b[1])
2427 && isprint(b[2]) && isprint(b[3]);
2428 if (isdcl) {
2429 int shebang_len;
2430
2431 /* Check for script */
2432 shebang_len = 0;
2433 if ((b[0] == '#') && (b[1] == '!'))
2434 shebang_len = 2;
2435 #ifdef ALTERNATE_SHEBANG
2436 else {
2437 shebang_len = strlen(ALTERNATE_SHEBANG);
2438 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
2439 char * perlstr;
2440 perlstr = strstr("perl", b);
2441 if (perlstr == NULL)
2442 shebang_len = 0;
2443 }
2444 else
2445 shebang_len = 0;
2446 }
2447 #endif
2448
2449 if (shebang_len > 0) {
2450 int i;
2451 int j;
2452 char tmpspec[VMS_MAXRSS];
2453
2454 i = shebang_len;
2455 /* Image is following after white space */
2456 /*--------------------------------------*/
2457 while (isprint(b[i]) && isspace(b[i]))
2458 i++;
2459
2460 j = 0;
2461 while (isprint(b[i]) && !isspace(b[i])) {
2462 tmpspec[j++] = b[i++];
2463 if (j >= NAM$C_MAXRSS)
2464 break;
2465 }
2466 tmpspec[j] = '\0';
2467
2468 /* There may be some default parameters to the image */
2469 /*---------------------------------------------------*/
2470 j = 0;
2471 while (isprint(b[i])) {
2472 image_argv[j++] = b[i++];
2473 if (j >= NAM$C_MAXRSS)
2474 break;
2475 }
2476 while ((j > 0) && !isprint((unsigned char)image_argv[j-1]))
2477 j--;
2478 image_argv[j] = 0;
2479
2480 /* It will need to be converted to VMS format and validated */
2481 if (tmpspec[0] != '\0') {
2482 char * iname;
2483
2484 /* Try to find the exact program requested to be run */
2485 /*---------------------------------------------------*/
2486 iname = int_rmsexpand(tmpspec, image_name, ".exe", RMSEXPAND_M_VMS,
2487 NULL, NULL);
2488 if (iname != NULL) {
2489 if (cando_by_name_int(S_IXUSR, 0, image_name, RMSEXPAND_M_VMS_IN))
2490 isdcl = 0; /* MCR prefix needed */
2491 else {
2492 /* Try again with a null type */
2493 /*----------------------------*/
2494 iname = int_rmsexpand(tmpspec, image_name, ".",
2495 RMSEXPAND_M_VMS, NULL, NULL);
2496 if (iname != NULL) {
2497 if (cando_by_name_int(S_IXUSR, 0, image_name,
2498 RMSEXPAND_M_VMS_IN))
2499 isdcl = 0; /* MCR prefix needed */
2500 }
2501 }
2502
2503 /* Did we find the image to run the script? */
2504 /*------------------------------------------*/
2505 if (isdcl) {
2506 char *tchr;
2507
2508 /* Assume DCL or foreign command exists */
2509 /*--------------------------------------*/
2510 tchr = strrchr(tmpspec, '/');
2511 if (tchr != NULL) {
2512 tchr++;
2513 }
2514 else {
2515 tchr = tmpspec;
2516 }
2517 strncpy(image_name, tchr, sizeof (image_name));
2518 }
2519 }
2520 }
2521 }
2522 }
2523 fclose(fp);
2524 }
2525 if (check_img && isdcl) {
2526 free(cmd);
2527 free(resspec);
2528 free(vmsspec);
2529 return RMS$_FNF;
2530 }
2531
2532 if (cando_by_name_int(S_IXUSR, 0, resspec, 0)) {
2533 vmscmd->dsc$a_pointer = malloc(MAX_DCL_LINE_LENGTH);
2534 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
2535 if (!isdcl) {
2536 strncpy(vmscmd->dsc$a_pointer, "$ MCR ", MAX_DCL_LINE_LENGTH);
2537 if (image_name[0] != 0) {
2538 strncat(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
2539 strncat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
2540 }
2541 }
2542 else if (image_name[0] != 0) {
2543 strncpy(vmscmd->dsc$a_pointer, image_name, MAX_DCL_LINE_LENGTH);
2544 strncat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
2545 }
2546 else {
2547 strncpy(vmscmd->dsc$a_pointer, "@", MAX_DCL_LINE_LENGTH);
2548 }
2549 if (suggest_quote) *suggest_quote = 1;
2550
2551 /* If there is an image name, use original command */
2552 if (image_name[0] == 0)
2553 strncat(vmscmd->dsc$a_pointer, resspec, MAX_DCL_LINE_LENGTH);
2554 else {
2555 rest = cmd;
2556 while (*rest && isspace((unsigned char)*rest)) rest++;
2557 }
2558
2559 if (image_argv[0] != 0) {
2560 strncat(vmscmd->dsc$a_pointer, image_argv, MAX_DCL_LINE_LENGTH);
2561 strncat(vmscmd->dsc$a_pointer, " ", MAX_DCL_LINE_LENGTH);
2562 }
2563 if (rest) {
2564 int rest_len;
2565 int vmscmd_len;
2566
2567 rest_len = strlen(rest);
2568 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
2569 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
2570 strncat(vmscmd->dsc$a_pointer, rest, MAX_DCL_LINE_LENGTH);
2571 else
2572 retsts = CLI$_BUFOVF;
2573 }
2574 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
2575 free(cmd);
2576 free(vmsspec);
2577 free(resspec);
2578 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
2579 }
2580 else
2581 retsts = RMS$_PRV;
2582 }
2583 }
2584 /* It's either a DCL command or we couldn't find a suitable image */
2585 vmscmd->dsc$w_length = strlen(cmd);
2586
2587 vmscmd->dsc$a_pointer = malloc(vmscmd->dsc$w_length + 1);
2588 strncpy(vmscmd->dsc$a_pointer, cmd, vmscmd->dsc$w_length + 1);
2589
2590 free(cmd);
2591 free(resspec);
2592 free(vmsspec);
2593
2594 /* check if it's a symbol (for quoting purposes) */
2595 if (suggest_quote && !*suggest_quote) {
2596 int iss;
2597 char equiv[LNM$C_NAMLENGTH];
2598 struct dsc$descriptor_s eqvdsc = {sizeof (equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, equiv};
2599
2600 iss = lib$get_symbol(vmscmd, &eqvdsc);
2601 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
2602 }
2603 if (!(retsts & 1)) {
2604 /* just hand off status values likely to be due to user error */
2605 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
2606 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
2607 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
2608 else { _ckvmssts(retsts); }
2609 }
2610
2611 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
2612
2613 }
2614
2615 /*
2616
2617 =item C<static int do_spawn2(const char *cmd, int flags)>
2618
2619 Implements C<Parrot_Run_OS_Command>.
2620 Spawn off a subprocess provided in command-line arguments. Wait for it to
2621 complete, returning the return value of the process.
2622
2623 =cut
2624
2625 */
2626
2627 static int
do_spawn2(const char * cmd,int flags)2628 do_spawn2(const char *cmd, int flags)
2629 {
2630 unsigned long int sts, substs;
2631
2632 if (!cmd || !*cmd) {
2633 sts = lib$spawn(0, 0, 0, &flags, 0, 0, &substs, 0, 0, 0, 0, 0, 0);
2634 if (!(sts & 1)) {
2635 switch (sts) {
2636 case RMS$_FNF:
2637 case RMS$_DNF:
2638 set_errno(ENOENT); break;
2639 case RMS$_DIR:
2640 set_errno(ENOTDIR); break;
2641 case RMS$_DEV:
2642 set_errno(ENODEV); break;
2643 case RMS$_PRV:
2644 set_errno(EACCES); break;
2645 case RMS$_SYN:
2646 set_errno(EINVAL); break;
2647 case CLI$_BUFOVF:
2648 case RMS$_RTB:
2649 case CLI$_TKNOVF:
2650 case CLI$_RSLOVF:
2651 set_errno(E2BIG); break;
2652 case LIB$_INVARG:
2653 case LIB$_INVSTRDES:
2654 case SS$_ACCVIO: /* shouldn't happen */
2655 _ckvmssts(sts); /* fall through */
2656 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2657 set_errno(EVMSERR);
2658 }
2659 set_vaxc_errno(sts);
2660 #if 0
2661 if (ckWARN(WARN_EXEC)) {
2662 Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't spawn: %s", Strerror(errno));
2663 }
2664 #endif
2665 }
2666 sts = substs;
2667 }
2668 else {
2669 char mode[3];
2670 FILE * fp;
2671
2672 strcpy(mode, (flags & CLI$M_NOWAIT) ? "n" : "nW");
2673
2674 fp = safe_popen(cmd, mode, (int *)&sts);
2675 if (fp != NULL)
2676 my_pclose(fp);
2677 /* sts will be the pid in the nowait case */
2678 }
2679 return sts;
2680 }
2681
2682 /*
2683
2684 =item C<static void set_user_lnm(const char *name, const char *eqv)>
2685
2686 I<vmssetuserlnm>
2687
2688 Sets a user-mode logical in the process logical name table
2689 used for redirection of sys$error.
2690
2691 =cut
2692
2693 */
2694
2695 static void
set_user_lnm(const char * name,const char * eqv)2696 set_user_lnm(const char *name, const char *eqv)
2697 {
2698 $DESCRIPTOR(d_tab, "LNM$PROCESS");
2699 struct dsc$descriptor_d d_name = {0, DSC$K_DTYPE_T, DSC$K_CLASS_D, 0};
2700 unsigned long int iss;
2701 unsigned int attr = LNM$M_CONFINE;
2702 unsigned char acmode = PSL$C_USER;
2703 struct item_list_3 lnmlst[2] =
2704 {{0, LNM$_STRING, 0, 0}, {0, 0, 0, 0}};
2705
2706 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
2707 d_name.dsc$w_length = strlen(name);
2708
2709 lnmlst[0].len = strlen(eqv);
2710 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
2711
2712 iss = sys$crelnm(&attr, &d_tab, &d_name, &acmode, lnmlst);
2713 if (!(iss&1)) lib$signal(iss);
2714 }
2715
2716 /*
2717
2718 =item C<static int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
2719 struct dsc$descriptor_s **tabvec, unsigned long int flags)>
2720
2721 ??
2722
2723 =cut
2724
2725 */
2726
2727 static int
vmstrnenv(const char * lnm,char * eqv,unsigned long int idx,struct dsc$descriptor_s ** tabvec,unsigned long int flags)2728 vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
2729 struct dsc$descriptor_s **tabvec, unsigned long int flags)
2730 {
2731 char *res = getenv(lnm);
2732 if (res == NULL)
2733 return 0;
2734
2735 strcpy(eqv, res);
2736 return 1;
2737 }
2738
2739
2740 /* default piping mailbox size */
2741 #ifdef __VAX
2742 # define PERL_BUFSIZ 512
2743 #else
2744 # define PERL_BUFSIZ 8192
2745 #endif
2746
2747 static $DESCRIPTOR(fildevdsc, "LNM$FILE_DEV");
2748 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
2749
2750 /*
2751
2752 =item C<static void create_mbx(unsigned short int *chan, struct dsc$descriptor_s
2753 *namdsc)>
2754
2755 Create mailbox for command descriptor
2756
2757 =cut
2758
2759 */
2760
2761 static void
create_mbx(unsigned short int * chan,struct dsc$descriptor_s * namdsc)2762 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2763 {
2764 unsigned long int mbxbufsiz;
2765 static unsigned long int syssize = 0;
2766 int dviitm = DVI$_DEVNAM;
2767 char csize[LNM$C_NAMLENGTH+1];
2768 int sts;
2769
2770 if (!syssize) {
2771 int syiitm = SYI$_MAXBUF;
2772 /*
2773 * Get the SYSGEN parameter MAXBUF
2774 *
2775 * If the logical 'PERL_MBX_SIZE' is defined
2776 * use the value of the logical instead of PERL_BUFSIZ, but
2777 * keep the size between 128 and MAXBUF.
2778 *
2779 */
2780 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2781 }
2782
2783 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2784 mbxbufsiz = atoi(csize);
2785 }
2786 else {
2787 mbxbufsiz = PERL_BUFSIZ;
2788 }
2789 if (mbxbufsiz < 128) mbxbufsiz = 128;
2790 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2791
2792 _ckvmssts(sys$crembx(0, chan, mbxbufsiz, mbxbufsiz, 0, 0, 0));
2793 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2794 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2795
2796 }
2797
2798 /*
2799
2800 =item C<static void vms_get_subproc_handles(int pid, PIOHANDLE *handles)>
2801
2802 Return the three stdio handles for the command.
2803
2804 =back
2805
2806 =cut
2807
2808 */
2809
2810 static void
vms_get_subproc_handles(int pid,PIOHANDLE * handles)2811 vms_get_subproc_handles(int pid, PIOHANDLE *handles)
2812 {
2813 pInfo pi;
2814
2815 for (pi = open_pipes; pi != NULL; pi = pi->next)
2816 if (pi->pid == pid) {
2817 handles[0] = pi->in->fd_out;
2818 handles[1] = pi->out->fd_out;
2819 handles[2] = pi->err->fd_out;
2820 break;
2821 }
2822 }
2823
2824
2825 /*
2826 * Local variables:
2827 * c-file-style: "parrot"
2828 * End:
2829 * vim: expandtab shiftwidth=4 cinoptions='\:2=2' :
2830 */
2831