3 * VMS-specific routines for perl5
6 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
7 * and Perl_cando by Craig Berry
8 * 29-Aug-2000 Charles Lane's piping improvements rolled in
9 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
18 #include <climsgdef.h>
28 #include <libclidef.h>
30 #include <lib$routines.h>
40 #include <str$routines.h>
45 /* Older versions of ssdef.h don't have these */
46 #ifndef SS$_INVFILFOROP
47 # define SS$_INVFILFOROP 3930
49 #ifndef SS$_NOSUCHOBJECT
50 # define SS$_NOSUCHOBJECT 2696
53 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
54 #define PERLIO_NOT_STDIO 0
56 /* Don't replace system definitions of vfork, getenv, and stat,
57 * code below needs to get to the underlying CRTL routines. */
58 #define DONT_MASK_RTL_CALLS
62 /* Anticipating future expansion in lexical warnings . . . */
64 # define WARN_INTERNAL WARN_MISC
67 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
68 # define RTL_USES_UTC 1
72 /* gcc's header files don't #define direct access macros
73 * corresponding to VAXC's variant structs */
75 # define uic$v_format uic$r_uic_form.uic$v_format
76 # define uic$v_group uic$r_uic_form.uic$v_group
77 # define uic$v_member uic$r_uic_form.uic$v_member
78 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
79 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
80 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
81 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
84 #if defined(NEED_AN_H_ERRNO)
89 unsigned short int buflen;
90 unsigned short int itmcode;
92 unsigned short int *retlen;
95 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
96 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
97 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
98 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
99 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
100 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
101 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
102 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
103 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
105 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
106 #define PERL_LNM_MAX_ALLOWED_INDEX 127
108 #define MAX_DCL_SYMBOL 255 /* well, what *we* can set, at least*/
109 #define MAX_DCL_LINE_LENGTH (4*MAX_DCL_SYMBOL-4)
111 static char *__mystrtolower(char *str)
113 if (str) for (; *str; ++str) *str= tolower(*str);
117 static struct dsc$descriptor_s fildevdsc =
118 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
119 static struct dsc$descriptor_s crtlenvdsc =
120 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
121 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
122 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
123 static struct dsc$descriptor_s **env_tables = defenv;
124 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
126 /* True if we shouldn't treat barewords as logicals during directory */
128 static int no_translate_barewords;
131 static int tz_updated = 1;
134 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
136 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
137 struct dsc$descriptor_s **tabvec, unsigned long int flags)
139 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
140 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
141 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
142 unsigned char acmode;
143 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
144 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
145 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
146 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
148 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
149 #if defined(PERL_IMPLICIT_CONTEXT)
151 # if defined(USE_5005THREADS)
152 /* We jump through these hoops because we can be called at */
153 /* platform-specific initialization time, which is before anything is */
154 /* set up--we can't even do a plain dTHX since that relies on the */
155 /* interpreter structure to be initialized */
157 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
163 aTHX = PERL_GET_INTERP;
171 if (!lnm || !eqv || idx > PERL_LNM_MAX_ALLOWED_INDEX) {
172 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
174 for (cp1 = (char *)lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
175 *cp2 = _toupper(*cp1);
176 if (cp1 - lnm > LNM$C_NAMLENGTH) {
177 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
181 lnmdsc.dsc$w_length = cp1 - lnm;
182 lnmdsc.dsc$a_pointer = uplnm;
183 uplnm[lnmdsc.dsc$w_length] = '\0';
184 secure = flags & PERL__TRNENV_SECURE;
185 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
186 if (!tabvec || !*tabvec) tabvec = env_tables;
188 for (curtab = 0; tabvec[curtab]; curtab++) {
189 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
190 if (!ivenv && !secure) {
195 Perl_warn(aTHX_ "Can't read CRTL environ\n");
198 retsts = SS$_NOLOGNAM;
199 for (i = 0; environ[i]; i++) {
200 if ((eq = strchr(environ[i],'=')) &&
201 !strncmp(environ[i],uplnm,eq - environ[i])) {
203 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
204 if (!eqvlen) continue;
209 if (retsts != SS$_NOLOGNAM) break;
212 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
213 !str$case_blind_compare(&tmpdsc,&clisym)) {
214 if (!ivsym && !secure) {
215 unsigned short int deflen = LNM$C_NAMLENGTH;
216 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
217 /* dynamic dsc to accomodate possible long value */
218 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
219 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
222 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
224 /* Special hack--we might be called before the interpreter's */
225 /* fully initialized, in which case either thr or PL_curcop */
226 /* might be bogus. We have to check, since ckWARN needs them */
227 /* both to be valid if running threaded */
228 #if defined(USE_5005THREADS)
229 if (thr && PL_curcop) {
231 if (ckWARN(WARN_MISC)) {
232 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
234 #if defined(USE_5005THREADS)
236 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
241 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
243 _ckvmssts(lib$sfree1_dd(&eqvdsc));
244 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
245 if (retsts == LIB$_NOSUCHSYM) continue;
250 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
251 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
252 if (retsts == SS$_NOLOGNAM) continue;
253 /* PPFs have a prefix */
256 *((int *)uplnm) == *((int *)"SYS$") &&
258 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
259 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
260 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
261 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
262 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
263 memcpy(eqv,eqv+4,eqvlen-4);
269 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
270 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
271 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
272 retsts == SS$_NOLOGNAM) {
273 set_errno(EINVAL); set_vaxc_errno(retsts);
275 else _ckvmssts(retsts);
277 } /* end of vmstrnenv */
280 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
281 /* Define as a function so we can access statics. */
282 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
284 return vmstrnenv(lnm,eqv,idx,fildev,
285 #ifdef SECURE_INTERNAL_GETENV
286 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
295 * Note: Uses Perl temp to store result so char * can be returned to
296 * caller; this pointer will be invalidated at next Perl statement
298 * We define this as a function rather than a macro in terms of my_getenv_len()
299 * so that it'll work when PL_curinterp is undefined (and we therefore can't
302 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
304 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
306 static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
307 char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2, *eqv;
308 unsigned long int idx = 0;
309 int trnsuccess, success, secure, saverr, savvmserr;
312 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
313 /* Set up a temporary buffer for the return value; Perl will
314 * clean it up at the next statement transition */
315 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
316 if (!tmpsv) return NULL;
319 else eqv = __my_getenv_eqv; /* Assume no interpreter ==> single thread */
320 for (cp1 = (char *) lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
321 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
322 getcwd(eqv,LNM$C_NAMLENGTH);
326 if ((cp2 = strchr(lnm,';')) != NULL) {
328 uplnm[cp2-lnm] = '\0';
329 idx = strtoul(cp2+1,NULL,0);
332 /* Impose security constraints only if tainting */
334 /* Impose security constraints only if tainting */
335 secure = PL_curinterp ? PL_tainting : will_taint;
336 saverr = errno; savvmserr = vaxc$errno;
339 success = vmstrnenv(lnm,eqv,idx,
340 secure ? fildev : NULL,
341 #ifdef SECURE_INTERNAL_GETENV
342 secure ? PERL__TRNENV_SECURE : 0
347 /* Discard NOLOGNAM on internal calls since we're often looking
348 * for an optional name, and this "error" often shows up as the
349 * (bogus) exit status for a die() call later on. */
350 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
351 return success ? eqv : Nullch;
354 } /* end of my_getenv() */
358 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
360 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
362 char *buf, *cp1, *cp2;
363 unsigned long idx = 0;
364 static char __my_getenv_len_eqv[LNM$C_NAMLENGTH+1];
365 int secure, saverr, savvmserr;
368 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
369 /* Set up a temporary buffer for the return value; Perl will
370 * clean it up at the next statement transition */
371 tmpsv = sv_2mortal(newSVpv("",LNM$C_NAMLENGTH+1));
372 if (!tmpsv) return NULL;
375 else buf = __my_getenv_len_eqv; /* Assume no interpreter ==> single thread */
376 for (cp1 = (char *)lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
377 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
378 getcwd(buf,LNM$C_NAMLENGTH);
383 if ((cp2 = strchr(lnm,';')) != NULL) {
386 idx = strtoul(cp2+1,NULL,0);
390 /* Impose security constraints only if tainting */
391 secure = PL_curinterp ? PL_tainting : will_taint;
392 saverr = errno; savvmserr = vaxc$errno;
395 *len = vmstrnenv(lnm,buf,idx,
396 secure ? fildev : NULL,
397 #ifdef SECURE_INTERNAL_GETENV
398 secure ? PERL__TRNENV_SECURE : 0
403 /* Discard NOLOGNAM on internal calls since we're often looking
404 * for an optional name, and this "error" often shows up as the
405 * (bogus) exit status for a die() call later on. */
406 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
407 return *len ? buf : Nullch;
410 } /* end of my_getenv_len() */
413 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
415 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
417 /*{{{ void prime_env_iter() */
420 /* Fill the %ENV associative array with all logical names we can
421 * find, in preparation for iterating over it.
424 static int primed = 0;
425 HV *seenhv = NULL, *envhv;
427 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
428 unsigned short int chan;
429 #ifndef CLI$M_TRUSTED
430 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
432 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
433 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
435 bool have_sym = FALSE, have_lnm = FALSE;
436 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
437 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
438 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
439 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
440 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
441 #if defined(PERL_IMPLICIT_CONTEXT)
444 #if defined(USE_5005THREADS) || defined(USE_ITHREADS)
445 static perl_mutex primenv_mutex;
446 MUTEX_INIT(&primenv_mutex);
449 #if defined(PERL_IMPLICIT_CONTEXT)
450 /* We jump through these hoops because we can be called at */
451 /* platform-specific initialization time, which is before anything is */
452 /* set up--we can't even do a plain dTHX since that relies on the */
453 /* interpreter structure to be initialized */
454 #if defined(USE_5005THREADS)
456 aTHX = PL_threadnum? THR : (struct perl_thread*)SvPVX(PL_thrsv);
462 aTHX = PERL_GET_INTERP;
469 if (primed || !PL_envgv) return;
470 MUTEX_LOCK(&primenv_mutex);
471 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
472 envhv = GvHVn(PL_envgv);
473 /* Perform a dummy fetch as an lval to insure that the hash table is
474 * set up. Otherwise, the hv_store() will turn into a nullop. */
475 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
477 for (i = 0; env_tables[i]; i++) {
478 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
479 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
480 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
482 if (have_sym || have_lnm) {
483 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
484 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
485 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
486 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
489 for (i--; i >= 0; i--) {
490 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
493 for (j = 0; environ[j]; j++) {
494 if (!(start = strchr(environ[j],'='))) {
495 if (ckWARN(WARN_INTERNAL))
496 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
500 sv = newSVpv(start,0);
502 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
507 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
508 !str$case_blind_compare(&tmpdsc,&clisym)) {
509 strcpy(cmd,"Show Symbol/Global *");
510 cmddsc.dsc$w_length = 20;
511 if (env_tables[i]->dsc$w_length == 12 &&
512 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
513 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
514 flags = defflags | CLI$M_NOLOGNAM;
517 strcpy(cmd,"Show Logical *");
518 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
519 strcat(cmd," /Table=");
520 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
521 cmddsc.dsc$w_length = strlen(cmd);
523 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
524 flags = defflags | CLI$M_NOCLISYM;
527 /* Create a new subprocess to execute each command, to exclude the
528 * remote possibility that someone could subvert a mbx or file used
529 * to write multiple commands to a single subprocess.
532 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
533 0,&riseandshine,0,0,&clidsc,&clitabdsc);
534 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
535 defflags &= ~CLI$M_TRUSTED;
536 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
538 if (!buf) New(1322,buf,mbxbufsiz + 1,char);
539 if (seenhv) SvREFCNT_dec(seenhv);
542 char *cp1, *cp2, *key;
543 unsigned long int sts, iosb[2], retlen, keylen;
546 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
547 if (sts & 1) sts = iosb[0] & 0xffff;
548 if (sts == SS$_ENDOFFILE) {
550 while (substs == 0) { sys$hiber(); wakect++;}
551 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
556 retlen = iosb[0] >> 16;
557 if (!retlen) continue; /* blank line */
559 if (iosb[1] != subpid) {
561 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
565 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
566 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
568 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
569 if (*cp1 == '(' || /* Logical name table name */
570 *cp1 == '=' /* Next eqv of searchlist */) continue;
571 if (*cp1 == '"') cp1++;
572 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
573 key = cp1; keylen = cp2 - cp1;
574 if (keylen && hv_exists(seenhv,key,keylen)) continue;
575 while (*cp2 && *cp2 != '=') cp2++;
576 while (*cp2 && *cp2 == '=') cp2++;
577 while (*cp2 && *cp2 == ' ') cp2++;
578 if (*cp2 == '"') { /* String translation; may embed "" */
579 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
580 cp2++; cp1--; /* Skip "" surrounding translation */
582 else { /* Numeric translation */
583 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
584 cp1--; /* stop on last non-space char */
586 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
587 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
590 PERL_HASH(hash,key,keylen);
591 sv = newSVpvn(cp2,cp1 - cp2 + 1);
593 hv_store(envhv,key,keylen,sv,hash);
594 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
596 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
597 /* get the PPFs for this process, not the subprocess */
598 char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
599 char eqv[LNM$C_NAMLENGTH+1];
601 for (i = 0; ppfs[i]; i++) {
602 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
603 sv = newSVpv(eqv,trnlen);
605 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
610 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
611 if (buf) Safefree(buf);
612 if (seenhv) SvREFCNT_dec(seenhv);
613 MUTEX_UNLOCK(&primenv_mutex);
616 } /* end of prime_env_iter */
620 /*{{{ int vmssetenv(char *lnm, char *eqv)*/
621 /* Define or delete an element in the same "environment" as
622 * vmstrnenv(). If an element is to be deleted, it's removed from
623 * the first place it's found. If it's to be set, it's set in the
624 * place designated by the first element of the table vector.
625 * Like setenv() returns 0 for success, non-zero on error.
628 Perl_vmssetenv(pTHX_ char *lnm, char *eqv, struct dsc$descriptor_s **tabvec)
630 char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
631 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
632 unsigned long int retsts, usermode = PSL$C_USER;
633 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
634 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
635 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
636 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
637 $DESCRIPTOR(local,"_LOCAL");
639 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
640 *cp2 = _toupper(*cp1);
641 if (cp1 - lnm > LNM$C_NAMLENGTH) {
642 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
646 lnmdsc.dsc$w_length = cp1 - lnm;
647 if (!tabvec || !*tabvec) tabvec = env_tables;
649 if (!eqv) { /* we're deleting n element */
650 for (curtab = 0; tabvec[curtab]; curtab++) {
651 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
653 for (i = 0; environ[i]; i++) { /* Iff it's an environ elt, reset */
654 if ((cp1 = strchr(environ[i],'=')) &&
655 !strncmp(environ[i],lnm,cp1 - environ[i])) {
657 return setenv(lnm,"",1) ? vaxc$errno : 0;
660 ivenv = 1; retsts = SS$_NOLOGNAM;
662 if (ckWARN(WARN_INTERNAL))
663 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
664 ivenv = 1; retsts = SS$_NOSUCHPGM;
670 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
671 !str$case_blind_compare(&tmpdsc,&clisym)) {
672 unsigned int symtype;
673 if (tabvec[curtab]->dsc$w_length == 12 &&
674 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
675 !str$case_blind_compare(&tmpdsc,&local))
676 symtype = LIB$K_CLI_LOCAL_SYM;
677 else symtype = LIB$K_CLI_GLOBAL_SYM;
678 retsts = lib$delete_symbol(&lnmdsc,&symtype);
679 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
680 if (retsts == LIB$_NOSUCHSYM) continue;
684 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
685 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
686 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
687 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
688 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
692 else { /* we're defining a value */
693 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
695 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
697 if (ckWARN(WARN_INTERNAL))
698 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
699 retsts = SS$_NOSUCHPGM;
703 eqvdsc.dsc$a_pointer = eqv;
704 eqvdsc.dsc$w_length = strlen(eqv);
705 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
706 !str$case_blind_compare(&tmpdsc,&clisym)) {
707 unsigned int symtype;
708 if (tabvec[0]->dsc$w_length == 12 &&
709 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
710 !str$case_blind_compare(&tmpdsc,&local))
711 symtype = LIB$K_CLI_LOCAL_SYM;
712 else symtype = LIB$K_CLI_GLOBAL_SYM;
713 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
716 if (!*eqv) eqvdsc.dsc$w_length = 1;
717 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
718 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH;
719 if (ckWARN(WARN_MISC)) {
720 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",lnm, LNM$C_NAMLENGTH);
723 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
729 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
730 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
731 set_errno(EVMSERR); break;
732 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
733 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
734 set_errno(EINVAL); break;
741 set_vaxc_errno(retsts);
742 return (int) retsts || 44; /* retsts should never be 0, but just in case */
745 /* We reset error values on success because Perl does an hv_fetch()
746 * before each hv_store(), and if the thing we're setting didn't
747 * previously exist, we've got a leftover error message. (Of course,
748 * this fails in the face of
749 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
750 * in that the error reported in $! isn't spurious,
751 * but it's right more often than not.)
753 set_errno(0); set_vaxc_errno(retsts);
757 } /* end of vmssetenv() */
760 /*{{{ void my_setenv(char *lnm, char *eqv)*/
761 /* This has to be a function since there's a prototype for it in proto.h */
763 Perl_my_setenv(pTHX_ char *lnm,char *eqv)
766 int len = strlen(lnm);
770 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
771 if (!strcmp(uplnm,"DEFAULT")) {
772 if (eqv && *eqv) chdir(eqv);
777 if (len == 6 || len == 2) {
780 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
782 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
783 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
787 (void) vmssetenv(lnm,eqv,NULL);
791 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
793 * sets a user-mode logical in the process logical name table
794 * used for redirection of sys$error
797 Perl_vmssetuserlnm(pTHX_ char *name, char *eqv)
799 $DESCRIPTOR(d_tab, "LNM$PROCESS");
800 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
801 unsigned long int iss, attr = LNM$M_CONFINE;
802 unsigned char acmode = PSL$C_USER;
803 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
805 d_name.dsc$a_pointer = name;
806 d_name.dsc$w_length = strlen(name);
808 lnmlst[0].buflen = strlen(eqv);
809 lnmlst[0].bufadr = eqv;
811 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
812 if (!(iss&1)) lib$signal(iss);
817 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
818 /* my_crypt - VMS password hashing
819 * my_crypt() provides an interface compatible with the Unix crypt()
820 * C library function, and uses sys$hash_password() to perform VMS
821 * password hashing. The quadword hashed password value is returned
822 * as a NUL-terminated 8 character string. my_crypt() does not change
823 * the case of its string arguments; in order to match the behavior
824 * of LOGINOUT et al., alphabetic characters in both arguments must
825 * be upcased by the caller.
828 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
830 # ifndef UAI$C_PREFERRED_ALGORITHM
831 # define UAI$C_PREFERRED_ALGORITHM 127
833 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
834 unsigned short int salt = 0;
835 unsigned long int sts;
837 unsigned short int dsc$w_length;
838 unsigned char dsc$b_type;
839 unsigned char dsc$b_class;
840 const char * dsc$a_pointer;
841 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
842 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
843 struct itmlst_3 uailst[3] = {
844 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
845 { sizeof salt, UAI$_SALT, &salt, 0},
846 { 0, 0, NULL, NULL}};
849 usrdsc.dsc$w_length = strlen(usrname);
850 usrdsc.dsc$a_pointer = usrname;
851 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
853 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
857 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
863 if (sts != RMS$_RNF) return NULL;
866 txtdsc.dsc$w_length = strlen(textpasswd);
867 txtdsc.dsc$a_pointer = textpasswd;
868 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
869 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
872 return (char *) hash;
874 } /* end of my_crypt() */
878 static char *mp_do_rmsexpand(pTHX_ char *, char *, int, char *, unsigned);
879 static char *mp_do_fileify_dirspec(pTHX_ char *, char *, int);
880 static char *mp_do_tovmsspec(pTHX_ char *, char *, int);
882 /*{{{int do_rmdir(char *name)*/
884 Perl_do_rmdir(pTHX_ char *name)
886 char dirfile[NAM$C_MAXRSS+1];
890 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
891 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
892 else retval = kill_file(dirfile);
895 } /* end of do_rmdir */
899 * Delete any file to which user has control access, regardless of whether
900 * delete access is explicitly allowed.
901 * Limitations: User must have write access to parent directory.
902 * Does not block signals or ASTs; if interrupted in midstream
903 * may leave file with an altered ACL.
906 /*{{{int kill_file(char *name)*/
908 Perl_kill_file(pTHX_ char *name)
910 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
911 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
912 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
913 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
915 unsigned char myace$b_length;
916 unsigned char myace$b_type;
917 unsigned short int myace$w_flags;
918 unsigned long int myace$l_access;
919 unsigned long int myace$l_ident;
920 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
921 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
922 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
924 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
925 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
926 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
927 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
928 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
929 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
931 /* Expand the input spec using RMS, since the CRTL remove() and
932 * system services won't do this by themselves, so we may miss
933 * a file "hiding" behind a logical name or search list. */
934 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
935 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
936 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
937 /* If not, can changing protections help? */
938 if (vaxc$errno != RMS$_PRV) return -1;
940 /* No, so we get our own UIC to use as a rights identifier,
941 * and the insert an ACE at the head of the ACL which allows us
942 * to delete the file.
944 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
945 fildsc.dsc$w_length = strlen(rspec);
946 fildsc.dsc$a_pointer = rspec;
948 newace.myace$l_ident = oldace.myace$l_ident;
949 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
951 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
952 set_errno(ENOENT); break;
954 set_errno(ENOTDIR); break;
956 set_errno(ENODEV); break;
957 case RMS$_SYN: case SS$_INVFILFOROP:
958 set_errno(EINVAL); break;
960 set_errno(EACCES); break;
964 set_vaxc_errno(aclsts);
967 /* Grab any existing ACEs with this identifier in case we fail */
968 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
969 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
970 || fndsts == SS$_NOMOREACE ) {
971 /* Add the new ACE . . . */
972 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
974 if ((rmsts = remove(name))) {
975 /* We blew it - dir with files in it, no write priv for
976 * parent directory, etc. Put things back the way they were. */
977 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
980 addlst[0].bufadr = &oldace;
981 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
988 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
989 /* We just deleted it, so of course it's not there. Some versions of
990 * VMS seem to return success on the unlock operation anyhow (after all
991 * the unlock is successful), but others don't.
993 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
994 if (aclsts & 1) aclsts = fndsts;
997 set_vaxc_errno(aclsts);
1003 } /* end of kill_file() */
1007 /*{{{int my_mkdir(char *,Mode_t)*/
1009 Perl_my_mkdir(pTHX_ char *dir, Mode_t mode)
1011 STRLEN dirlen = strlen(dir);
1013 /* zero length string sometimes gives ACCVIO */
1014 if (dirlen == 0) return -1;
1016 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1017 * null file name/type. However, it's commonplace under Unix,
1018 * so we'll allow it for a gain in portability.
1020 if (dir[dirlen-1] == '/') {
1021 char *newdir = savepvn(dir,dirlen-1);
1022 int ret = mkdir(newdir,mode);
1026 else return mkdir(dir,mode);
1027 } /* end of my_mkdir */
1030 /*{{{int my_chdir(char *)*/
1032 Perl_my_chdir(pTHX_ char *dir)
1034 STRLEN dirlen = strlen(dir);
1036 /* zero length string sometimes gives ACCVIO */
1037 if (dirlen == 0) return -1;
1039 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1041 * null file name/type. However, it's commonplace under Unix,
1042 * so we'll allow it for a gain in portability.
1044 if (dir[dirlen-1] == '/') {
1045 char *newdir = savepvn(dir,dirlen-1);
1046 int ret = chdir(newdir);
1050 else return chdir(dir);
1051 } /* end of my_chdir */
1055 /*{{{FILE *my_tmpfile()*/
1062 if ((fp = tmpfile())) return fp;
1064 New(1323,cp,L_tmpnam+24,char);
1065 strcpy(cp,"Sys$Scratch:");
1066 tmpnam(cp+strlen(cp));
1067 strcat(cp,".Perltmp");
1068 fp = fopen(cp,"w+","fop=dlt");
1075 #ifndef HOMEGROWN_POSIX_SIGNALS
1077 * The C RTL's sigaction fails to check for invalid signal numbers so we
1078 * help it out a bit. The docs are correct, but the actual routine doesn't
1079 * do what the docs say it will.
1081 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1083 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1084 struct sigaction* oact)
1086 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1087 SETERRNO(EINVAL, SS$_INVARG);
1090 return sigaction(sig, act, oact);
1095 #ifdef KILL_BY_SIGPRC
1096 #include <errnodef.h>
1098 /* We implement our own kill() using the undocumented system service
1099 sys$sigprc for one of two reasons:
1101 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1102 target process to do a sys$exit, which usually can't be handled
1103 gracefully...certainly not by Perl and the %SIG{} mechanism.
1105 2.) If the kill() in the CRTL can't be called from a signal
1106 handler without disappearing into the ether, i.e., the signal
1107 it purportedly sends is never trapped. Still true as of VMS 7.3.
1109 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1110 in the target process rather than calling sys$exit.
1112 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1113 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1114 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1115 with condition codes C$_SIG0+nsig*8, catching the exception on the
1116 target process and resignaling with appropriate arguments.
1118 But we don't have that VMS 7.0+ exception handler, so if you
1119 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1121 Also note that SIGTERM is listed in the docs as being "unimplemented",
1122 yet always seems to be signaled with a VMS condition code of 4 (and
1123 correctly handled for that code). So we hardwire it in.
1125 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1126 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1127 than signalling with an unrecognized (and unhandled by CRTL) code.
1130 #define _MY_SIG_MAX 17
1133 Perl_sig_to_vmscondition(int sig)
1135 static unsigned int sig_code[_MY_SIG_MAX+1] =
1138 SS$_HANGUP, /* 1 SIGHUP */
1139 SS$_CONTROLC, /* 2 SIGINT */
1140 SS$_CONTROLY, /* 3 SIGQUIT */
1141 SS$_RADRMOD, /* 4 SIGILL */
1142 SS$_BREAK, /* 5 SIGTRAP */
1143 SS$_OPCCUS, /* 6 SIGABRT */
1144 SS$_COMPAT, /* 7 SIGEMT */
1146 SS$_FLTOVF, /* 8 SIGFPE VAX */
1148 SS$_HPARITH, /* 8 SIGFPE AXP */
1150 SS$_ABORT, /* 9 SIGKILL */
1151 SS$_ACCVIO, /* 10 SIGBUS */
1152 SS$_ACCVIO, /* 11 SIGSEGV */
1153 SS$_BADPARAM, /* 12 SIGSYS */
1154 SS$_NOMBX, /* 13 SIGPIPE */
1155 SS$_ASTFLT, /* 14 SIGALRM */
1161 #if __VMS_VER >= 60200000
1162 static int initted = 0;
1165 sig_code[16] = C$_SIGUSR1;
1166 sig_code[17] = C$_SIGUSR2;
1170 if (sig < _SIG_MIN) return 0;
1171 if (sig > _MY_SIG_MAX) return 0;
1172 return sig_code[sig];
1177 Perl_my_kill(int pid, int sig)
1182 int sys$sigprc(unsigned int *pidadr,
1183 struct dsc$descriptor_s *prcname,
1186 code = Perl_sig_to_vmscondition(sig);
1188 if (!pid || !code) {
1192 iss = sys$sigprc((unsigned int *)&pid,0,code);
1193 if (iss&1) return 0;
1197 set_errno(EPERM); break;
1199 case SS$_NOSUCHNODE:
1200 case SS$_UNREACHABLE:
1201 set_errno(ESRCH); break;
1203 set_errno(ENOMEM); break;
1208 set_vaxc_errno(iss);
1214 /* default piping mailbox size */
1215 #define PERL_BUFSIZ 512
1219 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
1221 unsigned long int mbxbufsiz;
1222 static unsigned long int syssize = 0;
1223 unsigned long int dviitm = DVI$_DEVNAM;
1224 char csize[LNM$C_NAMLENGTH+1];
1227 unsigned long syiitm = SYI$_MAXBUF;
1229 * Get the SYSGEN parameter MAXBUF
1231 * If the logical 'PERL_MBX_SIZE' is defined
1232 * use the value of the logical instead of PERL_BUFSIZ, but
1233 * keep the size between 128 and MAXBUF.
1236 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
1239 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
1240 mbxbufsiz = atoi(csize);
1242 mbxbufsiz = PERL_BUFSIZ;
1244 if (mbxbufsiz < 128) mbxbufsiz = 128;
1245 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
1247 _ckvmssts(sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
1249 _ckvmssts(lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
1250 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
1252 } /* end of create_mbx() */
1255 /*{{{ my_popen and my_pclose*/
1257 typedef struct _iosb IOSB;
1258 typedef struct _iosb* pIOSB;
1259 typedef struct _pipe Pipe;
1260 typedef struct _pipe* pPipe;
1261 typedef struct pipe_details Info;
1262 typedef struct pipe_details* pInfo;
1263 typedef struct _srqp RQE;
1264 typedef struct _srqp* pRQE;
1265 typedef struct _tochildbuf CBuf;
1266 typedef struct _tochildbuf* pCBuf;
1269 unsigned short status;
1270 unsigned short count;
1271 unsigned long dvispec;
1274 #pragma member_alignment save
1275 #pragma nomember_alignment quadword
1276 struct _srqp { /* VMS self-relative queue entry */
1277 unsigned long qptr[2];
1279 #pragma member_alignment restore
1280 static RQE RQE_ZERO = {0,0};
1282 struct _tochildbuf {
1285 unsigned short size;
1293 unsigned short chan_in;
1294 unsigned short chan_out;
1296 unsigned int bufsize;
1308 #if defined(PERL_IMPLICIT_CONTEXT)
1309 void *thx; /* Either a thread or an interpreter */
1310 /* pointer, depending on how we're built */
1318 PerlIO *fp; /* file pointer to pipe mailbox */
1319 int useFILE; /* using stdio, not perlio */
1320 int pid; /* PID of subprocess */
1321 int mode; /* == 'r' if pipe open for reading */
1322 int done; /* subprocess has completed */
1323 int waiting; /* waiting for completion/closure */
1324 int closing; /* my_pclose is closing this pipe */
1325 unsigned long completion; /* termination status of subprocess */
1326 pPipe in; /* pipe in to sub */
1327 pPipe out; /* pipe out of sub */
1328 pPipe err; /* pipe of sub's sys$error */
1329 int in_done; /* true when in pipe finished */
1334 struct exit_control_block
1336 struct exit_control_block *flink;
1337 unsigned long int (*exit_routine)();
1338 unsigned long int arg_count;
1339 unsigned long int *status_address;
1340 unsigned long int exit_status;
1343 typedef struct _closed_pipes Xpipe;
1344 typedef struct _closed_pipes* pXpipe;
1346 struct _closed_pipes {
1347 int pid; /* PID of subprocess */
1348 unsigned long completion; /* termination status of subprocess */
1350 #define NKEEPCLOSED 50
1351 static Xpipe closed_list[NKEEPCLOSED];
1352 static int closed_index = 0;
1353 static int closed_num = 0;
1355 #define RETRY_DELAY "0 ::0.20"
1356 #define MAX_RETRY 50
1358 static int pipe_ef = 0; /* first call to safe_popen inits these*/
1359 static unsigned long mypid;
1360 static unsigned long delaytime[2];
1362 static pInfo open_pipes = NULL;
1363 static $DESCRIPTOR(nl_desc, "NL:");
1365 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
1369 static unsigned long int
1370 pipe_exit_routine(pTHX)
1373 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
1374 int sts, did_stuff, need_eof, j;
1377 flush any pending i/o
1383 PerlIO_flush(info->fp); /* first, flush data */
1385 fflush((FILE *)info->fp);
1391 next we try sending an EOF...ignore if doesn't work, make sure we
1399 _ckvmssts(sys$setast(0));
1400 if (info->in && !info->in->shut_on_empty) {
1401 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
1406 _ckvmssts(sys$setast(1));
1410 /* wait for EOF to have effect, up to ~ 30 sec [default] */
1412 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1417 _ckvmssts(sys$setast(0));
1418 if (info->waiting && info->done)
1420 nwait += info->waiting;
1421 _ckvmssts(sys$setast(1));
1431 _ckvmssts(sys$setast(0));
1432 if (!info->done) { /* Tap them gently on the shoulder . . .*/
1433 sts = sys$forcex(&info->pid,0,&abort);
1434 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1437 _ckvmssts(sys$setast(1));
1441 /* again, wait for effect */
1443 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
1448 _ckvmssts(sys$setast(0));
1449 if (info->waiting && info->done)
1451 nwait += info->waiting;
1452 _ckvmssts(sys$setast(1));
1461 _ckvmssts(sys$setast(0));
1462 if (!info->done) { /* We tried to be nice . . . */
1463 sts = sys$delprc(&info->pid,0);
1464 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts(sts);
1466 _ckvmssts(sys$setast(1));
1471 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
1472 else if (!(sts & 1)) retsts = sts;
1477 static struct exit_control_block pipe_exitblock =
1478 {(struct exit_control_block *) 0,
1479 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
1481 static void pipe_mbxtofd_ast(pPipe p);
1482 static void pipe_tochild1_ast(pPipe p);
1483 static void pipe_tochild2_ast(pPipe p);
1486 popen_completion_ast(pInfo info)
1488 pInfo i = open_pipes;
1492 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
1493 closed_list[closed_index].pid = info->pid;
1494 closed_list[closed_index].completion = info->completion;
1496 if (closed_index == NKEEPCLOSED)
1501 if (i == info) break;
1504 if (!i) return; /* unlinked, probably freed too */
1509 Writing to subprocess ...
1510 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
1512 chan_out may be waiting for "done" flag, or hung waiting
1513 for i/o completion to child...cancel the i/o. This will
1514 put it into "snarf mode" (done but no EOF yet) that discards
1517 Output from subprocess (stdout, stderr) needs to be flushed and
1518 shut down. We try sending an EOF, but if the mbx is full the pipe
1519 routine should still catch the "shut_on_empty" flag, telling it to
1520 use immediate-style reads so that "mbx empty" -> EOF.
1524 if (info->in && !info->in_done) { /* only for mode=w */
1525 if (info->in->shut_on_empty && info->in->need_wake) {
1526 info->in->need_wake = FALSE;
1527 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
1529 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
1533 if (info->out && !info->out_done) { /* were we also piping output? */
1534 info->out->shut_on_empty = TRUE;
1535 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1536 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1537 _ckvmssts_noperl(iss);
1540 if (info->err && !info->err_done) { /* we were piping stderr */
1541 info->err->shut_on_empty = TRUE;
1542 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
1543 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
1544 _ckvmssts_noperl(iss);
1546 _ckvmssts_noperl(sys$setef(pipe_ef));
1550 static unsigned long int setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
1551 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
1554 we actually differ from vmstrnenv since we use this to
1555 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
1556 are pointing to the same thing
1559 static unsigned short
1560 popen_translate(pTHX_ char *logical, char *result)
1563 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
1564 $DESCRIPTOR(d_log,"");
1566 unsigned short length;
1567 unsigned short code;
1569 unsigned short *retlenaddr;
1571 unsigned short l, ifi;
1573 d_log.dsc$a_pointer = logical;
1574 d_log.dsc$w_length = strlen(logical);
1576 itmlst[0].code = LNM$_STRING;
1577 itmlst[0].length = 255;
1578 itmlst[0].buffer_addr = result;
1579 itmlst[0].retlenaddr = &l;
1582 itmlst[1].length = 0;
1583 itmlst[1].buffer_addr = 0;
1584 itmlst[1].retlenaddr = 0;
1586 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
1587 if (iss == SS$_NOLOGNAM) {
1591 if (!(iss&1)) lib$signal(iss);
1594 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
1595 strip it off and return the ifi, if any
1598 if (result[0] == 0x1b && result[1] == 0x00) {
1599 memcpy(&ifi,result+2,2);
1600 strcpy(result,result+4);
1602 return ifi; /* this is the RMS internal file id */
1605 static void pipe_infromchild_ast(pPipe p);
1608 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
1609 inside an AST routine without worrying about reentrancy and which Perl
1610 memory allocator is being used.
1612 We read data and queue up the buffers, then spit them out one at a
1613 time to the output mailbox when the output mailbox is ready for one.
1616 #define INITIAL_TOCHILDQUEUE 2
1619 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
1623 char mbx1[64], mbx2[64];
1624 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1625 DSC$K_CLASS_S, mbx1},
1626 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1627 DSC$K_CLASS_S, mbx2};
1628 unsigned int dviitm = DVI$_DEVBUFSIZ;
1631 New(1368, p, 1, Pipe);
1633 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1634 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1635 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1638 p->shut_on_empty = FALSE;
1639 p->need_wake = FALSE;
1642 p->iosb.status = SS$_NORMAL;
1643 p->iosb2.status = SS$_NORMAL;
1649 #ifdef PERL_IMPLICIT_CONTEXT
1653 n = sizeof(CBuf) + p->bufsize;
1655 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
1656 _ckvmssts(lib$get_vm(&n, &b));
1657 b->buf = (char *) b + sizeof(CBuf);
1658 _ckvmssts(lib$insqhi(b, &p->free));
1661 pipe_tochild2_ast(p);
1662 pipe_tochild1_ast(p);
1668 /* reads the MBX Perl is writing, and queues */
1671 pipe_tochild1_ast(pPipe p)
1674 int iss = p->iosb.status;
1675 int eof = (iss == SS$_ENDOFFILE);
1676 #ifdef PERL_IMPLICIT_CONTEXT
1682 p->shut_on_empty = TRUE;
1684 _ckvmssts(sys$dassgn(p->chan_in));
1690 b->size = p->iosb.count;
1691 _ckvmssts(lib$insqhi(b, &p->wait));
1693 p->need_wake = FALSE;
1694 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
1697 p->retry = 1; /* initial call */
1700 if (eof) { /* flush the free queue, return when done */
1701 int n = sizeof(CBuf) + p->bufsize;
1703 iss = lib$remqti(&p->free, &b);
1704 if (iss == LIB$_QUEWASEMP) return;
1706 _ckvmssts(lib$free_vm(&n, &b));
1710 iss = lib$remqti(&p->free, &b);
1711 if (iss == LIB$_QUEWASEMP) {
1712 int n = sizeof(CBuf) + p->bufsize;
1713 _ckvmssts(lib$get_vm(&n, &b));
1714 b->buf = (char *) b + sizeof(CBuf);
1720 iss = sys$qio(0,p->chan_in,
1721 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
1723 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
1724 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
1729 /* writes queued buffers to output, waits for each to complete before
1733 pipe_tochild2_ast(pPipe p)
1736 int iss = p->iosb2.status;
1737 int n = sizeof(CBuf) + p->bufsize;
1738 int done = (p->info && p->info->done) ||
1739 iss == SS$_CANCEL || iss == SS$_ABORT;
1740 #if defined(PERL_IMPLICIT_CONTEXT)
1745 if (p->type) { /* type=1 has old buffer, dispose */
1746 if (p->shut_on_empty) {
1747 _ckvmssts(lib$free_vm(&n, &b));
1749 _ckvmssts(lib$insqhi(b, &p->free));
1754 iss = lib$remqti(&p->wait, &b);
1755 if (iss == LIB$_QUEWASEMP) {
1756 if (p->shut_on_empty) {
1758 _ckvmssts(sys$dassgn(p->chan_out));
1759 *p->pipe_done = TRUE;
1760 _ckvmssts(sys$setef(pipe_ef));
1762 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1763 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1767 p->need_wake = TRUE;
1777 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
1778 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
1780 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
1781 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
1790 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
1793 char mbx1[64], mbx2[64];
1794 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
1795 DSC$K_CLASS_S, mbx1},
1796 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
1797 DSC$K_CLASS_S, mbx2};
1798 unsigned int dviitm = DVI$_DEVBUFSIZ;
1800 New(1367, p, 1, Pipe);
1801 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
1802 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
1804 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1805 New(1367, p->buf, p->bufsize, char);
1806 p->shut_on_empty = FALSE;
1809 p->iosb.status = SS$_NORMAL;
1810 #if defined(PERL_IMPLICIT_CONTEXT)
1813 pipe_infromchild_ast(p);
1821 pipe_infromchild_ast(pPipe p)
1823 int iss = p->iosb.status;
1824 int eof = (iss == SS$_ENDOFFILE);
1825 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
1826 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
1827 #if defined(PERL_IMPLICIT_CONTEXT)
1831 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
1832 _ckvmssts(sys$dassgn(p->chan_out));
1837 input shutdown if EOF from self (done or shut_on_empty)
1838 output shutdown if closing flag set (my_pclose)
1839 send data/eof from child or eof from self
1840 otherwise, re-read (snarf of data from child)
1845 if (myeof && p->chan_in) { /* input shutdown */
1846 _ckvmssts(sys$dassgn(p->chan_in));
1851 if (myeof || kideof) { /* pass EOF to parent */
1852 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
1853 pipe_infromchild_ast, p,
1856 } else if (eof) { /* eat EOF --- fall through to read*/
1858 } else { /* transmit data */
1859 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
1860 pipe_infromchild_ast,p,
1861 p->buf, p->iosb.count, 0, 0, 0, 0));
1867 /* everything shut? flag as done */
1869 if (!p->chan_in && !p->chan_out) {
1870 *p->pipe_done = TRUE;
1871 _ckvmssts(sys$setef(pipe_ef));
1875 /* write completed (or read, if snarfing from child)
1876 if still have input active,
1877 queue read...immediate mode if shut_on_empty so we get EOF if empty
1879 check if Perl reading, generate EOFs as needed
1885 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
1886 pipe_infromchild_ast,p,
1887 p->buf, p->bufsize, 0, 0, 0, 0);
1888 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
1890 } else { /* send EOFs for extra reads */
1891 p->iosb.status = SS$_ENDOFFILE;
1892 p->iosb.dvispec = 0;
1893 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
1895 pipe_infromchild_ast, p, 0, 0, 0, 0));
1901 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
1905 unsigned long dviitm = DVI$_DEVBUFSIZ;
1907 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
1908 DSC$K_CLASS_S, mbx};
1910 /* things like terminals and mbx's don't need this filter */
1911 if (fd && fstat(fd,&s) == 0) {
1912 unsigned long dviitm = DVI$_DEVCHAR, devchar;
1913 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
1914 DSC$K_CLASS_S, s.st_dev};
1916 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
1917 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
1918 strcpy(out, s.st_dev);
1923 New(1366, p, 1, Pipe);
1924 p->fd_out = dup(fd);
1925 create_mbx(aTHX_ &p->chan_in, &d_mbx);
1926 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
1927 New(1366, p->buf, p->bufsize+1, char);
1928 p->shut_on_empty = FALSE;
1933 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
1934 pipe_mbxtofd_ast, p,
1935 p->buf, p->bufsize, 0, 0, 0, 0));
1941 pipe_mbxtofd_ast(pPipe p)
1943 int iss = p->iosb.status;
1944 int done = p->info->done;
1946 int eof = (iss == SS$_ENDOFFILE);
1947 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
1948 int err = !(iss&1) && !eof;
1949 #if defined(PERL_IMPLICIT_CONTEXT)
1953 if (done && myeof) { /* end piping */
1955 sys$dassgn(p->chan_in);
1956 *p->pipe_done = TRUE;
1957 _ckvmssts(sys$setef(pipe_ef));
1961 if (!err && !eof) { /* good data to send to file */
1962 p->buf[p->iosb.count] = '\n';
1963 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
1966 if (p->retry < MAX_RETRY) {
1967 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
1977 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
1978 pipe_mbxtofd_ast, p,
1979 p->buf, p->bufsize, 0, 0, 0, 0);
1980 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
1985 typedef struct _pipeloc PLOC;
1986 typedef struct _pipeloc* pPLOC;
1990 char dir[NAM$C_MAXRSS+1];
1992 static pPLOC head_PLOC = 0;
1995 free_pipelocs(pTHX_ void *head)
1998 pPLOC *pHead = (pPLOC *)head;
2010 store_pipelocs(pTHX)
2019 char temp[NAM$C_MAXRSS+1];
2023 free_pipelocs(aTHX_ &head_PLOC);
2025 /* the . directory from @INC comes last */
2028 p->next = head_PLOC;
2030 strcpy(p->dir,"./");
2032 /* get the directory from $^X */
2034 #ifdef PERL_IMPLICIT_CONTEXT
2035 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2037 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2039 strcpy(temp, PL_origargv[0]);
2040 x = strrchr(temp,']');
2043 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2045 p->next = head_PLOC;
2047 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2048 p->dir[NAM$C_MAXRSS] = '\0';
2052 /* reverse order of @INC entries, skip "." since entered above */
2054 #ifdef PERL_IMPLICIT_CONTEXT
2057 if (PL_incgv) av = GvAVn(PL_incgv);
2059 for (i = 0; av && i <= AvFILL(av); i++) {
2060 dirsv = *av_fetch(av,i,TRUE);
2062 if (SvROK(dirsv)) continue;
2063 dir = SvPVx(dirsv,n_a);
2064 if (strcmp(dir,".") == 0) continue;
2065 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2069 p->next = head_PLOC;
2071 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2072 p->dir[NAM$C_MAXRSS] = '\0';
2075 /* most likely spot (ARCHLIB) put first in the list */
2078 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2080 p->next = head_PLOC;
2082 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2083 p->dir[NAM$C_MAXRSS] = '\0';
2092 static int vmspipe_file_status = 0;
2093 static char vmspipe_file[NAM$C_MAXRSS+1];
2095 /* already found? Check and use ... need read+execute permission */
2097 if (vmspipe_file_status == 1) {
2098 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2099 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2100 return vmspipe_file;
2102 vmspipe_file_status = 0;
2105 /* scan through stored @INC, $^X */
2107 if (vmspipe_file_status == 0) {
2108 char file[NAM$C_MAXRSS+1];
2109 pPLOC p = head_PLOC;
2112 strcpy(file, p->dir);
2113 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
2114 file[NAM$C_MAXRSS] = '\0';
2117 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
2119 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
2120 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
2121 vmspipe_file_status = 1;
2122 return vmspipe_file;
2125 vmspipe_file_status = -1; /* failed, use tempfiles */
2132 vmspipe_tempfile(pTHX)
2134 char file[NAM$C_MAXRSS+1];
2136 static int index = 0;
2139 /* create a tempfile */
2141 /* we can't go from W, shr=get to R, shr=get without
2142 an intermediate vulnerable state, so don't bother trying...
2144 and lib$spawn doesn't shr=put, so have to close the write
2146 So... match up the creation date/time and the FID to
2147 make sure we're dealing with the same file
2152 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
2153 fp = fopen(file,"w");
2155 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
2156 fp = fopen(file,"w");
2158 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
2159 fp = fopen(file,"w");
2162 if (!fp) return 0; /* we're hosed */
2164 fprintf(fp,"$! 'f$verify(0)\n");
2165 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
2166 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
2167 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
2168 fprintf(fp,"$ perl_on = \"set noon\"\n");
2169 fprintf(fp,"$ perl_exit = \"exit\"\n");
2170 fprintf(fp,"$ perl_del = \"delete\"\n");
2171 fprintf(fp,"$ pif = \"if\"\n");
2172 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
2173 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
2174 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
2175 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
2176 fprintf(fp,"$! --- build command line to get max possible length\n");
2177 fprintf(fp,"$c=perl_popen_cmd0\n");
2178 fprintf(fp,"$c=c+perl_popen_cmd1\n");
2179 fprintf(fp,"$c=c+perl_popen_cmd2\n");
2180 fprintf(fp,"$x=perl_popen_cmd3\n");
2181 fprintf(fp,"$c=c+x\n");
2182 fprintf(fp,"$! --- get rid of global symbols\n");
2183 fprintf(fp,"$ perl_del/symbol/global perl_popen_in\n");
2184 fprintf(fp,"$ perl_del/symbol/global perl_popen_err\n");
2185 fprintf(fp,"$ perl_del/symbol/global perl_popen_out\n");
2186 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd0\n");
2187 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd1\n");
2188 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd2\n");
2189 fprintf(fp,"$ perl_del/symbol/global perl_popen_cmd3\n");
2190 fprintf(fp,"$ perl_on\n");
2191 fprintf(fp,"$ 'c\n");
2192 fprintf(fp,"$ perl_status = $STATUS\n");
2193 fprintf(fp,"$ perl_del 'perl_cfile'\n");
2194 fprintf(fp,"$ perl_exit 'perl_status'\n");
2197 fgetname(fp, file, 1);
2198 fstat(fileno(fp), &s0);
2201 fp = fopen(file,"r","shr=get");
2203 fstat(fileno(fp), &s1);
2205 if (s0.st_ino[0] != s1.st_ino[0] ||
2206 s0.st_ino[1] != s1.st_ino[1] ||
2207 s0.st_ino[2] != s1.st_ino[2] ||
2208 s0.st_ctime != s1.st_ctime ) {
2219 safe_popen(pTHX_ char *cmd, char *in_mode, int *psts)
2221 static int handler_set_up = FALSE;
2222 unsigned long int sts, flags = CLI$M_NOWAIT;
2223 unsigned int table = LIB$K_CLI_GLOBAL_SYM;
2225 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
2226 char in[512], out[512], err[512], mbx[512];
2228 char tfilebuf[NAM$C_MAXRSS+1];
2230 char cmd_sym_name[20];
2231 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
2232 DSC$K_CLASS_S, symbol};
2233 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
2235 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
2236 DSC$K_CLASS_S, cmd_sym_name};
2237 struct dsc$descriptor_s *vmscmd;
2238 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
2239 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
2240 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
2242 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
2244 /* once-per-program initialization...
2245 note that the SETAST calls and the dual test of pipe_ef
2246 makes sure that only the FIRST thread through here does
2247 the initialization...all other threads wait until it's
2250 Yeah, uglier than a pthread call, it's got all the stuff inline
2251 rather than in a separate routine.
2255 _ckvmssts(sys$setast(0));
2257 unsigned long int pidcode = JPI$_PID;
2258 $DESCRIPTOR(d_delay, RETRY_DELAY);
2259 _ckvmssts(lib$get_ef(&pipe_ef));
2260 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2261 _ckvmssts(sys$bintim(&d_delay, delaytime));
2263 if (!handler_set_up) {
2264 _ckvmssts(sys$dclexh(&pipe_exitblock));
2265 handler_set_up = TRUE;
2267 _ckvmssts(sys$setast(1));
2270 /* see if we can find a VMSPIPE.COM */
2273 vmspipe = find_vmspipe(aTHX);
2275 strcpy(tfilebuf+1,vmspipe);
2276 } else { /* uh, oh...we're in tempfile hell */
2277 tpipe = vmspipe_tempfile(aTHX);
2278 if (!tpipe) { /* a fish popular in Boston */
2279 if (ckWARN(WARN_PIPE)) {
2280 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
2284 fgetname(tpipe,tfilebuf+1,1);
2286 vmspipedsc.dsc$a_pointer = tfilebuf;
2287 vmspipedsc.dsc$w_length = strlen(tfilebuf);
2289 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
2292 case RMS$_FNF: case RMS$_DNF:
2293 set_errno(ENOENT); break;
2295 set_errno(ENOTDIR); break;
2297 set_errno(ENODEV); break;
2299 set_errno(EACCES); break;
2301 set_errno(EINVAL); break;
2302 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
2303 set_errno(E2BIG); break;
2304 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
2305 _ckvmssts(sts); /* fall through */
2306 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
2309 set_vaxc_errno(sts);
2310 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
2311 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
2316 New(1301,info,1,Info);
2318 strcpy(mode,in_mode);
2321 info->completion = 0;
2322 info->closing = FALSE;
2329 info->in_done = TRUE;
2330 info->out_done = TRUE;
2331 info->err_done = TRUE;
2332 in[0] = out[0] = err[0] = '\0';
2334 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
2338 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
2343 if (*mode == 'r') { /* piping from subroutine */
2345 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
2347 info->out->pipe_done = &info->out_done;
2348 info->out_done = FALSE;
2349 info->out->info = info;
2351 if (!info->useFILE) {
2352 info->fp = PerlIO_open(mbx, mode);
2354 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
2355 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
2358 if (!info->fp && info->out) {
2359 sys$cancel(info->out->chan_out);
2361 while (!info->out_done) {
2363 _ckvmssts(sys$setast(0));
2364 done = info->out_done;
2365 if (!done) _ckvmssts(sys$clref(pipe_ef));
2366 _ckvmssts(sys$setast(1));
2367 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2370 if (info->out->buf) Safefree(info->out->buf);
2371 Safefree(info->out);
2377 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2379 info->err->pipe_done = &info->err_done;
2380 info->err_done = FALSE;
2381 info->err->info = info;
2384 } else if (*mode == 'w') { /* piping to subroutine */
2386 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2388 info->out->pipe_done = &info->out_done;
2389 info->out_done = FALSE;
2390 info->out->info = info;
2393 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2395 info->err->pipe_done = &info->err_done;
2396 info->err_done = FALSE;
2397 info->err->info = info;
2400 info->in = pipe_tochild_setup(aTHX_ in,mbx);
2401 if (!info->useFILE) {
2402 info->fp = PerlIO_open(mbx, mode);
2404 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
2405 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
2409 info->in->pipe_done = &info->in_done;
2410 info->in_done = FALSE;
2411 info->in->info = info;
2415 if (!info->fp && info->in) {
2417 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
2418 0, 0, 0, 0, 0, 0, 0, 0));
2420 while (!info->in_done) {
2422 _ckvmssts(sys$setast(0));
2423 done = info->in_done;
2424 if (!done) _ckvmssts(sys$clref(pipe_ef));
2425 _ckvmssts(sys$setast(1));
2426 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2429 if (info->in->buf) Safefree(info->in->buf);
2437 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
2438 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
2440 info->out->pipe_done = &info->out_done;
2441 info->out_done = FALSE;
2442 info->out->info = info;
2445 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
2447 info->err->pipe_done = &info->err_done;
2448 info->err_done = FALSE;
2449 info->err->info = info;
2453 symbol[MAX_DCL_SYMBOL] = '\0';
2455 strncpy(symbol, in, MAX_DCL_SYMBOL);
2456 d_symbol.dsc$w_length = strlen(symbol);
2457 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
2459 strncpy(symbol, err, MAX_DCL_SYMBOL);
2460 d_symbol.dsc$w_length = strlen(symbol);
2461 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
2463 strncpy(symbol, out, MAX_DCL_SYMBOL);
2464 d_symbol.dsc$w_length = strlen(symbol);
2465 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
2467 p = vmscmd->dsc$a_pointer;
2468 while (*p && *p != '\n') p++;
2469 *p = '\0'; /* truncate on \n */
2470 p = vmscmd->dsc$a_pointer;
2471 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
2472 if (*p == '$') p++; /* remove leading $ */
2473 while (*p == ' ' || *p == '\t') p++;
2475 for (j = 0; j < 4; j++) {
2476 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2477 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2479 strncpy(symbol, p, MAX_DCL_SYMBOL);
2480 d_symbol.dsc$w_length = strlen(symbol);
2481 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
2483 if (strlen(p) > MAX_DCL_SYMBOL) {
2484 p += MAX_DCL_SYMBOL;
2489 _ckvmssts(sys$setast(0));
2490 info->next=open_pipes; /* prepend to list */
2492 _ckvmssts(sys$setast(1));
2493 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
2494 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
2495 * have SYS$COMMAND if we need it.
2497 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
2498 0, &info->pid, &info->completion,
2499 0, popen_completion_ast,info,0,0,0));
2501 /* if we were using a tempfile, close it now */
2503 if (tpipe) fclose(tpipe);
2505 /* once the subprocess is spawned, it has copied the symbols and
2506 we can get rid of ours */
2508 for (j = 0; j < 4; j++) {
2509 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
2510 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
2511 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
2513 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
2514 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
2515 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
2516 vms_execfree(vmscmd);
2518 #ifdef PERL_IMPLICIT_CONTEXT
2521 PL_forkprocess = info->pid;
2526 _ckvmssts(sys$setast(0));
2528 if (!done) _ckvmssts(sys$clref(pipe_ef));
2529 _ckvmssts(sys$setast(1));
2530 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2532 *psts = info->completion;
2533 my_pclose(info->fp);
2538 } /* end of safe_popen */
2541 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
2543 Perl_my_popen(pTHX_ char *cmd, char *mode)
2547 TAINT_PROPER("popen");
2548 PERL_FLUSHALL_FOR_CHILD;
2549 return safe_popen(aTHX_ cmd,mode,&sts);
2554 /*{{{ I32 my_pclose(PerlIO *fp)*/
2555 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
2557 pInfo info, last = NULL;
2558 unsigned long int retsts;
2561 for (info = open_pipes; info != NULL; last = info, info = info->next)
2562 if (info->fp == fp) break;
2564 if (info == NULL) { /* no such pipe open */
2565 set_errno(ECHILD); /* quoth POSIX */
2566 set_vaxc_errno(SS$_NONEXPR);
2570 /* If we were writing to a subprocess, insure that someone reading from
2571 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
2572 * produce an EOF record in the mailbox.
2574 * well, at least sometimes it *does*, so we have to watch out for
2575 * the first EOF closing the pipe (and DASSGN'ing the channel)...
2579 PerlIO_flush(info->fp); /* first, flush data */
2581 fflush((FILE *)info->fp);
2584 _ckvmssts(sys$setast(0));
2585 info->closing = TRUE;
2586 done = info->done && info->in_done && info->out_done && info->err_done;
2587 /* hanging on write to Perl's input? cancel it */
2588 if (info->mode == 'r' && info->out && !info->out_done) {
2589 if (info->out->chan_out) {
2590 _ckvmssts(sys$cancel(info->out->chan_out));
2591 if (!info->out->chan_in) { /* EOF generation, need AST */
2592 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
2596 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
2597 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2599 _ckvmssts(sys$setast(1));
2602 PerlIO_close(info->fp);
2604 fclose((FILE *)info->fp);
2607 we have to wait until subprocess completes, but ALSO wait until all
2608 the i/o completes...otherwise we'll be freeing the "info" structure
2609 that the i/o ASTs could still be using...
2613 _ckvmssts(sys$setast(0));
2614 done = info->done && info->in_done && info->out_done && info->err_done;
2615 if (!done) _ckvmssts(sys$clref(pipe_ef));
2616 _ckvmssts(sys$setast(1));
2617 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2619 retsts = info->completion;
2621 /* remove from list of open pipes */
2622 _ckvmssts(sys$setast(0));
2623 if (last) last->next = info->next;
2624 else open_pipes = info->next;
2625 _ckvmssts(sys$setast(1));
2627 /* free buffers and structures */
2630 if (info->in->buf) Safefree(info->in->buf);
2634 if (info->out->buf) Safefree(info->out->buf);
2635 Safefree(info->out);
2638 if (info->err->buf) Safefree(info->err->buf);
2639 Safefree(info->err);
2645 } /* end of my_pclose() */
2647 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2648 /* Roll our own prototype because we want this regardless of whether
2649 * _VMS_WAIT is defined.
2651 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
2653 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
2654 created with popen(); otherwise partially emulate waitpid() unless
2655 we have a suitable one from the CRTL that came with VMS 7.2 and later.
2656 Also check processes not considered by the CRTL waitpid().
2658 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
2660 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
2667 if (statusp) *statusp = 0;
2669 for (info = open_pipes; info != NULL; info = info->next)
2670 if (info->pid == pid) break;
2672 if (info != NULL) { /* we know about this child */
2673 while (!info->done) {
2674 _ckvmssts(sys$setast(0));
2676 if (!done) _ckvmssts(sys$clref(pipe_ef));
2677 _ckvmssts(sys$setast(1));
2678 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
2681 if (statusp) *statusp = info->completion;
2685 /* child that already terminated? */
2687 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
2688 if (closed_list[j].pid == pid) {
2689 if (statusp) *statusp = closed_list[j].completion;
2694 /* fall through if this child is not one of our own pipe children */
2696 #if defined(__CRTL_VER) && __CRTL_VER >= 70100322
2698 /* waitpid() became available in the CRTL as of VMS 7.0, but only
2699 * in 7.2 did we get a version that fills in the VMS completion
2700 * status as Perl has always tried to do.
2703 sts = __vms_waitpid( pid, statusp, flags );
2705 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
2708 /* If the real waitpid tells us the child does not exist, we
2709 * fall through here to implement waiting for a child that
2710 * was created by some means other than exec() (say, spawned
2711 * from DCL) or to wait for a process that is not a subprocess
2712 * of the current process.
2715 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70100322 */
2718 $DESCRIPTOR(intdsc,"0 00:00:01");
2719 unsigned long int ownercode = JPI$_OWNER, ownerpid;
2720 unsigned long int pidcode = JPI$_PID, mypid;
2721 unsigned long int interval[2];
2722 unsigned int jpi_iosb[2];
2723 struct itmlst_3 jpilist[2] = {
2724 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
2729 /* Sorry folks, we don't presently implement rooting around for
2730 the first child we can find, and we definitely don't want to
2731 pass a pid of -1 to $getjpi, where it is a wildcard operation.
2737 /* Get the owner of the child so I can warn if it's not mine. If the
2738 * process doesn't exist or I don't have the privs to look at it,
2739 * I can go home early.
2741 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
2742 if (sts & 1) sts = jpi_iosb[0];
2754 set_vaxc_errno(sts);
2758 if (ckWARN(WARN_EXEC)) {
2759 /* remind folks they are asking for non-standard waitpid behavior */
2760 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
2761 if (ownerpid != mypid)
2762 Perl_warner(aTHX_ packWARN(WARN_EXEC),
2763 "waitpid: process %x is not a child of process %x",
2767 /* simply check on it once a second until it's not there anymore. */
2769 _ckvmssts(sys$bintim(&intdsc,interval));
2770 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
2771 _ckvmssts(sys$schdwk(0,0,interval,0));
2772 _ckvmssts(sys$hiber());
2774 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
2779 } /* end of waitpid() */
2784 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
2786 my_gconvert(double val, int ndig, int trail, char *buf)
2788 static char __gcvtbuf[DBL_DIG+1];
2791 loc = buf ? buf : __gcvtbuf;
2793 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
2795 sprintf(loc,"%.*g",ndig,val);
2801 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
2802 return gcvt(val,ndig,loc);
2805 loc[0] = '0'; loc[1] = '\0';
2813 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
2814 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
2815 * to expand file specification. Allows for a single default file
2816 * specification and a simple mask of options. If outbuf is non-NULL,
2817 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
2818 * the resultant file specification is placed. If outbuf is NULL, the
2819 * resultant file specification is placed into a static buffer.
2820 * The third argument, if non-NULL, is taken to be a default file
2821 * specification string. The fourth argument is unused at present.
2822 * rmesexpand() returns the address of the resultant string if
2823 * successful, and NULL on error.
2825 static char *mp_do_tounixspec(pTHX_ char *, char *, int);
2828 mp_do_rmsexpand(pTHX_ char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
2830 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
2831 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
2832 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
2833 struct FAB myfab = cc$rms_fab;
2834 struct NAM mynam = cc$rms_nam;
2836 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
2838 if (!filespec || !*filespec) {
2839 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
2843 if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
2844 else outbuf = __rmsexpand_retbuf;
2846 if ((isunix = (strchr(filespec,'/') != NULL))) {
2847 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
2848 filespec = vmsfspec;
2851 myfab.fab$l_fna = filespec;
2852 myfab.fab$b_fns = strlen(filespec);
2853 myfab.fab$l_nam = &mynam;
2855 if (defspec && *defspec) {
2856 if (strchr(defspec,'/') != NULL) {
2857 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
2860 myfab.fab$l_dna = defspec;
2861 myfab.fab$b_dns = strlen(defspec);
2864 mynam.nam$l_esa = esa;
2865 mynam.nam$b_ess = sizeof esa;
2866 mynam.nam$l_rsa = outbuf;
2867 mynam.nam$b_rss = NAM$C_MAXRSS;
2869 retsts = sys$parse(&myfab,0,0);
2870 if (!(retsts & 1)) {
2871 mynam.nam$b_nop |= NAM$M_SYNCHK;
2872 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
2873 retsts = sys$parse(&myfab,0,0);
2874 if (retsts & 1) goto expanded;
2876 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
2877 (void) sys$parse(&myfab,0,0); /* Free search context */
2878 if (out) Safefree(out);
2879 set_vaxc_errno(retsts);
2880 if (retsts == RMS$_PRV) set_errno(EACCES);
2881 else if (retsts == RMS$_DEV) set_errno(ENODEV);
2882 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
2883 else set_errno(EVMSERR);
2886 retsts = sys$search(&myfab,0,0);
2887 if (!(retsts & 1) && retsts != RMS$_FNF) {
2888 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2889 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2890 if (out) Safefree(out);
2891 set_vaxc_errno(retsts);
2892 if (retsts == RMS$_PRV) set_errno(EACCES);
2893 else set_errno(EVMSERR);
2897 /* If the input filespec contained any lowercase characters,
2898 * downcase the result for compatibility with Unix-minded code. */
2900 for (out = myfab.fab$l_fna; *out; out++)
2901 if (islower(*out)) { haslower = 1; break; }
2902 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
2903 else { out = esa; speclen = mynam.nam$b_esl; }
2904 /* Trim off null fields added by $PARSE
2905 * If type > 1 char, must have been specified in original or default spec
2906 * (not true for version; $SEARCH may have added version of existing file).
2908 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
2909 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
2910 (mynam.nam$l_ver - mynam.nam$l_type == 1);
2911 if (trimver || trimtype) {
2912 if (defspec && *defspec) {
2913 char defesa[NAM$C_MAXRSS];
2914 struct FAB deffab = cc$rms_fab;
2915 struct NAM defnam = cc$rms_nam;
2917 deffab.fab$l_nam = &defnam;
2918 deffab.fab$l_fna = defspec; deffab.fab$b_fns = myfab.fab$b_dns;
2919 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
2920 defnam.nam$b_nop = NAM$M_SYNCHK;
2921 if (sys$parse(&deffab,0,0) & 1) {
2922 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
2923 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
2926 if (trimver) speclen = mynam.nam$l_ver - out;
2928 /* If we didn't already trim version, copy down */
2929 if (speclen > mynam.nam$l_ver - out)
2930 memcpy(mynam.nam$l_type, mynam.nam$l_ver,
2931 speclen - (mynam.nam$l_ver - out));
2932 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
2935 /* If we just had a directory spec on input, $PARSE "helpfully"
2936 * adds an empty name and type for us */
2937 if (mynam.nam$l_name == mynam.nam$l_type &&
2938 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
2939 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
2940 speclen = mynam.nam$l_name - out;
2941 out[speclen] = '\0';
2942 if (haslower) __mystrtolower(out);
2944 /* Have we been working with an expanded, but not resultant, spec? */
2945 /* Also, convert back to Unix syntax if necessary. */
2946 if (!mynam.nam$b_rsl) {
2948 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
2950 else strcpy(outbuf,esa);
2953 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
2954 strcpy(outbuf,tmpfspec);
2956 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
2957 mynam.nam$l_rsa = NULL; mynam.nam$b_rss = 0;
2958 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0); /* Free search context */
2962 /* External entry points */
2963 char *Perl_rmsexpand(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2964 { return do_rmsexpand(spec,buf,0,def,opt); }
2965 char *Perl_rmsexpand_ts(pTHX_ char *spec, char *buf, char *def, unsigned opt)
2966 { return do_rmsexpand(spec,buf,1,def,opt); }
2970 ** The following routines are provided to make life easier when
2971 ** converting among VMS-style and Unix-style directory specifications.
2972 ** All will take input specifications in either VMS or Unix syntax. On
2973 ** failure, all return NULL. If successful, the routines listed below
2974 ** return a pointer to a buffer containing the appropriately
2975 ** reformatted spec (and, therefore, subsequent calls to that routine
2976 ** will clobber the result), while the routines of the same names with
2977 ** a _ts suffix appended will return a pointer to a mallocd string
2978 ** containing the appropriately reformatted spec.
2979 ** In all cases, only explicit syntax is altered; no check is made that
2980 ** the resulting string is valid or that the directory in question
2983 ** fileify_dirspec() - convert a directory spec into the name of the
2984 ** directory file (i.e. what you can stat() to see if it's a dir).
2985 ** The style (VMS or Unix) of the result is the same as the style
2986 ** of the parameter passed in.
2987 ** pathify_dirspec() - convert a directory spec into a path (i.e.
2988 ** what you prepend to a filename to indicate what directory it's in).
2989 ** The style (VMS or Unix) of the result is the same as the style
2990 ** of the parameter passed in.
2991 ** tounixpath() - convert a directory spec into a Unix-style path.
2992 ** tovmspath() - convert a directory spec into a VMS-style path.
2993 ** tounixspec() - convert any file spec into a Unix-style file spec.
2994 ** tovmsspec() - convert any file spec into a VMS-style spec.
2996 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
2997 ** Permission is given to distribute this code as part of the Perl
2998 ** standard distribution under the terms of the GNU General Public
2999 ** License or the Perl Artistic License. Copies of each may be
3000 ** found in the Perl standard distribution.
3003 /*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
3004 static char *mp_do_fileify_dirspec(pTHX_ char *dir,char *buf,int ts)
3006 static char __fileify_retbuf[NAM$C_MAXRSS+1];
3007 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
3008 char *retspec, *cp1, *cp2, *lastdir;
3009 char trndir[NAM$C_MAXRSS+2], vmsdir[NAM$C_MAXRSS+1];
3011 if (!dir || !*dir) {
3012 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3014 dirlen = strlen(dir);
3015 while (dirlen && dir[dirlen-1] == '/') --dirlen;
3016 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
3017 strcpy(trndir,"/sys$disk/000000");
3021 if (dirlen > NAM$C_MAXRSS) {
3022 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN); return NULL;
3024 if (!strpbrk(dir+1,"/]>:")) {
3025 strcpy(trndir,*dir == '/' ? dir + 1: dir);
3026 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) ;
3028 dirlen = strlen(dir);
3031 strncpy(trndir,dir,dirlen);
3032 trndir[dirlen] = '\0';
3035 /* If we were handed a rooted logical name or spec, treat it like a
3036 * simple directory, so that
3037 * $ Define myroot dev:[dir.]
3038 * ... do_fileify_dirspec("myroot",buf,1) ...
3039 * does something useful.
3041 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".]")) {
3042 dir[--dirlen] = '\0';
3043 dir[dirlen-1] = ']';
3045 if (dirlen >= 2 && !strcmp(dir+dirlen-2,".>")) {
3046 dir[--dirlen] = '\0';
3047 dir[dirlen-1] = '>';
3050 if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
3051 /* If we've got an explicit filename, we can just shuffle the string. */
3052 if (*(cp1+1)) hasfilename = 1;
3053 /* Similarly, we can just back up a level if we've got multiple levels
3054 of explicit directories in a VMS spec which ends with directories. */
3056 for (cp2 = cp1; cp2 > dir; cp2--) {
3058 *cp2 = *cp1; *cp1 = '\0';
3062 if (*cp2 == '[' || *cp2 == '<') break;
3067 if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
3068 if (dir[0] == '.') {
3069 if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
3070 return do_fileify_dirspec("[]",buf,ts);
3071 else if (dir[1] == '.' &&
3072 (dir[2] == '\0' || (dir[2] == '/' && dir[3] == '\0')))
3073 return do_fileify_dirspec("[-]",buf,ts);
3075 if (dirlen && dir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
3076 dirlen -= 1; /* to last element */
3077 lastdir = strrchr(dir,'/');
3079 else if ((cp1 = strstr(dir,"/.")) != NULL) {
3080 /* If we have "/." or "/..", VMSify it and let the VMS code
3081 * below expand it, rather than repeating the code to handle
3082 * relative components of a filespec here */
3084 if (*(cp1+2) == '.') cp1++;
3085 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
3086 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3087 if (strchr(vmsdir,'/') != NULL) {
3088 /* If do_tovmsspec() returned it, it must have VMS syntax
3089 * delimiters in it, so it's a mixed VMS/Unix spec. We take
3090 * the time to check this here only so we avoid a recursion
3091 * loop; otherwise, gigo.
3093 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL;
3095 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3096 return do_tounixspec(trndir,buf,ts);
3099 } while ((cp1 = strstr(cp1,"/.")) != NULL);
3100 lastdir = strrchr(dir,'/');
3102 else if (dirlen >= 7 && !strcmp(&dir[dirlen-7],"/000000")) {
3103 /* Ditto for specs that end in an MFD -- let the VMS code
3104 * figure out whether it's a real device or a rooted logical. */
3105 dir[dirlen] = '/'; dir[dirlen+1] = '\0';
3106 if (do_tovmsspec(dir,vmsdir,0) == NULL) return NULL;
3107 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) return NULL;
3108 return do_tounixspec(trndir,buf,ts);
3111 if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
3112 !(lastdir = cp1 = strrchr(dir,']')) &&
3113 !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
3114 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
3116 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3117 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3118 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3119 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3120 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3121 (ver || *cp3)))))) {
3123 set_vaxc_errno(RMS$_DIR);
3129 /* If we lead off with a device or rooted logical, add the MFD
3130 if we're specifying a top-level directory. */
3131 if (lastdir && *dir == '/') {
3133 for (cp1 = lastdir - 1; cp1 > dir; cp1--) {
3140 retlen = dirlen + (addmfd ? 13 : 6);
3141 if (buf) retspec = buf;
3142 else if (ts) New(1309,retspec,retlen+1,char);
3143 else retspec = __fileify_retbuf;
3145 dirlen = lastdir - dir;
3146 memcpy(retspec,dir,dirlen);
3147 strcpy(&retspec[dirlen],"/000000");
3148 strcpy(&retspec[dirlen+7],lastdir);
3151 memcpy(retspec,dir,dirlen);
3152 retspec[dirlen] = '\0';
3154 /* We've picked up everything up to the directory file name.
3155 Now just add the type and version, and we're set. */
3156 strcat(retspec,".dir;1");
3159 else { /* VMS-style directory spec */
3160 char esa[NAM$C_MAXRSS+1], term, *cp;
3161 unsigned long int sts, cmplen, haslower = 0;
3162 struct FAB dirfab = cc$rms_fab;
3163 struct NAM savnam, dirnam = cc$rms_nam;
3165 dirfab.fab$b_fns = strlen(dir);
3166 dirfab.fab$l_fna = dir;
3167 dirfab.fab$l_nam = &dirnam;
3168 dirfab.fab$l_dna = ".DIR;1";
3169 dirfab.fab$b_dns = 6;
3170 dirnam.nam$b_ess = NAM$C_MAXRSS;
3171 dirnam.nam$l_esa = esa;
3173 for (cp = dir; *cp; cp++)
3174 if (islower(*cp)) { haslower = 1; break; }
3175 if (!((sts = sys$parse(&dirfab))&1)) {
3176 if (dirfab.fab$l_sts == RMS$_DIR) {
3177 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3178 sts = sys$parse(&dirfab) & 1;
3182 set_vaxc_errno(dirfab.fab$l_sts);
3188 if (sys$search(&dirfab)&1) { /* Does the file really exist? */
3189 /* Yes; fake the fnb bits so we'll check type below */
3190 dirnam.nam$l_fnb |= NAM$M_EXP_TYPE | NAM$M_EXP_VER;
3192 else { /* No; just work with potential name */
3193 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
3195 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
3196 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3197 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3202 if (!(dirnam.nam$l_fnb & (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
3203 cp1 = strchr(esa,']');
3204 if (!cp1) cp1 = strchr(esa,'>');
3205 if (cp1) { /* Should always be true */
3206 dirnam.nam$b_esl -= cp1 - esa - 1;
3207 memcpy(esa,cp1 + 1,dirnam.nam$b_esl);
3210 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3211 /* Yep; check version while we're at it, if it's there. */
3212 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3213 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3214 /* Something other than .DIR[;1]. Bzzt. */
3215 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3216 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3218 set_vaxc_errno(RMS$_DIR);
3222 esa[dirnam.nam$b_esl] = '\0';
3223 if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
3224 /* They provided at least the name; we added the type, if necessary, */
3225 if (buf) retspec = buf; /* in sys$parse() */
3226 else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
3227 else retspec = __fileify_retbuf;
3228 strcpy(retspec,esa);
3229 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3230 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3233 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
3234 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
3236 dirnam.nam$b_esl -= 9;
3238 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
3239 if (cp1 == NULL) { /* should never happen */
3240 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3241 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3246 retlen = strlen(esa);
3247 if ((cp1 = strrchr(esa,'.')) != NULL) {
3248 /* There's more than one directory in the path. Just roll back. */
3250 if (buf) retspec = buf;
3251 else if (ts) New(1311,retspec,retlen+7,char);
3252 else retspec = __fileify_retbuf;
3253 strcpy(retspec,esa);
3256 if (dirnam.nam$l_fnb & NAM$M_ROOT_DIR) {
3257 /* Go back and expand rooted logical name */
3258 dirnam.nam$b_nop = NAM$M_SYNCHK | NAM$M_NOCONCEAL;
3259 if (!(sys$parse(&dirfab) & 1)) {
3260 dirnam.nam$l_rlf = NULL;
3261 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3263 set_vaxc_errno(dirfab.fab$l_sts);
3266 retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
3267 if (buf) retspec = buf;
3268 else if (ts) New(1312,retspec,retlen+16,char);
3269 else retspec = __fileify_retbuf;
3270 cp1 = strstr(esa,"][");
3271 if (!cp1) cp1 = strstr(esa,"]<");
3273 memcpy(retspec,esa,dirlen);
3274 if (!strncmp(cp1+2,"000000]",7)) {
3275 retspec[dirlen-1] = '\0';
3276 for (cp1 = retspec+dirlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3277 if (*cp1 == '.') *cp1 = ']';
3279 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3280 memcpy(cp1+1,"000000]",7);
3284 memcpy(retspec+dirlen,cp1+2,retlen-dirlen);
3285 retspec[retlen] = '\0';
3286 /* Convert last '.' to ']' */
3287 for (cp1 = retspec+retlen-1; *cp1 != '.' && *cp1 != '['; cp1--) ;
3288 if (*cp1 == '.') *cp1 = ']';
3290 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
3291 memcpy(cp1+1,"000000]",7);
3295 else { /* This is a top-level dir. Add the MFD to the path. */
3296 if (buf) retspec = buf;
3297 else if (ts) New(1312,retspec,retlen+16,char);
3298 else retspec = __fileify_retbuf;
3301 while (*cp1 != ':') *(cp2++) = *(cp1++);
3302 strcpy(cp2,":[000000]");
3307 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3308 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3309 /* We've set up the string up through the filename. Add the
3310 type and version, and we're done. */
3311 strcat(retspec,".DIR;1");
3313 /* $PARSE may have upcased filespec, so convert output to lower
3314 * case if input contained any lowercase characters. */
3315 if (haslower) __mystrtolower(retspec);
3318 } /* end of do_fileify_dirspec() */
3320 /* External entry points */
3321 char *Perl_fileify_dirspec(pTHX_ char *dir, char *buf)
3322 { return do_fileify_dirspec(dir,buf,0); }
3323 char *Perl_fileify_dirspec_ts(pTHX_ char *dir, char *buf)
3324 { return do_fileify_dirspec(dir,buf,1); }
3326 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
3327 static char *mp_do_pathify_dirspec(pTHX_ char *dir,char *buf, int ts)
3329 static char __pathify_retbuf[NAM$C_MAXRSS+1];
3330 unsigned long int retlen;
3331 char *retpath, *cp1, *cp2, trndir[NAM$C_MAXRSS+1];
3333 if (!dir || !*dir) {
3334 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
3337 if (*dir) strcpy(trndir,dir);
3338 else getcwd(trndir,sizeof trndir - 1);
3340 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
3341 && my_trnlnm(trndir,trndir,0)) {
3342 STRLEN trnlen = strlen(trndir);
3344 /* Trap simple rooted lnms, and return lnm:[000000] */
3345 if (!strcmp(trndir+trnlen-2,".]")) {
3346 if (buf) retpath = buf;
3347 else if (ts) New(1318,retpath,strlen(dir)+10,char);
3348 else retpath = __pathify_retbuf;
3349 strcpy(retpath,dir);
3350 strcat(retpath,":[000000]");
3356 if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
3357 if (*dir == '.' && (*(dir+1) == '\0' ||
3358 (*(dir+1) == '.' && *(dir+2) == '\0')))
3359 retlen = 2 + (*(dir+1) != '\0');
3361 if ( !(cp1 = strrchr(dir,'/')) &&
3362 !(cp1 = strrchr(dir,']')) &&
3363 !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
3364 if ((cp2 = strchr(cp1,'.')) != NULL &&
3365 (*(cp2-1) != '/' || /* Trailing '.', '..', */
3366 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
3367 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
3368 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
3370 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3371 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3372 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3373 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3374 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3375 (ver || *cp3)))))) {
3377 set_vaxc_errno(RMS$_DIR);
3380 retlen = cp2 - dir + 1;
3382 else { /* No file type present. Treat the filename as a directory. */
3383 retlen = strlen(dir) + 1;
3386 if (buf) retpath = buf;
3387 else if (ts) New(1313,retpath,retlen+1,char);
3388 else retpath = __pathify_retbuf;
3389 strncpy(retpath,dir,retlen-1);
3390 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
3391 retpath[retlen-1] = '/'; /* with '/', add it. */
3392 retpath[retlen] = '\0';
3394 else retpath[retlen-1] = '\0';
3396 else { /* VMS-style directory spec */
3397 char esa[NAM$C_MAXRSS+1], *cp;
3398 unsigned long int sts, cmplen, haslower;
3399 struct FAB dirfab = cc$rms_fab;
3400 struct NAM savnam, dirnam = cc$rms_nam;
3402 /* If we've got an explicit filename, we can just shuffle the string. */
3403 if ( ( (cp1 = strrchr(dir,']')) != NULL ||
3404 (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
3405 if ((cp2 = strchr(cp1,'.')) != NULL) {
3407 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
3408 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
3409 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
3410 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
3411 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
3412 (ver || *cp3)))))) {
3414 set_vaxc_errno(RMS$_DIR);
3418 else { /* No file type, so just draw name into directory part */
3419 for (cp2 = cp1; *cp2; cp2++) ;
3422 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
3424 /* We've now got a VMS 'path'; fall through */
3426 dirfab.fab$b_fns = strlen(dir);
3427 dirfab.fab$l_fna = dir;
3428 if (dir[dirfab.fab$b_fns-1] == ']' ||
3429 dir[dirfab.fab$b_fns-1] == '>' ||
3430 dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
3431 if (buf) retpath = buf;
3432 else if (ts) New(1314,retpath,strlen(dir)+1,char);
3433 else retpath = __pathify_retbuf;
3434 strcpy(retpath,dir);
3437 dirfab.fab$l_dna = ".DIR;1";
3438 dirfab.fab$b_dns = 6;
3439 dirfab.fab$l_nam = &dirnam;
3440 dirnam.nam$b_ess = (unsigned char) sizeof esa - 1;
3441 dirnam.nam$l_esa = esa;
3443 for (cp = dir; *cp; cp++)
3444 if (islower(*cp)) { haslower = 1; break; }
3446 if (!(sts = (sys$parse(&dirfab)&1))) {
3447 if (dirfab.fab$l_sts == RMS$_DIR) {
3448 dirnam.nam$b_nop |= NAM$M_SYNCHK;
3449 sts = sys$parse(&dirfab) & 1;
3453 set_vaxc_errno(dirfab.fab$l_sts);
3459 if (!(sys$search(&dirfab)&1)) { /* Does the file really exist? */
3460 if (dirfab.fab$l_sts != RMS$_FNF) {
3461 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3462 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3464 set_vaxc_errno(dirfab.fab$l_sts);
3467 dirnam = savnam; /* No; just work with potential name */
3470 if (dirnam.nam$l_fnb & NAM$M_EXP_TYPE) { /* Was type specified? */
3471 /* Yep; check version while we're at it, if it's there. */
3472 cmplen = (dirnam.nam$l_fnb & NAM$M_EXP_VER) ? 6 : 4;
3473 if (strncmp(dirnam.nam$l_type,".DIR;1",cmplen)) {
3474 /* Something other than .DIR[;1]. Bzzt. */
3475 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3476 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3478 set_vaxc_errno(RMS$_DIR);
3482 /* OK, the type was fine. Now pull any file name into the
3484 if ((cp1 = strrchr(esa,']'))) *dirnam.nam$l_type = ']';
3486 cp1 = strrchr(esa,'>');
3487 *dirnam.nam$l_type = '>';
3490 *(dirnam.nam$l_type + 1) = '\0';
3491 retlen = dirnam.nam$l_type - esa + 2;
3492 if (buf) retpath = buf;
3493 else if (ts) New(1314,retpath,retlen,char);
3494 else retpath = __pathify_retbuf;
3495 strcpy(retpath,esa);
3496 dirnam.nam$b_nop |= NAM$M_SYNCHK; dirnam.nam$l_rlf = NULL;
3497 dirfab.fab$b_dns = 0; (void) sys$parse(&dirfab,0,0);
3498 /* $PARSE may have upcased filespec, so convert output to lower
3499 * case if input contained any lowercase characters. */
3500 if (haslower) __mystrtolower(retpath);
3504 } /* end of do_pathify_dirspec() */
3506 /* External entry points */
3507 char *Perl_pathify_dirspec(pTHX_ char *dir, char *buf)
3508 { return do_pathify_dirspec(dir,buf,0); }
3509 char *Perl_pathify_dirspec_ts(pTHX_ char *dir, char *buf)
3510 { return do_pathify_dirspec(dir,buf,1); }
3512 /*{{{ char *tounixspec[_ts](char *path, char *buf)*/
3513 static char *mp_do_tounixspec(pTHX_ char *spec, char *buf, int ts)
3515 static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
3516 char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
3517 int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
3519 if (spec == NULL) return NULL;
3520 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
3521 if (buf) rslt = buf;
3523 retlen = strlen(spec);
3524 cp1 = strchr(spec,'[');
3525 if (!cp1) cp1 = strchr(spec,'<');
3527 for (cp1++; *cp1; cp1++) {
3528 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
3529 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
3530 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
3533 New(1315,rslt,retlen+2+2*expand,char);
3535 else rslt = __tounixspec_retbuf;
3536 if (strchr(spec,'/') != NULL) {
3543 dirend = strrchr(spec,']');
3544 if (dirend == NULL) dirend = strrchr(spec,'>');
3545 if (dirend == NULL) dirend = strchr(spec,':');
3546 if (dirend == NULL) {
3550 if (*cp2 != '[' && *cp2 != '<') {
3553 else { /* the VMS spec begins with directories */
3555 if (*cp2 == ']' || *cp2 == '>') {
3556 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
3559 else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
3560 if (getcwd(tmp,sizeof tmp,1) == NULL) {
3561 if (ts) Safefree(rslt);
3566 while (*cp3 != ':' && *cp3) cp3++;
3568 if (strchr(cp3,']') != NULL) break;
3569 } while (vmstrnenv(tmp,tmp,0,fildev,0));
3571 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
3572 retlen = devlen + dirlen;
3573 Renew(rslt,retlen+1+2*expand,char);
3579 *(cp1++) = *(cp3++);
3580 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
3584 else if ( *cp2 == '.') {
3585 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
3586 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3592 for (; cp2 <= dirend; cp2++) {
3595 if (*(cp2+1) == '[') cp2++;
3597 else if (*cp2 == ']' || *cp2 == '>') {
3598 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
3600 else if (*cp2 == '.') {
3602 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
3603 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
3604 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
3605 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
3606 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
3608 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
3609 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
3613 else if (*cp2 == '-') {
3614 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
3615 while (*cp2 == '-') {
3617 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
3619 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
3620 if (ts) Safefree(rslt); /* filespecs like */
3621 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
3625 else *(cp1++) = *cp2;
3627 else *(cp1++) = *cp2;
3629 while (*cp2) *(cp1++) = *(cp2++);
3634 } /* end of do_tounixspec() */
3636 /* External entry points */
3637 char *Perl_tounixspec(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
3638 char *Perl_tounixspec_ts(pTHX_ char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
3640 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
3641 static char *mp_do_tovmsspec(pTHX_ char *path, char *buf, int ts) {
3642 static char __tovmsspec_retbuf[NAM$C_MAXRSS+1];
3643 char *rslt, *dirend;
3644 register char *cp1, *cp2;
3645 unsigned long int infront = 0, hasdir = 1;
3647 if (path == NULL) return NULL;
3648 if (buf) rslt = buf;
3649 else if (ts) New(1316,rslt,strlen(path)+9,char);
3650 else rslt = __tovmsspec_retbuf;
3651 if (strpbrk(path,"]:>") ||
3652 (dirend = strrchr(path,'/')) == NULL) {
3653 if (path[0] == '.') {
3654 if (path[1] == '\0') strcpy(rslt,"[]");
3655 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
3656 else strcpy(rslt,path); /* probably garbage */
3658 else strcpy(rslt,path);
3661 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
3662 if (!*(dirend+2)) dirend +=2;
3663 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
3664 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
3669 char trndev[NAM$C_MAXRSS+1];
3673 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
3675 if (!buf & ts) Renew(rslt,18,char);
3676 strcpy(rslt,"sys$disk:[000000]");
3679 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
3681 islnm = my_trnlnm(rslt,trndev,0);
3682 trnend = islnm ? strlen(trndev) - 1 : 0;
3683 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
3684 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
3685 /* If the first element of the path is a logical name, determine
3686 * whether it has to be translated so we can add more directories. */
3687 if (!islnm || rooted) {
3690 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
3694 if (cp2 != dirend) {
3695 if (!buf && ts) Renew(rslt,strlen(path)-strlen(rslt)+trnend+4,char);
3696 strcpy(rslt,trndev);
3697 cp1 = rslt + trnend;
3710 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
3711 cp2 += 2; /* skip over "./" - it's redundant */
3712 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
3714 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3715 *(cp1++) = '-'; /* "../" --> "-" */
3718 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
3719 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
3720 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3721 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
3724 if (cp2 > dirend) cp2 = dirend;
3726 else *(cp1++) = '.';
3728 for (; cp2 < dirend; cp2++) {
3730 if (*(cp2-1) == '/') continue;
3731 if (*(cp1-1) != '.') *(cp1++) = '.';
3734 else if (!infront && *cp2 == '.') {
3735 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
3736 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
3737 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
3738 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
3739 else if (*(cp1-2) == '[') *(cp1-1) = '-';
3740 else { /* back up over previous directory name */
3742 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
3743 if (*(cp1-1) == '[') {
3744 memcpy(cp1,"000000.",7);
3749 if (cp2 == dirend) break;
3751 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
3752 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
3753 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
3754 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
3756 *(cp1++) = '.'; /* Simulate trailing '/' */
3757 cp2 += 2; /* for loop will incr this to == dirend */
3759 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
3761 else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
3764 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
3765 if (*cp2 == '.') *(cp1++) = '_';
3766 else *(cp1++) = *cp2;
3770 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
3771 if (hasdir) *(cp1++) = ']';
3772 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
3773 while (*cp2) *(cp1++) = *(cp2++);
3778 } /* end of do_tovmsspec() */
3780 /* External entry points */
3781 char *Perl_tovmsspec(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,0); }
3782 char *Perl_tovmsspec_ts(pTHX_ char *path, char *buf) { return do_tovmsspec(path,buf,1); }
3784 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
3785 static char *mp_do_tovmspath(pTHX_ char *path, char *buf, int ts) {
3786 static char __tovmspath_retbuf[NAM$C_MAXRSS+1];
3788 char pathified[NAM$C_MAXRSS+1], vmsified[NAM$C_MAXRSS+1], *cp;
3790 if (path == NULL) return NULL;
3791 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3792 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) return NULL;
3793 if (buf) return buf;
3795 vmslen = strlen(vmsified);
3796 New(1317,cp,vmslen+1,char);
3797 memcpy(cp,vmsified,vmslen);
3802 strcpy(__tovmspath_retbuf,vmsified);
3803 return __tovmspath_retbuf;
3806 } /* end of do_tovmspath() */
3808 /* External entry points */
3809 char *Perl_tovmspath(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,0); }
3810 char *Perl_tovmspath_ts(pTHX_ char *path, char *buf) { return do_tovmspath(path,buf,1); }
3813 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
3814 static char *mp_do_tounixpath(pTHX_ char *path, char *buf, int ts) {
3815 static char __tounixpath_retbuf[NAM$C_MAXRSS+1];
3817 char pathified[NAM$C_MAXRSS+1], unixified[NAM$C_MAXRSS+1], *cp;
3819 if (path == NULL) return NULL;
3820 if (do_pathify_dirspec(path,pathified,0) == NULL) return NULL;
3821 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) return NULL;
3822 if (buf) return buf;
3824 unixlen = strlen(unixified);
3825 New(1317,cp,unixlen+1,char);
3826 memcpy(cp,unixified,unixlen);
3831 strcpy(__tounixpath_retbuf,unixified);
3832 return __tounixpath_retbuf;
3835 } /* end of do_tounixpath() */
3837 /* External entry points */
3838 char *Perl_tounixpath(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,0); }
3839 char *Perl_tounixpath_ts(pTHX_ char *path, char *buf) { return do_tounixpath(path,buf,1); }
3842 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
3844 *****************************************************************************
3846 * Copyright (C) 1989-1994 by *
3847 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
3849 * Permission is hereby granted for the reproduction of this software, *
3850 * on condition that this copyright notice is included in the reproduction, *
3851 * and that such reproduction is not for purposes of profit or material *
3854 * 27-Aug-1994 Modified for inclusion in perl5 *
3855 * by Charles Bailey bailey@newman.upenn.edu *
3856 *****************************************************************************
3860 * getredirection() is intended to aid in porting C programs
3861 * to VMS (Vax-11 C). The native VMS environment does not support
3862 * '>' and '<' I/O redirection, or command line wild card expansion,
3863 * or a command line pipe mechanism using the '|' AND background
3864 * command execution '&'. All of these capabilities are provided to any
3865 * C program which calls this procedure as the first thing in the
3867 * The piping mechanism will probably work with almost any 'filter' type
3868 * of program. With suitable modification, it may useful for other
3869 * portability problems as well.
3871 * Author: Mark Pizzolato mark@infocomm.com
3875 struct list_item *next;
3879 static void add_item(struct list_item **head,
3880 struct list_item **tail,
3884 static void mp_expand_wild_cards(pTHX_ char *item,
3885 struct list_item **head,
3886 struct list_item **tail,
3889 static int background_process(int argc, char **argv);
3891 static void pipe_and_fork(pTHX_ char **cmargv);
3893 /*{{{ void getredirection(int *ac, char ***av)*/
3895 mp_getredirection(pTHX_ int *ac, char ***av)
3897 * Process vms redirection arg's. Exit if any error is seen.
3898 * If getredirection() processes an argument, it is erased
3899 * from the vector. getredirection() returns a new argc and argv value.
3900 * In the event that a background command is requested (by a trailing "&"),
3901 * this routine creates a background subprocess, and simply exits the program.
3903 * Warning: do not try to simplify the code for vms. The code
3904 * presupposes that getredirection() is called before any data is
3905 * read from stdin or written to stdout.
3907 * Normal usage is as follows:
3913 * getredirection(&argc, &argv);
3917 int argc = *ac; /* Argument Count */
3918 char **argv = *av; /* Argument Vector */
3919 char *ap; /* Argument pointer */
3920 int j; /* argv[] index */
3921 int item_count = 0; /* Count of Items in List */
3922 struct list_item *list_head = 0; /* First Item in List */
3923 struct list_item *list_tail; /* Last Item in List */
3924 char *in = NULL; /* Input File Name */
3925 char *out = NULL; /* Output File Name */
3926 char *outmode = "w"; /* Mode to Open Output File */
3927 char *err = NULL; /* Error File Name */
3928 char *errmode = "w"; /* Mode to Open Error File */
3929 int cmargc = 0; /* Piped Command Arg Count */
3930 char **cmargv = NULL;/* Piped Command Arg Vector */
3933 * First handle the case where the last thing on the line ends with
3934 * a '&'. This indicates the desire for the command to be run in a
3935 * subprocess, so we satisfy that desire.
3938 if (0 == strcmp("&", ap))
3939 exit(background_process(--argc, argv));
3940 if (*ap && '&' == ap[strlen(ap)-1])
3942 ap[strlen(ap)-1] = '\0';
3943 exit(background_process(argc, argv));
3946 * Now we handle the general redirection cases that involve '>', '>>',
3947 * '<', and pipes '|'.
3949 for (j = 0; j < argc; ++j)
3951 if (0 == strcmp("<", argv[j]))
3955 fprintf(stderr,"No input file after < on command line");
3956 exit(LIB$_WRONUMARG);
3961 if ('<' == *(ap = argv[j]))
3966 if (0 == strcmp(">", ap))
3970 fprintf(stderr,"No output file after > on command line");
3971 exit(LIB$_WRONUMARG);
3990 fprintf(stderr,"No output file after > or >> on command line");
3991 exit(LIB$_WRONUMARG);
3995 if (('2' == *ap) && ('>' == ap[1]))
4012 fprintf(stderr,"No output file after 2> or 2>> on command line");
4013 exit(LIB$_WRONUMARG);
4017 if (0 == strcmp("|", argv[j]))
4021 fprintf(stderr,"No command into which to pipe on command line");
4022 exit(LIB$_WRONUMARG);
4024 cmargc = argc-(j+1);
4025 cmargv = &argv[j+1];
4029 if ('|' == *(ap = argv[j]))
4037 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
4040 * Allocate and fill in the new argument vector, Some Unix's terminate
4041 * the list with an extra null pointer.
4043 New(1302, argv, item_count+1, char *);
4045 for (j = 0; j < item_count; ++j, list_head = list_head->next)
4046 argv[j] = list_head->value;
4052 fprintf(stderr,"'|' and '>' may not both be specified on command line");
4053 exit(LIB$_INVARGORD);
4055 pipe_and_fork(aTHX_ cmargv);
4058 /* Check for input from a pipe (mailbox) */
4060 if (in == NULL && 1 == isapipe(0))
4062 char mbxname[L_tmpnam];
4064 long int dvi_item = DVI$_DEVBUFSIZ;
4065 $DESCRIPTOR(mbxnam, "");
4066 $DESCRIPTOR(mbxdevnam, "");
4068 /* Input from a pipe, reopen it in binary mode to disable */
4069 /* carriage control processing. */
4071 fgetname(stdin, mbxname);
4072 mbxnam.dsc$a_pointer = mbxname;
4073 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
4074 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
4075 mbxdevnam.dsc$a_pointer = mbxname;
4076 mbxdevnam.dsc$w_length = sizeof(mbxname);
4077 dvi_item = DVI$_DEVNAM;
4078 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
4079 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
4082 freopen(mbxname, "rb", stdin);
4085 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
4089 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
4091 fprintf(stderr,"Can't open input file %s as stdin",in);
4094 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
4096 fprintf(stderr,"Can't open output file %s as stdout",out);
4099 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
4102 if (strcmp(err,"&1") == 0) {
4103 dup2(fileno(stdout), fileno(stderr));
4104 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
4107 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
4109 fprintf(stderr,"Can't open error file %s as stderr",err);
4113 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
4117 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
4120 #ifdef ARGPROC_DEBUG
4121 PerlIO_printf(Perl_debug_log, "Arglist:\n");
4122 for (j = 0; j < *ac; ++j)
4123 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
4125 /* Clear errors we may have hit expanding wildcards, so they don't
4126 show up in Perl's $! later */
4127 set_errno(0); set_vaxc_errno(1);
4128 } /* end of getredirection() */
4131 static void add_item(struct list_item **head,
4132 struct list_item **tail,
4138 New(1303,*head,1,struct list_item);
4142 New(1304,(*tail)->next,1,struct list_item);
4143 *tail = (*tail)->next;
4145 (*tail)->value = value;
4149 static void mp_expand_wild_cards(pTHX_ char *item,
4150 struct list_item **head,
4151 struct list_item **tail,
4155 unsigned long int context = 0;
4161 char vmsspec[NAM$C_MAXRSS+1];
4162 $DESCRIPTOR(filespec, "");
4163 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
4164 $DESCRIPTOR(resultspec, "");
4165 unsigned long int zero = 0, sts;
4167 for (cp = item; *cp; cp++) {
4168 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
4169 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
4171 if (!*cp || isspace(*cp))
4173 add_item(head, tail, item, count);
4176 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
4177 resultspec.dsc$b_class = DSC$K_CLASS_D;
4178 resultspec.dsc$a_pointer = NULL;
4179 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
4180 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
4181 if (!isunix || !filespec.dsc$a_pointer)
4182 filespec.dsc$a_pointer = item;
4183 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
4185 * Only return version specs, if the caller specified a version
4187 had_version = strchr(item, ';');
4189 * Only return device and directory specs, if the caller specifed either.
4191 had_device = strchr(item, ':');
4192 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
4194 while (1 == (1 & (sts = lib$find_file(&filespec, &resultspec, &context,
4195 &defaultspec, 0, 0, &zero))))
4200 New(1305,string,resultspec.dsc$w_length+1,char);
4201 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
4202 string[resultspec.dsc$w_length] = '\0';
4203 if (NULL == had_version)
4204 *((char *)strrchr(string, ';')) = '\0';
4205 if ((!had_directory) && (had_device == NULL))
4207 if (NULL == (devdir = strrchr(string, ']')))
4208 devdir = strrchr(string, '>');
4209 strcpy(string, devdir + 1);
4212 * Be consistent with what the C RTL has already done to the rest of
4213 * the argv items and lowercase all of these names.
4215 for (c = string; *c; ++c)
4218 if (isunix) trim_unixpath(string,item,1);
4219 add_item(head, tail, string, count);
4222 if (sts != RMS$_NMF)
4224 set_vaxc_errno(sts);
4227 case RMS$_FNF: case RMS$_DNF:
4228 set_errno(ENOENT); break;
4230 set_errno(ENOTDIR); break;
4232 set_errno(ENODEV); break;
4233 case RMS$_FNM: case RMS$_SYN:
4234 set_errno(EINVAL); break;
4236 set_errno(EACCES); break;
4238 _ckvmssts_noperl(sts);
4242 add_item(head, tail, item, count);
4243 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
4244 _ckvmssts_noperl(lib$find_file_end(&context));
4247 static int child_st[2];/* Event Flag set when child process completes */
4249 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
4251 static unsigned long int exit_handler(int *status)
4255 if (0 == child_st[0])
4257 #ifdef ARGPROC_DEBUG
4258 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
4260 fflush(stdout); /* Have to flush pipe for binary data to */
4261 /* terminate properly -- <tp@mccall.com> */
4262 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
4263 sys$dassgn(child_chan);
4265 sys$synch(0, child_st);
4270 static void sig_child(int chan)
4272 #ifdef ARGPROC_DEBUG
4273 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
4275 if (child_st[0] == 0)
4279 static struct exit_control_block exit_block =
4284 &exit_block.exit_status,
4289 pipe_and_fork(pTHX_ char **cmargv)
4292 struct dsc$descriptor_s *vmscmd;
4293 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
4294 int sts, j, l, ismcr, quote, tquote = 0;
4296 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
4297 vms_execfree(vmscmd);
4302 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
4303 && toupper(*(q+2)) == 'R' && !*(q+3);
4305 while (q && l < MAX_DCL_LINE_LENGTH) {
4307 if (j > 0 && quote) {
4313 if (ismcr && j > 1) quote = 1;
4314 tquote = (strchr(q,' ')) != NULL || *q == '\0';
4317 if (quote || tquote) {
4323 if ((quote||tquote) && *q == '"') {
4333 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
4335 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
4339 static int background_process(int argc, char **argv)
4341 char command[2048] = "$";
4342 $DESCRIPTOR(value, "");
4343 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
4344 static $DESCRIPTOR(null, "NLA0:");
4345 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
4347 $DESCRIPTOR(pidstr, "");
4349 unsigned long int flags = 17, one = 1, retsts;
4351 strcat(command, argv[0]);
4354 strcat(command, " \"");
4355 strcat(command, *(++argv));
4356 strcat(command, "\"");
4358 value.dsc$a_pointer = command;
4359 value.dsc$w_length = strlen(value.dsc$a_pointer);
4360 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
4361 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
4362 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
4363 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
4366 _ckvmssts_noperl(retsts);
4368 #ifdef ARGPROC_DEBUG
4369 PerlIO_printf(Perl_debug_log, "%s\n", command);
4371 sprintf(pidstring, "%08X", pid);
4372 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
4373 pidstr.dsc$a_pointer = pidstring;
4374 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
4375 lib$set_symbol(&pidsymbol, &pidstr);
4379 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
4382 /* OS-specific initialization at image activation (not thread startup) */
4383 /* Older VAXC header files lack these constants */
4384 #ifndef JPI$_RIGHTS_SIZE
4385 # define JPI$_RIGHTS_SIZE 817
4387 #ifndef KGB$M_SUBSYSTEM
4388 # define KGB$M_SUBSYSTEM 0x8
4391 /*{{{void vms_image_init(int *, char ***)*/
4393 vms_image_init(int *argcp, char ***argvp)
4395 char eqv[LNM$C_NAMLENGTH+1] = "";
4396 unsigned int len, tabct = 8, tabidx = 0;
4397 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
4398 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
4399 unsigned short int dummy, rlen;
4400 struct dsc$descriptor_s **tabvec;
4401 #if defined(PERL_IMPLICIT_CONTEXT)
4404 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
4405 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
4406 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
4409 #ifdef KILL_BY_SIGPRC
4410 (void) Perl_csighandler_init();
4413 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
4414 _ckvmssts_noperl(iosb[0]);
4415 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
4416 if (iprv[i]) { /* Running image installed with privs? */
4417 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
4422 /* Rights identifiers might trigger tainting as well. */
4423 if (!will_taint && (rlen || rsz)) {
4424 while (rlen < rsz) {
4425 /* We didn't get all the identifiers on the first pass. Allocate a
4426 * buffer much larger than $GETJPI wants (rsz is size in bytes that
4427 * were needed to hold all identifiers at time of last call; we'll
4428 * allocate that many unsigned long ints), and go back and get 'em.
4429 * If it gave us less than it wanted to despite ample buffer space,
4430 * something's broken. Is your system missing a system identifier?
4432 if (rsz <= jpilist[1].buflen) {
4433 /* Perl_croak accvios when used this early in startup. */
4434 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
4435 rsz, (unsigned long) jpilist[1].buflen,
4436 "Check your rights database for corruption.\n");
4439 if (jpilist[1].bufadr != rlst) Safefree(jpilist[1].bufadr);
4440 jpilist[1].bufadr = New(1320,mask,rsz,unsigned long int);
4441 jpilist[1].buflen = rsz * sizeof(unsigned long int);
4442 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
4443 _ckvmssts_noperl(iosb[0]);
4445 mask = jpilist[1].bufadr;
4446 /* Check attribute flags for each identifier (2nd longword); protected
4447 * subsystem identifiers trigger tainting.
4449 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
4450 if (mask[i] & KGB$M_SUBSYSTEM) {
4455 if (mask != rlst) Safefree(mask);
4457 /* We need to use this hack to tell Perl it should run with tainting,
4458 * since its tainting flag may be part of the PL_curinterp struct, which
4459 * hasn't been allocated when vms_image_init() is called.
4463 New(1320,newap,*argcp+2,char **);
4464 newap[0] = argvp[0];
4466 Copy(argvp[1],newap[2],*argcp-1,char **);
4467 /* We orphan the old argv, since we don't know where it's come from,
4468 * so we don't know how to free it.
4470 *argcp++; argvp = newap;
4472 else { /* Did user explicitly request tainting? */
4474 char *cp, **av = *argvp;
4475 for (i = 1; i < *argcp; i++) {
4476 if (*av[i] != '-') break;
4477 for (cp = av[i]+1; *cp; cp++) {
4478 if (*cp == 'T') { will_taint = 1; break; }
4479 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
4480 strchr("DFIiMmx",*cp)) break;
4482 if (will_taint) break;
4487 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
4489 if (!tabidx) New(1321,tabvec,tabct,struct dsc$descriptor_s *);
4490 else if (tabidx >= tabct) {
4492 Renew(tabvec,tabct,struct dsc$descriptor_s *);
4494 New(1322,tabvec[tabidx],1,struct dsc$descriptor_s);
4495 tabvec[tabidx]->dsc$w_length = 0;
4496 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
4497 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
4498 tabvec[tabidx]->dsc$a_pointer = NULL;
4499 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
4501 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
4503 getredirection(argcp,argvp);
4504 #if defined(USE_5005THREADS) && ( defined(__DECC) || defined(__DECCXX) )
4506 # include <reentrancy.h>
4507 (void) decc$set_reentrancy(C$C_MULTITHREAD);
4516 * Trim Unix-style prefix off filespec, so it looks like what a shell
4517 * glob expansion would return (i.e. from specified prefix on, not
4518 * full path). Note that returned filespec is Unix-style, regardless
4519 * of whether input filespec was VMS-style or Unix-style.
4521 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
4522 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
4523 * vector of options; at present, only bit 0 is used, and if set tells
4524 * trim unixpath to try the current default directory as a prefix when
4525 * presented with a possibly ambiguous ... wildcard.
4527 * Returns !=0 on success, with trimmed filespec replacing contents of
4528 * fspec, and 0 on failure, with contents of fpsec unchanged.
4530 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
4532 Perl_trim_unixpath(pTHX_ char *fspec, char *wildspec, int opts)
4534 char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
4535 *template, *base, *end, *cp1, *cp2;
4536 register int tmplen, reslen = 0, dirs = 0;
4538 if (!wildspec || !fspec) return 0;
4539 if (strpbrk(wildspec,"]>:") != NULL) {
4540 if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
4541 else template = unixwild;
4543 else template = wildspec;
4544 if (strpbrk(fspec,"]>:") != NULL) {
4545 if (do_tounixspec(fspec,unixified,0) == NULL) return 0;
4546 else base = unixified;
4547 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
4548 * check to see that final result fits into (isn't longer than) fspec */
4549 reslen = strlen(fspec);
4553 /* No prefix or absolute path on wildcard, so nothing to remove */
4554 if (!*template || *template == '/') {
4555 if (base == fspec) return 1;
4556 tmplen = strlen(unixified);
4557 if (tmplen > reslen) return 0; /* not enough space */
4558 /* Copy unixified resultant, including trailing NUL */
4559 memmove(fspec,unixified,tmplen+1);
4563 for (end = base; *end; end++) ; /* Find end of resultant filespec */
4564 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
4565 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
4566 for (cp1 = end ;cp1 >= base; cp1--)
4567 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
4569 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
4573 char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
4574 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
4575 int ells = 1, totells, segdirs, match;
4576 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
4577 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4579 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
4581 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
4582 if (ellipsis == template && opts & 1) {
4583 /* Template begins with an ellipsis. Since we can't tell how many
4584 * directory names at the front of the resultant to keep for an
4585 * arbitrary starting point, we arbitrarily choose the current
4586 * default directory as a starting point. If it's there as a prefix,
4587 * clip it off. If not, fall through and act as if the leading
4588 * ellipsis weren't there (i.e. return shortest possible path that
4589 * could match template).
4591 if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
4592 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4593 if (_tolower(*cp1) != _tolower(*cp2)) break;
4594 segdirs = dirs - totells; /* Min # of dirs we must have left */
4595 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
4596 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
4597 memcpy(fspec,cp2+1,end - cp2);
4601 /* First off, back up over constant elements at end of path */
4603 for (front = end ; front >= base; front--)
4604 if (*front == '/' && !dirs--) { front++; break; }
4606 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + sizeof lcres;
4607 cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
4608 if (cp1 != '\0') return 0; /* Path too long. */
4610 *cp2 = '\0'; /* Pick up with memcpy later */
4611 lcfront = lcres + (front - base);
4612 /* Now skip over each ellipsis and try to match the path in front of it. */
4614 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
4615 if (*(cp1) == '.' && *(cp1+1) == '.' &&
4616 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
4617 if (cp1 < template) break; /* template started with an ellipsis */
4618 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
4619 ellipsis = cp1; continue;
4621 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
4623 for (segdirs = 0, cp2 = tpl;
4624 cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
4626 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
4627 else *cp2 = _tolower(*cp1); /* else lowercase for match */
4628 if (*cp2 == '/') segdirs++;
4630 if (cp1 != ellipsis - 1) return 0; /* Path too long */
4631 /* Back up at least as many dirs as in template before matching */
4632 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
4633 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
4634 for (match = 0; cp1 > lcres;) {
4635 resdsc.dsc$a_pointer = cp1;
4636 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
4638 if (match == 1) lcfront = cp1;
4640 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
4642 if (!match) return 0; /* Can't find prefix ??? */
4643 if (match > 1 && opts & 1) {
4644 /* This ... wildcard could cover more than one set of dirs (i.e.
4645 * a set of similar dir names is repeated). If the template
4646 * contains more than 1 ..., upstream elements could resolve the
4647 * ambiguity, but it's not worth a full backtracking setup here.
4648 * As a quick heuristic, clip off the current default directory
4649 * if it's present to find the trimmed spec, else use the
4650 * shortest string that this ... could cover.
4652 char def[NAM$C_MAXRSS+1], *st;
4654 if (getcwd(def, sizeof def,0) == NULL) return 0;
4655 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
4656 if (_tolower(*cp1) != _tolower(*cp2)) break;
4657 segdirs = dirs - totells; /* Min # of dirs we must have left */
4658 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
4659 if (*cp1 == '\0' && *cp2 == '/') {
4660 memcpy(fspec,cp2+1,end - cp2);
4663 /* Nope -- stick with lcfront from above and keep going. */
4666 memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
4671 } /* end of trim_unixpath() */
4676 * VMS readdir() routines.
4677 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
4679 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
4680 * Minor modifications to original routines.
4683 /* Number of elements in vms_versions array */
4684 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
4687 * Open a directory, return a handle for later use.
4689 /*{{{ DIR *opendir(char*name) */
4691 Perl_opendir(pTHX_ char *name)
4694 char dir[NAM$C_MAXRSS+1];
4697 if (do_tovmspath(name,dir,0) == NULL) {
4700 /* Check access before stat; otherwise stat does not
4701 * accurately report whether it's a directory.
4703 if (!cando_by_name(S_IRUSR,0,dir)) {
4704 set_errno(EACCES); set_vaxc_errno(RMS$_PRV);
4707 if (flex_stat(dir,&sb) == -1) return NULL;
4708 if (!S_ISDIR(sb.st_mode)) {
4709 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
4712 /* Get memory for the handle, and the pattern. */
4714 New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
4716 /* Fill in the fields; mainly playing with the descriptor. */
4717 (void)sprintf(dd->pattern, "%s*.*",dir);
4720 dd->vms_wantversions = 0;
4721 dd->pat.dsc$a_pointer = dd->pattern;
4722 dd->pat.dsc$w_length = strlen(dd->pattern);
4723 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
4724 dd->pat.dsc$b_class = DSC$K_CLASS_S;
4727 } /* end of opendir() */
4731 * Set the flag to indicate we want versions or not.
4733 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
4735 vmsreaddirversions(DIR *dd, int flag)
4737 dd->vms_wantversions = flag;
4742 * Free up an opened directory.
4744 /*{{{ void closedir(DIR *dd)*/
4748 (void)lib$find_file_end(&dd->context);
4749 Safefree(dd->pattern);
4750 Safefree((char *)dd);
4755 * Collect all the version numbers for the current file.
4758 collectversions(pTHX_ DIR *dd)
4760 struct dsc$descriptor_s pat;
4761 struct dsc$descriptor_s res;
4763 char *p, *text, buff[sizeof dd->entry.d_name];
4765 unsigned long context, tmpsts;
4767 /* Convenient shorthand. */
4770 /* Add the version wildcard, ignoring the "*.*" put on before */
4771 i = strlen(dd->pattern);
4772 New(1308,text,i + e->d_namlen + 3,char);
4773 (void)strcpy(text, dd->pattern);
4774 (void)sprintf(&text[i - 3], "%s;*", e->d_name);
4776 /* Set up the pattern descriptor. */
4777 pat.dsc$a_pointer = text;
4778 pat.dsc$w_length = i + e->d_namlen - 1;
4779 pat.dsc$b_dtype = DSC$K_DTYPE_T;
4780 pat.dsc$b_class = DSC$K_CLASS_S;
4782 /* Set up result descriptor. */
4783 res.dsc$a_pointer = buff;
4784 res.dsc$w_length = sizeof buff - 2;
4785 res.dsc$b_dtype = DSC$K_DTYPE_T;
4786 res.dsc$b_class = DSC$K_CLASS_S;
4788 /* Read files, collecting versions. */
4789 for (context = 0, e->vms_verscount = 0;
4790 e->vms_verscount < VERSIZE(e);
4791 e->vms_verscount++) {
4792 tmpsts = lib$find_file(&pat, &res, &context);
4793 if (tmpsts == RMS$_NMF || context == 0) break;
4795 buff[sizeof buff - 1] = '\0';
4796 if ((p = strchr(buff, ';')))
4797 e->vms_versions[e->vms_verscount] = atoi(p + 1);
4799 e->vms_versions[e->vms_verscount] = -1;
4802 _ckvmssts(lib$find_file_end(&context));
4805 } /* end of collectversions() */
4808 * Read the next entry from the directory.
4810 /*{{{ struct dirent *readdir(DIR *dd)*/
4812 Perl_readdir(pTHX_ DIR *dd)
4814 struct dsc$descriptor_s res;
4815 char *p, buff[sizeof dd->entry.d_name];
4816 unsigned long int tmpsts;
4818 /* Set up result descriptor, and get next file. */
4819 res.dsc$a_pointer = buff;
4820 res.dsc$w_length = sizeof buff - 2;
4821 res.dsc$b_dtype = DSC$K_DTYPE_T;
4822 res.dsc$b_class = DSC$K_CLASS_S;
4823 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
4824 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
4825 if (!(tmpsts & 1)) {
4826 set_vaxc_errno(tmpsts);
4829 set_errno(EACCES); break;
4831 set_errno(ENODEV); break;
4833 set_errno(ENOTDIR); break;
4834 case RMS$_FNF: case RMS$_DNF:
4835 set_errno(ENOENT); break;
4842 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
4843 buff[sizeof buff - 1] = '\0';
4844 for (p = buff; *p; p++) *p = _tolower(*p);
4845 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
4848 /* Skip any directory component and just copy the name. */
4849 if ((p = strchr(buff, ']'))) (void)strcpy(dd->entry.d_name, p + 1);
4850 else (void)strcpy(dd->entry.d_name, buff);
4852 /* Clobber the version. */
4853 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
4855 dd->entry.d_namlen = strlen(dd->entry.d_name);
4856 dd->entry.vms_verscount = 0;
4857 if (dd->vms_wantversions) collectversions(aTHX_ dd);
4860 } /* end of readdir() */
4864 * Return something that can be used in a seekdir later.
4866 /*{{{ long telldir(DIR *dd)*/
4875 * Return to a spot where we used to be. Brute force.
4877 /*{{{ void seekdir(DIR *dd,long count)*/
4879 Perl_seekdir(pTHX_ DIR *dd, long count)
4881 int vms_wantversions;
4883 /* If we haven't done anything yet... */
4887 /* Remember some state, and clear it. */
4888 vms_wantversions = dd->vms_wantversions;
4889 dd->vms_wantversions = 0;
4890 _ckvmssts(lib$find_file_end(&dd->context));
4893 /* The increment is in readdir(). */
4894 for (dd->count = 0; dd->count < count; )
4897 dd->vms_wantversions = vms_wantversions;
4899 } /* end of seekdir() */
4902 /* VMS subprocess management
4904 * my_vfork() - just a vfork(), after setting a flag to record that
4905 * the current script is trying a Unix-style fork/exec.
4907 * vms_do_aexec() and vms_do_exec() are called in response to the
4908 * perl 'exec' function. If this follows a vfork call, then they
4909 * call out the the regular perl routines in doio.c which do an
4910 * execvp (for those who really want to try this under VMS).
4911 * Otherwise, they do exactly what the perl docs say exec should
4912 * do - terminate the current script and invoke a new command
4913 * (See below for notes on command syntax.)
4915 * do_aspawn() and do_spawn() implement the VMS side of the perl
4916 * 'system' function.
4918 * Note on command arguments to perl 'exec' and 'system': When handled
4919 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
4920 * are concatenated to form a DCL command string. If the first arg
4921 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
4922 * the the command string is handed off to DCL directly. Otherwise,
4923 * the first token of the command is taken as the filespec of an image
4924 * to run. The filespec is expanded using a default type of '.EXE' and
4925 * the process defaults for device, directory, etc., and if found, the resultant
4926 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
4927 * the command string as parameters. This is perhaps a bit complicated,
4928 * but I hope it will form a happy medium between what VMS folks expect
4929 * from lib$spawn and what Unix folks expect from exec.
4932 static int vfork_called;
4934 /*{{{int my_vfork()*/
4945 vms_execfree(struct dsc$descriptor_s *vmscmd)
4948 if (vmscmd->dsc$a_pointer) {
4949 Safefree(vmscmd->dsc$a_pointer);
4956 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
4958 char *junk, *tmps = Nullch;
4959 register size_t cmdlen = 0;
4966 tmps = SvPV(really,rlen);
4973 for (idx++; idx <= sp; idx++) {
4975 junk = SvPVx(*idx,rlen);
4976 cmdlen += rlen ? rlen + 1 : 0;
4979 New(401,PL_Cmd,cmdlen+1,char);
4981 if (tmps && *tmps) {
4982 strcpy(PL_Cmd,tmps);
4985 else *PL_Cmd = '\0';
4986 while (++mark <= sp) {
4988 char *s = SvPVx(*mark,n_a);
4990 if (*PL_Cmd) strcat(PL_Cmd," ");
4996 } /* end of setup_argstr() */
4999 static unsigned long int
5000 setup_cmddsc(pTHX_ char *cmd, int check_img, int *suggest_quote,
5001 struct dsc$descriptor_s **pvmscmd)
5003 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
5004 $DESCRIPTOR(defdsc,".EXE");
5005 $DESCRIPTOR(defdsc2,".");
5006 $DESCRIPTOR(resdsc,resspec);
5007 struct dsc$descriptor_s *vmscmd;
5008 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5009 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
5010 register char *s, *rest, *cp, *wordbreak;
5013 New(402,vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
5014 vmscmd->dsc$a_pointer = NULL;
5015 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
5016 vmscmd->dsc$b_class = DSC$K_CLASS_S;
5017 vmscmd->dsc$w_length = 0;
5018 if (pvmscmd) *pvmscmd = vmscmd;
5020 if (suggest_quote) *suggest_quote = 0;
5022 if (strlen(cmd) > MAX_DCL_LINE_LENGTH)
5023 return CLI$_BUFOVF; /* continuation lines currently unsupported */
5025 while (*s && isspace(*s)) s++;
5027 if (*s == '@' || *s == '$') {
5028 vmsspec[0] = *s; rest = s + 1;
5029 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
5031 else { cp = vmsspec; rest = s; }
5032 if (*rest == '.' || *rest == '/') {
5035 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
5036 rest++, cp2++) *cp2 = *rest;
5038 if (do_tovmsspec(resspec,cp,0)) {
5041 for (cp2 = vmsspec + strlen(vmsspec);
5042 *rest && cp2 - vmsspec < sizeof vmsspec;
5043 rest++, cp2++) *cp2 = *rest;
5048 /* Intuit whether verb (first word of cmd) is a DCL command:
5049 * - if first nonspace char is '@', it's a DCL indirection
5051 * - if verb contains a filespec separator, it's not a DCL command
5052 * - if it doesn't, caller tells us whether to default to a DCL
5053 * command, or to a local image unless told it's DCL (by leading '$')
5057 if (suggest_quote) *suggest_quote = 1;
5059 register char *filespec = strpbrk(s,":<[.;");
5060 rest = wordbreak = strpbrk(s," \"\t/");
5061 if (!wordbreak) wordbreak = s + strlen(s);
5062 if (*s == '$') check_img = 0;
5063 if (filespec && (filespec < wordbreak)) isdcl = 0;
5064 else isdcl = !check_img;
5068 imgdsc.dsc$a_pointer = s;
5069 imgdsc.dsc$w_length = wordbreak - s;
5070 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5072 _ckvmssts(lib$find_file_end(&cxt));
5073 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5074 if (!(retsts & 1) && *s == '$') {
5075 _ckvmssts(lib$find_file_end(&cxt));
5076 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
5077 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
5079 _ckvmssts(lib$find_file_end(&cxt));
5080 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
5084 _ckvmssts(lib$find_file_end(&cxt));
5089 while (*s && !isspace(*s)) s++;
5092 /* check that it's really not DCL with no file extension */
5093 fp = fopen(resspec,"r","ctx=bin,shr=get");
5095 char b[4] = {0,0,0,0};
5096 read(fileno(fp),b,4);
5097 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
5100 if (check_img && isdcl) return RMS$_FNF;
5102 if (cando_by_name(S_IXUSR,0,resspec)) {
5103 New(402,vmscmd->dsc$a_pointer,7 + s - resspec + (rest ? strlen(rest) : 0),char);
5105 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
5106 if (suggest_quote) *suggest_quote = 1;
5108 strcpy(vmscmd->dsc$a_pointer,"@");
5109 if (suggest_quote) *suggest_quote = 1;
5111 strcat(vmscmd->dsc$a_pointer,resspec);
5112 if (rest) strcat(vmscmd->dsc$a_pointer,rest);
5113 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
5114 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5116 else retsts = RMS$_PRV;
5119 /* It's either a DCL command or we couldn't find a suitable image */
5120 vmscmd->dsc$w_length = strlen(cmd);
5121 /* if (cmd == PL_Cmd) {
5122 vmscmd->dsc$a_pointer = PL_Cmd;
5123 if (suggest_quote) *suggest_quote = 1;
5126 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
5128 /* check if it's a symbol (for quoting purposes) */
5129 if (suggest_quote && !*suggest_quote) {
5131 char equiv[LNM$C_NAMLENGTH];
5132 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5133 eqvdsc.dsc$a_pointer = equiv;
5135 iss = lib$get_symbol(vmscmd,&eqvdsc);
5136 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
5138 if (!(retsts & 1)) {
5139 /* just hand off status values likely to be due to user error */
5140 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
5141 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
5142 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
5143 else { _ckvmssts(retsts); }
5146 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
5148 } /* end of setup_cmddsc() */
5151 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
5153 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
5156 if (vfork_called) { /* this follows a vfork - act Unixish */
5158 if (vfork_called < 0) {
5159 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5162 else return do_aexec(really,mark,sp);
5164 /* no vfork - act VMSish */
5165 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
5170 } /* end of vms_do_aexec() */
5173 /* {{{bool vms_do_exec(char *cmd) */
5175 Perl_vms_do_exec(pTHX_ char *cmd)
5177 struct dsc$descriptor_s *vmscmd;
5179 if (vfork_called) { /* this follows a vfork - act Unixish */
5181 if (vfork_called < 0) {
5182 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
5185 else return do_exec(cmd);
5188 { /* no vfork - act VMSish */
5189 unsigned long int retsts;
5192 TAINT_PROPER("exec");
5193 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
5194 retsts = lib$do_command(vmscmd);
5197 case RMS$_FNF: case RMS$_DNF:
5198 set_errno(ENOENT); break;
5200 set_errno(ENOTDIR); break;
5202 set_errno(ENODEV); break;
5204 set_errno(EACCES); break;
5206 set_errno(EINVAL); break;
5207 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5208 set_errno(E2BIG); break;
5209 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5210 _ckvmssts(retsts); /* fall through */
5211 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5214 set_vaxc_errno(retsts);
5215 if (ckWARN(WARN_EXEC)) {
5216 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
5217 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
5219 vms_execfree(vmscmd);
5224 } /* end of vms_do_exec() */
5227 unsigned long int Perl_do_spawn(pTHX_ char *);
5229 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
5231 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
5233 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
5236 } /* end of do_aspawn() */
5239 /* {{{unsigned long int do_spawn(char *cmd) */
5241 Perl_do_spawn(pTHX_ char *cmd)
5243 unsigned long int sts, substs;
5246 TAINT_PROPER("spawn");
5247 if (!cmd || !*cmd) {
5248 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
5251 case RMS$_FNF: case RMS$_DNF:
5252 set_errno(ENOENT); break;
5254 set_errno(ENOTDIR); break;
5256 set_errno(ENODEV); break;
5258 set_errno(EACCES); break;
5260 set_errno(EINVAL); break;
5261 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
5262 set_errno(E2BIG); break;
5263 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
5264 _ckvmssts(sts); /* fall through */
5265 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
5268 set_vaxc_errno(sts);
5269 if (ckWARN(WARN_EXEC)) {
5270 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
5277 (void) safe_popen(aTHX_ cmd, "nW", (int *)&sts);
5280 } /* end of do_spawn() */
5284 static unsigned int *sockflags, sockflagsize;
5287 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
5288 * routines found in some versions of the CRTL can't deal with sockets.
5289 * We don't shim the other file open routines since a socket isn't
5290 * likely to be opened by a name.
5292 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
5293 FILE *my_fdopen(int fd, const char *mode)
5295 FILE *fp = fdopen(fd, (char *) mode);
5298 unsigned int fdoff = fd / sizeof(unsigned int);
5299 struct stat sbuf; /* native stat; we don't need flex_stat */
5300 if (!sockflagsize || fdoff > sockflagsize) {
5301 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
5302 else New (1324,sockflags,fdoff+2,unsigned int);
5303 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
5304 sockflagsize = fdoff + 2;
5306 if (fstat(fd,&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
5307 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
5316 * Clear the corresponding bit when the (possibly) socket stream is closed.
5317 * There still a small hole: we miss an implicit close which might occur
5318 * via freopen(). >> Todo
5320 /*{{{ int my_fclose(FILE *fp)*/
5321 int my_fclose(FILE *fp) {
5323 unsigned int fd = fileno(fp);
5324 unsigned int fdoff = fd / sizeof(unsigned int);
5326 if (sockflagsize && fdoff <= sockflagsize)
5327 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
5335 * A simple fwrite replacement which outputs itmsz*nitm chars without
5336 * introducing record boundaries every itmsz chars.
5337 * We are using fputs, which depends on a terminating null. We may
5338 * well be writing binary data, so we need to accommodate not only
5339 * data with nulls sprinkled in the middle but also data with no null
5342 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
5344 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
5346 register char *cp, *end, *cpd, *data;
5347 register unsigned int fd = fileno(dest);
5348 register unsigned int fdoff = fd / sizeof(unsigned int);
5350 int bufsize = itmsz * nitm + 1;
5352 if (fdoff < sockflagsize &&
5353 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
5354 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
5358 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
5359 memcpy( data, src, itmsz*nitm );
5360 data[itmsz*nitm] = '\0';
5362 end = data + itmsz * nitm;
5363 retval = (int) nitm; /* on success return # items written */
5366 while (cpd <= end) {
5367 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
5368 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
5370 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
5374 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
5377 } /* end of my_fwrite() */
5380 /*{{{ int my_flush(FILE *fp)*/
5382 Perl_my_flush(pTHX_ FILE *fp)
5385 if ((res = fflush(fp)) == 0 && fp) {
5386 #ifdef VMS_DO_SOCKETS
5388 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
5390 res = fsync(fileno(fp));
5393 * If the flush succeeded but set end-of-file, we need to clear
5394 * the error because our caller may check ferror(). BTW, this
5395 * probably means we just flushed an empty file.
5397 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
5404 * Here are replacements for the following Unix routines in the VMS environment:
5405 * getpwuid Get information for a particular UIC or UID
5406 * getpwnam Get information for a named user
5407 * getpwent Get information for each user in the rights database
5408 * setpwent Reset search to the start of the rights database
5409 * endpwent Finish searching for users in the rights database
5411 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
5412 * (defined in pwd.h), which contains the following fields:-
5414 * char *pw_name; Username (in lower case)
5415 * char *pw_passwd; Hashed password
5416 * unsigned int pw_uid; UIC
5417 * unsigned int pw_gid; UIC group number
5418 * char *pw_unixdir; Default device/directory (VMS-style)
5419 * char *pw_gecos; Owner name
5420 * char *pw_dir; Default device/directory (Unix-style)
5421 * char *pw_shell; Default CLI name (eg. DCL)
5423 * If the specified user does not exist, getpwuid and getpwnam return NULL.
5425 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
5426 * not the UIC member number (eg. what's returned by getuid()),
5427 * getpwuid() can accept either as input (if uid is specified, the caller's
5428 * UIC group is used), though it won't recognise gid=0.
5430 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
5431 * information about other users in your group or in other groups, respectively.
5432 * If the required privilege is not available, then these routines fill only
5433 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
5436 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
5439 /* sizes of various UAF record fields */
5440 #define UAI$S_USERNAME 12
5441 #define UAI$S_IDENT 31
5442 #define UAI$S_OWNER 31
5443 #define UAI$S_DEFDEV 31
5444 #define UAI$S_DEFDIR 63
5445 #define UAI$S_DEFCLI 31
5448 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
5449 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
5450 (uic).uic$v_group != UIC$K_WILD_GROUP)
5452 static char __empty[]= "";
5453 static struct passwd __passwd_empty=
5454 {(char *) __empty, (char *) __empty, 0, 0,
5455 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
5456 static int contxt= 0;
5457 static struct passwd __pwdcache;
5458 static char __pw_namecache[UAI$S_IDENT+1];
5461 * This routine does most of the work extracting the user information.
5463 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
5466 unsigned char length;
5467 char pw_gecos[UAI$S_OWNER+1];
5469 static union uicdef uic;
5471 unsigned char length;
5472 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
5475 unsigned char length;
5476 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
5479 unsigned char length;
5480 char pw_shell[UAI$S_DEFCLI+1];
5482 static char pw_passwd[UAI$S_PWD+1];
5484 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
5485 struct dsc$descriptor_s name_desc;
5486 unsigned long int sts;
5488 static struct itmlst_3 itmlst[]= {
5489 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
5490 {sizeof(uic), UAI$_UIC, &uic, &luic},
5491 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
5492 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
5493 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
5494 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
5495 {0, 0, NULL, NULL}};
5497 name_desc.dsc$w_length= strlen(name);
5498 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5499 name_desc.dsc$b_class= DSC$K_CLASS_S;
5500 name_desc.dsc$a_pointer= (char *) name;
5502 /* Note that sys$getuai returns many fields as counted strings. */
5503 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
5504 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
5505 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
5507 else { _ckvmssts(sts); }
5508 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
5510 if ((int) owner.length < lowner) lowner= (int) owner.length;
5511 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
5512 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
5513 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
5514 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
5515 owner.pw_gecos[lowner]= '\0';
5516 defdev.pw_dir[ldefdev+ldefdir]= '\0';
5517 defcli.pw_shell[ldefcli]= '\0';
5518 if (valid_uic(uic)) {
5519 pwd->pw_uid= uic.uic$l_uic;
5520 pwd->pw_gid= uic.uic$v_group;
5523 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
5524 pwd->pw_passwd= pw_passwd;
5525 pwd->pw_gecos= owner.pw_gecos;
5526 pwd->pw_dir= defdev.pw_dir;
5527 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
5528 pwd->pw_shell= defcli.pw_shell;
5529 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
5531 ldir= strlen(pwd->pw_unixdir) - 1;
5532 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
5535 strcpy(pwd->pw_unixdir, pwd->pw_dir);
5536 __mystrtolower(pwd->pw_unixdir);
5541 * Get information for a named user.
5543 /*{{{struct passwd *getpwnam(char *name)*/
5544 struct passwd *Perl_my_getpwnam(pTHX_ char *name)
5546 struct dsc$descriptor_s name_desc;
5548 unsigned long int status, sts;
5550 __pwdcache = __passwd_empty;
5551 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
5552 /* We still may be able to determine pw_uid and pw_gid */
5553 name_desc.dsc$w_length= strlen(name);
5554 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
5555 name_desc.dsc$b_class= DSC$K_CLASS_S;
5556 name_desc.dsc$a_pointer= (char *) name;
5557 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
5558 __pwdcache.pw_uid= uic.uic$l_uic;
5559 __pwdcache.pw_gid= uic.uic$v_group;
5562 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
5563 set_vaxc_errno(sts);
5564 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
5567 else { _ckvmssts(sts); }
5570 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
5571 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
5572 __pwdcache.pw_name= __pw_namecache;
5574 } /* end of my_getpwnam() */
5578 * Get information for a particular UIC or UID.
5579 * Called by my_getpwent with uid=-1 to list all users.
5581 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
5582 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
5584 const $DESCRIPTOR(name_desc,__pw_namecache);
5585 unsigned short lname;
5587 unsigned long int status;
5589 if (uid == (unsigned int) -1) {
5591 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
5592 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
5593 set_vaxc_errno(status);
5594 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5598 else { _ckvmssts(status); }
5599 } while (!valid_uic (uic));
5603 if (!uic.uic$v_group)
5604 uic.uic$v_group= PerlProc_getgid();
5606 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
5607 else status = SS$_IVIDENT;
5608 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
5609 status == RMS$_PRV) {
5610 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
5613 else { _ckvmssts(status); }
5615 __pw_namecache[lname]= '\0';
5616 __mystrtolower(__pw_namecache);
5618 __pwdcache = __passwd_empty;
5619 __pwdcache.pw_name = __pw_namecache;
5621 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
5622 The identifier's value is usually the UIC, but it doesn't have to be,
5623 so if we can, we let fillpasswd update this. */
5624 __pwdcache.pw_uid = uic.uic$l_uic;
5625 __pwdcache.pw_gid = uic.uic$v_group;
5627 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
5630 } /* end of my_getpwuid() */
5634 * Get information for next user.
5636 /*{{{struct passwd *my_getpwent()*/
5637 struct passwd *Perl_my_getpwent(pTHX)
5639 return (my_getpwuid((unsigned int) -1));
5644 * Finish searching rights database for users.
5646 /*{{{void my_endpwent()*/
5647 void Perl_my_endpwent(pTHX)
5650 _ckvmssts(sys$finish_rdb(&contxt));
5656 #ifdef HOMEGROWN_POSIX_SIGNALS
5657 /* Signal handling routines, pulled into the core from POSIX.xs.
5659 * We need these for threads, so they've been rolled into the core,
5660 * rather than left in POSIX.xs.
5662 * (DRS, Oct 23, 1997)
5665 /* sigset_t is atomic under VMS, so these routines are easy */
5666 /*{{{int my_sigemptyset(sigset_t *) */
5667 int my_sigemptyset(sigset_t *set) {
5668 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5674 /*{{{int my_sigfillset(sigset_t *)*/
5675 int my_sigfillset(sigset_t *set) {
5677 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5678 for (i = 0; i < NSIG; i++) *set |= (1 << i);
5684 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
5685 int my_sigaddset(sigset_t *set, int sig) {
5686 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5687 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5688 *set |= (1 << (sig - 1));
5694 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
5695 int my_sigdelset(sigset_t *set, int sig) {
5696 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5697 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5698 *set &= ~(1 << (sig - 1));
5704 /*{{{int my_sigismember(sigset_t *set, int sig)*/
5705 int my_sigismember(sigset_t *set, int sig) {
5706 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
5707 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
5708 return *set & (1 << (sig - 1));
5713 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
5714 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
5717 /* If set and oset are both null, then things are badly wrong. Bail out. */
5718 if ((oset == NULL) && (set == NULL)) {
5719 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
5723 /* If set's null, then we're just handling a fetch. */
5725 tempmask = sigblock(0);
5730 tempmask = sigsetmask(*set);
5733 tempmask = sigblock(*set);
5736 tempmask = sigblock(0);
5737 sigsetmask(*oset & ~tempmask);
5740 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
5745 /* Did they pass us an oset? If so, stick our holding mask into it */
5752 #endif /* HOMEGROWN_POSIX_SIGNALS */
5755 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
5756 * my_utime(), and flex_stat(), all of which operate on UTC unless
5757 * VMSISH_TIMES is true.
5759 /* method used to handle UTC conversions:
5760 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
5762 static int gmtime_emulation_type;
5763 /* number of secs to add to UTC POSIX-style time to get local time */
5764 static long int utc_offset_secs;
5766 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
5767 * in vmsish.h. #undef them here so we can call the CRTL routines
5776 * DEC C previous to 6.0 corrupts the behavior of the /prefix
5777 * qualifier with the extern prefix pragma. This provisional
5778 * hack circumvents this prefix pragma problem in previous
5781 #if defined(__VMS_VER) && __VMS_VER >= 70000000
5782 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
5783 # pragma __extern_prefix save
5784 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
5785 # define gmtime decc$__utctz_gmtime
5786 # define localtime decc$__utctz_localtime
5787 # define time decc$__utc_time
5788 # pragma __extern_prefix restore
5790 struct tm *gmtime(), *localtime();
5796 static time_t toutc_dst(time_t loc) {
5799 if ((rsltmp = localtime(&loc)) == NULL) return -1;
5800 loc -= utc_offset_secs;
5801 if (rsltmp->tm_isdst) loc -= 3600;
5804 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5805 ((gmtime_emulation_type || my_time(NULL)), \
5806 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
5807 ((secs) - utc_offset_secs))))
5809 static time_t toloc_dst(time_t utc) {
5812 utc += utc_offset_secs;
5813 if ((rsltmp = localtime(&utc)) == NULL) return -1;
5814 if (rsltmp->tm_isdst) utc += 3600;
5817 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
5818 ((gmtime_emulation_type || my_time(NULL)), \
5819 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
5820 ((secs) + utc_offset_secs))))
5822 #ifndef RTL_USES_UTC
5825 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
5826 DST starts on 1st sun of april at 02:00 std time
5827 ends on last sun of october at 02:00 dst time
5828 see the UCX management command reference, SET CONFIG TIMEZONE
5829 for formatting info.
5831 No, it's not as general as it should be, but then again, NOTHING
5832 will handle UK times in a sensible way.
5837 parse the DST start/end info:
5838 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
5842 tz_parse_startend(char *s, struct tm *w, int *past)
5844 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
5845 int ly, dozjd, d, m, n, hour, min, sec, j, k;
5850 if (!past) return 0;
5853 if (w->tm_year % 4 == 0) ly = 1;
5854 if (w->tm_year % 100 == 0) ly = 0;
5855 if (w->tm_year+1900 % 400 == 0) ly = 1;
5858 dozjd = isdigit(*s);
5859 if (*s == 'J' || *s == 'j' || dozjd) {
5860 if (!dozjd && !isdigit(*++s)) return 0;
5863 d = d*10 + *s++ - '0';
5865 d = d*10 + *s++ - '0';
5868 if (d == 0) return 0;
5869 if (d > 366) return 0;
5871 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
5874 } else if (*s == 'M' || *s == 'm') {
5875 if (!isdigit(*++s)) return 0;
5877 if (isdigit(*s)) m = 10*m + *s++ - '0';
5878 if (*s != '.') return 0;
5879 if (!isdigit(*++s)) return 0;
5881 if (n < 1 || n > 5) return 0;
5882 if (*s != '.') return 0;
5883 if (!isdigit(*++s)) return 0;
5885 if (d > 6) return 0;
5889 if (!isdigit(*++s)) return 0;
5891 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
5893 if (!isdigit(*++s)) return 0;
5895 if (isdigit(*s)) min = 10*min + *s++ - '0';
5897 if (!isdigit(*++s)) return 0;
5899 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
5909 if (w->tm_yday < d) goto before;
5910 if (w->tm_yday > d) goto after;
5912 if (w->tm_mon+1 < m) goto before;
5913 if (w->tm_mon+1 > m) goto after;
5915 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
5916 k = d - j; /* mday of first d */
5918 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
5919 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
5920 if (w->tm_mday < k) goto before;
5921 if (w->tm_mday > k) goto after;
5924 if (w->tm_hour < hour) goto before;
5925 if (w->tm_hour > hour) goto after;
5926 if (w->tm_min < min) goto before;
5927 if (w->tm_min > min) goto after;
5928 if (w->tm_sec < sec) goto before;
5942 /* parse the offset: (+|-)hh[:mm[:ss]] */
5945 tz_parse_offset(char *s, int *offset)
5947 int hour = 0, min = 0, sec = 0;
5950 if (!offset) return 0;
5952 if (*s == '-') {neg++; s++;}
5954 if (!isdigit(*s)) return 0;
5956 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
5957 if (hour > 24) return 0;
5959 if (!isdigit(*++s)) return 0;
5961 if (isdigit(*s)) min = min*10 + (*s++ - '0');
5962 if (min > 59) return 0;
5964 if (!isdigit(*++s)) return 0;
5966 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
5967 if (sec > 59) return 0;
5971 *offset = (hour*60+min)*60 + sec;
5972 if (neg) *offset = -*offset;
5977 input time is w, whatever type of time the CRTL localtime() uses.
5978 sets dst, the zone, and the gmtoff (seconds)
5980 caches the value of TZ and UCX$TZ env variables; note that
5981 my_setenv looks for these and sets a flag if they're changed
5984 We have to watch out for the "australian" case (dst starts in
5985 october, ends in april)...flagged by "reverse" and checked by
5986 scanning through the months of the previous year.
5991 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
5996 char *dstzone, *tz, *s_start, *s_end;
5997 int std_off, dst_off, isdst;
5998 int y, dststart, dstend;
5999 static char envtz[1025]; /* longer than any logical, symbol, ... */
6000 static char ucxtz[1025];
6001 static char reversed = 0;
6007 reversed = -1; /* flag need to check */
6008 envtz[0] = ucxtz[0] = '\0';
6009 tz = my_getenv("TZ",0);
6010 if (tz) strcpy(envtz, tz);
6011 tz = my_getenv("UCX$TZ",0);
6012 if (tz) strcpy(ucxtz, tz);
6013 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
6016 if (!*tz) tz = ucxtz;
6019 while (isalpha(*s)) s++;
6020 s = tz_parse_offset(s, &std_off);
6022 if (!*s) { /* no DST, hurray we're done! */
6028 while (isalpha(*s)) s++;
6029 s2 = tz_parse_offset(s, &dst_off);
6033 dst_off = std_off - 3600;
6036 if (!*s) { /* default dst start/end?? */
6037 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
6038 s = strchr(ucxtz,',');
6040 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
6042 if (*s != ',') return 0;
6045 when = _toutc(when); /* convert to utc */
6046 when = when - std_off; /* convert to pseudolocal time*/
6048 w2 = localtime(&when);
6051 s = tz_parse_startend(s_start,w2,&dststart);
6053 if (*s != ',') return 0;
6056 when = _toutc(when); /* convert to utc */
6057 when = when - dst_off; /* convert to pseudolocal time*/
6058 w2 = localtime(&when);
6059 if (w2->tm_year != y) { /* spans a year, just check one time */
6060 when += dst_off - std_off;
6061 w2 = localtime(&when);
6064 s = tz_parse_startend(s_end,w2,&dstend);
6067 if (reversed == -1) { /* need to check if start later than end */
6071 if (when < 2*365*86400) {
6072 when += 2*365*86400;
6076 w2 =localtime(&when);
6077 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
6079 for (j = 0; j < 12; j++) {
6080 w2 =localtime(&when);
6081 (void) tz_parse_startend(s_start,w2,&ds);
6082 (void) tz_parse_startend(s_end,w2,&de);
6083 if (ds != de) break;
6087 if (de && !ds) reversed = 1;
6090 isdst = dststart && !dstend;
6091 if (reversed) isdst = dststart || !dstend;
6094 if (dst) *dst = isdst;
6095 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
6096 if (isdst) tz = dstzone;
6098 while(isalpha(*tz)) *zone++ = *tz++;
6104 #endif /* !RTL_USES_UTC */
6106 /* my_time(), my_localtime(), my_gmtime()
6107 * By default traffic in UTC time values, using CRTL gmtime() or
6108 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
6109 * Note: We need to use these functions even when the CRTL has working
6110 * UTC support, since they also handle C<use vmsish qw(times);>
6112 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
6113 * Modified by Charles Bailey <bailey@newman.upenn.edu>
6116 /*{{{time_t my_time(time_t *timep)*/
6117 time_t Perl_my_time(pTHX_ time_t *timep)
6122 if (gmtime_emulation_type == 0) {
6124 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
6125 /* results of calls to gmtime() and localtime() */
6126 /* for same &base */
6128 gmtime_emulation_type++;
6129 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
6130 char off[LNM$C_NAMLENGTH+1];;
6132 gmtime_emulation_type++;
6133 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
6134 gmtime_emulation_type++;
6135 utc_offset_secs = 0;
6136 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
6138 else { utc_offset_secs = atol(off); }
6140 else { /* We've got a working gmtime() */
6141 struct tm gmt, local;
6144 tm_p = localtime(&base);
6146 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
6147 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
6148 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
6149 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
6155 # ifdef RTL_USES_UTC
6156 if (VMSISH_TIME) when = _toloc(when);
6158 if (!VMSISH_TIME) when = _toutc(when);
6161 if (timep != NULL) *timep = when;
6164 } /* end of my_time() */
6168 /*{{{struct tm *my_gmtime(const time_t *timep)*/
6170 Perl_my_gmtime(pTHX_ const time_t *timep)
6176 if (timep == NULL) {
6177 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6180 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6184 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
6186 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
6187 return gmtime(&when);
6189 /* CRTL localtime() wants local time as input, so does no tz correction */
6190 rsltmp = localtime(&when);
6191 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
6194 } /* end of my_gmtime() */
6198 /*{{{struct tm *my_localtime(const time_t *timep)*/
6200 Perl_my_localtime(pTHX_ const time_t *timep)
6202 time_t when, whenutc;
6206 if (timep == NULL) {
6207 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6210 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
6211 if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
6214 # ifdef RTL_USES_UTC
6216 if (VMSISH_TIME) when = _toutc(when);
6218 /* CRTL localtime() wants UTC as input, does tz correction itself */
6219 return localtime(&when);
6221 # else /* !RTL_USES_UTC */
6224 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
6225 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
6228 #ifndef RTL_USES_UTC
6229 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
6230 when = whenutc - offset; /* pseudolocal time*/
6233 /* CRTL localtime() wants local time as input, so does no tz correction */
6234 rsltmp = localtime(&when);
6235 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
6239 } /* end of my_localtime() */
6242 /* Reset definitions for later calls */
6243 #define gmtime(t) my_gmtime(t)
6244 #define localtime(t) my_localtime(t)
6245 #define time(t) my_time(t)
6248 /* my_utime - update modification time of a file
6249 * calling sequence is identical to POSIX utime(), but under
6250 * VMS only the modification time is changed; ODS-2 does not
6251 * maintain access times. Restrictions differ from the POSIX
6252 * definition in that the time can be changed as long as the
6253 * caller has permission to execute the necessary IO$_MODIFY $QIO;
6254 * no separate checks are made to insure that the caller is the
6255 * owner of the file or has special privs enabled.
6256 * Code here is based on Joe Meadows' FILE utility.
6259 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
6260 * to VMS epoch (01-JAN-1858 00:00:00.00)
6261 * in 100 ns intervals.
6263 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
6265 /*{{{int my_utime(char *path, struct utimbuf *utimes)*/
6266 int Perl_my_utime(pTHX_ char *file, struct utimbuf *utimes)
6269 long int bintime[2], len = 2, lowbit, unixtime,
6270 secscale = 10000000; /* seconds --> 100 ns intervals */
6271 unsigned long int chan, iosb[2], retsts;
6272 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
6273 struct FAB myfab = cc$rms_fab;
6274 struct NAM mynam = cc$rms_nam;
6275 #if defined (__DECC) && defined (__VAX)
6276 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
6277 * at least through VMS V6.1, which causes a type-conversion warning.
6279 # pragma message save
6280 # pragma message disable cvtdiftypes
6282 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
6283 struct fibdef myfib;
6284 #if defined (__DECC) && defined (__VAX)
6285 /* This should be right after the declaration of myatr, but due
6286 * to a bug in VAX DEC C, this takes effect a statement early.
6288 # pragma message restore
6290 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
6291 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
6292 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
6294 if (file == NULL || *file == '\0') {
6296 set_vaxc_errno(LIB$_INVARG);
6299 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
6301 if (utimes != NULL) {
6302 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
6303 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
6304 * Since time_t is unsigned long int, and lib$emul takes a signed long int
6305 * as input, we force the sign bit to be clear by shifting unixtime right
6306 * one bit, then multiplying by an extra factor of 2 in lib$emul().
6308 lowbit = (utimes->modtime & 1) ? secscale : 0;
6309 unixtime = (long int) utimes->modtime;
6311 /* If input was UTC; convert to local for sys svc */
6312 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
6314 unixtime >>= 1; secscale <<= 1;
6315 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
6316 if (!(retsts & 1)) {
6318 set_vaxc_errno(retsts);
6321 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
6322 if (!(retsts & 1)) {
6324 set_vaxc_errno(retsts);
6329 /* Just get the current time in VMS format directly */
6330 retsts = sys$gettim(bintime);
6331 if (!(retsts & 1)) {
6333 set_vaxc_errno(retsts);
6338 myfab.fab$l_fna = vmsspec;
6339 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
6340 myfab.fab$l_nam = &mynam;
6341 mynam.nam$l_esa = esa;
6342 mynam.nam$b_ess = (unsigned char) sizeof esa;
6343 mynam.nam$l_rsa = rsa;
6344 mynam.nam$b_rss = (unsigned char) sizeof rsa;
6346 /* Look for the file to be affected, letting RMS parse the file
6347 * specification for us as well. I have set errno using only
6348 * values documented in the utime() man page for VMS POSIX.
6350 retsts = sys$parse(&myfab,0,0);
6351 if (!(retsts & 1)) {
6352 set_vaxc_errno(retsts);
6353 if (retsts == RMS$_PRV) set_errno(EACCES);
6354 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
6355 else set_errno(EVMSERR);
6358 retsts = sys$search(&myfab,0,0);
6359 if (!(retsts & 1)) {
6360 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6361 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6362 set_vaxc_errno(retsts);
6363 if (retsts == RMS$_PRV) set_errno(EACCES);
6364 else if (retsts == RMS$_FNF) set_errno(ENOENT);
6365 else set_errno(EVMSERR);
6369 devdsc.dsc$w_length = mynam.nam$b_dev;
6370 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
6372 retsts = sys$assign(&devdsc,&chan,0,0);
6373 if (!(retsts & 1)) {
6374 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6375 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6376 set_vaxc_errno(retsts);
6377 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
6378 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
6379 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
6380 else set_errno(EVMSERR);
6384 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
6385 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
6387 memset((void *) &myfib, 0, sizeof myfib);
6388 #if defined(__DECC) || defined(__DECCXX)
6389 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
6390 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
6391 /* This prevents the revision time of the file being reset to the current
6392 * time as a result of our IO$_MODIFY $QIO. */
6393 myfib.fib$l_acctl = FIB$M_NORECORD;
6395 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
6396 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
6397 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
6399 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
6400 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
6401 myfab.fab$b_dns = 0; (void) sys$parse(&myfab,0,0);
6402 _ckvmssts(sys$dassgn(chan));
6403 if (retsts & 1) retsts = iosb[0];
6404 if (!(retsts & 1)) {
6405 set_vaxc_errno(retsts);
6406 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6407 else set_errno(EVMSERR);
6412 } /* end of my_utime() */
6416 * flex_stat, flex_fstat
6417 * basic stat, but gets it right when asked to stat
6418 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
6421 /* encode_dev packs a VMS device name string into an integer to allow
6422 * simple comparisons. This can be used, for example, to check whether two
6423 * files are located on the same device, by comparing their encoded device
6424 * names. Even a string comparison would not do, because stat() reuses the
6425 * device name buffer for each call; so without encode_dev, it would be
6426 * necessary to save the buffer and use strcmp (this would mean a number of
6427 * changes to the standard Perl code, to say nothing of what a Perl script
6430 * The device lock id, if it exists, should be unique (unless perhaps compared
6431 * with lock ids transferred from other nodes). We have a lock id if the disk is
6432 * mounted cluster-wide, which is when we tend to get long (host-qualified)
6433 * device names. Thus we use the lock id in preference, and only if that isn't
6434 * available, do we try to pack the device name into an integer (flagged by
6435 * the sign bit (LOCKID_MASK) being set).
6437 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
6438 * name and its encoded form, but it seems very unlikely that we will find
6439 * two files on different disks that share the same encoded device names,
6440 * and even more remote that they will share the same file id (if the test
6441 * is to check for the same file).
6443 * A better method might be to use sys$device_scan on the first call, and to
6444 * search for the device, returning an index into the cached array.
6445 * The number returned would be more intelligable.
6446 * This is probably not worth it, and anyway would take quite a bit longer
6447 * on the first call.
6449 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
6450 static mydev_t encode_dev (pTHX_ const char *dev)
6453 unsigned long int f;
6458 if (!dev || !dev[0]) return 0;
6462 struct dsc$descriptor_s dev_desc;
6463 unsigned long int status, lockid, item = DVI$_LOCKID;
6465 /* For cluster-mounted disks, the disk lock identifier is unique, so we
6466 can try that first. */
6467 dev_desc.dsc$w_length = strlen (dev);
6468 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
6469 dev_desc.dsc$b_class = DSC$K_CLASS_S;
6470 dev_desc.dsc$a_pointer = (char *) dev;
6471 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
6472 if (lockid) return (lockid & ~LOCKID_MASK);
6476 /* Otherwise we try to encode the device name */
6480 for (q = dev + strlen(dev); q--; q >= dev) {
6483 else if (isalpha (toupper (*q)))
6484 c= toupper (*q) - 'A' + (char)10;
6486 continue; /* Skip '$'s */
6488 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
6490 enc += f * (unsigned long int) c;
6492 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
6494 } /* end of encode_dev() */
6496 static char namecache[NAM$C_MAXRSS+1];
6499 is_null_device(name)
6502 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
6503 The underscore prefix, controller letter, and unit number are
6504 independently optional; for our purposes, the colon punctuation
6505 is not. The colon can be trailed by optional directory and/or
6506 filename, but two consecutive colons indicates a nodename rather
6507 than a device. [pr] */
6508 if (*name == '_') ++name;
6509 if (tolower(*name++) != 'n') return 0;
6510 if (tolower(*name++) != 'l') return 0;
6511 if (tolower(*name) == 'a') ++name;
6512 if (*name == '0') ++name;
6513 return (*name++ == ':') && (*name != ':');
6516 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
6517 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
6518 * subset of the applicable information.
6521 Perl_cando(pTHX_ Mode_t bit, Uid_t effective, Stat_t *statbufp)
6523 char fname_phdev[NAM$C_MAXRSS+1];
6524 if (statbufp == &PL_statcache) return cando_by_name(bit,effective,namecache);
6526 char fname[NAM$C_MAXRSS+1];
6527 unsigned long int retsts;
6528 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
6529 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6531 /* If the struct mystat is stale, we're OOL; stat() overwrites the
6532 device name on successive calls */
6533 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
6534 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
6535 namdsc.dsc$a_pointer = fname;
6536 namdsc.dsc$w_length = sizeof fname - 1;
6538 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
6539 &namdsc,&namdsc.dsc$w_length,0,0);
6541 fname[namdsc.dsc$w_length] = '\0';
6543 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
6544 * but if someone has redefined that logical, Perl gets very lost. Since
6545 * we have the physical device name from the stat buffer, just paste it on.
6547 strcpy( fname_phdev, statbufp->st_devnam );
6548 strcat( fname_phdev, strrchr(fname, ':') );
6550 return cando_by_name(bit,effective,fname_phdev);
6552 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
6553 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
6557 return FALSE; /* Should never get to here */
6559 } /* end of cando() */
6563 /*{{{I32 cando_by_name(I32 bit, Uid_t effective, char *fname)*/
6565 Perl_cando_by_name(pTHX_ I32 bit, Uid_t effective, char *fname)
6567 static char usrname[L_cuserid];
6568 static struct dsc$descriptor_s usrdsc =
6569 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
6570 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
6571 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
6572 unsigned short int retlen;
6573 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6574 union prvdef curprv;
6575 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
6576 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
6577 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
6578 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
6580 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
6582 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6584 if (!fname || !*fname) return FALSE;
6585 /* Make sure we expand logical names, since sys$check_access doesn't */
6586 if (!strpbrk(fname,"/]>:")) {
6587 strcpy(fileified,fname);
6588 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) ;
6591 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
6592 retlen = namdsc.dsc$w_length = strlen(vmsname);
6593 namdsc.dsc$a_pointer = vmsname;
6594 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
6595 vmsname[retlen-1] == ':') {
6596 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
6597 namdsc.dsc$w_length = strlen(fileified);
6598 namdsc.dsc$a_pointer = fileified;
6602 case S_IXUSR: case S_IXGRP: case S_IXOTH:
6603 access = ARM$M_EXECUTE; break;
6604 case S_IRUSR: case S_IRGRP: case S_IROTH:
6605 access = ARM$M_READ; break;
6606 case S_IWUSR: case S_IWGRP: case S_IWOTH:
6607 access = ARM$M_WRITE; break;
6608 case S_IDUSR: case S_IDGRP: case S_IDOTH:
6609 access = ARM$M_DELETE; break;
6614 /* Before we call $check_access, create a user profile with the current
6615 * process privs since otherwise it just uses the default privs from the
6616 * UAF and might give false positives or negatives.
6619 /* get current process privs and username */
6620 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
6623 /* find out the space required for the profile */
6624 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
6625 &usrprodsc.dsc$w_length,0));
6627 /* allocate space for the profile and get it filled in */
6628 New(1330,usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
6629 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
6630 &usrprodsc.dsc$w_length,0));
6632 /* use the profile to check access to the file; free profile & analyze results */
6633 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
6634 Safefree(usrprodsc.dsc$a_pointer);
6635 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
6636 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
6637 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
6638 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
6639 set_vaxc_errno(retsts);
6640 if (retsts == SS$_NOPRIV) set_errno(EACCES);
6641 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
6642 else set_errno(ENOENT);
6645 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
6650 return FALSE; /* Should never get here */
6652 } /* end of cando_by_name() */
6656 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
6658 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
6660 if (!fstat(fd,(stat_t *) statbufp)) {
6661 if (statbufp == (Stat_t *) &PL_statcache) *namecache == '\0';
6662 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6663 # ifdef RTL_USES_UTC
6666 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6667 statbufp->st_atime = _toloc(statbufp->st_atime);
6668 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6673 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6677 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6678 statbufp->st_atime = _toutc(statbufp->st_atime);
6679 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6686 } /* end of flex_fstat() */
6689 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
6691 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
6693 char fileified[NAM$C_MAXRSS+1];
6694 char temp_fspec[NAM$C_MAXRSS+300];
6696 int saved_errno, saved_vaxc_errno;
6698 if (!fspec) return retval;
6699 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
6700 strcpy(temp_fspec, fspec);
6701 if (statbufp == (Stat_t *) &PL_statcache)
6702 do_tovmsspec(temp_fspec,namecache,0);
6703 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
6704 memset(statbufp,0,sizeof *statbufp);
6705 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
6706 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
6707 statbufp->st_uid = 0x00010001;
6708 statbufp->st_gid = 0x0001;
6709 time((time_t *)&statbufp->st_mtime);
6710 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
6714 /* Try for a directory name first. If fspec contains a filename without
6715 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
6716 * and sea:[wine.dark]water. exist, we prefer the directory here.
6717 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
6718 * not sea:[wine.dark]., if the latter exists. If the intended target is
6719 * the file with null type, specify this by calling flex_stat() with
6720 * a '.' at the end of fspec.
6722 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
6723 retval = stat(fileified,(stat_t *) statbufp);
6724 if (!retval && statbufp == (Stat_t *) &PL_statcache)
6725 strcpy(namecache,fileified);
6727 if (retval) retval = stat(temp_fspec,(stat_t *) statbufp);
6729 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
6730 # ifdef RTL_USES_UTC
6733 statbufp->st_mtime = _toloc(statbufp->st_mtime);
6734 statbufp->st_atime = _toloc(statbufp->st_atime);
6735 statbufp->st_ctime = _toloc(statbufp->st_ctime);
6740 if (!VMSISH_TIME) { /* Return UTC instead of local time */
6744 statbufp->st_mtime = _toutc(statbufp->st_mtime);
6745 statbufp->st_atime = _toutc(statbufp->st_atime);
6746 statbufp->st_ctime = _toutc(statbufp->st_ctime);
6750 /* If we were successful, leave errno where we found it */
6751 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
6754 } /* end of flex_stat() */
6758 /*{{{char *my_getlogin()*/
6759 /* VMS cuserid == Unix getlogin, except calling sequence */
6763 static char user[L_cuserid];
6764 return cuserid(user);
6769 /* rmscopy - copy a file using VMS RMS routines
6771 * Copies contents and attributes of spec_in to spec_out, except owner
6772 * and protection information. Name and type of spec_in are used as
6773 * defaults for spec_out. The third parameter specifies whether rmscopy()
6774 * should try to propagate timestamps from the input file to the output file.
6775 * If it is less than 0, no timestamps are preserved. If it is 0, then
6776 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
6777 * propagated to the output file at creation iff the output file specification
6778 * did not contain an explicit name or type, and the revision date is always
6779 * updated at the end of the copy operation. If it is greater than 0, then
6780 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
6781 * other than the revision date should be propagated, and bit 1 indicates
6782 * that the revision date should be propagated.
6784 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
6786 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
6787 * Incorporates, with permission, some code from EZCOPY by Tim Adye
6788 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
6789 * as part of the Perl standard distribution under the terms of the
6790 * GNU General Public License or the Perl Artistic License. Copies
6791 * of each may be found in the Perl standard distribution.
6793 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
6795 Perl_rmscopy(pTHX_ char *spec_in, char *spec_out, int preserve_dates)
6797 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
6798 rsa[NAM$C_MAXRSS], ubf[32256];
6799 unsigned long int i, sts, sts2;
6800 struct FAB fab_in, fab_out;
6801 struct RAB rab_in, rab_out;
6803 struct XABDAT xabdat;
6804 struct XABFHC xabfhc;
6805 struct XABRDT xabrdt;
6806 struct XABSUM xabsum;
6808 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
6809 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
6810 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
6814 fab_in = cc$rms_fab;
6815 fab_in.fab$l_fna = vmsin;
6816 fab_in.fab$b_fns = strlen(vmsin);
6817 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
6818 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
6819 fab_in.fab$l_fop = FAB$M_SQO;
6820 fab_in.fab$l_nam = &nam;
6821 fab_in.fab$l_xab = (void *) &xabdat;
6824 nam.nam$l_rsa = rsa;
6825 nam.nam$b_rss = sizeof(rsa);
6826 nam.nam$l_esa = esa;
6827 nam.nam$b_ess = sizeof (esa);
6828 nam.nam$b_esl = nam.nam$b_rsl = 0;
6830 xabdat = cc$rms_xabdat; /* To get creation date */
6831 xabdat.xab$l_nxt = (void *) &xabfhc;
6833 xabfhc = cc$rms_xabfhc; /* To get record length */
6834 xabfhc.xab$l_nxt = (void *) &xabsum;
6836 xabsum = cc$rms_xabsum; /* To get key and area information */
6838 if (!((sts = sys$open(&fab_in)) & 1)) {
6839 set_vaxc_errno(sts);
6841 case RMS$_FNF: case RMS$_DNF:
6842 set_errno(ENOENT); break;
6844 set_errno(ENOTDIR); break;
6846 set_errno(ENODEV); break;
6848 set_errno(EINVAL); break;
6850 set_errno(EACCES); break;
6858 fab_out.fab$w_ifi = 0;
6859 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
6860 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
6861 fab_out.fab$l_fop = FAB$M_SQO;
6862 fab_out.fab$l_fna = vmsout;
6863 fab_out.fab$b_fns = strlen(vmsout);
6864 fab_out.fab$l_dna = nam.nam$l_name;
6865 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
6867 if (preserve_dates == 0) { /* Act like DCL COPY */
6868 nam.nam$b_nop = NAM$M_SYNCHK;
6869 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
6870 if (!((sts = sys$parse(&fab_out)) & 1)) {
6871 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
6872 set_vaxc_errno(sts);
6875 fab_out.fab$l_xab = (void *) &xabdat;
6876 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
6878 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
6879 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
6880 preserve_dates =0; /* bitmask from this point forward */
6882 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
6883 if (!((sts = sys$create(&fab_out)) & 1)) {
6884 set_vaxc_errno(sts);
6887 set_errno(ENOENT); break;
6889 set_errno(ENOTDIR); break;
6891 set_errno(ENODEV); break;
6893 set_errno(EINVAL); break;
6895 set_errno(EACCES); break;
6901 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
6902 if (preserve_dates & 2) {
6903 /* sys$close() will process xabrdt, not xabdat */
6904 xabrdt = cc$rms_xabrdt;
6906 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
6908 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
6909 * is unsigned long[2], while DECC & VAXC use a struct */
6910 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
6912 fab_out.fab$l_xab = (void *) &xabrdt;
6915 rab_in = cc$rms_rab;
6916 rab_in.rab$l_fab = &fab_in;
6917 rab_in.rab$l_rop = RAB$M_BIO;
6918 rab_in.rab$l_ubf = ubf;
6919 rab_in.rab$w_usz = sizeof ubf;
6920 if (!((sts = sys$connect(&rab_in)) & 1)) {
6921 sys$close(&fab_in); sys$close(&fab_out);
6922 set_errno(EVMSERR); set_vaxc_errno(sts);
6926 rab_out = cc$rms_rab;
6927 rab_out.rab$l_fab = &fab_out;
6928 rab_out.rab$l_rbf = ubf;
6929 if (!((sts = sys$connect(&rab_out)) & 1)) {
6930 sys$close(&fab_in); sys$close(&fab_out);
6931 set_errno(EVMSERR); set_vaxc_errno(sts);
6935 while ((sts = sys$read(&rab_in))) { /* always true */
6936 if (sts == RMS$_EOF) break;
6937 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
6938 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
6939 sys$close(&fab_in); sys$close(&fab_out);
6940 set_errno(EVMSERR); set_vaxc_errno(sts);
6945 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
6946 sys$close(&fab_in); sys$close(&fab_out);
6947 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
6949 set_errno(EVMSERR); set_vaxc_errno(sts);
6955 } /* end of rmscopy() */
6959 /*** The following glue provides 'hooks' to make some of the routines
6960 * from this file available from Perl. These routines are sufficiently
6961 * basic, and are required sufficiently early in the build process,
6962 * that's it's nice to have them available to miniperl as well as the
6963 * full Perl, so they're set up here instead of in an extension. The
6964 * Perl code which handles importation of these names into a given
6965 * package lives in [.VMS]Filespec.pm in @INC.
6969 rmsexpand_fromperl(pTHX_ CV *cv)
6972 char *fspec, *defspec = NULL, *rslt;
6975 if (!items || items > 2)
6976 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
6977 fspec = SvPV(ST(0),n_a);
6978 if (!fspec || !*fspec) XSRETURN_UNDEF;
6979 if (items == 2) defspec = SvPV(ST(1),n_a);
6981 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
6982 ST(0) = sv_newmortal();
6983 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
6988 vmsify_fromperl(pTHX_ CV *cv)
6994 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
6995 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
6996 ST(0) = sv_newmortal();
6997 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
7002 unixify_fromperl(pTHX_ CV *cv)
7008 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
7009 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
7010 ST(0) = sv_newmortal();
7011 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
7016 fileify_fromperl(pTHX_ CV *cv)
7022 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
7023 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
7024 ST(0) = sv_newmortal();
7025 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
7030 pathify_fromperl(pTHX_ CV *cv)
7036 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
7037 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
7038 ST(0) = sv_newmortal();
7039 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
7044 vmspath_fromperl(pTHX_ CV *cv)
7050 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
7051 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
7052 ST(0) = sv_newmortal();
7053 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
7058 unixpath_fromperl(pTHX_ CV *cv)
7064 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
7065 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
7066 ST(0) = sv_newmortal();
7067 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
7072 candelete_fromperl(pTHX_ CV *cv)
7075 char fspec[NAM$C_MAXRSS+1], *fsp;
7080 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
7082 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7083 if (SvTYPE(mysv) == SVt_PVGV) {
7084 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
7085 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7092 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
7093 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7099 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
7104 rmscopy_fromperl(pTHX_ CV *cv)
7107 char inspec[NAM$C_MAXRSS+1], outspec[NAM$C_MAXRSS+1], *inp, *outp;
7109 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
7110 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7111 unsigned long int sts;
7116 if (items < 2 || items > 3)
7117 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
7119 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
7120 if (SvTYPE(mysv) == SVt_PVGV) {
7121 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
7122 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7129 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
7130 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7135 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
7136 if (SvTYPE(mysv) == SVt_PVGV) {
7137 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
7138 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7145 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
7146 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
7151 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
7153 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
7159 mod2fname(pTHX_ CV *cv)
7162 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
7163 workbuff[NAM$C_MAXRSS*1 + 1];
7164 int total_namelen = 3, counter, num_entries;
7165 /* ODS-5 ups this, but we want to be consistent, so... */
7166 int max_name_len = 39;
7167 AV *in_array = (AV *)SvRV(ST(0));
7169 num_entries = av_len(in_array);
7171 /* All the names start with PL_. */
7172 strcpy(ultimate_name, "PL_");
7174 /* Clean up our working buffer */
7175 Zero(work_name, sizeof(work_name), char);
7177 /* Run through the entries and build up a working name */
7178 for(counter = 0; counter <= num_entries; counter++) {
7179 /* If it's not the first name then tack on a __ */
7181 strcat(work_name, "__");
7183 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
7187 /* Check to see if we actually have to bother...*/
7188 if (strlen(work_name) + 3 <= max_name_len) {
7189 strcat(ultimate_name, work_name);
7191 /* It's too darned big, so we need to go strip. We use the same */
7192 /* algorithm as xsubpp does. First, strip out doubled __ */
7193 char *source, *dest, last;
7196 for (source = work_name; *source; source++) {
7197 if (last == *source && last == '_') {
7203 /* Go put it back */
7204 strcpy(work_name, workbuff);
7205 /* Is it still too big? */
7206 if (strlen(work_name) + 3 > max_name_len) {
7207 /* Strip duplicate letters */
7210 for (source = work_name; *source; source++) {
7211 if (last == toupper(*source)) {
7215 last = toupper(*source);
7217 strcpy(work_name, workbuff);
7220 /* Is it *still* too big? */
7221 if (strlen(work_name) + 3 > max_name_len) {
7222 /* Too bad, we truncate */
7223 work_name[max_name_len - 2] = 0;
7225 strcat(ultimate_name, work_name);
7228 /* Okay, return it */
7229 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
7234 hushexit_fromperl(pTHX_ CV *cv)
7239 VMSISH_HUSHED = SvTRUE(ST(0));
7241 ST(0) = boolSV(VMSISH_HUSHED);
7246 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
7247 struct interp_intern *dst)
7249 memcpy(dst,src,sizeof(struct interp_intern));
7253 Perl_sys_intern_clear(pTHX)
7258 Perl_sys_intern_init(pTHX)
7260 unsigned int ix = RAND_MAX;
7266 MY_INV_RAND_MAX = 1./x;
7273 char* file = __FILE__;
7274 char temp_buff[512];
7275 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
7276 no_translate_barewords = TRUE;
7278 no_translate_barewords = FALSE;
7281 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
7282 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
7283 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
7284 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
7285 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
7286 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
7287 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
7288 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
7289 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
7290 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
7291 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
7293 store_pipelocs(aTHX); /* will redo any earlier attempts */