This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl5.000 patch.0o: [address] a few more Configure and build nits.
[perl5.git] / vms / vms.c
CommitLineData
a0d0e21e
LW
1/* VMS-specific routines for perl5
2 *
3 * Last revised: 09-Oct-1994
4 */
5
6#include <acedef.h>
7#include <acldef.h>
8#include <armdef.h>
9#include <chpdef.h>
10#include <descrip.h>
11#include <dvidef.h>
12#include <float.h>
13#include <fscndef.h>
14#include <iodef.h>
15#include <jpidef.h>
16#include <libdef.h>
17#include <lib$routines.h>
18#include <lnmdef.h>
19#include <psldef.h>
20#include <rms.h>
21#include <shrdef.h>
22#include <ssdef.h>
23#include <starlet.h>
24#include <stsdef.h>
25#include <syidef.h>
26
27
28#include "EXTERN.h"
29#include "perl.h"
30
31struct itmlst_3 {
32 unsigned short int buflen;
33 unsigned short int itmcode;
34 void *bufadr;
35 unsigned long int retlen;
36};
37
38static unsigned long int sts;
39
40#define _cksts(call) \
41 if (!(sts=(call))&1) { \
42 errno = EVMSERR; vaxc$errno = sts; \
43 croak("fatal error at %s, line %d",__FILE__,__LINE__); \
44 } else { 1; }
45
46/* my_getenv
47 * Translate a logical name. Substitute for CRTL getenv() to avoid
48 * memory leak, and to keep my_getenv() and my_setenv() in the same
49 * domain (mostly - my_getenv() need not return a translation from
50 * the process logical name table)
51 *
52 * Note: Uses static buffer -- not thread-safe!
53 */
54/*{{{ char *my_getenv(char *lnm)*/
55char *
56my_getenv(char *lnm)
57{
58 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
59 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
60 unsigned short int eqvlen;
61 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
62 $DESCRIPTOR(sysdiskdsc,"SYS$DISK");
63 $DESCRIPTOR(tabdsc,"LNM$FILE_DEV");
64 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
65 eqvdsc = {sizeof __my_getenv_eqv,DSC$K_DTYPE_T,
66 DSC$K_CLASS_S, __my_getenv_eqv};
67 struct itmlst_3 lnmlst[2] = {sizeof __my_getenv_eqv - 1, LNM$_STRING,
68 __my_getenv_eqv, &eqvlen, 0, 0, 0, 0};
69
70 for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
71 *cp2 = '\0';
72 lnmdsc.dsc$w_length = cp1 - lnm;
73 if (lnmdsc.dsc$w_length = 7 && !strncmp(uplnm,"DEFAULT",7)) {
74 _cksts(sys$trnlnm(&attr,&tabdsc,&sysdiskdsc,0,lnmlst));
75 eqvdsc.dsc$a_pointer += eqvlen;
76 eqvdsc.dsc$w_length = sizeof __my_getenv_eqv - eqvlen - 1;
77 _cksts(sys$setddir(0,&eqvlen,&eqvdsc));
78 eqvdsc.dsc$a_pointer[eqvlen] = '\0';
79 return __my_getenv_eqv;
80 }
81 else {
82 retsts = sys$trnlnm(&attr,&tabdsc,&lnmdsc,0,lnmlst);
83 if (retsts != SS$_NOLOGNAM) {
84 if (retsts & 1) {
85 __my_getenv_eqv[eqvlen] = '\0';
86 return __my_getenv_eqv;
87 }
88 _cksts(retsts);
89 }
90 else {
91 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&(eqvdsc.dsc$w_length),0);
92 if (retsts != LIB$_NOSUCHSYM) {
93 /* We want to return only logical names or CRTL Unix emulations */
94 if (retsts & 1) return Nullch;
95 _cksts(retsts);
96 }
97 else return getenv(lnm); /* Try for CRTL emulation of a Unix/POSIX name */
98 }
99 }
100 return NULL;
101
102} /* end of my_getenv() */
103/*}}}*/
104
105/*{{{ void my_setenv(char *lnm, char *eqv)*/
106void
107my_setenv(char *lnm,char *eqv)
108/* Define a supervisor-mode logical name in the process table.
109 * In the future we'll add tables, attribs, and acmodes,
110 * probably through a different call.
111 */
112{
113 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
114 unsigned long int retsts, usermode = PSL$C_USER;
115 $DESCRIPTOR(tabdsc,"LNM$PROCESS");
116 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
117 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
118
119 for(cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
120 lnmdsc.dsc$w_length = cp1 - lnm;
121
122 if (!eqv || !*eqv) { /* we're deleting a logical name */
123 retsts = sys$dellnm(&tabdsc,&lnmdsc,&usermode); /* try user mode first */
124 if (retsts != SS$_NOLOGNAM) _cksts(retsts);
125 if (!(retsts & 1)) {
126 retsts = lib$delete_logical(&lnmdsc,&tabdsc); /* then supervisor mode */
127 if (retsts != SS$_NOLOGNAM) _cksts(retsts);
128 }
129 }
130 else {
131 eqvdsc.dsc$w_length = strlen(eqv);
132 eqvdsc.dsc$a_pointer = eqv;
133
134 _cksts(lib$set_logical(&lnmdsc,&eqvdsc,&tabdsc,0,0));
135 }
136
137} /* end of my_setenv() */
138/*}}}*/
139
140static char *do_fileify_dirspec(char *, char *, int);
141static char *do_tovmsspec(char *, char *, int);
142
143/*{{{int do_rmdir(char *name)*/
144int
145do_rmdir(char *name)
146{
147 char dirfile[NAM$C_MAXRSS+1];
148 int retval;
149 stat_t st;
150
151 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
152 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
153 else retval = kill_file(dirfile);
154 return retval;
155
156} /* end of do_rmdir */
157/*}}}*/
158
159/* kill_file
160 * Delete any file to which user has control access, regardless of whether
161 * delete access is explicitly allowed.
162 * Limitations: User must have write access to parent directory.
163 * Does not block signals or ASTs; if interrupted in midstream
164 * may leave file with an altered ACL.
165 * HANDLE WITH CARE!
166 */
167/*{{{int kill_file(char *name)*/
168int
169kill_file(char *name)
170{
171 char vmsname[NAM$C_MAXRSS+1];
172 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
173 unsigned long int uics[2] = {0,0}, cxt = 0, aclsts, fndsts, rmsts = -1;
174 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
175 struct myacedef {
176 unsigned char ace$b_length;
177 unsigned char ace$b_type;
178 unsigned short int ace$w_flags;
179 unsigned long int ace$l_access;
180 unsigned long int ace$l_ident;
181 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
182 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
183 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
184 struct itmlst_3
185 findlst[3] = {sizeof oldace, ACL$C_FNDACLENT, &oldace, 0,
186 sizeof oldace, ACL$C_READACE, &oldace, 0, 0, 0, 0, 0},
187 addlst[2] = {sizeof newace, ACL$C_ADDACLENT, &newace, 0, 0, 0, 0, 0},
188 dellst[2] = {sizeof newace, ACL$C_DELACLENT, &newace, 0, 0, 0, 0, 0},
189 lcklst[2] = {sizeof newace, ACL$C_WLOCK_ACL, &newace, 0, 0, 0, 0, 0},
190 ulklst[2] = {sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0, 0, 0, 0, 0};
191
192 if (!remove(name)) return 0; /* Can we just get rid of it? */
193
194 /* No, so we get our own UIC to use as a rights identifier,
195 * and the insert an ACE at the head of the ACL which allows us
196 * to delete the file.
197 */
198 _cksts(lib$getjpi(&jpicode,0,0,&(oldace.ace$l_ident),0,0));
199 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
200 fildsc.dsc$w_length = strlen(vmsname);
201 fildsc.dsc$a_pointer = vmsname;
202 cxt = 0;
203 newace.ace$l_ident = oldace.ace$l_ident;
204 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
205 errno = EVMSERR;
206 vaxc$errno = aclsts;
207 return -1;
208 }
209 /* Grab any existing ACEs with this identifier in case we fail */
210 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
211 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY) {
212 /* Add the new ACE . . . */
213 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
214 goto yourroom;
215 if (rmsts = remove(name)) {
216 /* We blew it - dir with files in it, no write priv for
217 * parent directory, etc. Put things back the way they were. */
218 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
219 goto yourroom;
220 if (fndsts & 1) {
221 addlst[0].bufadr = &oldace;
222 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
223 goto yourroom;
224 }
225 }
226 }
227
228 yourroom:
229 if (rmsts) {
230 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
231 if (aclsts & 1) aclsts = fndsts;
232 }
233 if (!(aclsts & 1)) {
234 errno = EVMSERR;
235 vaxc$errno = aclsts;
236 return -1;
237 }
238
239 return rmsts;
240
241} /* end of kill_file() */
242/*}}}*/
243
244static void
245create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
246{
247 static unsigned long int mbxbufsiz;
248 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
249
250 if (!mbxbufsiz) {
251 /*
252 * Get the SYSGEN parameter MAXBUF, and the smaller of it and the
253 * preprocessor consant BUFSIZ from stdio.h as the size of the
254 * 'pipe' mailbox.
255 */
256 _cksts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
257 if (mbxbufsiz > BUFSIZ) mbxbufsiz = BUFSIZ;
258 }
259 _cksts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
260
261 _cksts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
262 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
263
264} /* end of create_mbx() */
265
266/*{{{ my_popen and my_pclose*/
267struct pipe_details
268{
269 struct pipe_details *next;
270 FILE *fp;
271 int pid;
272 unsigned long int completion;
273};
274
275static struct pipe_details *open_pipes = NULL;
276static $DESCRIPTOR(nl_desc, "NL:");
277static int waitpid_asleep = 0;
278
279static void
280popen_completion_ast(unsigned long int unused)
281{
282 if (waitpid_asleep) {
283 waitpid_asleep = 0;
284 sys$wake(0,0);
285 }
286}
287
288/*{{{ FILE *my_popen(char *cmd, char *mode)*/
289FILE *
290my_popen(char *cmd, char *mode)
291{
292 char mbxname[64];
293 unsigned short int chan;
294 unsigned long int flags=1; /* nowait - gnu c doesn't allow &1 */
295 struct pipe_details *info;
296 struct dsc$descriptor_s namdsc = {sizeof mbxname, DSC$K_DTYPE_T,
297 DSC$K_CLASS_S, mbxname},
298 cmddsc = {0, DSC$K_DTYPE_T,
299 DSC$K_CLASS_S, 0};
300
301
302 New(7001,info,1,struct pipe_details);
303
304 info->completion=0; /* I assume this will remain 0 until terminates */
305
306 /* create mailbox */
307 create_mbx(&chan,&namdsc);
308
309 /* open a FILE* onto it */
310 info->fp=fopen(mbxname, mode);
311
312 /* give up other channel onto it */
313 _cksts(sys$dassgn(chan));
314
315 if (!info->fp)
316 return Nullfp;
317
318 cmddsc.dsc$w_length=strlen(cmd);
319 cmddsc.dsc$a_pointer=cmd;
320
321 if (strcmp(mode,"r")==0) {
322 _cksts(lib$spawn(&cmddsc, &nl_desc, &namdsc, &flags,
323 0 /* name */, &info->pid, &info->completion,
324 0, popen_completion_ast,0,0,0,0));
325 }
326 else {
327 _cksts(lib$spawn(&cmddsc, &namdsc, 0 /* sys$output */,
328 0 /* name */, &info->pid, &info->completion));
329 }
330
331 info->next=open_pipes; /* prepend to list */
332 open_pipes=info;
333
334 return info->fp;
335}
336/*}}}*/
337
338/*{{{ I32 my_pclose(FILE *fp)*/
339I32 my_pclose(FILE *fp)
340{
341 struct pipe_details *info, *last = NULL;
342 unsigned long int abort = SS$_TIMEOUT, retsts;
343
344 for (info = open_pipes; info != NULL; last = info, info = info->next)
345 if (info->fp == fp) break;
346
347 if (info == NULL)
348 /* get here => no such pipe open */
349 croak("my_pclose() - no such pipe open ???");
350
351 if (!info->completion) { /* Tap them gently on the shoulder . . .*/
352 _cksts(sys$forcex(&info->pid,0,&abort));
353 sleep(1);
354 }
355 if (!info->completion) /* We tried to be nice . . . */
356 _cksts(sys$delprc(&info->pid));
357
358 fclose(info->fp);
359 /* remove from list of open pipes */
360 if (last) last->next = info->next;
361 else open_pipes = info->next;
362 retsts = info->completion;
363 Safefree(info);
364
365 return retsts;
366} /* end of my_pclose() */
367
368#ifndef HAS_WAITPID
369/* sort-of waitpid; use only with popen() */
370/*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
371unsigned long int
372waitpid(unsigned long int pid, int *statusp, int flags)
373{
374 struct pipe_details *info;
375 unsigned long int abort = SS$_TIMEOUT;
376
377 for (info = open_pipes; info != NULL; info = info->next)
378 if (info->pid == pid) break;
379
380 if (info != NULL) { /* we know about this child */
381 while (!info->completion) {
382 waitpid_asleep = 1;
383 sys$hiber();
384 }
385
386 *statusp = info->completion;
387 return pid;
388 }
389 else { /* we haven't heard of this child */
390 $DESCRIPTOR(intdsc,"0 00:00:01");
391 unsigned long int ownercode = JPI$_OWNER, ownerpid, mypid;
392 unsigned long int interval[2];
393
394 _cksts(lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0));
395 _cksts(lib$getjpi(&ownercode,0,0,&mypid,0,0));
396 if (ownerpid != mypid)
397 croak("pid %d not a child",pid);
398
399 _cksts(sys$bintim(&intdsc,interval));
400 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
401 _cksts(sys$schdwk(0,0,interval,0));
402 _cksts(sys$hiber());
403 }
404 _cksts(sts);
405
406 /* There's no easy way to find the termination status a child we're
407 * not aware of beforehand. If we're really interested in the future,
408 * we can go looking for a termination mailbox, or chase after the
409 * accounting record for the process.
410 */
411 *statusp = 0;
412 return pid;
413 }
414
415} /* end of waitpid() */
416#endif
417/*}}}*/
418/*}}}*/
419/*}}}*/
420
421/*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
422char *
423my_gconvert(double val, int ndig, int trail, char *buf)
424{
425 static char __gcvtbuf[DBL_DIG+1];
426 char *loc;
427
428 loc = buf ? buf : __gcvtbuf;
429 if (val) {
430 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
431 return gcvt(val,ndig,loc);
432 }
433 else {
434 loc[0] = '0'; loc[1] = '\0';
435 return loc;
436 }
437
438}
439/*}}}*/
440
441/*
442** The following routines are provided to make life easier when
443** converting among VMS-style and Unix-style directory specifications.
444** All will take input specifications in either VMS or Unix syntax. On
445** failure, all return NULL. If successful, the routines listed below
446** return a pointer to a static buffer containing the appropriately
447** reformatted spec (and, therefore, subsequent calls to that routine
448** will clobber the result), while the routines of the same names with
449** a _ts suffix appended will return a pointer to a mallocd string
450** containing the appropriately reformatted spec.
451** In all cases, only explicit syntax is altered; no check is made that
452** the resulting string is valid or that the directory in question
453** actually exists.
454**
455** fileify_dirspec() - convert a directory spec into the name of the
456** directory file (i.e. what you can stat() to see if it's a dir).
457** The style (VMS or Unix) of the result is the same as the style
458** of the parameter passed in.
459** pathify_dirspec() - convert a directory spec into a path (i.e.
460** what you prepend to a filename to indicate what directory it's in).
461** The style (VMS or Unix) of the result is the same as the style
462** of the parameter passed in.
463** tounixpath() - convert a directory spec into a Unix-style path.
464** tovmspath() - convert a directory spec into a VMS-style path.
465** tounixspec() - convert any file spec into a Unix-style file spec.
466** tovmsspec() - convert any file spec into a VMS-style spec.
467 */
468
469/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
470static char *do_fileify_dirspec(char *dir,char *buf,int ts)
471{
472 static char __fileify_retbuf[NAM$C_MAXRSS+1];
473 unsigned long int dirlen, retlen, addmfd = 0;
474 char *retspec, *cp1, *cp2, *lastdir;
475
476 if (dir == NULL) return NULL;
477
478 dirlen = strlen(dir);
479 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
480 if (dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
481 dirlen -= 1; /* to last element */
482 lastdir = strrchr(dir,'/');
483 }
484 else {
485 if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
486 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
487 if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
488 toupper(*(cp2+2)) == 'I' &&
489 toupper(*(cp2+3)) == 'R') {
490 if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
491 if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
492 errno = ENOTDIR; /* Bzzt. */
493 return NULL;
494 }
495 }
496 dirlen = cp2 - dir;
497 }
498 else { /* There's a type, and it's not .dir. Bzzt. */
499 errno = ENOTDIR;
500 return NULL;
501 }
502 }
503 /* If we lead off with a device or rooted logical, add the MFD
504 if we're specifying a top-level directory. */
505 if (lastdir && *dir == '/') {
506 addmfd = 1;
507 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
508 if (*cp1 == '/') {
509 addmfd = 0;
510 break;
511 }
512 }
513 }
514 retlen = dirlen + addmfd ? 13 : 6;
515 if (buf) retspec = buf;
516 else if (ts) New(7009,retspec,retlen+6,char);
517 else retspec = __fileify_retbuf;
518 if (addmfd) {
519 dirlen = lastdir - dir;
520 memcpy(retspec,dir,dirlen);
521 strcpy(&retspec[dirlen],"/000000");
522 strcpy(&retspec[dirlen+7],lastdir);
523 }
524 else {
525 memcpy(retspec,dir,dirlen);
526 retspec[dirlen] = '\0';
527 }
528 }
529 /* We've picked up everything up to the directory file name.
530 Now just add the type and version, and we're set. */
531 strcat(retspec,".dir;1");
532 return retspec;
533 }
534 else { /* VMS-style directory spec */
535 char esa[NAM$C_MAXRSS+1], term;
536 unsigned long int sts, cmplen;
537 struct FAB dirfab = cc$rms_fab;
538 struct NAM savnam, dirnam = cc$rms_nam;
539
540 dirfab.fab$b_fns = strlen(dir);
541 dirfab.fab$l_fna = dir;
542 dirfab.fab$l_nam = &dirnam;
543 dirnam.nam$b_ess = NAM$C_MAXRSS;
544 dirnam.nam$l_esa = esa;
545 dirnam.nam$b_nop = NAM$M_SYNCHK;
546 if (!(sys$parse(&dirfab)&1)) {
547 errno = EVMSERR;
548 vaxc$errno = dirfab.fab$l_sts;
549 return NULL;
550 }
551 savnam = dirnam;
552 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
553 /* Yes; fake the fnb bits so we'll check type below */
554 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
555 }
556 else {
557 if (dirfab.fab$l_sts != RMS$_FNF) {
558 errno = EVMSERR;
559 vaxc$errno = dirfab.fab$l_sts;
560 return NULL;
561 }
562 dirnam = savnam; /* No; just work with potential name */
563 }
564
565 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
566 /* Yep; check version while we're at it, if it's there. */
567 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
568 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
569 /* Something other than .DIR[;1]. Bzzt. */
570 errno = ENOTDIR;
571 return NULL;
572 }
573 else { /* Ok, it was .DIR[;1]; copy over everything up to the */
574 retlen = dirnam.nam$l_type - esa; /* file name. */
575 if (buf) retspec = buf;
576 else if (ts) New(7010,retspec,retlen+6,char);
577 else retspec = __fileify_retbuf;
578 strncpy(retspec,esa,retlen);
579 retspec[retlen] = '\0';
580 }
581 }
582 else {
583 /* They didn't explicitly specify the directory file. Ignore
584 any file names in the input, pull off the last element of the
585 directory path, and make it the file name. If you want to
586 pay attention to filenames without .dir in the input, just use
587 ".DIR;1" as a default filespec for the $PARSE */
588 esa[dirnam.nam$b_esl] = '\0';
589 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
590 if (cp1 == NULL) return NULL; /* should never happen */
591 term = *cp1;
592 *cp1 = '\0';
593 retlen = strlen(esa);
594 if ((cp1 = strrchr(esa,'.')) != NULL) {
595 /* There's more than one directory in the path. Just roll back. */
596 *cp1 = term;
597 if (buf) retspec = buf;
598 else if (ts) New(7011,retspec,retlen+6,char);
599 else retspec = __fileify_retbuf;
600 strcpy(retspec,esa);
601 }
602 else { /* This is a top-level dir. Add the MFD to the path. */
603 if (buf) retspec = buf;
604 else if (ts) New(7012,retspec,retlen+14,char);
605 else retspec = __fileify_retbuf;
606 cp1 = esa;
607 cp2 = retspec;
608 while (*cp1 != ':') *(cp2++) = *(cp1++);
609 strcpy(cp2,":[000000]");
610 cp1 += 2;
611 strcpy(cp2+9,cp1);
612 }
613 }
614 /* Again, we've set up the string up through the filename. Add the
615 type and version, and we're done. */
616 strcat(retspec,".DIR;1");
617 return retspec;
618 }
619} /* end of do_fileify_dirspec() */
620/*}}}*/
621/* External entry points */
622char *fileify_dirspec(char *dir, char *buf)
623{ return do_fileify_dirspec(dir,buf,0); }
624char *fileify_dirspec_ts(char *dir, char *buf)
625{ return do_fileify_dirspec(dir,buf,1); }
626
627/*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
628static char *do_pathify_dirspec(char *dir,char *buf, int ts)
629{
630 static char __pathify_retbuf[NAM$C_MAXRSS+1];
631 unsigned long int retlen;
632 char *retpath, *cp1, *cp2;
633
634 if (dir == NULL) return NULL;
635
636 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
637 if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
638 if (cp2 = strchr(cp1,'.')) {
639 if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
640 toupper(*(cp2+2)) == 'I' && /* Trim it off. */
641 toupper(*(cp2+3)) == 'R') {
642 retlen = cp2 - dir + 1;
643 }
644 else { /* Some other file type. Bzzt. */
645 errno = ENOTDIR;
646 return NULL;
647 }
648 }
649 else { /* No file type present. Treat the filename as a directory. */
650 retlen = strlen(dir) + 1;
651 }
652 if (buf) retpath = buf;
653 else if (ts) New(7013,retpath,retlen,char);
654 else retpath = __pathify_retbuf;
655 strncpy(retpath,dir,retlen-1);
656 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
657 retpath[retlen-1] = '/'; /* with '/', add it. */
658 retpath[retlen] = '\0';
659 }
660 else retpath[retlen-1] = '\0';
661 }
662 else { /* VMS-style directory spec */
663 char esa[NAM$C_MAXRSS+1];
664 unsigned long int sts, cmplen;
665 struct FAB dirfab = cc$rms_fab;
666 struct NAM savnam, dirnam = cc$rms_nam;
667
668 dirfab.fab$b_fns = strlen(dir);
669 dirfab.fab$l_fna = dir;
670 dirfab.fab$l_nam = &dirnam;
671 dirnam.nam$b_ess = sizeof esa;
672 dirnam.nam$l_esa = esa;
673 dirnam.nam$b_nop = NAM$M_SYNCHK;
674 if (!(sys$parse(&dirfab)&1)) {
675 errno = EVMSERR;
676 vaxc$errno = dirfab.fab$l_sts;
677 return NULL;
678 }
679 savnam = dirnam;
680 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
681 /* Yes; fake the fnb bits so we'll check type below */
682 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
683 }
684 else {
685 if (dirfab.fab$l_sts != RMS$_FNF) {
686 errno = EVMSERR;
687 vaxc$errno = dirfab.fab$l_sts;
688 return NULL;
689 }
690 dirnam = savnam; /* No; just work with potential name */
691 }
692
693 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
694 /* Yep; check version while we're at it, if it's there. */
695 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
696 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
697 /* Something other than .DIR[;1]. Bzzt. */
698 errno = ENOTDIR;
699 return NULL;
700 }
701 /* OK, the type was fine. Now pull any file name into the
702 directory path. */
703 if (cp1 = strrchr(esa,']')) *dirnam.nam$l_type = ']';
704 else {
705 cp1 = strrchr(esa,'>');
706 *dirnam.nam$l_type = '>';
707 }
708 *cp1 = '.';
709 *(dirnam.nam$l_type + 1) = '\0';
710 retlen = dirnam.nam$l_type - esa + 2;
711 }
712 else {
713 /* There wasn't a type on the input, so ignore any file names as
714 well. If you want to pay attention to filenames without .dir
715 in the input, just use ".DIR;1" as a default filespec for
716 the $PARSE and set retlen thus
717 retlen = (dirnam.nam$b_rsl ? dirnam.nam$b_rsl : dirnam.nam$b_esl);
718 */
719 retlen = dirnam.nam$l_name - esa;
720 esa[retlen] = '\0';
721 }
722 if (buf) retpath = buf;
723 else if (ts) New(7014,retpath,retlen,char);
724 else retpath = __pathify_retbuf;
725 strcpy(retpath,esa);
726 }
727
728 return retpath;
729} /* end of do_pathify_dirspec() */
730/*}}}*/
731/* External entry points */
732char *pathify_dirspec(char *dir, char *buf)
733{ return do_pathify_dirspec(dir,buf,0); }
734char *pathify_dirspec_ts(char *dir, char *buf)
735{ return do_pathify_dirspec(dir,buf,1); }
736
737/*{{{ char *tounixspec[_ts](char *path, char *buf)*/
738static char *do_tounixspec(char *spec, char *buf, int ts)
739{
740 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
741 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
742 int devlen, dirlen;
743
744 if (spec == NULL || *spec == '\0') return NULL;
745 if (buf) rslt = buf;
746 else if (ts) New(7015,rslt,NAM$C_MAXRSS+1,char);
747 else rslt = __tounixspec_retbuf;
748 if (strchr(spec,'/') != NULL) {
749 strcpy(rslt,spec);
750 return rslt;
751 }
752
753 cp1 = rslt;
754 cp2 = spec;
755 dirend = strrchr(spec,']');
756 if (dirend == NULL) dirend = strrchr(spec,'>');
757 if (dirend == NULL) dirend = strchr(spec,':');
758 if (dirend == NULL) {
759 strcpy(rslt,spec);
760 return rslt;
761 }
762 if (*cp2 != '[') {
763 *(cp1++) = '/';
764 }
765 else { /* the VMS spec begins with directories */
766 cp2++;
767 if (*cp2 == '-') {
768 while (*cp2 == '-') {
769 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
770 cp2++;
771 }
772 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
773 if (ts) Safefree(rslt); /* filespecs like */
774 errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */
775 return NULL;
776 }
777 cp2++;
778 }
779 else if ( *(cp2) != '.') { /* add the implied device into the Unix spec */
780 *(cp1++) = '/';
781 if (getcwd(tmp,sizeof tmp,1) == NULL) {
782 if (ts) Safefree(rslt);
783 return NULL;
784 }
785 do {
786 cp3 = tmp;
787 while (*cp3 != ':' && *cp3) cp3++;
788 *(cp3++) = '\0';
789 if (strchr(cp3,']') != NULL) break;
790 } while (((cp3 = getenv(tmp)) != NULL) && strcpy(tmp,cp3));
791 cp3 = tmp;
792 while (*cp3) *(cp1++) = *(cp3++);
793 *(cp1++) = '/';
794 if ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > NAM$C_MAXRSS) {
795 if (ts) Safefree(rslt);
796 errno = ERANGE;
797 return NULL;
798 }
799 }
800 else cp2++;
801 }
802 for (; cp2 <= dirend; cp2++) {
803 if (*cp2 == ':') {
804 *(cp1++) = '/';
805 if (*(cp2+1) == '[') cp2++;
806 }
807 else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
808 else if (*cp2 == '.') {
809 *(cp1++) = '/';
810 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
811 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
812 }
813 else if (*cp2 == '-') {
814 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
815 while (*cp2 == '-') {
816 cp2++;
817 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
818 }
819 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
820 if (ts) Safefree(rslt); /* filespecs like */
821 errno = EVMSERR; vaxc$errno = RMS$_SYN; /* [--foo.bar] */
822 return NULL;
823 }
824 cp2++;
825 }
826 else *(cp1++) = *cp2;
827 }
828 else *(cp1++) = *cp2;
829 }
830 while (*cp2) *(cp1++) = *(cp2++);
831 *cp1 = '\0';
832
833 return rslt;
834
835} /* end of do_tounixspec() */
836/*}}}*/
837/* External entry points */
838char *tounixspec(char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
839char *tounixspec_ts(char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
840
841/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
842static char *do_tovmsspec(char *path, char *buf, int ts) {
843 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
844 char *rslt, *dirend, *cp1, *cp2;
845
846 if (path == NULL || *path == '\0') return NULL;
847 if (buf) rslt = buf;
848 else if (ts) New(7016,rslt,strlen(path)+1,char);
849 else rslt = __tovmsspec_retbuf;
850 if (strchr(path,']') != NULL || strchr(path,'>') != NULL ||
851 (dirend = strrchr(path,'/')) == NULL) {
852 strcpy(rslt,path);
853 return rslt;
854 }
855 cp1 = rslt;
856 cp2 = path;
857 if (*cp2 == '/') {
858 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
859 *(cp1++) = ':';
860 *(cp1++) = '[';
861 cp2++;
862 }
863 else {
864 *(cp1++) = '[';
865 *(cp1++) = '.';
866 }
867 for (; cp2 < dirend; cp2++) *(cp1++) = (*cp2 == '/') ? '.' : *cp2;
868 *(cp1++) = ']';
869 cp2++;
870 while (*cp2) *(cp1++) = *(cp2++);
871 *cp1 = '\0';
872
873 return rslt;
874
875} /* end of do_tovmsspec() */
876/*}}}*/
877/* External entry points */
878char *tovmsspec(char *path, char *buf) { return do_tovmsspec(path,buf,0); }
879char *tovmsspec_ts(char *path, char *buf) { return do_tovmsspec(path,buf,1); }
880
881/*{{{ char *tovmspath[_ts](char *path, char *buf)*/
882static char *do_tovmspath(char *path, char *buf, int ts) {
883 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
884 int vmslen;
885 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
886
887 if (path == NULL || *path == '\0') return NULL;
888 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
889 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
890 if (buf) return buf;
891 else if (ts) {
892 vmslen = strlen(vmsified);
893 New(7017,cp,vmslen,char);
894 memcpy(cp,vmsified,vmslen);
895 cp[vmslen] = '\0';
896 return cp;
897 }
898 else {
899 strcpy(__tovmspath_retbuf,vmsified);
900 return __tovmspath_retbuf;
901 }
902
903} /* end of do_tovmspath() */
904/*}}}*/
905/* External entry points */
906char *tovmspath(char *path, char *buf) { return do_tovmspath(path,buf,0); }
907char *tovmspath_ts(char *path, char *buf) { return do_tovmspath(path,buf,1); }
908
909
910/*{{{ char *tounixpath[_ts](char *path, char *buf)*/
911static char *do_tounixpath(char *path, char *buf, int ts) {
912 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
913 int unixlen;
914 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
915
916 if (path == NULL || *path == '\0') return NULL;
917 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
918 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
919 if (buf) return buf;
920 else if (ts) {
921 unixlen = strlen(unixified);
922 New(7017,cp,unixlen,char);
923 memcpy(cp,unixified,unixlen);
924 cp[unixlen] = '\0';
925 return cp;
926 }
927 else {
928 strcpy(__tounixpath_retbuf,unixified);
929 return __tounixpath_retbuf;
930 }
931
932} /* end of do_tounixpath() */
933/*}}}*/
934/* External entry points */
935char *tounixpath(char *path, char *buf) { return do_tounixpath(path,buf,0); }
936char *tounixpath_ts(char *path, char *buf) { return do_tounixpath(path,buf,1); }
937
938/*
939 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
940 *
941 *****************************************************************************
942 * *
943 * Copyright (C) 1989-1994 by *
944 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
945 * *
946 * Permission is hereby granted for the reproduction of this software, *
947 * on condition that this copyright notice is included in the reproduction, *
948 * and that such reproduction is not for purposes of profit or material *
949 * gain. *
950 * *
951 * 27-Aug-1994 Modified for inclusion in perl5 *
952 * by Charles Bailey bailey@genetics.upenn.edu *
953 *****************************************************************************
954 */
955
956/*
957 * getredirection() is intended to aid in porting C programs
958 * to VMS (Vax-11 C). The native VMS environment does not support
959 * '>' and '<' I/O redirection, or command line wild card expansion,
960 * or a command line pipe mechanism using the '|' AND background
961 * command execution '&'. All of these capabilities are provided to any
962 * C program which calls this procedure as the first thing in the
963 * main program.
964 * The piping mechanism will probably work with almost any 'filter' type
965 * of program. With suitable modification, it may useful for other
966 * portability problems as well.
967 *
968 * Author: Mark Pizzolato mark@infocomm.com
969 */
970struct list_item
971 {
972 struct list_item *next;
973 char *value;
974 };
975
976static void add_item(struct list_item **head,
977 struct list_item **tail,
978 char *value,
979 int *count);
980
981static void expand_wild_cards(char *item,
982 struct list_item **head,
983 struct list_item **tail,
984 int *count);
985
986static int background_process(int argc, char **argv);
987
988static void pipe_and_fork(char **cmargv);
989
990/*{{{ void getredirection(int *ac, char ***av)*/
991void
992getredirection(int *ac, char ***av)
993/*
994 * Process vms redirection arg's. Exit if any error is seen.
995 * If getredirection() processes an argument, it is erased
996 * from the vector. getredirection() returns a new argc and argv value.
997 * In the event that a background command is requested (by a trailing "&"),
998 * this routine creates a background subprocess, and simply exits the program.
999 *
1000 * Warning: do not try to simplify the code for vms. The code
1001 * presupposes that getredirection() is called before any data is
1002 * read from stdin or written to stdout.
1003 *
1004 * Normal usage is as follows:
1005 *
1006 * main(argc, argv)
1007 * int argc;
1008 * char *argv[];
1009 * {
1010 * getredirection(&argc, &argv);
1011 * }
1012 */
1013{
1014 int argc = *ac; /* Argument Count */
1015 char **argv = *av; /* Argument Vector */
1016 char *ap; /* Argument pointer */
1017 int j; /* argv[] index */
1018 int item_count = 0; /* Count of Items in List */
1019 struct list_item *list_head = 0; /* First Item in List */
1020 struct list_item *list_tail; /* Last Item in List */
1021 char *in = NULL; /* Input File Name */
1022 char *out = NULL; /* Output File Name */
1023 char *outmode = "w"; /* Mode to Open Output File */
1024 char *err = NULL; /* Error File Name */
1025 char *errmode = "w"; /* Mode to Open Error File */
1026 int cmargc = 0; /* Piped Command Arg Count */
1027 char **cmargv = NULL;/* Piped Command Arg Vector */
1028 stat_t statbuf; /* fstat buffer */
1029
1030 /*
1031 * First handle the case where the last thing on the line ends with
1032 * a '&'. This indicates the desire for the command to be run in a
1033 * subprocess, so we satisfy that desire.
1034 */
1035 ap = argv[argc-1];
1036 if (0 == strcmp("&", ap))
1037 exit(background_process(--argc, argv));
1038 if ('&' == ap[strlen(ap)-1])
1039 {
1040 ap[strlen(ap)-1] = '\0';
1041 exit(background_process(argc, argv));
1042 }
1043 /*
1044 * Now we handle the general redirection cases that involve '>', '>>',
1045 * '<', and pipes '|'.
1046 */
1047 for (j = 0; j < argc; ++j)
1048 {
1049 if (0 == strcmp("<", argv[j]))
1050 {
1051 if (j+1 >= argc)
1052 {
1053 errno = EINVAL;
1054 croak("No input file");
1055 }
1056 in = argv[++j];
1057 continue;
1058 }
1059 if ('<' == *(ap = argv[j]))
1060 {
1061 in = 1 + ap;
1062 continue;
1063 }
1064 if (0 == strcmp(">", ap))
1065 {
1066 if (j+1 >= argc)
1067 {
1068 errno = EINVAL;
1069 croak("No input file");
1070 }
1071 out = argv[++j];
1072 continue;
1073 }
1074 if ('>' == *ap)
1075 {
1076 if ('>' == ap[1])
1077 {
1078 outmode = "a";
1079 if ('\0' == ap[2])
1080 out = argv[++j];
1081 else
1082 out = 2 + ap;
1083 }
1084 else
1085 out = 1 + ap;
1086 if (j >= argc)
1087 {
1088 errno = EINVAL;
1089 croak("No output file");
1090 }
1091 continue;
1092 }
1093 if (('2' == *ap) && ('>' == ap[1]))
1094 {
1095 if ('>' == ap[2])
1096 {
1097 errmode = "a";
1098 if ('\0' == ap[3])
1099 err = argv[++j];
1100 else
1101 err = 3 + ap;
1102 }
1103 else
1104 if ('\0' == ap[2])
1105 err = argv[++j];
1106 else
1107 err = 1 + ap;
1108 if (j >= argc)
1109 {
1110 errno = EINVAL;
1111 croak("No error file");
1112 }
1113 continue;
1114 }
1115 if (0 == strcmp("|", argv[j]))
1116 {
1117 if (j+1 >= argc)
1118 {
1119 errno = EPIPE;
1120 croak("No command into which to pipe");
1121 }
1122 cmargc = argc-(j+1);
1123 cmargv = &argv[j+1];
1124 argc = j;
1125 continue;
1126 }
1127 if ('|' == *(ap = argv[j]))
1128 {
1129 ++argv[j];
1130 cmargc = argc-j;
1131 cmargv = &argv[j];
1132 argc = j;
1133 continue;
1134 }
1135 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
1136 }
1137 /*
1138 * Allocate and fill in the new argument vector, Some Unix's terminate
1139 * the list with an extra null pointer.
1140 */
1141 New(7002, argv, item_count+1, char *);
1142 *av = argv;
1143 for (j = 0; j < item_count; ++j, list_head = list_head->next)
1144 argv[j] = list_head->value;
1145 *ac = item_count;
1146 if (cmargv != NULL)
1147 {
1148 if (out != NULL)
1149 {
1150 errno = EINVAL;
1151 croak("'|' and '>' may not both be specified on command line");
1152 }
1153 pipe_and_fork(cmargv);
1154 }
1155
1156 /* Check for input from a pipe (mailbox) */
1157
1158 if (1 == isapipe(0))
1159 {
1160 char mbxname[L_tmpnam];
1161 long int bufsize;
1162 long int dvi_item = DVI$_DEVBUFSIZ;
1163 $DESCRIPTOR(mbxnam, "");
1164 $DESCRIPTOR(mbxdevnam, "");
1165
1166 /* Input from a pipe, reopen it in binary mode to disable */
1167 /* carriage control processing. */
1168
1169 if (in != NULL)
1170 {
1171 errno = EINVAL;
1172 croak("'|' and '<' may not both be specified on command line");
1173 }
1174 fgetname(stdin, mbxname);
1175 mbxnam.dsc$a_pointer = mbxname;
1176 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
1177 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
1178 mbxdevnam.dsc$a_pointer = mbxname;
1179 mbxdevnam.dsc$w_length = sizeof(mbxname);
1180 dvi_item = DVI$_DEVNAM;
1181 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
1182 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
1183 errno = 0;
1184 freopen(mbxname, "rb", stdin);
1185 if (errno != 0)
1186 {
1187 croak("Error reopening pipe (name: %s) in binary mode",mbxname);
1188 }
1189 }
1190 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
1191 {
1192 croak("Can't open input file %s",in);
1193 }
1194 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
1195 {
1196 croak("Can't open output file %s",out);
1197 }
1198 if ((err != NULL) && (NULL == freopen(err, errmode, stderr, "mbc=32", "mbf=2")))
1199 {
1200 croak("Can't open error file %s",err);
1201 }
1202#ifdef ARGPROC_DEBUG
1203 fprintf(stderr, "Arglist:\n");
1204 for (j = 0; j < *ac; ++j)
1205 fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
1206#endif
1207} /* end of getredirection() */
1208/*}}}*/
1209
1210static void add_item(struct list_item **head,
1211 struct list_item **tail,
1212 char *value,
1213 int *count)
1214{
1215 if (*head == 0)
1216 {
1217 New(7003,*head,1,struct list_item);
1218 *tail = *head;
1219 }
1220 else {
1221 New(7004,(*tail)->next,1,struct list_item);
1222 *tail = (*tail)->next;
1223 }
1224 (*tail)->value = value;
1225 ++(*count);
1226}
1227
1228static void expand_wild_cards(char *item,
1229 struct list_item **head,
1230 struct list_item **tail,
1231 int *count)
1232{
1233int expcount = 0;
1234int context = 0;
1235int isunix = 0;
1236int status;
1237int status_value;
1238char *had_version;
1239char *had_device;
1240int had_directory;
1241char *devdir;
1242char vmsspec[NAM$C_MAXRSS+1];
1243$DESCRIPTOR(filespec, "");
1244$DESCRIPTOR(defaultspec, "SYS$DISK:[]*.*;");
1245$DESCRIPTOR(resultspec, "");
1246unsigned long int zero = 0;
1247
1248 if (strcspn(item, "*%") == strlen(item))
1249 {
1250 add_item(head, tail, item, count);
1251 return;
1252 }
1253 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
1254 resultspec.dsc$b_class = DSC$K_CLASS_D;
1255 resultspec.dsc$a_pointer = NULL;
1256 if (isunix = strchr(item,'/'))
1257 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
1258 if (!isunix || !filespec.dsc$a_pointer)
1259 filespec.dsc$a_pointer = item;
1260 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
1261 /*
1262 * Only return version specs, if the caller specified a version
1263 */
1264 had_version = strchr(item, ';');
1265 /*
1266 * Only return device and directory specs, if the caller specifed either.
1267 */
1268 had_device = strchr(item, ':');
1269 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
1270
1271 while (1 == (1&lib$find_file(&filespec, &resultspec, &context,
1272 &defaultspec, 0, &status_value, &zero)))
1273 {
1274 char *string;
1275 char *c;
1276
1277 New(7005,string,resultspec.dsc$w_length+1,char);
1278 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
1279 string[resultspec.dsc$w_length] = '\0';
1280 if (NULL == had_version)
1281 *((char *)strrchr(string, ';')) = '\0';
1282 if ((!had_directory) && (had_device == NULL))
1283 {
1284 if (NULL == (devdir = strrchr(string, ']')))
1285 devdir = strrchr(string, '>');
1286 strcpy(string, devdir + 1);
1287 }
1288 /*
1289 * Be consistent with what the C RTL has already done to the rest of
1290 * the argv items and lowercase all of these names.
1291 */
1292 for (c = string; *c; ++c)
1293 if (isupper(*c))
1294 *c = tolower(*c);
1295 if (isunix) trim_unixpath(item,string);
1296 add_item(head, tail, string, count);
1297 ++expcount;
1298 }
1299 if (expcount == 0)
1300 add_item(head, tail, item, count);
1301 lib$sfree1_dd(&resultspec);
1302 lib$find_file_end(&context);
1303}
1304
1305static int child_st[2];/* Event Flag set when child process completes */
1306
1307static short child_chan;/* I/O Channel for Pipe Mailbox */
1308
1309static exit_handler(int *status)
1310{
1311short iosb[4];
1312
1313 if (0 == child_st[0])
1314 {
1315#ifdef ARGPROC_DEBUG
1316 fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
1317#endif
1318 fflush(stdout); /* Have to flush pipe for binary data to */
1319 /* terminate properly -- <tp@mccall.com> */
1320 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
1321 sys$dassgn(child_chan);
1322 fclose(stdout);
1323 sys$synch(0, child_st);
1324 }
1325 return(1);
1326}
1327
1328static void sig_child(int chan)
1329{
1330#ifdef ARGPROC_DEBUG
1331 fprintf(stderr, "Child Completion AST\n");
1332#endif
1333 if (child_st[0] == 0)
1334 child_st[0] = 1;
1335}
1336
1337static struct exit_control_block
1338 {
1339 struct exit_control_block *flink;
1340 int (*exit_routine)();
1341 int arg_count;
1342 int *status_address;
1343 int exit_status;
1344 } exit_block =
1345 {
1346 0,
1347 exit_handler,
1348 1,
1349 &exit_block.exit_status,
1350 0
1351 };
1352
1353static void pipe_and_fork(char **cmargv)
1354{
1355 char subcmd[2048];
1356 $DESCRIPTOR(cmddsc, "");
1357 static char mbxname[64];
1358 $DESCRIPTOR(mbxdsc, mbxname);
1359 short iosb[4];
1360 int status;
1361 int pid, j;
1362 short dvi_item = DVI$_DEVNAM;
1363 unsigned long int zero = 0, one = 1;
1364
1365 strcpy(subcmd, cmargv[0]);
1366 for (j = 1; NULL != cmargv[j]; ++j)
1367 {
1368 strcat(subcmd, " \"");
1369 strcat(subcmd, cmargv[j]);
1370 strcat(subcmd, "\"");
1371 }
1372 cmddsc.dsc$a_pointer = subcmd;
1373 cmddsc.dsc$w_length = strlen(cmddsc.dsc$a_pointer);
1374
1375 create_mbx(&child_chan,&mbxdsc);
1376#ifdef ARGPROC_DEBUG
1377 fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
1378 fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
1379#endif
1380 if (0 == (1&(vaxc$errno = lib$spawn(&cmddsc, &mbxdsc, 0, &one,
1381 0, &pid, child_st, &zero, sig_child,
1382 &child_chan))))
1383 {
1384 errno = EVMSERR;
1385 croak("Can't spawn subprocess");
1386 }
1387#ifdef ARGPROC_DEBUG
1388 fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
1389#endif
1390 sys$dclexh(&exit_block);
1391 if (NULL == freopen(mbxname, "wb", stdout))
1392 {
1393 croak("Can't open pipe mailbox for output");
1394 }
1395}
1396
1397static int background_process(int argc, char **argv)
1398{
1399char command[2048] = "$";
1400$DESCRIPTOR(value, "");
1401static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
1402static $DESCRIPTOR(null, "NLA0:");
1403static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
1404char pidstring[80];
1405$DESCRIPTOR(pidstr, "");
1406int pid;
1407unsigned long int flags = 17, one = 1;
1408
1409 strcat(command, argv[0]);
1410 while (--argc)
1411 {
1412 strcat(command, " \"");
1413 strcat(command, *(++argv));
1414 strcat(command, "\"");
1415 }
1416 value.dsc$a_pointer = command;
1417 value.dsc$w_length = strlen(value.dsc$a_pointer);
1418 if (0 == (1&(vaxc$errno = lib$set_symbol(&cmd, &value))))
1419 {
1420 errno = EVMSERR;
1421 croak("Can't create symbol for subprocess command");
1422 }
1423 if ((0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &flags, 0, &pid)))) &&
1424 (vaxc$errno != 0x38250))
1425 {
1426 errno = EVMSERR;
1427 croak("Can't spawn subprocess");
1428 }
1429 if (vaxc$errno == 0x38250) /* We must be BATCH, so retry */
1430 if (0 == (1&(vaxc$errno = lib$spawn(&cmd, &null, 0, &one, 0, &pid))))
1431 {
1432 errno = EVMSERR;
1433 croak("Can't spawn subprocess");
1434 }
1435#ifdef ARGPROC_DEBUG
1436 fprintf(stderr, "%s\n", command);
1437#endif
1438 sprintf(pidstring, "%08X", pid);
1439 fprintf(stderr, "%s\n", pidstring);
1440 pidstr.dsc$a_pointer = pidstring;
1441 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
1442 lib$set_symbol(&pidsymbol, &pidstr);
1443 return(SS$_NORMAL);
1444}
1445/*}}}*/
1446/***** End of code taken from Mark Pizzolato's argproc.c package *****/
1447
1448/*
1449 * flex_stat, flex_fstat
1450 * basic stat, but gets it right when asked to stat
1451 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
1452 */
1453
1454static char namecache[NAM$C_MAXRSS+1];
1455
1456static int
1457is_null_device(name)
1458 const char *name;
1459{
1460 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
1461 The underscore prefix, controller letter, and unit number are
1462 independently optional; for our purposes, the colon punctuation
1463 is not. The colon can be trailed by optional directory and/or
1464 filename, but two consecutive colons indicates a nodename rather
1465 than a device. [pr] */
1466 if (*name == '_') ++name;
1467 if (tolower(*name++) != 'n') return 0;
1468 if (tolower(*name++) != 'l') return 0;
1469 if (tolower(*name) == 'a') ++name;
1470 if (*name == '0') ++name;
1471 return (*name++ == ':') && (*name != ':');
1472}
1473
1474/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
1475int
1476flex_fstat(int fd, struct stat *statbuf)
1477{
1478 char fspec[NAM$C_MAXRSS+1];
1479
1480 if (!getname(fd,fspec)) return -1;
1481 return flex_stat(fspec,statbuf);
1482
1483} /* end of flex_fstat() */
1484/*}}}*/
1485
1486/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
1487flex_stat(char *fspec, struct stat *statbufp)
1488{
1489 char fileified[NAM$C_MAXRSS+1];
1490 int retval,myretval;
1491 struct stat tmpbuf;
1492
1493
1494 if (statbufp == &statcache) strcpy(namecache,fspec);
1495 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
1496 memset(statbufp,0,sizeof *statbufp);
1497 statbufp->st_dev = "_NLA0:";
1498 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
1499 statbufp->st_uid = 0x00010001;
1500 statbufp->st_gid = 0x0001;
1501 time(&statbufp->st_mtime);
1502 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
1503 return 0;
1504 }
1505 if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
1506 else {
1507 myretval = stat(fileified,&tmpbuf);
1508 }
1509 retval = stat(fspec,statbufp);
1510 if (!myretval) {
1511 if (retval == -1) {
1512 *statbufp = tmpbuf;
1513 retval = 0;
1514 }
1515 else if (!retval) { /* Dir with same name. Substitute it. */
1516 statbufp->st_mode &= ~S_IFDIR;
1517 statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
1518 strcpy(namecache,fileified);
1519 }
1520 }
1521 return retval;
1522
1523} /* end of flex_stat() */
1524/*}}}*/
1525
1526/* trim_unixpath()
1527 * Trim Unix-style prefix off filespec, so it looks like what a shell
1528 * glob expansion would return (i.e. from specified prefix on, not
1529 * full path). Note that returned filespec is Unix-style, regardless
1530 * of whether input filespec was VMS-style or Unix-style.
1531 *
1532 * Returns !=0 on success, 0 on failure.
1533 */
1534/*{{{int trim_unixpath(char *template, char *fspec)*/
1535int
1536trim_unixpath(char *template, char *fspec)
1537{
1538 char unixified[NAM$C_MAXRSS+1], *base, *cp1, *cp2;
1539 register int tmplen;
1540
1541 if (strpbrk(fspec,"]>:") != NULL) {
1542 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
1543 else base = unixified;
1544 }
1545 else base = fspec;
1546 for (cp2 = base; *cp2; cp2++) ; /* Find end of filespec */
1547
1548 /* Find prefix to template consisting of path elements without wildcards */
1549 if ((cp1 = strpbrk(template,"*%?")) == NULL)
1550 for (cp1 = template; *cp1; cp1++) ;
1551 else while (cp1 >= template && *cp1 != '/') cp1--;
1552 if (cp1 == template) return 1; /* Wildcard was up front - no prefix to clip */
1553 tmplen = cp1 - template;
1554
1555 /* Try to find template prefix on filespec */
1556 if (!memcmp(base,template,tmplen)) return 1; /* Nothing before prefix - we're done */
1557 for (; cp2 - base > tmplen; base++) {
1558 if (*base != '/') continue;
1559 if (!memcmp(base + 1,template,tmplen)) break;
1560 }
1561 if (cp2 - base == tmplen) return 0; /* Not there - not good */
1562 base++; /* Move past leading '/' */
1563 /* Copy down remaining portion of filespec, including trailing NUL */
1564 memmove(fspec,base,cp2 - base + 1);
1565 return 1;
1566
1567} /* end of trim_unixpath() */
1568/*}}}*/
1569
1570/* Do the permissions allow some operation? Assumes statcache already set. */
1571/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
1572 * subset of the applicable information.
1573 */
1574/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
1575I32
1576cando(I32 bit, I32 effective, struct stat *statbufp)
1577{
1578 unsigned long int objtyp = ACL$C_FILE, access, retsts;
1579 unsigned short int retlen;
1580 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, namecache};
1581 static char usrname[L_cuserid];
1582 static struct dsc$descriptor_s usrdsc =
1583 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
1584 struct itmlst_3 armlst[2] = {sizeof access, CHP$_ACCESS, &access, &retlen,
1585 0, 0, 0, 0};
1586
1587 if (!usrdsc.dsc$w_length) {
1588 cuserid(usrname);
1589 usrdsc.dsc$w_length = strlen(usrname);
1590 }
1591 namdsc.dsc$w_length = strlen(namecache);
1592 switch (bit) {
1593 case S_IXUSR:
1594 case S_IXGRP:
1595 case S_IXOTH:
1596 access = ARM$M_EXECUTE;
1597 break;
1598 case S_IRUSR:
1599 case S_IRGRP:
1600 case S_IROTH:
1601 access = ARM$M_READ;
1602 break;
1603 case S_IWUSR:
1604 case S_IWGRP:
1605 case S_IWOTH:
1606 access = ARM$M_READ;
1607 break;
1608 default:
1609 return FALSE;
1610 }
1611
1612 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
1613 if (retsts == SS$_NORMAL) return TRUE;
1614 if (retsts == SS$_NOPRIV) return FALSE;
1615 _cksts(retsts);
1616
1617 return FALSE; /* Should never get here */
1618
1619} /* end of cando() */
1620/*}}}*/
1621
1622/*
1623 * VMS readdir() routines.
1624 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
1625 * This code has no copyright.
1626 *
1627 * 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
1628 * Minor modifications to original routines.
1629 */
1630
1631 /* Number of elements in vms_versions array */
1632#define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
1633
1634/*
1635 * Open a directory, return a handle for later use.
1636 */
1637/*{{{ DIR *opendir(char*name) */
1638DIR *
1639opendir(char *name)
1640{
1641 DIR *dd;
1642 char dir[NAM$C_MAXRSS+1];
1643
1644 /* Get memory for the handle, and the pattern. */
1645 New(7006,dd,1,DIR);
1646 if (do_tovmspath(name,dir,0) == NULL) {
1647 Safefree((char *)dd);
1648 return(NULL);
1649 }
1650 New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
1651
1652 /* Fill in the fields; mainly playing with the descriptor. */
1653 (void)sprintf(dd->pattern, "%s*.*",dir);
1654 dd->context = 0;
1655 dd->count = 0;
1656 dd->vms_wantversions = 0;
1657 dd->pat.dsc$a_pointer = dd->pattern;
1658 dd->pat.dsc$w_length = strlen(dd->pattern);
1659 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
1660 dd->pat.dsc$b_class = DSC$K_CLASS_S;
1661
1662 return dd;
1663} /* end of opendir() */
1664/*}}}*/
1665
1666/*
1667 * Set the flag to indicate we want versions or not.
1668 */
1669/*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
1670void
1671vmsreaddirversions(DIR *dd, int flag)
1672{
1673 dd->vms_wantversions = flag;
1674}
1675/*}}}*/
1676
1677/*
1678 * Free up an opened directory.
1679 */
1680/*{{{ void closedir(DIR *dd)*/
1681void
1682closedir(DIR *dd)
1683{
1684 (void)lib$find_file_end(&dd->context);
1685 Safefree(dd->pattern);
1686 Safefree((char *)dd);
1687}
1688/*}}}*/
1689
1690/*
1691 * Collect all the version numbers for the current file.
1692 */
1693static void
1694collectversions(dd)
1695 DIR *dd;
1696{
1697 struct dsc$descriptor_s pat;
1698 struct dsc$descriptor_s res;
1699 struct dirent *e;
1700 char *p, *text, buff[sizeof dd->entry.d_name];
1701 int i;
1702 unsigned long context, tmpsts;
1703
1704 /* Convenient shorthand. */
1705 e = &dd->entry;
1706
1707 /* Add the version wildcard, ignoring the "*.*" put on before */
1708 i = strlen(dd->pattern);
1709 New(7008,text,i + e->d_namlen + 3,char);
1710 (void)strcpy(text, dd->pattern);
1711 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
1712
1713 /* Set up the pattern descriptor. */
1714 pat.dsc$a_pointer = text;
1715 pat.dsc$w_length = i + e->d_namlen - 1;
1716 pat.dsc$b_dtype = DSC$K_DTYPE_T;
1717 pat.dsc$b_class = DSC$K_CLASS_S;
1718
1719 /* Set up result descriptor. */
1720 res.dsc$a_pointer = buff;
1721 res.dsc$w_length = sizeof buff - 2;
1722 res.dsc$b_dtype = DSC$K_DTYPE_T;
1723 res.dsc$b_class = DSC$K_CLASS_S;
1724
1725 /* Read files, collecting versions. */
1726 for (context = 0, e->vms_verscount = 0;
1727 e->vms_verscount < VERSIZE(e);
1728 e->vms_verscount++) {
1729 tmpsts = lib$find_file(&pat, &res, &context);
1730 if (tmpsts == RMS$_NMF || context == 0) break;
1731 _cksts(tmpsts);
1732 buff[sizeof buff - 1] = '\0';
1733 if (p = strchr(buff, ';'))
1734 e->vms_versions[e->vms_verscount] = atoi(p + 1);
1735 else
1736 e->vms_versions[e->vms_verscount] = -1;
1737 }
1738
1739 _cksts(lib$find_file_end(&context));
1740 Safefree(text);
1741
1742} /* end of collectversions() */
1743
1744/*
1745 * Read the next entry from the directory.
1746 */
1747/*{{{ struct dirent *readdir(DIR *dd)*/
1748struct dirent *
1749readdir(DIR *dd)
1750{
1751 struct dsc$descriptor_s res;
1752 char *p, buff[sizeof dd->entry.d_name];
1753 int i;
1754 unsigned long int tmpsts;
1755
1756 /* Set up result descriptor, and get next file. */
1757 res.dsc$a_pointer = buff;
1758 res.dsc$w_length = sizeof buff - 2;
1759 res.dsc$b_dtype = DSC$K_DTYPE_T;
1760 res.dsc$b_class = DSC$K_CLASS_S;
1761 dd->count++;
1762 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
1763 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
1764
1765 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
1766 buff[sizeof buff - 1] = '\0';
1767 for (p = buff; !isspace(*p); p++) *p = _tolower(*p);
1768 *p = '\0';
1769
1770 /* Skip any directory component and just copy the name. */
1771 if (p = strchr(buff, ']')) (void)strcpy(dd->entry.d_name, p + 1);
1772 else (void)strcpy(dd->entry.d_name, buff);
1773
1774 /* Clobber the version. */
1775 if (p = strchr(dd->entry.d_name, ';')) *p = '\0';
1776
1777 dd->entry.d_namlen = strlen(dd->entry.d_name);
1778 dd->entry.vms_verscount = 0;
1779 if (dd->vms_wantversions) collectversions(dd);
1780 return &dd->entry;
1781
1782} /* end of readdir() */
1783/*}}}*/
1784
1785/*
1786 * Return something that can be used in a seekdir later.
1787 */
1788/*{{{ long telldir(DIR *dd)*/
1789long
1790telldir(DIR *dd)
1791{
1792 return dd->count;
1793}
1794/*}}}*/
1795
1796/*
1797 * Return to a spot where we used to be. Brute force.
1798 */
1799/*{{{ void seekdir(DIR *dd,long count)*/
1800void
1801seekdir(DIR *dd, long count)
1802{
1803 int vms_wantversions;
1804 unsigned long int tmpsts;
1805
1806 /* If we haven't done anything yet... */
1807 if (dd->count == 0)
1808 return;
1809
1810 /* Remember some state, and clear it. */
1811 vms_wantversions = dd->vms_wantversions;
1812 dd->vms_wantversions = 0;
1813 _cksts(lib$find_file_end(&dd->context));
1814 dd->context = 0;
1815
1816 /* The increment is in readdir(). */
1817 for (dd->count = 0; dd->count < count; )
1818 (void)readdir(dd);
1819
1820 dd->vms_wantversions = vms_wantversions;
1821
1822} /* end of seekdir() */
1823/*}}}*/
1824
1825/* VMS subprocess management
1826 *
1827 * my_vfork() - just a vfork(), after setting a flag to record that
1828 * the current script is trying a Unix-style fork/exec.
1829 *
1830 * vms_do_aexec() and vms_do_exec() are called in response to the
1831 * perl 'exec' function. If this follows a vfork call, then they
1832 * call out the the regular perl routines in doio.c which do an
1833 * execvp (for those who really want to try this under VMS).
1834 * Otherwise, they do exactly what the perl docs say exec should
1835 * do - terminate the current script and invoke a new command
1836 * (See below for notes on command syntax.)
1837 *
1838 * do_aspawn() and do_spawn() implement the VMS side of the perl
1839 * 'system' function.
1840 *
1841 * Note on command arguments to perl 'exec' and 'system': When handled
1842 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
1843 * are concatenated to form a DCL command string. If the first arg
1844 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
1845 * the the command string is hrnded off to DCL directly. Otherwise,
1846 * the first token of the command is taken as the filespec of an image
1847 * to run. The filespec is expanded using a default type of '.EXE' and
1848 * the process defaults for device, directory, etc., and the resultant
1849 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
1850 * the command string as parameters. This is perhaps a bit compicated,
1851 * but I hope it will form a happy medium between what VMS folks expect
1852 * from lib$spawn and what Unix folks expect from exec.
1853 */
1854
1855static int vfork_called;
1856
1857/*{{{int my_vfork()*/
1858int
1859my_vfork()
1860{
1861 vfork_called = 1;
1862 return vfork();
1863}
1864/*}}}*/
1865
1866static void
1867setup_argstr(SV *really, SV **mark, SV **sp, char **argstr)
1868{
1869 char *tmps, *junk;
1870 register size_t cmdlen = 0;
1871 size_t rlen;
1872 register SV **idx;
1873
1874 idx = mark;
1875 if (really && *(tmps = SvPV(really,rlen))) {
1876 cmdlen += rlen + 1;
1877 idx++;
1878 }
1879
1880 for (idx++; idx <= sp; idx++) {
1881 if (*idx) {
1882 junk = SvPVx(*idx,rlen);
1883 cmdlen += rlen ? rlen + 1 : 0;
1884 }
1885 }
1886 New(401,*argstr,cmdlen, char);
1887
1888 if (*tmps) {
1889 strcpy(*argstr,tmps);
1890 mark++;
1891 }
1892 else **argstr = '\0';
1893 while (++mark <= sp) {
1894 if (*mark) {
1895 strcat(*argstr," ");
1896 strcat(*argstr,SvPVx(*mark,na));
1897 }
1898 }
1899
1900} /* end of setup_argstr() */
1901
1902static unsigned long int
1903setup_cmddsc(char *cmd, struct dsc$descriptor_s *cmddsc, int check_img)
1904{
1905 char resspec[NAM$C_MAXRSS+1];
1906 $DESCRIPTOR(defdsc,".EXE");
1907 $DESCRIPTOR(resdsc,resspec);
1908 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1909 unsigned long int cxt = 0, flags = 1, retsts;
1910 register char *s, *rest, *cp;
1911 register int isdcl = 0;
1912
1913 s = cmd;
1914 while (*s && isspace(*s)) s++;
1915 if (check_img) {
1916 if (*s == '$') { /* Check whether this is a DCL command: leading $ and */
1917 isdcl = 1; /* no dev/dir separators (i.e. not a foreign command) */
1918 for (cp = s; *cp && *cp != '/' && !isspace(*cp); cp++) {
1919 if (*cp == ':' || *cp == '[' || *cp == '<') {
1920 isdcl = 0;
1921 break;
1922 }
1923 }
1924 }
1925 }
1926 else isdcl = 1;
1927 if (isdcl) { /* It's a DCL command, just do it. */
1928 cmddsc->dsc$a_pointer = cmd;
1929 cmddsc->dsc$w_length = strlen(cmd);
1930 }
1931 else { /* assume first token is an image spec */
1932 cmd = s;
1933 while (*s && !isspace(*s)) s++;
1934 rest = *s ? s : 0;
1935 imgdsc.dsc$a_pointer = cmd;
1936 imgdsc.dsc$w_length = s - cmd;
1937 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
1938 if ((retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
1939 else {
1940 _cksts(retsts);
1941 _cksts(lib$find_file_end(&cxt));
1942 s = resspec;
1943 while (*s && !isspace(*s)) s++;
1944 *s = '\0';
1945 New(402,Cmd,6 + s - resspec + (rest ? strlen(rest) : 0),char);
1946 strcpy(Cmd,"$ MCR ");
1947 strcat(Cmd,resspec);
1948 if (rest) strcat(Cmd,rest);
1949 cmddsc->dsc$a_pointer = Cmd;
1950 cmddsc->dsc$w_length = strlen(Cmd);
1951 }
1952 }
1953
1954 return SS$_NORMAL;
1955} /* end of setup_cmddsc() */
1956
1957/* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
1958bool
1959vms_do_aexec(SV *really,SV **mark,SV **sp)
1960{
1961
1962 if (sp > mark) {
1963 if (vfork_called) { /* this follows a vfork - act Unixish */
1964 vfork_called = 0;
1965 do_aexec(really,mark,sp);
1966 }
1967 else { /* no vfork - act VMSish */
1968 setup_argstr(really,mark,sp,&Argv);
1969 return vms_do_exec(Argv);
1970 }
1971 }
1972
1973 return FALSE;
1974} /* end of vms_do_aexec() */
1975/*}}}*/
1976
1977/* {{{bool vms_do_exec(char *cmd) */
1978bool
1979vms_do_exec(char *cmd)
1980{
1981
1982 if (vfork_called) { /* this follows a vfork - act Unixish */
1983 vfork_called = 0;
1984 do_exec(cmd);
1985 }
1986 else { /* no vfork - act VMSish */
1987 struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1988
1989 if ((vaxc$errno = setup_cmddsc(cmd,&cmddsc,1)) & 1)
1990 vaxc$errno = lib$do_command(&cmddsc);
1991
1992 errno = EVMSERR;
1993 if (dowarn)
1994 warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
1995 do_execfree();
1996 }
1997
1998 return FALSE;
1999
2000} /* end of vms_do_exec() */
2001/*}}}*/
2002
2003unsigned long int do_spawn(char *);
2004
2005/* {{{ unsigned long int do_aspawn(SV *really,SV **mark,SV **sp) */
2006unsigned long int
2007do_aspawn(SV *really,SV **mark,SV **sp)
2008{
2009
2010 if (sp > mark) {
2011 setup_argstr(really,mark,sp,&Argv);
2012 return do_spawn(Argv);
2013 }
2014
2015 return SS$_ABORT;
2016} /* end of do_aspawn() */
2017/*}}}*/
2018
2019/* {{{unsigned long int do_spawn(char *cmd) */
2020unsigned long int
2021do_spawn(char *cmd)
2022{
2023 struct dsc$descriptor_s cmddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
2024 unsigned long int substs;
2025
2026 if ((substs = setup_cmddsc(cmd,&cmddsc,0)) & 1)
2027 _cksts(lib$spawn(&cmddsc,&nl_desc,0,0,0,&substs,0,0,0,0,0));
2028
2029 if (!(substs&1)) {
2030 vaxc$errno = substs;
2031 errno = EVMSERR;
2032 if (dowarn)
2033 warn("Can't exec \"%s\": %s", cmddsc.dsc$a_pointer, Strerror(errno));
2034 }
2035 return substs;
2036
2037} /* end of do_spawn() */
2038/*}}}*/
2039
2040/*
2041 * A simple fwrite replacement which outputs itmsz*nitm chars without
2042 * introducing record boundaries every itmsz chars.
2043 */
2044/*{{{ int my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)*/
2045int
2046my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
2047{
2048 register char *cp, *end;
2049
2050 end = (char *)src + itmsz * nitm;
2051
2052 while ((char *)src <= end) {
2053 for (cp = src; cp <= end; cp++) if (!*cp) break;
2054 if (fputs(src,dest) == EOF) return EOF;
2055 if (cp < end)
2056 if (fputc('\0',dest) == EOF) return EOF;
2057 src = cp + 1;
2058 }
2059
2060 return 1;
2061
2062} /* end of my_fwrite() */
2063/*}}}*/
2064
2065#ifndef VMS_DO_SOCKETS
2066/***** The following two routines are temporary, and should be removed,
2067 * along with the corresponding #defines in vmsish.h, when TCP/IP support
2068 * has been added to the VMS port of perl5. (The temporary hacks are
2069 * here now sho that pack can handle type N elements.)
2070 * - C. Bailey 16-Aug-1994
2071 *****/
2072
2073/*{{{ unsigned short int tmp_shortflip(unsigned short int val)*/
2074unsigned short int
2075tmp_shortflip(unsigned short int val)
2076{
2077 return val << 8 | val >> 8;
2078}
2079/*}}}*/
2080
2081/*{{{ unsigned long int tmp_longflip(unsigned long int val)*/
2082unsigned long int
2083tmp_longflip(unsigned long int val)
2084{
2085 unsigned long int scratch = val;
2086 unsigned char savbyte, *tmp;
2087
2088 tmp = (unsigned char *) &scratch;
2089 savbyte = tmp[0]; tmp[0] = tmp[3]; tmp[3] = savbyte;
2090 savbyte = tmp[1]; tmp[1] = tmp[2]; tmp[2] = savbyte;
2091
2092 return scratch;
2093}
2094/*}}}*/
2095#endif