3 * VMS-specific routines for perl5
6 * August 2005 Convert VMS status code to UNIX status codes
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
44 #include <str$routines.h>
50 #if __CRTL_VER >= 70300000 && !defined(__VAX)
54 /* Set the maximum filespec size here as it is larger for EFS file
56 * Not fully implemented at this time because the larger size
57 * will likely impact the stack local storage requirements of
58 * threaded code, and probably cause hard to diagnose failures.
59 * To implement the larger sizes, all places where filename
60 * storage is put on the stack need to be changed to use
61 * New()/SafeFree() instead.
66 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
67 #ifndef VMS_LONGNAME_SUPPORT
68 #define VMS_LONGNAME_SUPPORT 1
69 #endif /* VMS_LONGNAME_SUPPORT */
70 #endif /* NAML$C_MAXRSS */
71 #endif /* VMS_MAXRSS */
74 /* temporary hack until support is complete */
75 #ifdef VMS_LONGNAME_SUPPORT
76 #undef VMS_LONGNAME_SUPPORT
79 /* end of temporary hack until support is complete */
82 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
85 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
86 int decc$feature_get_index(const char *name);
87 char* decc$feature_get_name(int index);
88 int decc$feature_get_value(int index, int mode);
89 int decc$feature_set_value(int index, int mode, int value);
94 #if __CRTL_VER >= 70300000 && !defined(__VAX)
96 static int set_feature_default(const char *name, int value)
101 index = decc$feature_get_index(name);
103 status = decc$feature_set_value(index, 1, value);
104 if (index == -1 || (status == -1)) {
108 status = decc$feature_get_value(index, 1);
109 if (status != value) {
117 /* Older versions of ssdef.h don't have these */
118 #ifndef SS$_INVFILFOROP
119 # define SS$_INVFILFOROP 3930
121 #ifndef SS$_NOSUCHOBJECT
122 # define SS$_NOSUCHOBJECT 2696
125 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
126 #define PERLIO_NOT_STDIO 0
128 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
129 * code below needs to get to the underlying CRTL routines. */
130 #define DONT_MASK_RTL_CALLS
134 /* Anticipating future expansion in lexical warnings . . . */
135 #ifndef WARN_INTERNAL
136 # define WARN_INTERNAL WARN_MISC
139 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
140 # define RTL_USES_UTC 1
144 /* gcc's header files don't #define direct access macros
145 * corresponding to VAXC's variant structs */
147 # define uic$v_format uic$r_uic_form.uic$v_format
148 # define uic$v_group uic$r_uic_form.uic$v_group
149 # define uic$v_member uic$r_uic_form.uic$v_member
150 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
151 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
152 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
153 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
156 #if defined(NEED_AN_H_ERRNO)
161 #pragma message disable pragma
162 #pragma member_alignment save
163 #pragma nomember_alignment longword
165 #pragma message disable misalgndmem
168 unsigned short int buflen;
169 unsigned short int itmcode;
171 unsigned short int *retlen;
174 #pragma message restore
175 #pragma member_alignment restore
178 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
179 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
180 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
181 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
182 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
183 #define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
184 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
185 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
186 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
187 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
188 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
190 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
191 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
192 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
193 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
195 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
196 #define PERL_LNM_MAX_ALLOWED_INDEX 127
198 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
199 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
202 #define PERL_LNM_MAX_ITER 10
204 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
205 #if __CRTL_VER >= 70302000 && !defined(__VAX)
206 #define MAX_DCL_SYMBOL (8192)
207 #define MAX_DCL_LINE_LENGTH (4096 - 4)
209 #define MAX_DCL_SYMBOL (1024)
210 #define MAX_DCL_LINE_LENGTH (1024 - 4)
213 static char *__mystrtolower(char *str)
215 if (str) for (; *str; ++str) *str= tolower(*str);
219 static struct dsc$descriptor_s fildevdsc =
220 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
221 static struct dsc$descriptor_s crtlenvdsc =
222 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
223 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
224 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
225 static struct dsc$descriptor_s **env_tables = defenv;
226 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
228 /* True if we shouldn't treat barewords as logicals during directory */
230 static int no_translate_barewords;
233 static int tz_updated = 1;
236 /* DECC Features that may need to affect how Perl interprets
237 * displays filename information
239 static int decc_disable_to_vms_logname_translation = 1;
240 static int decc_disable_posix_root = 1;
241 int decc_efs_case_preserve = 0;
242 static int decc_efs_charset = 0;
243 static int decc_filename_unix_no_version = 0;
244 static int decc_filename_unix_only = 0;
245 int decc_filename_unix_report = 0;
246 int decc_posix_compliant_pathnames = 0;
247 int decc_readdir_dropdotnotype = 0;
248 static int vms_process_case_tolerant = 1;
250 /* bug workarounds if needed */
251 int decc_bug_readdir_efs1 = 0;
252 int decc_bug_devnull = 0;
253 int decc_bug_fgetname = 0;
254 int decc_dir_barename = 0;
256 /* Is this a UNIX file specification?
257 * No longer a simple check with EFS file specs
258 * For now, not a full check, but need to
259 * handle POSIX ^UP^ specifications
260 * Fixing to handle ^/ cases would require
261 * changes to many other conversion routines.
264 static is_unix_filespec(const char *path)
270 if (strncmp(path,"\"^UP^",5) != 0) {
271 pch1 = strchr(path, '/');
276 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
277 if (decc_filename_unix_report || decc_filename_unix_only) {
278 if (strcmp(path,".") == 0)
288 * Routine to retrieve the maximum equivalence index for an input
289 * logical name. Some calls to this routine have no knowledge if
290 * the variable is a logical or not. So on error we return a max
293 /*{{{int my_maxidx(const char *lnm) */
295 my_maxidx(const char *lnm)
299 int attr = LNM$M_CASE_BLIND;
300 struct dsc$descriptor lnmdsc;
301 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
304 lnmdsc.dsc$w_length = strlen(lnm);
305 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
306 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
307 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
309 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
310 if ((status & 1) == 0)
317 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
319 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
320 struct dsc$descriptor_s **tabvec, unsigned long int flags)
323 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
324 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
325 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
327 unsigned char acmode;
328 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
329 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
330 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
331 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
333 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
334 #if defined(PERL_IMPLICIT_CONTEXT)
337 aTHX = PERL_GET_INTERP;
343 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
344 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
346 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
347 *cp2 = _toupper(*cp1);
348 if (cp1 - lnm > LNM$C_NAMLENGTH) {
349 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
353 lnmdsc.dsc$w_length = cp1 - lnm;
354 lnmdsc.dsc$a_pointer = uplnm;
355 uplnm[lnmdsc.dsc$w_length] = '\0';
356 secure = flags & PERL__TRNENV_SECURE;
357 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
358 if (!tabvec || !*tabvec) tabvec = env_tables;
360 for (curtab = 0; tabvec[curtab]; curtab++) {
361 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
362 if (!ivenv && !secure) {
367 Perl_warn(aTHX_ "Can't read CRTL environ\n");
370 retsts = SS$_NOLOGNAM;
371 for (i = 0; environ[i]; i++) {
372 if ((eq = strchr(environ[i],'=')) &&
373 lnmdsc.dsc$w_length == (eq - environ[i]) &&
374 !strncmp(environ[i],uplnm,eq - environ[i])) {
376 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
377 if (!eqvlen) continue;
382 if (retsts != SS$_NOLOGNAM) break;
385 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
386 !str$case_blind_compare(&tmpdsc,&clisym)) {
387 if (!ivsym && !secure) {
388 unsigned short int deflen = LNM$C_NAMLENGTH;
389 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
390 /* dynamic dsc to accomodate possible long value */
391 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
392 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
394 if (eqvlen > MAX_DCL_SYMBOL) {
395 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
396 eqvlen = MAX_DCL_SYMBOL;
397 /* Special hack--we might be called before the interpreter's */
398 /* fully initialized, in which case either thr or PL_curcop */
399 /* might be bogus. We have to check, since ckWARN needs them */
400 /* both to be valid if running threaded */
401 if (ckWARN(WARN_MISC)) {
402 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
405 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
407 _ckvmssts(lib$sfree1_dd(&eqvdsc));
408 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
409 if (retsts == LIB$_NOSUCHSYM) continue;
414 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
415 midx = my_maxidx(lnm);
416 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
417 lnmlst[1].bufadr = cp2;
419 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
420 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
421 if (retsts == SS$_NOLOGNAM) break;
422 /* PPFs have a prefix */
425 *((int *)uplnm) == *((int *)"SYS$") &&
427 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
428 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
429 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
430 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
431 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
432 memmove(eqv,eqv+4,eqvlen-4);
438 if ((retsts == SS$_IVLOGNAM) ||
439 (retsts == SS$_NOLOGNAM)) { continue; }
442 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
443 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
444 if (retsts == SS$_NOLOGNAM) continue;
447 eqvlen = strlen(eqv);
451 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
452 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
453 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
454 retsts == SS$_NOLOGNAM) {
455 set_errno(EINVAL); set_vaxc_errno(retsts);
457 else _ckvmssts(retsts);
459 } /* end of vmstrnenv */
462 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
463 /* Define as a function so we can access statics. */
464 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
466 return vmstrnenv(lnm,eqv,idx,fildev,
467 #ifdef SECURE_INTERNAL_GETENV
468 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
477 * Note: Uses Perl temp to store result so char * can be returned to
478 * caller; this pointer will be invalidated at next Perl statement
480 * We define this as a function rather than a macro in terms of my_getenv_len()
481 * so that it'll work when PL_curinterp is undefined (and we therefore can't
484 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
486 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
489 static char *__my_getenv_eqv = NULL;
490 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
491 unsigned long int idx = 0;
492 int trnsuccess, success, secure, saverr, savvmserr;
496 midx = my_maxidx(lnm) + 1;
498 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
499 /* Set up a temporary buffer for the return value; Perl will
500 * clean it up at the next statement transition */
501 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
502 if (!tmpsv) return NULL;
506 /* Assume no interpreter ==> single thread */
507 if (__my_getenv_eqv != NULL) {
508 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
511 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
513 eqv = __my_getenv_eqv;
516 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
517 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
519 getcwd(eqv,LNM$C_NAMLENGTH);
523 /* Get rid of "000000/ in rooted filespecs */
526 zeros = strstr(eqv, "/000000/");
529 mlen = len - (zeros - eqv) - 7;
530 memmove(zeros, &zeros[7], mlen);
538 /* Impose security constraints only if tainting */
540 /* Impose security constraints only if tainting */
541 secure = PL_curinterp ? PL_tainting : will_taint;
542 saverr = errno; savvmserr = vaxc$errno;
549 #ifdef SECURE_INTERNAL_GETENV
550 secure ? PERL__TRNENV_SECURE : 0
556 /* For the getenv interface we combine all the equivalence names
557 * of a search list logical into one value to acquire a maximum
558 * value length of 255*128 (assuming %ENV is using logicals).
560 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
562 /* If the name contains a semicolon-delimited index, parse it
563 * off and make sure we only retrieve the equivalence name for
565 if ((cp2 = strchr(lnm,';')) != NULL) {
567 uplnm[cp2-lnm] = '\0';
568 idx = strtoul(cp2+1,NULL,0);
570 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
573 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
575 /* Discard NOLOGNAM on internal calls since we're often looking
576 * for an optional name, and this "error" often shows up as the
577 * (bogus) exit status for a die() call later on. */
578 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
579 return success ? eqv : Nullch;
582 } /* end of my_getenv() */
586 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
588 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
592 unsigned long idx = 0;
594 static char *__my_getenv_len_eqv = NULL;
595 int secure, saverr, savvmserr;
598 midx = my_maxidx(lnm) + 1;
600 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
601 /* Set up a temporary buffer for the return value; Perl will
602 * clean it up at the next statement transition */
603 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
604 if (!tmpsv) return NULL;
608 /* Assume no interpreter ==> single thread */
609 if (__my_getenv_len_eqv != NULL) {
610 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
613 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
615 buf = __my_getenv_len_eqv;
618 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
619 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
622 getcwd(buf,LNM$C_NAMLENGTH);
625 /* Get rid of "000000/ in rooted filespecs */
627 zeros = strstr(buf, "/000000/");
630 mlen = *len - (zeros - buf) - 7;
631 memmove(zeros, &zeros[7], mlen);
640 /* Impose security constraints only if tainting */
641 secure = PL_curinterp ? PL_tainting : will_taint;
642 saverr = errno; savvmserr = vaxc$errno;
649 #ifdef SECURE_INTERNAL_GETENV
650 secure ? PERL__TRNENV_SECURE : 0
656 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
658 if ((cp2 = strchr(lnm,';')) != NULL) {
661 idx = strtoul(cp2+1,NULL,0);
663 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
666 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
668 /* Get rid of "000000/ in rooted filespecs */
671 zeros = strstr(buf, "/000000/");
674 mlen = *len - (zeros - buf) - 7;
675 memmove(zeros, &zeros[7], mlen);
681 /* Discard NOLOGNAM on internal calls since we're often looking
682 * for an optional name, and this "error" often shows up as the
683 * (bogus) exit status for a die() call later on. */
684 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
685 return *len ? buf : Nullch;
688 } /* end of my_getenv_len() */
691 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
693 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
695 /*{{{ void prime_env_iter() */
698 /* Fill the %ENV associative array with all logical names we can
699 * find, in preparation for iterating over it.
702 static int primed = 0;
703 HV *seenhv = NULL, *envhv;
705 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
706 unsigned short int chan;
707 #ifndef CLI$M_TRUSTED
708 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
710 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
711 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
713 bool have_sym = FALSE, have_lnm = FALSE;
714 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
715 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
716 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
717 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
718 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
719 #if defined(PERL_IMPLICIT_CONTEXT)
722 #if defined(USE_ITHREADS)
723 static perl_mutex primenv_mutex;
724 MUTEX_INIT(&primenv_mutex);
727 #if defined(PERL_IMPLICIT_CONTEXT)
728 /* We jump through these hoops because we can be called at */
729 /* platform-specific initialization time, which is before anything is */
730 /* set up--we can't even do a plain dTHX since that relies on the */
731 /* interpreter structure to be initialized */
733 aTHX = PERL_GET_INTERP;
739 if (primed || !PL_envgv) return;
740 MUTEX_LOCK(&primenv_mutex);
741 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
742 envhv = GvHVn(PL_envgv);
743 /* Perform a dummy fetch as an lval to insure that the hash table is
744 * set up. Otherwise, the hv_store() will turn into a nullop. */
745 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
747 for (i = 0; env_tables[i]; i++) {
748 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
749 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
750 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
752 if (have_sym || have_lnm) {
753 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
754 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
755 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
756 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
759 for (i--; i >= 0; i--) {
760 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
763 for (j = 0; environ[j]; j++) {
764 if (!(start = strchr(environ[j],'='))) {
765 if (ckWARN(WARN_INTERNAL))
766 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
770 sv = newSVpv(start,0);
772 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
777 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
778 !str$case_blind_compare(&tmpdsc,&clisym)) {
779 strcpy(cmd,"Show Symbol/Global *");
780 cmddsc.dsc$w_length = 20;
781 if (env_tables[i]->dsc$w_length == 12 &&
782 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
783 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
784 flags = defflags | CLI$M_NOLOGNAM;
787 strcpy(cmd,"Show Logical *");
788 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
789 strcat(cmd," /Table=");
790 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
791 cmddsc.dsc$w_length = strlen(cmd);
793 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
794 flags = defflags | CLI$M_NOCLISYM;
797 /* Create a new subprocess to execute each command, to exclude the
798 * remote possibility that someone could subvert a mbx or file used
799 * to write multiple commands to a single subprocess.
802 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
803 0,&riseandshine,0,0,&clidsc,&clitabdsc);
804 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
805 defflags &= ~CLI$M_TRUSTED;
806 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
808 if (!buf) Newx(buf,mbxbufsiz + 1,char);
809 if (seenhv) SvREFCNT_dec(seenhv);
812 char *cp1, *cp2, *key;
813 unsigned long int sts, iosb[2], retlen, keylen;
816 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
817 if (sts & 1) sts = iosb[0] & 0xffff;
818 if (sts == SS$_ENDOFFILE) {
820 while (substs == 0) { sys$hiber(); wakect++;}
821 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
826 retlen = iosb[0] >> 16;
827 if (!retlen) continue; /* blank line */
829 if (iosb[1] != subpid) {
831 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
835 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
836 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
838 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
839 if (*cp1 == '(' || /* Logical name table name */
840 *cp1 == '=' /* Next eqv of searchlist */) continue;
841 if (*cp1 == '"') cp1++;
842 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
843 key = cp1; keylen = cp2 - cp1;
844 if (keylen && hv_exists(seenhv,key,keylen)) continue;
845 while (*cp2 && *cp2 != '=') cp2++;
846 while (*cp2 && *cp2 == '=') cp2++;
847 while (*cp2 && *cp2 == ' ') cp2++;
848 if (*cp2 == '"') { /* String translation; may embed "" */
849 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
850 cp2++; cp1--; /* Skip "" surrounding translation */
852 else { /* Numeric translation */
853 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
854 cp1--; /* stop on last non-space char */
856 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
857 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
860 PERL_HASH(hash,key,keylen);
862 if (cp1 == cp2 && *cp2 == '.') {
863 /* A single dot usually means an unprintable character, such as a null
864 * to indicate a zero-length value. Get the actual value to make sure.
866 char lnm[LNM$C_NAMLENGTH+1];
867 char eqv[MAX_DCL_SYMBOL+1];
868 strncpy(lnm, key, keylen);
869 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
870 sv = newSVpvn(eqv, strlen(eqv));
873 sv = newSVpvn(cp2,cp1 - cp2 + 1);
877 hv_store(envhv,key,keylen,sv,hash);
878 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
880 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
881 /* get the PPFs for this process, not the subprocess */
882 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
883 char eqv[LNM$C_NAMLENGTH+1];
885 for (i = 0; ppfs[i]; i++) {
886 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
887 sv = newSVpv(eqv,trnlen);
889 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
894 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
895 if (buf) Safefree(buf);
896 if (seenhv) SvREFCNT_dec(seenhv);
897 MUTEX_UNLOCK(&primenv_mutex);
900 } /* end of prime_env_iter */
904 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
905 /* Define or delete an element in the same "environment" as
906 * vmstrnenv(). If an element is to be deleted, it's removed from
907 * the first place it's found. If it's to be set, it's set in the
908 * place designated by the first element of the table vector.
909 * Like setenv() returns 0 for success, non-zero on error.
912 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
915 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
916 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
918 unsigned long int retsts, usermode = PSL$C_USER;
919 struct itmlst_3 *ile, *ilist;
920 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
921 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
922 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
923 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
924 $DESCRIPTOR(local,"_LOCAL");
927 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
931 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
932 *cp2 = _toupper(*cp1);
933 if (cp1 - lnm > LNM$C_NAMLENGTH) {
934 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
938 lnmdsc.dsc$w_length = cp1 - lnm;
939 if (!tabvec || !*tabvec) tabvec = env_tables;
941 if (!eqv) { /* we're deleting n element */
942 for (curtab = 0; tabvec[curtab]; curtab++) {
943 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
945 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
946 if ((cp1 = strchr(environ[i],'=')) &&
947 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
948 !strncmp(environ[i],lnm,cp1 - environ[i])) {
950 return setenv(lnm,"",1) ? vaxc$errno : 0;
953 ivenv = 1; retsts = SS$_NOLOGNAM;
955 if (ckWARN(WARN_INTERNAL))
956 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
957 ivenv = 1; retsts = SS$_NOSUCHPGM;
963 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
964 !str$case_blind_compare(&tmpdsc,&clisym)) {
965 unsigned int symtype;
966 if (tabvec[curtab]->dsc$w_length == 12 &&
967 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
968 !str$case_blind_compare(&tmpdsc,&local))
969 symtype = LIB$K_CLI_LOCAL_SYM;
970 else symtype = LIB$K_CLI_GLOBAL_SYM;
971 retsts = lib$delete_symbol(&lnmdsc,&symtype);
972 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
973 if (retsts == LIB$_NOSUCHSYM) continue;
977 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
978 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
979 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
980 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
981 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
985 else { /* we're defining a value */
986 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
988 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
990 if (ckWARN(WARN_INTERNAL))
991 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
992 retsts = SS$_NOSUCHPGM;
996 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
997 eqvdsc.dsc$w_length = strlen(eqv);
998 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
999 !str$case_blind_compare(&tmpdsc,&clisym)) {
1000 unsigned int symtype;
1001 if (tabvec[0]->dsc$w_length == 12 &&
1002 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1003 !str$case_blind_compare(&tmpdsc,&local))
1004 symtype = LIB$K_CLI_LOCAL_SYM;
1005 else symtype = LIB$K_CLI_GLOBAL_SYM;
1006 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1009 if (!*eqv) eqvdsc.dsc$w_length = 1;
1010 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1012 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1013 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1014 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1015 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1016 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1017 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1020 Newx(ilist,nseg+1,struct itmlst_3);
1023 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1026 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1028 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1029 ile->itmcode = LNM$_STRING;
1031 if ((j+1) == nseg) {
1032 ile->buflen = strlen(c);
1033 /* in case we are truncating one that's too long */
1034 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1037 ile->buflen = LNM$C_NAMLENGTH;
1041 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1045 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1050 if (!(retsts & 1)) {
1052 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1053 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1054 set_errno(EVMSERR); break;
1055 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1056 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1057 set_errno(EINVAL); break;
1064 set_vaxc_errno(retsts);
1065 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1068 /* We reset error values on success because Perl does an hv_fetch()
1069 * before each hv_store(), and if the thing we're setting didn't
1070 * previously exist, we've got a leftover error message. (Of course,
1071 * this fails in the face of
1072 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1073 * in that the error reported in $! isn't spurious,
1074 * but it's right more often than not.)
1076 set_errno(0); set_vaxc_errno(retsts);
1080 } /* end of vmssetenv() */
1083 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1084 /* This has to be a function since there's a prototype for it in proto.h */
1086 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1089 int len = strlen(lnm);
1093 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1094 if (!strcmp(uplnm,"DEFAULT")) {
1095 if (eqv && *eqv) my_chdir(eqv);
1099 #ifndef RTL_USES_UTC
1100 if (len == 6 || len == 2) {
1103 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1105 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1106 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1110 (void) vmssetenv(lnm,eqv,NULL);
1114 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1116 * sets a user-mode logical in the process logical name table
1117 * used for redirection of sys$error
1120 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1122 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1123 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1124 unsigned long int iss, attr = LNM$M_CONFINE;
1125 unsigned char acmode = PSL$C_USER;
1126 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1128 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1129 d_name.dsc$w_length = strlen(name);
1131 lnmlst[0].buflen = strlen(eqv);
1132 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1134 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1135 if (!(iss&1)) lib$signal(iss);
1140 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1141 /* my_crypt - VMS password hashing
1142 * my_crypt() provides an interface compatible with the Unix crypt()
1143 * C library function, and uses sys$hash_password() to perform VMS
1144 * password hashing. The quadword hashed password value is returned
1145 * as a NUL-terminated 8 character string. my_crypt() does not change
1146 * the case of its string arguments; in order to match the behavior
1147 * of LOGINOUT et al., alphabetic characters in both arguments must
1148 * be upcased by the caller.
1150 * - fix me to call ACM services when available
1153 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1155 # ifndef UAI$C_PREFERRED_ALGORITHM
1156 # define UAI$C_PREFERRED_ALGORITHM 127
1158 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1159 unsigned short int salt = 0;
1160 unsigned long int sts;
1162 unsigned short int dsc$w_length;
1163 unsigned char dsc$b_type;
1164 unsigned char dsc$b_class;
1165 const char * dsc$a_pointer;
1166 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1167 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1168 struct itmlst_3 uailst[3] = {
1169 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1170 { sizeof salt, UAI$_SALT, &salt, 0},
1171 { 0, 0, NULL, NULL}};
1172 static char hash[9];
1174 usrdsc.dsc$w_length = strlen(usrname);
1175 usrdsc.dsc$a_pointer = usrname;
1176 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1178 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1182 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1187 set_vaxc_errno(sts);
1188 if (sts != RMS$_RNF) return NULL;
1191 txtdsc.dsc$w_length = strlen(textpasswd);
1192 txtdsc.dsc$a_pointer = textpasswd;
1193 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1194 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1197 return (char *) hash;
1199 } /* end of my_crypt() */
1203 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1204 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1205 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1207 /* fixup barenames that are directories for internal use.
1208 * There have been problems with the consistent handling of UNIX
1209 * style directory names when routines are presented with a name that
1210 * has no directory delimitors at all. So this routine will eventually
1213 static char * fixup_bare_dirnames(const char * name)
1215 if (decc_disable_to_vms_logname_translation) {
1222 * A little hack to get around a bug in some implemenation of remove()
1223 * that do not know how to delete a directory
1225 * Delete any file to which user has control access, regardless of whether
1226 * delete access is explicitly allowed.
1227 * Limitations: User must have write access to parent directory.
1228 * Does not block signals or ASTs; if interrupted in midstream
1229 * may leave file with an altered ACL.
1232 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1234 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1236 char *vmsname, *rspec;
1238 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1239 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1240 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1242 unsigned char myace$b_length;
1243 unsigned char myace$b_type;
1244 unsigned short int myace$w_flags;
1245 unsigned long int myace$l_access;
1246 unsigned long int myace$l_ident;
1247 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1248 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1249 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1251 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1252 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1253 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1254 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1255 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1256 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1258 /* Expand the input spec using RMS, since the CRTL remove() and
1259 * system services won't do this by themselves, so we may miss
1260 * a file "hiding" behind a logical name or search list. */
1261 Newx(vmsname, NAM$C_MAXRSS+1, char);
1262 if (do_tovmsspec(name,vmsname,0) == NULL) {
1267 if (decc_posix_compliant_pathnames) {
1268 /* In POSIX mode, we prefer to remove the UNIX name */
1270 remove_name = (char *)name;
1273 Newx(rspec, NAM$C_MAXRSS+1, char);
1274 if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1280 remove_name = rspec;
1283 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1285 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1286 Newx(remove_name, NAM$C_MAXRSS+1, char);
1287 do_pathify_dirspec(name, remove_name, 0);
1288 if (!rmdir(remove_name)) {
1290 Safefree(remove_name);
1292 return 0; /* Can we just get rid of it? */
1296 if (!rmdir(remove_name)) {
1298 return 0; /* Can we just get rid of it? */
1304 if (!remove(remove_name)) {
1306 return 0; /* Can we just get rid of it? */
1309 /* If not, can changing protections help? */
1310 if (vaxc$errno != RMS$_PRV) {
1315 /* No, so we get our own UIC to use as a rights identifier,
1316 * and the insert an ACE at the head of the ACL which allows us
1317 * to delete the file.
1319 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1320 fildsc.dsc$w_length = strlen(rspec);
1321 fildsc.dsc$a_pointer = rspec;
1323 newace.myace$l_ident = oldace.myace$l_ident;
1324 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1326 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1327 set_errno(ENOENT); break;
1329 set_errno(ENOTDIR); break;
1331 set_errno(ENODEV); break;
1332 case RMS$_SYN: case SS$_INVFILFOROP:
1333 set_errno(EINVAL); break;
1335 set_errno(EACCES); break;
1339 set_vaxc_errno(aclsts);
1343 /* Grab any existing ACEs with this identifier in case we fail */
1344 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1345 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1346 || fndsts == SS$_NOMOREACE ) {
1347 /* Add the new ACE . . . */
1348 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1351 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1353 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1354 Newx(remove_name, NAM$C_MAXRSS+1, char);
1355 do_pathify_dirspec(name, remove_name, 0);
1356 rmsts = rmdir(remove_name);
1357 Safefree(remove_name);
1360 rmsts = rmdir(remove_name);
1364 rmsts = remove(remove_name);
1366 /* We blew it - dir with files in it, no write priv for
1367 * parent directory, etc. Put things back the way they were. */
1368 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1371 addlst[0].bufadr = &oldace;
1372 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1379 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1380 /* We just deleted it, so of course it's not there. Some versions of
1381 * VMS seem to return success on the unlock operation anyhow (after all
1382 * the unlock is successful), but others don't.
1384 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1385 if (aclsts & 1) aclsts = fndsts;
1386 if (!(aclsts & 1)) {
1388 set_vaxc_errno(aclsts);
1396 } /* end of kill_file() */
1400 /*{{{int do_rmdir(char *name)*/
1402 Perl_do_rmdir(pTHX_ const char *name)
1404 char dirfile[NAM$C_MAXRSS+1];
1408 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1409 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1410 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1413 } /* end of do_rmdir */
1417 * Delete any file to which user has control access, regardless of whether
1418 * delete access is explicitly allowed.
1419 * Limitations: User must have write access to parent directory.
1420 * Does not block signals or ASTs; if interrupted in midstream
1421 * may leave file with an altered ACL.
1424 /*{{{int kill_file(char *name)*/
1426 Perl_kill_file(pTHX_ const char *name)
1428 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1429 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1430 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1431 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1433 unsigned char myace$b_length;
1434 unsigned char myace$b_type;
1435 unsigned short int myace$w_flags;
1436 unsigned long int myace$l_access;
1437 unsigned long int myace$l_ident;
1438 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1439 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1440 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1442 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1443 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1444 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1445 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1446 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1447 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1449 /* Expand the input spec using RMS, since the CRTL remove() and
1450 * system services won't do this by themselves, so we may miss
1451 * a file "hiding" behind a logical name or search list. */
1452 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1453 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1454 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1455 /* If not, can changing protections help? */
1456 if (vaxc$errno != RMS$_PRV) return -1;
1458 /* No, so we get our own UIC to use as a rights identifier,
1459 * and the insert an ACE at the head of the ACL which allows us
1460 * to delete the file.
1462 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1463 fildsc.dsc$w_length = strlen(rspec);
1464 fildsc.dsc$a_pointer = rspec;
1466 newace.myace$l_ident = oldace.myace$l_ident;
1467 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1469 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1470 set_errno(ENOENT); break;
1472 set_errno(ENOTDIR); break;
1474 set_errno(ENODEV); break;
1475 case RMS$_SYN: case SS$_INVFILFOROP:
1476 set_errno(EINVAL); break;
1478 set_errno(EACCES); break;
1482 set_vaxc_errno(aclsts);
1485 /* Grab any existing ACEs with this identifier in case we fail */
1486 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1487 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1488 || fndsts == SS$_NOMOREACE ) {
1489 /* Add the new ACE . . . */
1490 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1492 if ((rmsts = remove(name))) {
1493 /* We blew it - dir with files in it, no write priv for
1494 * parent directory, etc. Put things back the way they were. */
1495 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1498 addlst[0].bufadr = &oldace;
1499 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1506 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1507 /* We just deleted it, so of course it's not there. Some versions of
1508 * VMS seem to return success on the unlock operation anyhow (after all
1509 * the unlock is successful), but others don't.
1511 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1512 if (aclsts & 1) aclsts = fndsts;
1513 if (!(aclsts & 1)) {
1515 set_vaxc_errno(aclsts);
1521 } /* end of kill_file() */
1525 /*{{{int my_mkdir(char *,Mode_t)*/
1527 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1529 STRLEN dirlen = strlen(dir);
1531 /* zero length string sometimes gives ACCVIO */
1532 if (dirlen == 0) return -1;
1534 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1535 * null file name/type. However, it's commonplace under Unix,
1536 * so we'll allow it for a gain in portability.
1538 if (dir[dirlen-1] == '/') {
1539 char *newdir = savepvn(dir,dirlen-1);
1540 int ret = mkdir(newdir,mode);
1544 else return mkdir(dir,mode);
1545 } /* end of my_mkdir */
1548 /*{{{int my_chdir(char *)*/
1550 Perl_my_chdir(pTHX_ const char *dir)
1552 STRLEN dirlen = strlen(dir);
1554 /* zero length string sometimes gives ACCVIO */
1555 if (dirlen == 0) return -1;
1558 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1559 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1560 * so that existing scripts do not need to be changed.
1563 while ((dirlen > 0) && (*dir1 == ' ')) {
1568 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1570 * null file name/type. However, it's commonplace under Unix,
1571 * so we'll allow it for a gain in portability.
1573 * - Preview- '/' will be valid soon on VMS
1575 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1576 char *newdir = savepvn(dir,dirlen-1);
1577 int ret = chdir(newdir);
1581 else return chdir(dir);
1582 } /* end of my_chdir */
1586 /*{{{FILE *my_tmpfile()*/
1593 if ((fp = tmpfile())) return fp;
1595 Newx(cp,L_tmpnam+24,char);
1596 if (decc_filename_unix_only == 0)
1597 strcpy(cp,"Sys$Scratch:");
1600 tmpnam(cp+strlen(cp));
1601 strcat(cp,".Perltmp");
1602 fp = fopen(cp,"w+","fop=dlt");
1609 #ifndef HOMEGROWN_POSIX_SIGNALS
1611 * The C RTL's sigaction fails to check for invalid signal numbers so we
1612 * help it out a bit. The docs are correct, but the actual routine doesn't
1613 * do what the docs say it will.
1615 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1617 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1618 struct sigaction* oact)
1620 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1621 SETERRNO(EINVAL, SS$_INVARG);
1624 return sigaction(sig, act, oact);
1629 #ifdef KILL_BY_SIGPRC
1630 #include <errnodef.h>
1632 /* We implement our own kill() using the undocumented system service
1633 sys$sigprc for one of two reasons:
1635 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1636 target process to do a sys$exit, which usually can't be handled
1637 gracefully...certainly not by Perl and the %SIG{} mechanism.
1639 2.) If the kill() in the CRTL can't be called from a signal
1640 handler without disappearing into the ether, i.e., the signal
1641 it purportedly sends is never trapped. Still true as of VMS 7.3.
1643 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1644 in the target process rather than calling sys$exit.
1646 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1647 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1648 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1649 with condition codes C$_SIG0+nsig*8, catching the exception on the
1650 target process and resignaling with appropriate arguments.
1652 But we don't have that VMS 7.0+ exception handler, so if you
1653 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1655 Also note that SIGTERM is listed in the docs as being "unimplemented",
1656 yet always seems to be signaled with a VMS condition code of 4 (and
1657 correctly handled for that code). So we hardwire it in.
1659 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1660 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1661 than signalling with an unrecognized (and unhandled by CRTL) code.
1664 #define _MY_SIG_MAX 17
1667 Perl_sig_to_vmscondition(int sig)
1669 static unsigned int sig_code[_MY_SIG_MAX+1] =
1672 SS$_HANGUP, /* 1 SIGHUP */
1673 SS$_CONTROLC, /* 2 SIGINT */
1674 SS$_CONTROLY, /* 3 SIGQUIT */
1675 SS$_RADRMOD, /* 4 SIGILL */
1676 SS$_BREAK, /* 5 SIGTRAP */
1677 SS$_OPCCUS, /* 6 SIGABRT */
1678 SS$_COMPAT, /* 7 SIGEMT */
1680 SS$_FLTOVF, /* 8 SIGFPE VAX */
1682 SS$_HPARITH, /* 8 SIGFPE AXP */
1684 SS$_ABORT, /* 9 SIGKILL */
1685 SS$_ACCVIO, /* 10 SIGBUS */
1686 SS$_ACCVIO, /* 11 SIGSEGV */
1687 SS$_BADPARAM, /* 12 SIGSYS */
1688 SS$_NOMBX, /* 13 SIGPIPE */
1689 SS$_ASTFLT, /* 14 SIGALRM */
1695 #if __VMS_VER >= 60200000
1696 static int initted = 0;
1699 sig_code[16] = C$_SIGUSR1;
1700 sig_code[17] = C$_SIGUSR2;
1704 if (sig < _SIG_MIN) return 0;
1705 if (sig > _MY_SIG_MAX) return 0;
1706 return sig_code[sig];
1710 Perl_my_kill(int pid, int sig)
1715 int sys$sigprc(unsigned int *pidadr,
1716 struct dsc$descriptor_s *prcname,
1719 /* sig 0 means validate the PID */
1720 /*------------------------------*/
1722 const unsigned long int jpicode = JPI$_PID;
1725 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1726 if ($VMS_STATUS_SUCCESS(status))
1729 case SS$_NOSUCHNODE:
1730 case SS$_UNREACHABLE:
1744 code = Perl_sig_to_vmscondition(sig);
1747 SETERRNO(EINVAL, SS$_BADPARAM);
1751 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
1752 * signals are to be sent to multiple processes.
1753 * pid = 0 - all processes in group except ones that the system exempts
1754 * pid = -1 - all processes except ones that the system exempts
1755 * pid = -n - all processes in group (abs(n)) except ...
1756 * For now, just report as not supported.
1760 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
1764 iss = sys$sigprc((unsigned int *)&pid,0,code);
1765 if (iss&1) return 0;
1769 set_errno(EPERM); break;
1771 case SS$_NOSUCHNODE:
1772 case SS$_UNREACHABLE:
1773 set_errno(ESRCH); break;
1775 set_errno(ENOMEM); break;
1780 set_vaxc_errno(iss);
1786 /* Routine to convert a VMS status code to a UNIX status code.
1787 ** More tricky than it appears because of conflicting conventions with
1790 ** VMS status codes are a bit mask, with the least significant bit set for
1793 ** Special UNIX status of EVMSERR indicates that no translation is currently
1794 ** available, and programs should check the VMS status code.
1796 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
1800 #ifndef C_FACILITY_NO
1801 #define C_FACILITY_NO 0x350000
1804 #define DCL_IVVERB 0x38090
1807 int Perl_vms_status_to_unix(int vms_status, int child_flag)
1815 /* Assume the best or the worst */
1816 if (vms_status & STS$M_SUCCESS)
1819 unix_status = EVMSERR;
1821 msg_status = vms_status & ~STS$M_CONTROL;
1823 facility = vms_status & STS$M_FAC_NO;
1824 fac_sp = vms_status & STS$M_FAC_SP;
1825 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
1827 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
1833 unix_status = EFAULT;
1835 case SS$_DEVOFFLINE:
1836 unix_status = EBUSY;
1839 unix_status = ENOTCONN;
1847 case SS$_INVFILFOROP:
1851 unix_status = EINVAL;
1853 case SS$_UNSUPPORTED:
1854 unix_status = ENOTSUP;
1859 unix_status = EACCES;
1861 case SS$_DEVICEFULL:
1862 unix_status = ENOSPC;
1865 unix_status = ENODEV;
1867 case SS$_NOSUCHFILE:
1868 case SS$_NOSUCHOBJECT:
1869 unix_status = ENOENT;
1871 case SS$_ABORT: /* Fatal case */
1872 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
1873 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
1874 unix_status = EINTR;
1877 unix_status = E2BIG;
1880 unix_status = ENOMEM;
1883 unix_status = EPERM;
1885 case SS$_NOSUCHNODE:
1886 case SS$_UNREACHABLE:
1887 unix_status = ESRCH;
1890 unix_status = ECHILD;
1893 if ((facility == 0) && (msg_no < 8)) {
1894 /* These are not real VMS status codes so assume that they are
1895 ** already UNIX status codes
1897 unix_status = msg_no;
1903 /* Translate a POSIX exit code to a UNIX exit code */
1904 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
1905 unix_status = (msg_no & 0x07F8) >> 3;
1909 /* Documented traditional behavior for handling VMS child exits */
1910 /*--------------------------------------------------------------*/
1911 if (child_flag != 0) {
1913 /* Success / Informational return 0 */
1914 /*----------------------------------*/
1915 if (msg_no & STS$K_SUCCESS)
1918 /* Warning returns 1 */
1919 /*-------------------*/
1920 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
1923 /* Everything else pass through the severity bits */
1924 /*------------------------------------------------*/
1925 return (msg_no & STS$M_SEVERITY);
1928 /* Normal VMS status to ERRNO mapping attempt */
1929 /*--------------------------------------------*/
1930 switch(msg_status) {
1931 /* case RMS$_EOF: */ /* End of File */
1932 case RMS$_FNF: /* File Not Found */
1933 case RMS$_DNF: /* Dir Not Found */
1934 unix_status = ENOENT;
1936 case RMS$_RNF: /* Record Not Found */
1937 unix_status = ESRCH;
1940 unix_status = ENOTDIR;
1943 unix_status = ENODEV;
1948 unix_status = EBADF;
1951 unix_status = EEXIST;
1955 case LIB$_INVSTRDES:
1957 case LIB$_NOSUCHSYM:
1958 case LIB$_INVSYMNAM:
1960 unix_status = EINVAL;
1966 unix_status = E2BIG;
1968 case RMS$_PRV: /* No privilege */
1969 case RMS$_ACC: /* ACP file access failed */
1970 case RMS$_WLK: /* Device write locked */
1971 unix_status = EACCES;
1973 /* case RMS$_NMF: */ /* No more files */
1981 /* Try to guess at what VMS error status should go with a UNIX errno
1982 * value. This is hard to do as there could be many possible VMS
1983 * error statuses that caused the errno value to be set.
1986 int Perl_unix_status_to_vms(int unix_status)
1988 int test_unix_status;
1990 /* Trivial cases first */
1991 /*---------------------*/
1992 if (unix_status == EVMSERR)
1995 /* Is vaxc$errno sane? */
1996 /*---------------------*/
1997 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
1998 if (test_unix_status == unix_status)
2001 /* If way out of range, must be VMS code already */
2002 /*-----------------------------------------------*/
2003 if (unix_status > EVMSERR)
2006 /* If out of range, punt */
2007 /*-----------------------*/
2008 if (unix_status > __ERRNO_MAX)
2012 /* Ok, now we have to do it the hard way. */
2013 /*----------------------------------------*/
2014 switch(unix_status) {
2015 case 0: return SS$_NORMAL;
2016 case EPERM: return SS$_NOPRIV;
2017 case ENOENT: return SS$_NOSUCHOBJECT;
2018 case ESRCH: return SS$_UNREACHABLE;
2019 case EINTR: return SS$_ABORT;
2022 case E2BIG: return SS$_BUFFEROVF;
2024 case EBADF: return RMS$_IFI;
2025 case ECHILD: return SS$_NONEXPR;
2027 case ENOMEM: return SS$_INSFMEM;
2028 case EACCES: return SS$_FILACCERR;
2029 case EFAULT: return SS$_ACCVIO;
2031 case EBUSY: return SS$_DEVOFFLINE;
2032 case EEXIST: return RMS$_FEX;
2034 case ENODEV: return SS$_NOSUCHDEV;
2035 case ENOTDIR: return RMS$_DIR;
2037 case EINVAL: return SS$_INVARG;
2043 case ENOSPC: return SS$_DEVICEFULL;
2044 case ESPIPE: return LIB$_INVARG;
2049 case ERANGE: return LIB$_INVARG;
2050 /* case EWOULDBLOCK */
2051 /* case EINPROGRESS */
2054 /* case EDESTADDRREQ */
2056 /* case EPROTOTYPE */
2057 /* case ENOPROTOOPT */
2058 /* case EPROTONOSUPPORT */
2059 /* case ESOCKTNOSUPPORT */
2060 /* case EOPNOTSUPP */
2061 /* case EPFNOSUPPORT */
2062 /* case EAFNOSUPPORT */
2063 /* case EADDRINUSE */
2064 /* case EADDRNOTAVAIL */
2066 /* case ENETUNREACH */
2067 /* case ENETRESET */
2068 /* case ECONNABORTED */
2069 /* case ECONNRESET */
2072 case ENOTCONN: return SS$_CLEARED;
2073 /* case ESHUTDOWN */
2074 /* case ETOOMANYREFS */
2075 /* case ETIMEDOUT */
2076 /* case ECONNREFUSED */
2078 /* case ENAMETOOLONG */
2079 /* case EHOSTDOWN */
2080 /* case EHOSTUNREACH */
2081 /* case ENOTEMPTY */
2093 /* case ECANCELED */
2097 return SS$_UNSUPPORTED;
2103 /* case EABANDONED */
2105 return SS$_ABORT; /* punt */
2108 return SS$_ABORT; /* Should not get here */
2112 /* default piping mailbox size */
2113 #define PERL_BUFSIZ 512
2117 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2119 unsigned long int mbxbufsiz;
2120 static unsigned long int syssize = 0;
2121 unsigned long int dviitm = DVI$_DEVNAM;
2122 char csize[LNM$C_NAMLENGTH+1];
2126 unsigned long syiitm = SYI$_MAXBUF;
2128 * Get the SYSGEN parameter MAXBUF
2130 * If the logical 'PERL_MBX_SIZE' is defined
2131 * use the value of the logical instead of PERL_BUFSIZ, but
2132 * keep the size between 128 and MAXBUF.
2135 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2138 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2139 mbxbufsiz = atoi(csize);
2141 mbxbufsiz = PERL_BUFSIZ;
2143 if (mbxbufsiz < 128) mbxbufsiz = 128;
2144 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2146 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2148 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2149 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2151 } /* end of create_mbx() */
2154 /*{{{ my_popen and my_pclose*/
2156 typedef struct _iosb IOSB;
2157 typedef struct _iosb* pIOSB;
2158 typedef struct _pipe Pipe;
2159 typedef struct _pipe* pPipe;
2160 typedef struct pipe_details Info;
2161 typedef struct pipe_details* pInfo;
2162 typedef struct _srqp RQE;
2163 typedef struct _srqp* pRQE;
2164 typedef struct _tochildbuf CBuf;
2165 typedef struct _tochildbuf* pCBuf;
2168 unsigned short status;
2169 unsigned short count;
2170 unsigned long dvispec;
2173 #pragma member_alignment save
2174 #pragma nomember_alignment quadword
2175 struct _srqp { /* VMS self-relative queue entry */
2176 unsigned long qptr[2];
2178 #pragma member_alignment restore
2179 static RQE RQE_ZERO = {0,0};
2181 struct _tochildbuf {
2184 unsigned short size;
2192 unsigned short chan_in;
2193 unsigned short chan_out;
2195 unsigned int bufsize;
2207 #if defined(PERL_IMPLICIT_CONTEXT)
2208 void *thx; /* Either a thread or an interpreter */
2209 /* pointer, depending on how we're built */
2217 PerlIO *fp; /* file pointer to pipe mailbox */
2218 int useFILE; /* using stdio, not perlio */
2219 int pid; /* PID of subprocess */
2220 int mode; /* == 'r' if pipe open for reading */
2221 int done; /* subprocess has completed */
2222 int waiting; /* waiting for completion/closure */
2223 int closing; /* my_pclose is closing this pipe */
2224 unsigned long completion; /* termination status of subprocess */
2225 pPipe in; /* pipe in to sub */
2226 pPipe out; /* pipe out of sub */
2227 pPipe err; /* pipe of sub's sys$error */
2228 int in_done; /* true when in pipe finished */
2233 struct exit_control_block
2235 struct exit_control_block *flink;
2236 unsigned long int (*exit_routine)();
2237 unsigned long int arg_count;
2238 unsigned long int *status_address;
2239 unsigned long int exit_status;
2242 typedef struct _closed_pipes Xpipe;
2243 typedef struct _closed_pipes* pXpipe;
2245 struct _closed_pipes {
2246 int pid; /* PID of subprocess */
2247 unsigned long completion; /* termination status of subprocess */
2249 #define NKEEPCLOSED 50
2250 static Xpipe closed_list[NKEEPCLOSED];
2251 static int closed_index = 0;
2252 static int closed_num = 0;
2254 #define RETRY_DELAY "0 ::0.20"
2255 #define MAX_RETRY 50
2257 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2258 static unsigned long mypid;
2259 static unsigned long delaytime[2];
2261 static pInfo open_pipes = NULL;
2262 static $DESCRIPTOR(nl_desc, "NL:");
2264 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2268 static unsigned long int
2269 pipe_exit_routine(pTHX)
2272 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2273 int sts, did_stuff, need_eof, j;
2276 flush any pending i/o
2282 PerlIO_flush(info->fp); /* first, flush data */
2284 fflush((FILE *)info->fp);
2290 next we try sending an EOF...ignore if doesn't work, make sure we
2298 _ckvmssts_noperl(sys$setast(0));
2299 if (info->in && !info->in->shut_on_empty) {
2300 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2305 _ckvmssts_noperl(sys$setast(1));
2309 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2311 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2316 _ckvmssts_noperl(sys$setast(0));
2317 if (info->waiting && info->done)
2319 nwait += info->waiting;
2320 _ckvmssts_noperl(sys$setast(1));
2330 _ckvmssts_noperl(sys$setast(0));
2331 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2332 sts = sys$forcex(&info->pid,0,&abort);
2333 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2336 _ckvmssts_noperl(sys$setast(1));
2340 /* again, wait for effect */
2342 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2347 _ckvmssts_noperl(sys$setast(0));
2348 if (info->waiting && info->done)
2350 nwait += info->waiting;
2351 _ckvmssts_noperl(sys$setast(1));
2360 _ckvmssts_noperl(sys$setast(0));
2361 if (!info->done) { /* We tried to be nice . . . */
2362 sts = sys$delprc(&info->pid,0);
2363 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2365 _ckvmssts_noperl(sys$setast(1));
2370 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2371 else if (!(sts & 1)) retsts = sts;
2376 static struct exit_control_block pipe_exitblock =
2377 {(struct exit_control_block *) 0,
2378 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2380 static void pipe_mbxtofd_ast(pPipe p);
2381 static void pipe_tochild1_ast(pPipe p);
2382 static void pipe_tochild2_ast(pPipe p);
2385 popen_completion_ast(pInfo info)
2387 pInfo i = open_pipes;
2392 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2393 closed_list[closed_index].pid = info->pid;
2394 closed_list[closed_index].completion = info->completion;
2396 if (closed_index == NKEEPCLOSED)
2401 if (i == info) break;
2404 if (!i) return; /* unlinked, probably freed too */
2409 Writing to subprocess ...
2410 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2412 chan_out may be waiting for "done" flag, or hung waiting
2413 for i/o completion to child...cancel the i/o. This will
2414 put it into "snarf mode" (done but no EOF yet) that discards
2417 Output from subprocess (stdout, stderr) needs to be flushed and
2418 shut down. We try sending an EOF, but if the mbx is full the pipe
2419 routine should still catch the "shut_on_empty" flag, telling it to
2420 use immediate-style reads so that "mbx empty" -> EOF.
2424 if (info->in && !info->in_done) { /* only for mode=w */
2425 if (info->in->shut_on_empty && info->in->need_wake) {
2426 info->in->need_wake = FALSE;
2427 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2429 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2433 if (info->out && !info->out_done) { /* were we also piping output? */
2434 info->out->shut_on_empty = TRUE;
2435 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2436 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2437 _ckvmssts_noperl(iss);
2440 if (info->err && !info->err_done) { /* we were piping stderr */
2441 info->err->shut_on_empty = TRUE;
2442 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2443 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2444 _ckvmssts_noperl(iss);
2446 _ckvmssts_noperl(sys$setef(pipe_ef));
2450 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2451 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2454 we actually differ from vmstrnenv since we use this to
2455 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2456 are pointing to the same thing
2459 static unsigned short
2460 popen_translate(pTHX_ char *logical, char *result)
2463 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2464 $DESCRIPTOR(d_log,"");
2466 unsigned short length;
2467 unsigned short code;
2469 unsigned short *retlenaddr;
2471 unsigned short l, ifi;
2473 d_log.dsc$a_pointer = logical;
2474 d_log.dsc$w_length = strlen(logical);
2476 itmlst[0].code = LNM$_STRING;
2477 itmlst[0].length = 255;
2478 itmlst[0].buffer_addr = result;
2479 itmlst[0].retlenaddr = &l;
2482 itmlst[1].length = 0;
2483 itmlst[1].buffer_addr = 0;
2484 itmlst[1].retlenaddr = 0;
2486 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2487 if (iss == SS$_NOLOGNAM) {
2491 if (!(iss&1)) lib$signal(iss);
2494 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2495 strip it off and return the ifi, if any
2498 if (result[0] == 0x1b && result[1] == 0x00) {
2499 memmove(&ifi,result+2,2);
2500 strcpy(result,result+4);
2502 return ifi; /* this is the RMS internal file id */
2505 static void pipe_infromchild_ast(pPipe p);
2508 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2509 inside an AST routine without worrying about reentrancy and which Perl
2510 memory allocator is being used.
2512 We read data and queue up the buffers, then spit them out one at a
2513 time to the output mailbox when the output mailbox is ready for one.
2516 #define INITIAL_TOCHILDQUEUE 2
2519 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2523 char mbx1[64], mbx2[64];
2524 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2525 DSC$K_CLASS_S, mbx1},
2526 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2527 DSC$K_CLASS_S, mbx2};
2528 unsigned int dviitm = DVI$_DEVBUFSIZ;
2532 _ckvmssts(lib$get_vm(&n, &p));
2534 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2535 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2536 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2539 p->shut_on_empty = FALSE;
2540 p->need_wake = FALSE;
2543 p->iosb.status = SS$_NORMAL;
2544 p->iosb2.status = SS$_NORMAL;
2550 #ifdef PERL_IMPLICIT_CONTEXT
2554 n = sizeof(CBuf) + p->bufsize;
2556 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2557 _ckvmssts(lib$get_vm(&n, &b));
2558 b->buf = (char *) b + sizeof(CBuf);
2559 _ckvmssts(lib$insqhi(b, &p->free));
2562 pipe_tochild2_ast(p);
2563 pipe_tochild1_ast(p);
2569 /* reads the MBX Perl is writing, and queues */
2572 pipe_tochild1_ast(pPipe p)
2575 int iss = p->iosb.status;
2576 int eof = (iss == SS$_ENDOFFILE);
2578 #ifdef PERL_IMPLICIT_CONTEXT
2584 p->shut_on_empty = TRUE;
2586 _ckvmssts(sys$dassgn(p->chan_in));
2592 b->size = p->iosb.count;
2593 _ckvmssts(sts = lib$insqhi(b, &p->wait));
2595 p->need_wake = FALSE;
2596 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2599 p->retry = 1; /* initial call */
2602 if (eof) { /* flush the free queue, return when done */
2603 int n = sizeof(CBuf) + p->bufsize;
2605 iss = lib$remqti(&p->free, &b);
2606 if (iss == LIB$_QUEWASEMP) return;
2608 _ckvmssts(lib$free_vm(&n, &b));
2612 iss = lib$remqti(&p->free, &b);
2613 if (iss == LIB$_QUEWASEMP) {
2614 int n = sizeof(CBuf) + p->bufsize;
2615 _ckvmssts(lib$get_vm(&n, &b));
2616 b->buf = (char *) b + sizeof(CBuf);
2622 iss = sys$qio(0,p->chan_in,
2623 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2625 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2626 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2631 /* writes queued buffers to output, waits for each to complete before
2635 pipe_tochild2_ast(pPipe p)
2638 int iss = p->iosb2.status;
2639 int n = sizeof(CBuf) + p->bufsize;
2640 int done = (p->info && p->info->done) ||
2641 iss == SS$_CANCEL || iss == SS$_ABORT;
2642 #if defined(PERL_IMPLICIT_CONTEXT)
2647 if (p->type) { /* type=1 has old buffer, dispose */
2648 if (p->shut_on_empty) {
2649 _ckvmssts(lib$free_vm(&n, &b));
2651 _ckvmssts(lib$insqhi(b, &p->free));
2656 iss = lib$remqti(&p->wait, &b);
2657 if (iss == LIB$_QUEWASEMP) {
2658 if (p->shut_on_empty) {
2660 _ckvmssts(sys$dassgn(p->chan_out));
2661 *p->pipe_done = TRUE;
2662 _ckvmssts(sys$setef(pipe_ef));
2664 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2665 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2669 p->need_wake = TRUE;
2679 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2680 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2682 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2683 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2692 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2695 char mbx1[64], mbx2[64];
2696 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2697 DSC$K_CLASS_S, mbx1},
2698 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2699 DSC$K_CLASS_S, mbx2};
2700 unsigned int dviitm = DVI$_DEVBUFSIZ;
2702 int n = sizeof(Pipe);
2703 _ckvmssts(lib$get_vm(&n, &p));
2704 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2705 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2707 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2708 n = p->bufsize * sizeof(char);
2709 _ckvmssts(lib$get_vm(&n, &p->buf));
2710 p->shut_on_empty = FALSE;
2713 p->iosb.status = SS$_NORMAL;
2714 #if defined(PERL_IMPLICIT_CONTEXT)
2717 pipe_infromchild_ast(p);
2725 pipe_infromchild_ast(pPipe p)
2727 int iss = p->iosb.status;
2728 int eof = (iss == SS$_ENDOFFILE);
2729 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2730 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2731 #if defined(PERL_IMPLICIT_CONTEXT)
2735 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
2736 _ckvmssts(sys$dassgn(p->chan_out));
2741 input shutdown if EOF from self (done or shut_on_empty)
2742 output shutdown if closing flag set (my_pclose)
2743 send data/eof from child or eof from self
2744 otherwise, re-read (snarf of data from child)
2749 if (myeof && p->chan_in) { /* input shutdown */
2750 _ckvmssts(sys$dassgn(p->chan_in));
2755 if (myeof || kideof) { /* pass EOF to parent */
2756 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
2757 pipe_infromchild_ast, p,
2760 } else if (eof) { /* eat EOF --- fall through to read*/
2762 } else { /* transmit data */
2763 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
2764 pipe_infromchild_ast,p,
2765 p->buf, p->iosb.count, 0, 0, 0, 0));
2771 /* everything shut? flag as done */
2773 if (!p->chan_in && !p->chan_out) {
2774 *p->pipe_done = TRUE;
2775 _ckvmssts(sys$setef(pipe_ef));
2779 /* write completed (or read, if snarfing from child)
2780 if still have input active,
2781 queue read...immediate mode if shut_on_empty so we get EOF if empty
2783 check if Perl reading, generate EOFs as needed
2789 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
2790 pipe_infromchild_ast,p,
2791 p->buf, p->bufsize, 0, 0, 0, 0);
2792 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
2794 } else { /* send EOFs for extra reads */
2795 p->iosb.status = SS$_ENDOFFILE;
2796 p->iosb.dvispec = 0;
2797 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
2799 pipe_infromchild_ast, p, 0, 0, 0, 0));
2805 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
2809 unsigned long dviitm = DVI$_DEVBUFSIZ;
2811 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
2812 DSC$K_CLASS_S, mbx};
2813 int n = sizeof(Pipe);
2815 /* things like terminals and mbx's don't need this filter */
2816 if (fd && fstat(fd,&s) == 0) {
2817 unsigned long dviitm = DVI$_DEVCHAR, devchar;
2818 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
2819 DSC$K_CLASS_S, s.st_dev};
2821 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
2822 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
2823 strcpy(out, s.st_dev);
2828 _ckvmssts(lib$get_vm(&n, &p));
2829 p->fd_out = dup(fd);
2830 create_mbx(aTHX_ &p->chan_in, &d_mbx);
2831 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2832 n = (p->bufsize+1) * sizeof(char);
2833 _ckvmssts(lib$get_vm(&n, &p->buf));
2834 p->shut_on_empty = FALSE;
2839 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
2840 pipe_mbxtofd_ast, p,
2841 p->buf, p->bufsize, 0, 0, 0, 0));
2847 pipe_mbxtofd_ast(pPipe p)
2849 int iss = p->iosb.status;
2850 int done = p->info->done;
2852 int eof = (iss == SS$_ENDOFFILE);
2853 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
2854 int err = !(iss&1) && !eof;
2855 #if defined(PERL_IMPLICIT_CONTEXT)
2859 if (done && myeof) { /* end piping */
2861 sys$dassgn(p->chan_in);
2862 *p->pipe_done = TRUE;
2863 _ckvmssts(sys$setef(pipe_ef));
2867 if (!err && !eof) { /* good data to send to file */
2868 p->buf[p->iosb.count] = '\n';
2869 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
2872 if (p->retry < MAX_RETRY) {
2873 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
2883 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
2884 pipe_mbxtofd_ast, p,
2885 p->buf, p->bufsize, 0, 0, 0, 0);
2886 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
2891 typedef struct _pipeloc PLOC;
2892 typedef struct _pipeloc* pPLOC;
2896 char dir[NAM$C_MAXRSS+1];
2898 static pPLOC head_PLOC = 0;
2901 free_pipelocs(pTHX_ void *head)
2904 pPLOC *pHead = (pPLOC *)head;
2916 store_pipelocs(pTHX)
2925 char temp[NAM$C_MAXRSS+1];
2929 free_pipelocs(aTHX_ &head_PLOC);
2931 /* the . directory from @INC comes last */
2933 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2934 p->next = head_PLOC;
2936 strcpy(p->dir,"./");
2938 /* get the directory from $^X */
2940 #ifdef PERL_IMPLICIT_CONTEXT
2941 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2943 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
2945 strcpy(temp, PL_origargv[0]);
2946 x = strrchr(temp,']');
2948 x = strrchr(temp,'>');
2950 /* It could be a UNIX path */
2951 x = strrchr(temp,'/');
2957 /* Got a bare name, so use default directory */
2962 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
2963 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2964 p->next = head_PLOC;
2966 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2967 p->dir[NAM$C_MAXRSS] = '\0';
2971 /* reverse order of @INC entries, skip "." since entered above */
2973 #ifdef PERL_IMPLICIT_CONTEXT
2976 if (PL_incgv) av = GvAVn(PL_incgv);
2978 for (i = 0; av && i <= AvFILL(av); i++) {
2979 dirsv = *av_fetch(av,i,TRUE);
2981 if (SvROK(dirsv)) continue;
2982 dir = SvPVx(dirsv,n_a);
2983 if (strcmp(dir,".") == 0) continue;
2984 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
2987 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2988 p->next = head_PLOC;
2990 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
2991 p->dir[NAM$C_MAXRSS] = '\0';
2994 /* most likely spot (ARCHLIB) put first in the list */
2997 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
2998 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
2999 p->next = head_PLOC;
3001 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3002 p->dir[NAM$C_MAXRSS] = '\0';
3011 static int vmspipe_file_status = 0;
3012 static char vmspipe_file[NAM$C_MAXRSS+1];
3014 /* already found? Check and use ... need read+execute permission */
3016 if (vmspipe_file_status == 1) {
3017 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3018 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3019 return vmspipe_file;
3021 vmspipe_file_status = 0;
3024 /* scan through stored @INC, $^X */
3026 if (vmspipe_file_status == 0) {
3027 char file[NAM$C_MAXRSS+1];
3028 pPLOC p = head_PLOC;
3031 strcpy(file, p->dir);
3032 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3033 file[NAM$C_MAXRSS] = '\0';
3036 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3038 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3039 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3040 vmspipe_file_status = 1;
3041 return vmspipe_file;
3044 vmspipe_file_status = -1; /* failed, use tempfiles */
3051 vmspipe_tempfile(pTHX)
3053 char file[NAM$C_MAXRSS+1];
3055 static int index = 0;
3059 /* create a tempfile */
3061 /* we can't go from W, shr=get to R, shr=get without
3062 an intermediate vulnerable state, so don't bother trying...
3064 and lib$spawn doesn't shr=put, so have to close the write
3066 So... match up the creation date/time and the FID to
3067 make sure we're dealing with the same file
3072 if (!decc_filename_unix_only) {
3073 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3074 fp = fopen(file,"w");
3076 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3077 fp = fopen(file,"w");
3079 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3080 fp = fopen(file,"w");
3085 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3086 fp = fopen(file,"w");
3088 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3089 fp = fopen(file,"w");
3091 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3092 fp = fopen(file,"w");
3096 if (!fp) return 0; /* we're hosed */
3098 fprintf(fp,"$! 'f$verify(0)'\n");
3099 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3100 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3101 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3102 fprintf(fp,"$ perl_on = \"set noon\"\n");
3103 fprintf(fp,"$ perl_exit = \"exit\"\n");
3104 fprintf(fp,"$ perl_del = \"delete\"\n");
3105 fprintf(fp,"$ pif = \"if\"\n");
3106 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3107 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3108 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3109 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3110 fprintf(fp,"$! --- build command line to get max possible length\n");
3111 fprintf(fp,"$c=perl_popen_cmd0\n");
3112 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3113 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3114 fprintf(fp,"$x=perl_popen_cmd3\n");
3115 fprintf(fp,"$c=c+x\n");
3116 fprintf(fp,"$ perl_on\n");
3117 fprintf(fp,"$ 'c'\n");
3118 fprintf(fp,"$ perl_status = $STATUS\n");
3119 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3120 fprintf(fp,"$ perl_exit 'perl_status'\n");
3123 fgetname(fp, file, 1);
3124 fstat(fileno(fp), (struct stat *)&s0);
3127 if (decc_filename_unix_only)
3128 do_tounixspec(file, file, 0);
3129 fp = fopen(file,"r","shr=get");
3131 fstat(fileno(fp), (struct stat *)&s1);
3133 #if defined(_USE_STD_STAT)
3134 cmp_result = s0.crtl_stat.st_ino != s1.crtl_stat.st_ino;
3136 cmp_result = memcmp(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino, 6);
3138 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3149 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3151 static int handler_set_up = FALSE;
3152 unsigned long int sts, flags = CLI$M_NOWAIT;
3153 /* The use of a GLOBAL table (as was done previously) rendered
3154 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3155 * environment. Hence we've switched to LOCAL symbol table.
3157 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3159 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3160 char in[512], out[512], err[512], mbx[512];
3162 char tfilebuf[NAM$C_MAXRSS+1];
3164 char cmd_sym_name[20];
3165 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3166 DSC$K_CLASS_S, symbol};
3167 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3169 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3170 DSC$K_CLASS_S, cmd_sym_name};
3171 struct dsc$descriptor_s *vmscmd;
3172 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3173 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3174 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3176 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3178 /* once-per-program initialization...
3179 note that the SETAST calls and the dual test of pipe_ef
3180 makes sure that only the FIRST thread through here does
3181 the initialization...all other threads wait until it's
3184 Yeah, uglier than a pthread call, it's got all the stuff inline
3185 rather than in a separate routine.
3189 _ckvmssts(sys$setast(0));
3191 unsigned long int pidcode = JPI$_PID;
3192 $DESCRIPTOR(d_delay, RETRY_DELAY);
3193 _ckvmssts(lib$get_ef(&pipe_ef));
3194 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3195 _ckvmssts(sys$bintim(&d_delay, delaytime));
3197 if (!handler_set_up) {
3198 _ckvmssts(sys$dclexh(&pipe_exitblock));
3199 handler_set_up = TRUE;
3201 _ckvmssts(sys$setast(1));
3204 /* see if we can find a VMSPIPE.COM */
3207 vmspipe = find_vmspipe(aTHX);
3209 strcpy(tfilebuf+1,vmspipe);
3210 } else { /* uh, oh...we're in tempfile hell */
3211 tpipe = vmspipe_tempfile(aTHX);
3212 if (!tpipe) { /* a fish popular in Boston */
3213 if (ckWARN(WARN_PIPE)) {
3214 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3218 fgetname(tpipe,tfilebuf+1,1);
3220 vmspipedsc.dsc$a_pointer = tfilebuf;
3221 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3223 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3226 case RMS$_FNF: case RMS$_DNF:
3227 set_errno(ENOENT); break;
3229 set_errno(ENOTDIR); break;
3231 set_errno(ENODEV); break;
3233 set_errno(EACCES); break;
3235 set_errno(EINVAL); break;
3236 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3237 set_errno(E2BIG); break;
3238 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3239 _ckvmssts(sts); /* fall through */
3240 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3243 set_vaxc_errno(sts);
3244 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3245 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3251 _ckvmssts(lib$get_vm(&n, &info));
3253 strcpy(mode,in_mode);
3256 info->completion = 0;
3257 info->closing = FALSE;
3264 info->in_done = TRUE;
3265 info->out_done = TRUE;
3266 info->err_done = TRUE;
3267 in[0] = out[0] = err[0] = '\0';
3269 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3273 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3278 if (*mode == 'r') { /* piping from subroutine */
3280 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3282 info->out->pipe_done = &info->out_done;
3283 info->out_done = FALSE;
3284 info->out->info = info;
3286 if (!info->useFILE) {
3287 info->fp = PerlIO_open(mbx, mode);
3289 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3290 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3293 if (!info->fp && info->out) {
3294 sys$cancel(info->out->chan_out);
3296 while (!info->out_done) {
3298 _ckvmssts(sys$setast(0));
3299 done = info->out_done;
3300 if (!done) _ckvmssts(sys$clref(pipe_ef));
3301 _ckvmssts(sys$setast(1));
3302 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3305 if (info->out->buf) {
3306 n = info->out->bufsize * sizeof(char);
3307 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3310 _ckvmssts(lib$free_vm(&n, &info->out));
3312 _ckvmssts(lib$free_vm(&n, &info));
3317 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3319 info->err->pipe_done = &info->err_done;
3320 info->err_done = FALSE;
3321 info->err->info = info;
3324 } else if (*mode == 'w') { /* piping to subroutine */
3326 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3328 info->out->pipe_done = &info->out_done;
3329 info->out_done = FALSE;
3330 info->out->info = info;
3333 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3335 info->err->pipe_done = &info->err_done;
3336 info->err_done = FALSE;
3337 info->err->info = info;
3340 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3341 if (!info->useFILE) {
3342 info->fp = PerlIO_open(mbx, mode);
3344 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3345 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3349 info->in->pipe_done = &info->in_done;
3350 info->in_done = FALSE;
3351 info->in->info = info;
3355 if (!info->fp && info->in) {
3357 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3358 0, 0, 0, 0, 0, 0, 0, 0));
3360 while (!info->in_done) {
3362 _ckvmssts(sys$setast(0));
3363 done = info->in_done;
3364 if (!done) _ckvmssts(sys$clref(pipe_ef));
3365 _ckvmssts(sys$setast(1));
3366 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3369 if (info->in->buf) {
3370 n = info->in->bufsize * sizeof(char);
3371 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3374 _ckvmssts(lib$free_vm(&n, &info->in));
3376 _ckvmssts(lib$free_vm(&n, &info));
3382 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3383 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3385 info->out->pipe_done = &info->out_done;
3386 info->out_done = FALSE;
3387 info->out->info = info;
3390 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3392 info->err->pipe_done = &info->err_done;
3393 info->err_done = FALSE;
3394 info->err->info = info;
3398 symbol[MAX_DCL_SYMBOL] = '\0';
3400 strncpy(symbol, in, MAX_DCL_SYMBOL);
3401 d_symbol.dsc$w_length = strlen(symbol);
3402 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3404 strncpy(symbol, err, MAX_DCL_SYMBOL);
3405 d_symbol.dsc$w_length = strlen(symbol);
3406 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3408 strncpy(symbol, out, MAX_DCL_SYMBOL);
3409 d_symbol.dsc$w_length = strlen(symbol);
3410 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3412 p = vmscmd->dsc$a_pointer;
3413 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3414 if (*p == '$') p++; /* remove leading $ */
3415 while (*p == ' ' || *p == '\t') p++;
3417 for (j = 0; j < 4; j++) {
3418 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3419 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3421 strncpy(symbol, p, MAX_DCL_SYMBOL);
3422 d_symbol.dsc$w_length = strlen(symbol);
3423 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3425 if (strlen(p) > MAX_DCL_SYMBOL) {
3426 p += MAX_DCL_SYMBOL;
3431 _ckvmssts(sys$setast(0));
3432 info->next=open_pipes; /* prepend to list */
3434 _ckvmssts(sys$setast(1));
3435 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3436 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3437 * have SYS$COMMAND if we need it.
3439 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3440 0, &info->pid, &info->completion,
3441 0, popen_completion_ast,info,0,0,0));
3443 /* if we were using a tempfile, close it now */
3445 if (tpipe) fclose(tpipe);
3447 /* once the subprocess is spawned, it has copied the symbols and
3448 we can get rid of ours */
3450 for (j = 0; j < 4; j++) {
3451 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3452 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3453 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3455 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3456 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3457 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3458 vms_execfree(vmscmd);
3460 #ifdef PERL_IMPLICIT_CONTEXT
3463 PL_forkprocess = info->pid;
3468 _ckvmssts(sys$setast(0));
3470 if (!done) _ckvmssts(sys$clref(pipe_ef));
3471 _ckvmssts(sys$setast(1));
3472 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3474 *psts = info->completion;
3475 /* Caller thinks it is open and tries to close it. */
3476 /* This causes some problems, as it changes the error status */
3477 /* my_pclose(info->fp); */
3482 } /* end of safe_popen */
3485 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3487 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3491 TAINT_PROPER("popen");
3492 PERL_FLUSHALL_FOR_CHILD;
3493 return safe_popen(aTHX_ cmd,mode,&sts);
3498 /*{{{ I32 my_pclose(PerlIO *fp)*/
3499 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3501 pInfo info, last = NULL;
3502 unsigned long int retsts;
3505 for (info = open_pipes; info != NULL; last = info, info = info->next)
3506 if (info->fp == fp) break;
3508 if (info == NULL) { /* no such pipe open */
3509 set_errno(ECHILD); /* quoth POSIX */
3510 set_vaxc_errno(SS$_NONEXPR);
3514 /* If we were writing to a subprocess, insure that someone reading from
3515 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
3516 * produce an EOF record in the mailbox.
3518 * well, at least sometimes it *does*, so we have to watch out for
3519 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3523 PerlIO_flush(info->fp); /* first, flush data */
3525 fflush((FILE *)info->fp);
3528 _ckvmssts(sys$setast(0));
3529 info->closing = TRUE;
3530 done = info->done && info->in_done && info->out_done && info->err_done;
3531 /* hanging on write to Perl's input? cancel it */
3532 if (info->mode == 'r' && info->out && !info->out_done) {
3533 if (info->out->chan_out) {
3534 _ckvmssts(sys$cancel(info->out->chan_out));
3535 if (!info->out->chan_in) { /* EOF generation, need AST */
3536 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3540 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3541 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3543 _ckvmssts(sys$setast(1));
3546 PerlIO_close(info->fp);
3548 fclose((FILE *)info->fp);
3551 we have to wait until subprocess completes, but ALSO wait until all
3552 the i/o completes...otherwise we'll be freeing the "info" structure
3553 that the i/o ASTs could still be using...
3557 _ckvmssts(sys$setast(0));
3558 done = info->done && info->in_done && info->out_done && info->err_done;
3559 if (!done) _ckvmssts(sys$clref(pipe_ef));
3560 _ckvmssts(sys$setast(1));
3561 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3563 retsts = info->completion;
3565 /* remove from list of open pipes */
3566 _ckvmssts(sys$setast(0));
3567 if (last) last->next = info->next;
3568 else open_pipes = info->next;
3569 _ckvmssts(sys$setast(1));
3571 /* free buffers and structures */
3574 if (info->in->buf) {
3575 n = info->in->bufsize * sizeof(char);
3576 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3579 _ckvmssts(lib$free_vm(&n, &info->in));
3582 if (info->out->buf) {
3583 n = info->out->bufsize * sizeof(char);
3584 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3587 _ckvmssts(lib$free_vm(&n, &info->out));
3590 if (info->err->buf) {
3591 n = info->err->bufsize * sizeof(char);
3592 _ckvmssts(lib$free_vm(&n, &info->err->buf));
3595 _ckvmssts(lib$free_vm(&n, &info->err));
3598 _ckvmssts(lib$free_vm(&n, &info));
3602 } /* end of my_pclose() */
3604 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3605 /* Roll our own prototype because we want this regardless of whether
3606 * _VMS_WAIT is defined.
3608 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3610 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3611 created with popen(); otherwise partially emulate waitpid() unless
3612 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3613 Also check processes not considered by the CRTL waitpid().
3615 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3617 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3624 if (statusp) *statusp = 0;
3626 for (info = open_pipes; info != NULL; info = info->next)
3627 if (info->pid == pid) break;
3629 if (info != NULL) { /* we know about this child */
3630 while (!info->done) {
3631 _ckvmssts(sys$setast(0));
3633 if (!done) _ckvmssts(sys$clref(pipe_ef));
3634 _ckvmssts(sys$setast(1));
3635 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3638 if (statusp) *statusp = info->completion;
3642 /* child that already terminated? */
3644 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3645 if (closed_list[j].pid == pid) {
3646 if (statusp) *statusp = closed_list[j].completion;
3651 /* fall through if this child is not one of our own pipe children */
3653 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3655 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3656 * in 7.2 did we get a version that fills in the VMS completion
3657 * status as Perl has always tried to do.
3660 sts = __vms_waitpid( pid, statusp, flags );
3662 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3665 /* If the real waitpid tells us the child does not exist, we
3666 * fall through here to implement waiting for a child that
3667 * was created by some means other than exec() (say, spawned
3668 * from DCL) or to wait for a process that is not a subprocess
3669 * of the current process.
3672 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3675 $DESCRIPTOR(intdsc,"0 00:00:01");
3676 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3677 unsigned long int pidcode = JPI$_PID, mypid;
3678 unsigned long int interval[2];
3679 unsigned int jpi_iosb[2];
3680 struct itmlst_3 jpilist[2] = {
3681 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
3686 /* Sorry folks, we don't presently implement rooting around for
3687 the first child we can find, and we definitely don't want to
3688 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3694 /* Get the owner of the child so I can warn if it's not mine. If the
3695 * process doesn't exist or I don't have the privs to look at it,
3696 * I can go home early.
3698 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3699 if (sts & 1) sts = jpi_iosb[0];
3711 set_vaxc_errno(sts);
3715 if (ckWARN(WARN_EXEC)) {
3716 /* remind folks they are asking for non-standard waitpid behavior */
3717 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3718 if (ownerpid != mypid)
3719 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3720 "waitpid: process %x is not a child of process %x",
3724 /* simply check on it once a second until it's not there anymore. */
3726 _ckvmssts(sys$bintim(&intdsc,interval));
3727 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3728 _ckvmssts(sys$schdwk(0,0,interval,0));
3729 _ckvmssts(sys$hiber());
3731 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3736 } /* end of waitpid() */
3741 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3743 my_gconvert(double val, int ndig, int trail, char *buf)
3745 static char __gcvtbuf[DBL_DIG+1];
3748 loc = buf ? buf : __gcvtbuf;
3750 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
3752 sprintf(loc,"%.*g",ndig,val);
3758 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
3759 return gcvt(val,ndig,loc);
3762 loc[0] = '0'; loc[1] = '\0';
3769 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
3770 static int rms_free_search_context(struct FAB * fab)
3774 nam = fab->fab$l_nam;
3775 nam->nam$b_nop |= NAM$M_SYNCHK;
3776 nam->nam$l_rlf = NULL;
3778 return sys$parse(fab, NULL, NULL);
3781 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
3782 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
3783 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
3784 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
3785 #define rms_nam_esll(nam) nam.nam$b_esl
3786 #define rms_nam_esl(nam) nam.nam$b_esl
3787 #define rms_nam_name(nam) nam.nam$l_name
3788 #define rms_nam_namel(nam) nam.nam$l_name
3789 #define rms_nam_type(nam) nam.nam$l_type
3790 #define rms_nam_typel(nam) nam.nam$l_type
3791 #define rms_nam_ver(nam) nam.nam$l_ver
3792 #define rms_nam_verl(nam) nam.nam$l_ver
3793 #define rms_nam_rsll(nam) nam.nam$b_rsl
3794 #define rms_nam_rsl(nam) nam.nam$b_rsl
3795 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
3796 #define rms_set_fna(fab, nam, name, size) \
3797 fab.fab$b_fns = size; fab.fab$l_fna = name;
3798 #define rms_get_fna(fab, nam) fab.fab$l_fna
3799 #define rms_set_dna(fab, nam, name, size) \
3800 fab.fab$b_dns = size; fab.fab$l_dna = name;
3801 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
3802 #define rms_set_esa(fab, nam, name, size) \
3803 nam.nam$b_ess = size; nam.nam$l_esa = name;
3804 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3805 nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
3806 #define rms_set_rsa(nam, name, size) \
3807 nam.nam$l_rsa = name; nam.nam$b_rss = size;
3808 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3809 nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
3812 static int rms_free_search_context(struct FAB * fab)
3816 nam = fab->fab$l_naml;
3817 nam->naml$b_nop |= NAM$M_SYNCHK;
3818 nam->naml$l_rlf = NULL;
3819 nam->naml$l_long_defname_size = 0;
3821 return sys$parse(fab, NULL, NULL);
3824 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
3825 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
3826 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
3827 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
3828 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
3829 #define rms_nam_esl(nam) nam.naml$b_esl
3830 #define rms_nam_name(nam) nam.naml$l_name
3831 #define rms_nam_namel(nam) nam.naml$l_long_name
3832 #define rms_nam_type(nam) nam.naml$l_type
3833 #define rms_nam_typel(nam) nam.naml$l_long_type
3834 #define rms_nam_ver(nam) nam.naml$l_ver
3835 #define rms_nam_verl(nam) nam.naml$l_long_ver
3836 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
3837 #define rms_nam_rsl(nam) nam.naml$b_rsl
3838 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
3839 #define rms_set_fna(fab, nam, name, size) \
3840 fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
3841 nam.naml$l_long_filename_size = size; \
3842 nam.naml$l_long_filename = name
3843 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
3844 #define rms_set_dna(fab, nam, name, size) \
3845 fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
3846 nam.naml$l_long_defname_size = size; \
3847 nam.naml$l_long_defname = name
3848 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
3849 #define rms_set_esa(fab, nam, name, size) \
3850 nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
3851 nam.naml$l_long_expand_alloc = size; \
3852 nam.naml$l_long_expand = name
3853 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
3854 nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
3855 nam.naml$l_long_expand = l_name; \
3856 nam.naml$l_long_expand_alloc = l_size;
3857 #define rms_set_rsa(nam, name, size) \
3858 nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
3859 nam.naml$l_long_result = name; \
3860 nam.naml$l_long_result_alloc = size;
3861 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
3862 nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
3863 nam.naml$l_long_result = l_name; \
3864 nam.naml$l_long_result_alloc = l_size;
3869 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
3870 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
3871 * to expand file specification. Allows for a single default file
3872 * specification and a simple mask of options. If outbuf is non-NULL,
3873 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
3874 * the resultant file specification is placed. If outbuf is NULL, the
3875 * resultant file specification is placed into a static buffer.
3876 * The third argument, if non-NULL, is taken to be a default file
3877 * specification string. The fourth argument is unused at present.
3878 * rmesexpand() returns the address of the resultant string if
3879 * successful, and NULL on error.
3881 * New functionality for previously unused opts value:
3882 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
3884 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
3886 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
3887 /* ODS-2 only version */
3889 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
3891 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
3892 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
3893 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
3894 struct FAB myfab = cc$rms_fab;
3895 struct NAM mynam = cc$rms_nam;
3897 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
3900 if (!filespec || !*filespec) {
3901 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
3905 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
3906 else outbuf = __rmsexpand_retbuf;
3908 isunix = is_unix_filespec(filespec);
3910 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
3915 filespec = vmsfspec;
3918 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
3919 myfab.fab$b_fns = strlen(filespec);
3920 myfab.fab$l_nam = &mynam;
3922 if (defspec && *defspec) {
3923 if (strchr(defspec,'/') != NULL) {
3924 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
3931 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
3932 myfab.fab$b_dns = strlen(defspec);
3935 mynam.nam$l_esa = esa;
3936 mynam.nam$b_ess = sizeof esa;
3937 mynam.nam$l_rsa = outbuf;
3938 mynam.nam$b_rss = NAM$C_MAXRSS;
3940 #ifdef NAM$M_NO_SHORT_UPCASE
3941 if (decc_efs_case_preserve)
3942 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
3945 retsts = sys$parse(&myfab,0,0);
3946 if (!(retsts & 1)) {
3947 mynam.nam$b_nop |= NAM$M_SYNCHK;
3948 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
3949 retsts = sys$parse(&myfab,0,0);
3950 if (retsts & 1) goto expanded;
3952 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
3953 sts = sys$parse(&myfab,0,0); /* Free search context */
3954 if (out) Safefree(out);
3955 set_vaxc_errno(retsts);
3956 if (retsts == RMS$_PRV) set_errno(EACCES);
3957 else if (retsts == RMS$_DEV) set_errno(ENODEV);
3958 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
3959 else set_errno(EVMSERR);
3962 retsts = sys$search(&myfab,0,0);
3963 if (!(retsts & 1) && retsts != RMS$_FNF) {
3964 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
3965 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
3966 if (out) Safefree(out);
3967 set_vaxc_errno(retsts);
3968 if (retsts == RMS$_PRV) set_errno(EACCES);
3969 else set_errno(EVMSERR);
3973 /* If the input filespec contained any lowercase characters,
3974 * downcase the result for compatibility with Unix-minded code. */
3976 if (!decc_efs_case_preserve) {
3977 for (out = myfab.fab$l_fna; *out; out++)
3978 if (islower(*out)) { haslower = 1; break; }
3980 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
3981 else { out = esa; speclen = mynam.nam$b_esl; }
3982 /* Trim off null fields added by $PARSE
3983 * If type > 1 char, must have been specified in original or default spec
3984 * (not true for version; $SEARCH may have added version of existing file).
3986 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
3987 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
3988 (mynam.nam$l_ver - mynam.nam$l_type == 1);
3989 if (trimver || trimtype) {
3990 if (defspec && *defspec) {
3991 char defesa[NAM$C_MAXRSS];
3992 struct FAB deffab = cc$rms_fab;
3993 struct NAM defnam = cc$rms_nam;
3995 deffab.fab$l_nam = &defnam;
3996 /* cast below ok for read only pointer */
3997 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
3998 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
3999 defnam.nam$b_nop = NAM$M_SYNCHK;
4000 #ifdef NAM$M_NO_SHORT_UPCASE
4001 if (decc_efs_case_preserve)
4002 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4004 if (sys$parse(&deffab,0,0) & 1) {
4005 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4006 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4010 if (*mynam.nam$l_ver != '\"')
4011 speclen = mynam.nam$l_ver - out;
4014 /* If we didn't already trim version, copy down */
4015 if (speclen > mynam.nam$l_ver - out)
4016 memmove(mynam.nam$l_type, mynam.nam$l_ver,
4017 speclen - (mynam.nam$l_ver - out));
4018 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4021 /* If we just had a directory spec on input, $PARSE "helpfully"
4022 * adds an empty name and type for us */
4023 if (mynam.nam$l_name == mynam.nam$l_type &&
4024 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
4025 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4026 speclen = mynam.nam$l_name - out;
4028 /* Posix format specifications must have matching quotes */
4029 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4030 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4031 out[speclen] = '\"';
4036 out[speclen] = '\0';
4037 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4039 /* Have we been working with an expanded, but not resultant, spec? */
4040 /* Also, convert back to Unix syntax if necessary. */
4041 if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4044 if (!mynam.nam$b_rsl) {
4046 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4048 else strcpy(outbuf,esa);
4051 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4052 strcpy(outbuf,tmpfspec);
4054 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4055 mynam.nam$l_rsa = NULL;
4056 mynam.nam$b_rss = 0;
4057 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4061 /* ODS-5 supporting routine */
4063 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4065 static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4066 char * vmsfspec, *tmpfspec;
4067 char * esa, *cp, *out = NULL;
4070 struct FAB myfab = cc$rms_fab;
4071 rms_setup_nam(mynam);
4073 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4076 if (!filespec || !*filespec) {
4077 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4081 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4082 else outbuf = __rmsexpand_retbuf;
4088 isunix = is_unix_filespec(filespec);
4090 Newx(vmsfspec, VMS_MAXRSS, char);
4091 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4097 filespec = vmsfspec;
4099 /* Unless we are forcing to VMS format, a UNIX input means
4100 * UNIX output, and that requires long names to be used
4102 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4103 opts |= PERL_RMSEXPAND_M_LONG;
4109 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4110 rms_bind_fab_nam(myfab, mynam);
4112 if (defspec && *defspec) {
4114 t_isunix = is_unix_filespec(defspec);
4116 Newx(tmpfspec, VMS_MAXRSS, char);
4117 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4119 if (vmsfspec != NULL)
4127 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4130 Newx(esa, NAM$C_MAXRSS + 1, char);
4131 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4132 Newx(esal, NAML$C_MAXRSS + 1, char);
4134 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4136 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4137 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4140 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4141 Newx(outbufl, VMS_MAXRSS, char);
4142 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4144 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4148 #ifdef NAM$M_NO_SHORT_UPCASE
4149 if (decc_efs_case_preserve)
4150 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4153 /* First attempt to parse as an existing file */
4154 retsts = sys$parse(&myfab,0,0);
4155 if (!(retsts & STS$K_SUCCESS)) {
4157 /* Could not find the file, try as syntax only if error is not fatal */
4158 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4159 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4160 retsts = sys$parse(&myfab,0,0);
4161 if (retsts & STS$K_SUCCESS) goto expanded;
4164 /* Still could not parse the file specification */
4165 /*----------------------------------------------*/
4166 sts = rms_free_search_context(&myfab); /* Free search context */
4167 if (out) Safefree(out);
4168 if (tmpfspec != NULL)
4170 if (vmsfspec != NULL)
4174 set_vaxc_errno(retsts);
4175 if (retsts == RMS$_PRV) set_errno(EACCES);
4176 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4177 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4178 else set_errno(EVMSERR);
4181 retsts = sys$search(&myfab,0,0);
4182 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4183 sts = rms_free_search_context(&myfab); /* Free search context */
4184 if (out) Safefree(out);
4185 if (tmpfspec != NULL)
4187 if (vmsfspec != NULL)
4191 set_vaxc_errno(retsts);
4192 if (retsts == RMS$_PRV) set_errno(EACCES);
4193 else set_errno(EVMSERR);
4197 /* If the input filespec contained any lowercase characters,
4198 * downcase the result for compatibility with Unix-minded code. */
4200 if (!decc_efs_case_preserve) {
4201 for (out = rms_get_fna(myfab, mynam); *out; out++)
4202 if (islower(*out)) { haslower = 1; break; }
4205 /* Is a long or a short name expected */
4206 /*------------------------------------*/
4207 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4208 if (rms_nam_rsll(mynam)) {
4210 speclen = rms_nam_rsll(mynam);
4213 out = esal; /* Not esa */
4214 speclen = rms_nam_esll(mynam);
4218 if (rms_nam_rsl(mynam)) {
4220 speclen = rms_nam_rsl(mynam);
4223 out = esa; /* Not esal */
4224 speclen = rms_nam_esl(mynam);
4227 /* Trim off null fields added by $PARSE
4228 * If type > 1 char, must have been specified in original or default spec
4229 * (not true for version; $SEARCH may have added version of existing file).
4231 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4232 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4233 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4234 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4237 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4238 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4240 if (trimver || trimtype) {
4241 if (defspec && *defspec) {
4242 char *defesal = NULL;
4243 Newx(defesal, NAML$C_MAXRSS + 1, char);
4244 if (defesal != NULL) {
4245 struct FAB deffab = cc$rms_fab;
4246 rms_setup_nam(defnam);
4248 rms_bind_fab_nam(deffab, defnam);
4252 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4254 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4256 rms_set_nam_nop(defnam, 0);
4257 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4258 #ifdef NAM$M_NO_SHORT_UPCASE
4259 if (decc_efs_case_preserve)
4260 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4262 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4264 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4267 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4274 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4275 if (*(rms_nam_verl(mynam)) != '\"')
4276 speclen = rms_nam_verl(mynam) - out;
4279 if (*(rms_nam_ver(mynam)) != '\"')
4280 speclen = rms_nam_ver(mynam) - out;
4284 /* If we didn't already trim version, copy down */
4285 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4286 if (speclen > rms_nam_verl(mynam) - out)
4288 (rms_nam_typel(mynam),
4289 rms_nam_verl(mynam),
4290 speclen - (rms_nam_verl(mynam) - out));
4291 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4294 if (speclen > rms_nam_ver(mynam) - out)
4296 (rms_nam_type(mynam),
4298 speclen - (rms_nam_ver(mynam) - out));
4299 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4304 /* Done with these copies of the input files */
4305 /*-------------------------------------------*/
4306 if (vmsfspec != NULL)
4308 if (tmpfspec != NULL)
4311 /* If we just had a directory spec on input, $PARSE "helpfully"
4312 * adds an empty name and type for us */
4313 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4314 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4315 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4316 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4317 speclen = rms_nam_namel(mynam) - out;
4320 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4321 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4322 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4323 speclen = rms_nam_name(mynam) - out;
4326 /* Posix format specifications must have matching quotes */
4327 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4328 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4329 out[speclen] = '\"';
4333 out[speclen] = '\0';
4334 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4336 /* Have we been working with an expanded, but not resultant, spec? */
4337 /* Also, convert back to Unix syntax if necessary. */
4339 if (!rms_nam_rsll(mynam)) {
4341 if (do_tounixspec(esa,outbuf,0) == NULL) {
4347 else strcpy(outbuf,esa);
4350 Newx(tmpfspec, VMS_MAXRSS, char);
4351 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4357 strcpy(outbuf,tmpfspec);
4361 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4362 sts = rms_free_search_context(&myfab); /* Free search context */
4369 /* External entry points */
4370 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4371 { return do_rmsexpand(spec,buf,0,def,opt); }
4372 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4373 { return do_rmsexpand(spec,buf,1,def,opt); }
4377 ** The following routines are provided to make life easier when
4378 ** converting among VMS-style and Unix-style directory specifications.
4379 ** All will take input specifications in either VMS or Unix syntax. On
4380 ** failure, all return NULL. If successful, the routines listed below
4381 ** return a pointer to a buffer containing the appropriately
4382 ** reformatted spec (and, therefore, subsequent calls to that routine
4383 ** will clobber the result), while the routines of the same names with
4384 ** a _ts suffix appended will return a pointer to a mallocd string
4385 ** containing the appropriately reformatted spec.
4386 ** In all cases, only explicit syntax is altered; no check is made that
4387 ** the resulting string is valid or that the directory in question
4390 ** fileify_dirspec() - convert a directory spec into the name of the
4391 ** directory file (i.e. what you can stat() to see if it's a dir).
4392 ** The style (VMS or Unix) of the result is the same as the style
4393 ** of the parameter passed in.
4394 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4395 ** what you prepend to a filename to indicate what directory it's in).
4396 ** The style (VMS or Unix) of the result is the same as the style
4397 ** of the parameter passed in.
4398 ** tounixpath() - convert a directory spec into a Unix-style path.
4399 ** tovmspath() - convert a directory spec into a VMS-style path.
4400 ** tounixspec() - convert any file spec into a Unix-style file spec.
4401 ** tovmsspec() - convert any file spec into a VMS-style spec.
4403 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4404 ** Permission is given to distribute this code as part of the Perl
4405 ** standard distribution under the terms of the GNU General Public
4406 ** License or the Perl Artistic License. Copies of each may be
4407 ** found in the Perl standard distribution.
4410 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4411 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4413 static char __fileify_retbuf[VMS_MAXRSS];
4414 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4415 char *retspec, *cp1, *cp2, *lastdir;
4416 char *trndir, *vmsdir;
4417 unsigned short int trnlnm_iter_count;
4420 if (!dir || !*dir) {
4421 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4423 dirlen = strlen(dir);
4424 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4425 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4426 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4433 if (dirlen > (VMS_MAXRSS - 1)) {
4434 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4437 Newx(trndir, VMS_MAXRSS + 1, char);
4438 if (!strpbrk(dir+1,"/]>:") &&
4439 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4440 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4441 trnlnm_iter_count = 0;
4442 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4443 trnlnm_iter_count++;
4444 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4446 dirlen = strlen(trndir);
4449 strncpy(trndir,dir,dirlen);
4450 trndir[dirlen] = '\0';
4453 /* At this point we are done with *dir and use *trndir which is a
4454 * copy that can be modified. *dir must not be modified.
4457 /* If we were handed a rooted logical name or spec, treat it like a
4458 * simple directory, so that
4459 * $ Define myroot dev:[dir.]
4460 * ... do_fileify_dirspec("myroot",buf,1) ...
4461 * does something useful.
4463 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4464 trndir[--dirlen] = '\0';
4465 trndir[dirlen-1] = ']';
4467 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4468 trndir[--dirlen] = '\0';
4469 trndir[dirlen-1] = '>';
4472 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4473 /* If we've got an explicit filename, we can just shuffle the string. */
4474 if (*(cp1+1)) hasfilename = 1;
4475 /* Similarly, we can just back up a level if we've got multiple levels
4476 of explicit directories in a VMS spec which ends with directories. */
4478 for (cp2 = cp1; cp2 > trndir; cp2--) {
4480 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4481 *cp2 = *cp1; *cp1 = '\0';
4486 if (*cp2 == '[' || *cp2 == '<') break;
4491 Newx(vmsdir, VMS_MAXRSS + 1, char);
4492 cp1 = strpbrk(trndir,"]:>");
4493 if (hasfilename || !cp1) { /* Unix-style path or filename */
4494 if (trndir[0] == '.') {
4495 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4498 return do_fileify_dirspec("[]",buf,ts);
4500 else if (trndir[1] == '.' &&
4501 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4504 return do_fileify_dirspec("[-]",buf,ts);
4507 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4508 dirlen -= 1; /* to last element */
4509 lastdir = strrchr(trndir,'/');
4511 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4512 /* If we have "/." or "/..", VMSify it and let the VMS code
4513 * below expand it, rather than repeating the code to handle
4514 * relative components of a filespec here */
4516 if (*(cp1+2) == '.') cp1++;
4517 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4519 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4524 if (strchr(vmsdir,'/') != NULL) {
4525 /* If do_tovmsspec() returned it, it must have VMS syntax
4526 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4527 * the time to check this here only so we avoid a recursion
4528 * loop; otherwise, gigo.
4532 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4535 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4540 ret_chr = do_tounixspec(trndir,buf,ts);
4546 } while ((cp1 = strstr(cp1,"/.")) != NULL);
4547 lastdir = strrchr(trndir,'/');
4549 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4551 /* Ditto for specs that end in an MFD -- let the VMS code
4552 * figure out whether it's a real device or a rooted logical. */
4554 /* This should not happen any more. Allowing the fake /000000
4555 * in a UNIX pathname causes all sorts of problems when trying
4556 * to run in UNIX emulation. So the VMS to UNIX conversions
4557 * now remove the fake /000000 directories.
4560 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4561 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4566 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4571 ret_chr = do_tounixspec(trndir,buf,ts);
4578 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4579 !(lastdir = cp1 = strrchr(trndir,']')) &&
4580 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4581 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
4584 /* For EFS or ODS-5 look for the last dot */
4585 if (decc_efs_charset) {
4586 cp2 = strrchr(cp1,'.');
4588 if (vms_process_case_tolerant) {
4589 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4590 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4591 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4592 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4593 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4594 (ver || *cp3)))))) {
4598 set_vaxc_errno(RMS$_DIR);
4603 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4604 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4605 !*(cp2+3) || *(cp2+3) != 'R' ||
4606 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4607 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4608 (ver || *cp3)))))) {
4612 set_vaxc_errno(RMS$_DIR);
4616 dirlen = cp2 - trndir;
4620 retlen = dirlen + 6;
4621 if (buf) retspec = buf;
4622 else if (ts) Newx(retspec,retlen+1,char);
4623 else retspec = __fileify_retbuf;
4624 memcpy(retspec,trndir,dirlen);
4625 retspec[dirlen] = '\0';
4627 /* We've picked up everything up to the directory file name.
4628 Now just add the type and version, and we're set. */
4629 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4630 strcat(retspec,".dir;1");
4632 strcat(retspec,".DIR;1");
4637 else { /* VMS-style directory spec */
4639 char *esa, term, *cp;
4640 unsigned long int sts, cmplen, haslower = 0;
4641 unsigned int nam_fnb;
4643 struct FAB dirfab = cc$rms_fab;
4644 rms_setup_nam(savnam);
4645 rms_setup_nam(dirnam);
4647 Newx(esa, VMS_MAXRSS + 1, char);
4648 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4649 rms_bind_fab_nam(dirfab, dirnam);
4650 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4651 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4652 #ifdef NAM$M_NO_SHORT_UPCASE
4653 if (decc_efs_case_preserve)
4654 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4657 for (cp = trndir; *cp; cp++)
4658 if (islower(*cp)) { haslower = 1; break; }
4659 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4660 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4661 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4662 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4669 set_vaxc_errno(dirfab.fab$l_sts);
4675 /* Does the file really exist? */
4676 if (sys$search(&dirfab)& STS$K_SUCCESS) {
4677 /* Yes; fake the fnb bits so we'll check type below */
4678 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4680 else { /* No; just work with potential name */
4681 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4686 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
4687 sts = rms_free_search_context(&dirfab);
4692 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4693 cp1 = strchr(esa,']');
4694 if (!cp1) cp1 = strchr(esa,'>');
4695 if (cp1) { /* Should always be true */
4696 rms_nam_esll(dirnam) -= cp1 - esa - 1;
4697 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4700 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
4701 /* Yep; check version while we're at it, if it's there. */
4702 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4703 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4704 /* Something other than .DIR[;1]. Bzzt. */
4705 sts = rms_free_search_context(&dirfab);
4710 set_vaxc_errno(RMS$_DIR);
4714 esa[rms_nam_esll(dirnam)] = '\0';
4715 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4716 /* They provided at least the name; we added the type, if necessary, */
4717 if (buf) retspec = buf; /* in sys$parse() */
4718 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4719 else retspec = __fileify_retbuf;
4720 strcpy(retspec,esa);
4721 sts = rms_free_search_context(&dirfab);
4727 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4728 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4730 rms_nam_esll(dirnam) -= 9;
4732 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4733 if (cp1 == NULL) { /* should never happen */
4734 sts = rms_free_search_context(&dirfab);
4742 retlen = strlen(esa);
4743 cp1 = strrchr(esa,'.');
4744 /* ODS-5 directory specifications can have extra "." in them. */
4745 while (cp1 != NULL) {
4746 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4750 while ((cp1 > esa) && (*cp1 != '.'))
4757 if ((cp1) != NULL) {
4758 /* There's more than one directory in the path. Just roll back. */
4760 if (buf) retspec = buf;
4761 else if (ts) Newx(retspec,retlen+7,char);
4762 else retspec = __fileify_retbuf;
4763 strcpy(retspec,esa);
4766 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4767 /* Go back and expand rooted logical name */
4768 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4769 #ifdef NAM$M_NO_SHORT_UPCASE
4770 if (decc_efs_case_preserve)
4771 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4773 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4774 sts = rms_free_search_context(&dirfab);
4779 set_vaxc_errno(dirfab.fab$l_sts);
4782 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4783 if (buf) retspec = buf;
4784 else if (ts) Newx(retspec,retlen+16,char);
4785 else retspec = __fileify_retbuf;
4786 cp1 = strstr(esa,"][");
4787 if (!cp1) cp1 = strstr(esa,"]<");
4789 memcpy(retspec,esa,dirlen);
4790 if (!strncmp(cp1+2,"000000]",7)) {
4791 retspec[dirlen-1] = '\0';
4792 /* Not full ODS-5, just extra dots in directories for now */
4793 cp1 = retspec + dirlen - 1;
4794 while (cp1 > retspec)
4799 if (*(cp1-1) != '^')
4804 if (*cp1 == '.') *cp1 = ']';
4806 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4807 memmove(cp1+1,"000000]",7);
4811 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
4812 retspec[retlen] = '\0';
4813 /* Convert last '.' to ']' */
4814 cp1 = retspec+retlen-1;
4815 while (*cp != '[') {
4818 /* Do not trip on extra dots in ODS-5 directories */
4819 if ((cp1 == retspec) || (*(cp1-1) != '^'))
4823 if (*cp1 == '.') *cp1 = ']';
4825 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
4826 memmove(cp1+1,"000000]",7);
4830 else { /* This is a top-level dir. Add the MFD to the path. */
4831 if (buf) retspec = buf;
4832 else if (ts) Newx(retspec,retlen+16,char);
4833 else retspec = __fileify_retbuf;
4836 while (*cp1 != ':') *(cp2++) = *(cp1++);
4837 strcpy(cp2,":[000000]");
4842 sts = rms_free_search_context(&dirfab);
4843 /* We've set up the string up through the filename. Add the
4844 type and version, and we're done. */
4845 strcat(retspec,".DIR;1");
4847 /* $PARSE may have upcased filespec, so convert output to lower
4848 * case if input contained any lowercase characters. */
4849 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
4855 } /* end of do_fileify_dirspec() */
4857 /* External entry points */
4858 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
4859 { return do_fileify_dirspec(dir,buf,0); }
4860 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
4861 { return do_fileify_dirspec(dir,buf,1); }
4863 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
4864 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
4866 static char __pathify_retbuf[VMS_MAXRSS];
4867 unsigned long int retlen;
4868 char *retpath, *cp1, *cp2, *trndir;
4869 unsigned short int trnlnm_iter_count;
4873 if (!dir || !*dir) {
4874 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4877 Newx(trndir, VMS_MAXRSS, char);
4878 if (*dir) strcpy(trndir,dir);
4879 else getcwd(trndir,VMS_MAXRSS - 1);
4881 trnlnm_iter_count = 0;
4882 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
4883 && my_trnlnm(trndir,trndir,0)) {
4884 trnlnm_iter_count++;
4885 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4886 trnlen = strlen(trndir);
4888 /* Trap simple rooted lnms, and return lnm:[000000] */
4889 if (!strcmp(trndir+trnlen-2,".]")) {
4890 if (buf) retpath = buf;
4891 else if (ts) Newx(retpath,strlen(dir)+10,char);
4892 else retpath = __pathify_retbuf;
4893 strcpy(retpath,dir);
4894 strcat(retpath,":[000000]");
4900 /* At this point we do not work with *dir, but the copy in
4901 * *trndir that is modifiable.
4904 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
4905 if (*trndir == '.' && (*(trndir+1) == '\0' ||
4906 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
4907 retlen = 2 + (*(trndir+1) != '\0');
4909 if ( !(cp1 = strrchr(trndir,'/')) &&
4910 !(cp1 = strrchr(trndir,']')) &&
4911 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
4912 if ((cp2 = strchr(cp1,'.')) != NULL &&
4913 (*(cp2-1) != '/' || /* Trailing '.', '..', */
4914 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
4915 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
4916 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
4919 /* For EFS or ODS-5 look for the last dot */
4920 if (decc_efs_charset) {
4921 cp2 = strrchr(cp1,'.');
4923 if (vms_process_case_tolerant) {
4924 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4925 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4926 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4927 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4928 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4929 (ver || *cp3)))))) {
4932 set_vaxc_errno(RMS$_DIR);
4937 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4938 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4939 !*(cp2+3) || *(cp2+3) != 'R' ||
4940 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4941 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4942 (ver || *cp3)))))) {
4945 set_vaxc_errno(RMS$_DIR);
4949 retlen = cp2 - trndir + 1;
4951 else { /* No file type present. Treat the filename as a directory. */
4952 retlen = strlen(trndir) + 1;
4955 if (buf) retpath = buf;
4956 else if (ts) Newx(retpath,retlen+1,char);
4957 else retpath = __pathify_retbuf;
4958 strncpy(retpath, trndir, retlen-1);
4959 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
4960 retpath[retlen-1] = '/'; /* with '/', add it. */
4961 retpath[retlen] = '\0';
4963 else retpath[retlen-1] = '\0';
4965 else { /* VMS-style directory spec */
4967 unsigned long int sts, cmplen, haslower;
4968 struct FAB dirfab = cc$rms_fab;
4970 rms_setup_nam(savnam);
4971 rms_setup_nam(dirnam);
4973 /* If we've got an explicit filename, we can just shuffle the string. */
4974 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
4975 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
4976 if ((cp2 = strchr(cp1,'.')) != NULL) {
4978 if (vms_process_case_tolerant) {
4979 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4980 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4981 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4982 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4983 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4984 (ver || *cp3)))))) {
4987 set_vaxc_errno(RMS$_DIR);
4992 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4993 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4994 !*(cp2+3) || *(cp2+3) != 'R' ||
4995 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4996 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4997 (ver || *cp3)))))) {
5000 set_vaxc_errno(RMS$_DIR);
5005 else { /* No file type, so just draw name into directory part */
5006 for (cp2 = cp1; *cp2; cp2++) ;
5009 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5011 /* We've now got a VMS 'path'; fall through */
5014 dirlen = strlen(trndir);
5015 if (trndir[dirlen-1] == ']' ||
5016 trndir[dirlen-1] == '>' ||
5017 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5018 if (buf) retpath = buf;
5019 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5020 else retpath = __pathify_retbuf;
5021 strcpy(retpath,trndir);
5025 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5026 Newx(esa, VMS_MAXRSS, char);
5027 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5028 rms_bind_fab_nam(dirfab, dirnam);
5029 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5030 #ifdef NAM$M_NO_SHORT_UPCASE
5031 if (decc_efs_case_preserve)
5032 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5035 for (cp = trndir; *cp; cp++)
5036 if (islower(*cp)) { haslower = 1; break; }
5038 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5039 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5040 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5041 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5047 set_vaxc_errno(dirfab.fab$l_sts);
5053 /* Does the file really exist? */
5054 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5055 if (dirfab.fab$l_sts != RMS$_FNF) {
5057 sts1 = rms_free_search_context(&dirfab);
5061 set_vaxc_errno(dirfab.fab$l_sts);
5064 dirnam = savnam; /* No; just work with potential name */
5067 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5068 /* Yep; check version while we're at it, if it's there. */
5069 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5070 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5072 /* Something other than .DIR[;1]. Bzzt. */
5073 sts2 = rms_free_search_context(&dirfab);
5077 set_vaxc_errno(RMS$_DIR);
5081 /* OK, the type was fine. Now pull any file name into the
5083 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5085 cp1 = strrchr(esa,'>');
5086 *(rms_nam_typel(dirnam)) = '>';
5089 *(rms_nam_typel(dirnam) + 1) = '\0';
5090 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5091 if (buf) retpath = buf;
5092 else if (ts) Newx(retpath,retlen,char);
5093 else retpath = __pathify_retbuf;
5094 strcpy(retpath,esa);
5096 sts = rms_free_search_context(&dirfab);
5097 /* $PARSE may have upcased filespec, so convert output to lower
5098 * case if input contained any lowercase characters. */
5099 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5104 } /* end of do_pathify_dirspec() */
5106 /* External entry points */
5107 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5108 { return do_pathify_dirspec(dir,buf,0); }
5109 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5110 { return do_pathify_dirspec(dir,buf,1); }
5112 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5113 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5115 static char __tounixspec_retbuf[VMS_MAXRSS];
5116 char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
5118 int devlen, dirlen, retlen = VMS_MAXRSS;
5119 int expand = 1; /* guarantee room for leading and trailing slashes */
5120 unsigned short int trnlnm_iter_count;
5123 if (spec == NULL) return NULL;
5124 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5125 if (buf) rslt = buf;
5127 retlen = strlen(spec);
5128 cp1 = strchr(spec,'[');
5129 if (!cp1) cp1 = strchr(spec,'<');
5131 for (cp1++; *cp1; cp1++) {
5132 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
5133 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5134 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5137 Newx(rslt,retlen+2+2*expand,char);
5139 else rslt = __tounixspec_retbuf;
5141 /* New VMS specific format needs translation
5142 * glob passes filenames with trailing '\n' and expects this preserved.
5144 if (decc_posix_compliant_pathnames) {
5145 if (strncmp(spec, "\"^UP^", 5) == 0) {
5151 Newx(tunix, VMS_MAXRSS + 1,char);
5152 strcpy(tunix, spec);
5153 tunix_len = strlen(tunix);
5155 if (tunix[tunix_len - 1] == '\n') {
5156 tunix[tunix_len - 1] = '\"';
5157 tunix[tunix_len] = '\0';
5161 uspec = decc$translate_vms(tunix);
5163 if ((int)uspec > 0) {
5169 /* If we can not translate it, makemaker wants as-is */
5177 cmp_rslt = 0; /* Presume VMS */
5178 cp1 = strchr(spec, '/');
5182 /* Look for EFS ^/ */
5183 if (decc_efs_charset) {
5184 while (cp1 != NULL) {
5187 /* Found illegal VMS, assume UNIX */
5192 cp1 = strchr(cp1, '/');
5196 /* Look for "." and ".." */
5197 if (decc_filename_unix_report) {
5198 if (spec[0] == '.') {
5199 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5203 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5209 /* This is already UNIX or at least nothing VMS understands */
5217 dirend = strrchr(spec,']');
5218 if (dirend == NULL) dirend = strrchr(spec,'>');
5219 if (dirend == NULL) dirend = strchr(spec,':');
5220 if (dirend == NULL) {
5225 /* Special case 1 - sys$posix_root = / */
5226 #if __CRTL_VER >= 70000000
5227 if (!decc_disable_posix_root) {
5228 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5236 /* Special case 2 - Convert NLA0: to /dev/null */
5237 #if __CRTL_VER < 70000000
5238 cmp_rslt = strncmp(spec,"NLA0:", 5);
5240 cmp_rslt = strncmp(spec,"nla0:", 5);
5242 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5244 if (cmp_rslt == 0) {
5245 strcpy(rslt, "/dev/null");
5248 if (spec[6] != '\0') {
5255 /* Also handle special case "SYS$SCRATCH:" */
5256 #if __CRTL_VER < 70000000
5257 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5259 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5261 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5263 if (cmp_rslt == 0) {
5266 islnm = my_trnlnm(tmp, "TMP", 0);
5268 strcpy(rslt, "/tmp");
5271 if (spec[12] != '\0') {
5279 if (*cp2 != '[' && *cp2 != '<') {
5282 else { /* the VMS spec begins with directories */
5284 if (*cp2 == ']' || *cp2 == '>') {
5285 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5288 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5289 if (getcwd(tmp,sizeof tmp,1) == NULL) {
5290 if (ts) Safefree(rslt);
5293 trnlnm_iter_count = 0;
5296 while (*cp3 != ':' && *cp3) cp3++;
5298 if (strchr(cp3,']') != NULL) break;
5299 trnlnm_iter_count++;
5300 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5301 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5303 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5304 retlen = devlen + dirlen;
5305 Renew(rslt,retlen+1+2*expand,char);
5311 *(cp1++) = *(cp3++);
5312 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5316 if ((*cp2 == '^')) {
5317 /* EFS file escape, pass the next character as is */
5318 /* Fix me: HEX encoding for UNICODE not implemented */
5321 else if ( *cp2 == '.') {
5322 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5323 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5329 for (; cp2 <= dirend; cp2++) {
5330 if ((*cp2 == '^')) {
5331 /* EFS file escape, pass the next character as is */
5332 /* Fix me: HEX encoding for UNICODE not implemented */
5338 if (*(cp2+1) == '[') cp2++;
5340 else if (*cp2 == ']' || *cp2 == '>') {
5341 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5343 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5345 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5346 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5347 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5348 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5349 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5351 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5352 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5356 else if (*cp2 == '-') {
5357 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5358 while (*cp2 == '-') {
5360 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5362 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5363 if (ts) Safefree(rslt); /* filespecs like */
5364 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5368 else *(cp1++) = *cp2;
5370 else *(cp1++) = *cp2;
5372 while (*cp2) *(cp1++) = *(cp2++);
5375 /* This still leaves /000000/ when working with a
5376 * VMS device root or concealed root.
5382 ulen = strlen(rslt);
5384 /* Get rid of "000000/ in rooted filespecs */
5386 zeros = strstr(rslt, "/000000/");
5387 if (zeros != NULL) {
5389 mlen = ulen - (zeros - rslt) - 7;
5390 memmove(zeros, &zeros[7], mlen);
5399 } /* end of do_tounixspec() */
5401 /* External entry points */
5402 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5403 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5405 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5407 static int posix_to_vmsspec
5408 (char *vmspath, int vmspath_len, const char *unixpath) {
5410 struct FAB myfab = cc$rms_fab;
5411 struct NAML mynam = cc$rms_naml;
5412 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5413 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5419 /* If not a posix spec already, convert it */
5421 unixlen = strlen(unixpath);
5426 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5427 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5430 /* This is already a VMS specification, no conversion */
5432 strncpy(vmspath,unixpath, vmspath_len);
5434 vmspath[vmspath_len] = 0;
5435 if (unixpath[unixlen - 1] == '/')
5437 Newx(esa, VMS_MAXRSS, char);
5438 myfab.fab$l_fna = vmspath;
5439 myfab.fab$b_fns = strlen(vmspath);
5440 myfab.fab$l_naml = &mynam;
5441 mynam.naml$l_esa = NULL;
5442 mynam.naml$b_ess = 0;
5443 mynam.naml$l_long_expand = esa;
5444 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5445 mynam.naml$l_rsa = NULL;
5446 mynam.naml$b_rss = 0;
5447 if (decc_efs_case_preserve)
5448 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5449 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5451 /* Set up the remaining naml fields */
5452 sts = sys$parse(&myfab);
5454 /* It failed! Try again as a UNIX filespec */
5460 /* get the Device ID and the FID */
5461 sts = sys$search(&myfab);
5462 /* on any failure, returned the POSIX ^UP^ filespec */
5467 specdsc.dsc$a_pointer = vmspath;
5468 specdsc.dsc$w_length = vmspath_len;
5470 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5471 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5472 sts = lib$fid_to_name
5473 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5475 /* on any failure, returned the POSIX ^UP^ filespec */
5477 /* This can happen if user does not have permission to read directories */
5478 if (strncmp(unixpath,"\"^UP^",5) != 0)
5479 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5481 strcpy(vmspath, unixpath);
5484 vmspath[specdsc.dsc$w_length] = 0;
5486 /* Are we expecting a directory? */
5487 if (dir_flag != 0) {
5493 i = specdsc.dsc$w_length - 1;
5497 /* Version must be '1' */
5498 if (vmspath[i--] != '1')
5500 /* Version delimiter is one of ".;" */
5501 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5504 if (vmspath[i--] != 'R')
5506 if (vmspath[i--] != 'I')
5508 if (vmspath[i--] != 'D')
5510 if (vmspath[i--] != '.')
5512 eptr = &vmspath[i+1];
5514 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5515 if (vmspath[i-1] != '^') {
5523 /* Get rid of 6 imaginary zero directory filename */
5524 vmspath[i+1] = '\0';
5528 if (vmspath[i] == '0')
5542 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5543 static int posix_to_vmsspec_hardway
5544 (char *vmspath, int vmspath_len, const char *unixpath) {
5547 const char *unixptr;
5549 const char *lastslash;
5550 const char *lastdot;
5561 /* Ignore leading "/" characters */
5562 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5565 unixlen = strlen(unixptr);
5567 /* Do nothing with blank paths */
5573 lastslash = strrchr(unixptr,'/');
5574 lastdot = strrchr(unixptr,'.');
5577 /* last dot is last dot or past end of string */
5578 if (lastdot == NULL)
5579 lastdot = unixptr + unixlen;
5581 /* if no directories, set last slash to beginning of string */
5582 if (lastslash == NULL) {
5583 lastslash = unixptr;
5586 /* Watch out for trailing "." after last slash, still a directory */
5587 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5588 lastslash = unixptr + unixlen;
5591 /* Watch out for traiing ".." after last slash, still a directory */
5592 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5593 lastslash = unixptr + unixlen;
5596 /* dots in directories are aways escaped */
5597 if (lastdot < lastslash)
5598 lastdot = unixptr + unixlen;
5601 /* if (unixptr < lastslash) then we are in a directory */
5609 /* This could have a "^UP^ on the front */
5610 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5615 /* Start with the UNIX path */
5616 if (*unixptr != '/') {
5617 /* relative paths */
5618 if (lastslash > unixptr) {
5621 /* skip leading ./ */
5623 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5629 /* Are we still in a directory? */
5630 if (unixptr <= lastslash) {
5635 /* if not backing up, then it is relative forward. */
5636 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5637 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5645 /* Perl wants an empty directory here to tell the difference
5646 * between a DCL commmand and a filename
5655 /* Handle two special files . and .. */
5656 if (unixptr[0] == '.') {
5657 if (unixptr[1] == '\0') {
5664 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5675 else { /* Absolute PATH handling */
5679 /* Need to find out where root is */
5681 /* In theory, this procedure should never get an absolute POSIX pathname
5682 * that can not be found on the POSIX root.
5683 * In practice, that can not be relied on, and things will show up
5684 * here that are a VMS device name or concealed logical name instead.
5685 * So to make things work, this procedure must be tolerant.
5687 Newx(esa, vmspath_len, char);
5690 nextslash = strchr(&unixptr[1],'/');
5692 if (nextslash != NULL) {
5693 seg_len = nextslash - &unixptr[1];
5694 strncpy(vmspath, unixptr, seg_len + 1);
5695 vmspath[seg_len+1] = 0;
5696 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5700 /* This is verified to be a real path */
5702 sts = posix_to_vmsspec(esa, vmspath_len, "/");
5703 strcpy(vmspath, esa);
5704 vmslen = strlen(vmspath);
5705 vmsptr = vmspath + vmslen;
5707 if (unixptr < lastslash) {
5716 cmp = strcmp(rptr,"000000.");
5721 } /* removing 6 zeros */
5722 } /* vmslen < 7, no 6 zeros possible */
5723 } /* Not in a directory */
5724 } /* end of verified real path handling */
5729 /* Ok, we have a device or a concealed root that is not in POSIX
5730 * or we have garbage. Make the best of it.
5733 /* Posix to VMS destroyed this, so copy it again */
5734 strncpy(vmspath, &unixptr[1], seg_len);
5735 vmspath[seg_len] = 0;
5737 vmsptr = &vmsptr[vmslen];
5740 /* Now do we need to add the fake 6 zero directory to it? */
5742 if ((*lastslash == '/') && (nextslash < lastslash)) {
5743 /* No there is another directory */
5749 /* now we have foo:bar or foo:[000000]bar to decide from */
5750 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5751 trnend = islnm ? islnm - 1 : 0;
5753 /* if this was a logical name, ']' or '>' must be present */
5754 /* if not a logical name, then assume a device and hope. */
5755 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5757 /* if log name and trailing '.' then rooted - treat as device */
5758 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5760 /* Fix me, if not a logical name, a device lookup should be
5761 * done to see if the device is file structured. If the device
5762 * is not file structured, the 6 zeros should not be put on.
5764 * As it is, perl is occasionally looking for dev:[000000]tty.
5765 * which looks a little strange.
5768 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5769 /* No real directory present */
5774 /* Put the device delimiter on */
5777 unixptr = nextslash;
5780 /* Start directory if needed */
5781 if (!islnm || add_6zero) {
5787 /* add fake 000000] if needed */
5800 } /* non-POSIX translation */
5802 } /* End of relative/absolute path handling */
5804 while ((*unixptr) && (vmslen < vmspath_len)){
5809 if (dir_start != 0) {
5811 /* First characters in a directory are handled special */
5812 while ((*unixptr == '/') ||
5813 ((*unixptr == '.') &&
5814 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
5819 /* Skip redundant / in specification */
5820 while ((*unixptr == '/') && (dir_start != 0)) {
5823 if (unixptr == lastslash)
5826 if (unixptr == lastslash)
5829 /* Skip redundant ./ characters */
5830 while ((*unixptr == '.') &&
5831 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
5834 if (unixptr == lastslash)
5836 if (*unixptr == '/')
5839 if (unixptr == lastslash)
5842 /* Skip redundant ../ characters */
5843 while ((*unixptr == '.') && (unixptr[1] == '.') &&
5844 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
5845 /* Set the backing up flag */
5851 unixptr++; /* first . */
5852 unixptr++; /* second . */
5853 if (unixptr == lastslash)
5855 if (*unixptr == '/') /* The slash */
5858 if (unixptr == lastslash)
5861 /* To do: Perl expects /.../ to be translated to [...] on VMS */
5862 /* Not needed when VMS is pretending to be UNIX. */
5864 /* Is this loop stuck because of too many dots? */
5865 if (loop_flag == 0) {
5866 /* Exit the loop and pass the rest through */
5871 /* Are we done with directories yet? */
5872 if (unixptr >= lastslash) {
5874 /* Watch out for trailing dots */
5883 if (*unixptr == '/')
5887 /* Have we stopped backing up? */
5892 /* dir_start continues to be = 1 */
5894 if (*unixptr == '-') {
5896 *vmsptr++ = *unixptr++;
5900 /* Now are we done with directories yet? */
5901 if (unixptr >= lastslash) {
5903 /* Watch out for trailing dots */
5919 if (*unixptr == '\0')
5922 /* Normal characters - More EFS work probably needed */
5928 /* remove multiple / */
5929 while (unixptr[1] == '/') {
5932 if (unixptr == lastslash) {
5933 /* Watch out for trailing dots */
5945 /* To do: Perl expects /.../ to be translated to [...] on VMS */
5946 /* Not needed when VMS is pretending to be UNIX. */
5950 if (*unixptr != '\0')
5966 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
5972 /* trailing dot ==> '^..' on VMS */
5973 if (*unixptr == '\0') {
5977 *vmsptr++ = *unixptr++;
5980 if (quoted && (unixptr[1] == '\0')) {
5985 *vmsptr++ = *unixptr++;
5992 *vmsptr++ = *unixptr++;
5996 if (*unixptr != '\0') {
5997 *vmsptr++ = *unixptr++;
6004 /* Make sure directory is closed */
6005 if (unixptr == lastslash) {
6007 vmsptr2 = vmsptr - 1;
6009 if (*vmsptr2 != ']') {
6012 /* directories do not end in a dot bracket */
6013 if (*vmsptr2 == '.') {
6017 if (*vmsptr2 != '^') {
6018 vmsptr--; /* back up over the dot */
6026 /* Add a trailing dot if a file with no extension */
6027 vmsptr2 = vmsptr - 1;
6028 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6029 (*lastdot != '.')) {
6040 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6041 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6042 static char __tovmsspec_retbuf[VMS_MAXRSS];
6043 char *rslt, *dirend;
6048 unsigned long int infront = 0, hasdir = 1;
6052 if (path == NULL) return NULL;
6053 rslt_len = VMS_MAXRSS;
6054 if (buf) rslt = buf;
6055 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6056 else rslt = __tovmsspec_retbuf;
6057 if (strpbrk(path,"]:>") ||
6058 (dirend = strrchr(path,'/')) == NULL) {
6059 if (path[0] == '.') {
6060 if (path[1] == '\0') strcpy(rslt,"[]");
6061 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6062 else strcpy(rslt,path); /* probably garbage */
6064 else strcpy(rslt,path);
6068 /* Posix specifications are now a native VMS format */
6069 /*--------------------------------------------------*/
6070 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6071 if (decc_posix_compliant_pathnames) {
6072 if (strncmp(path,"\"^UP^",5) == 0) {
6073 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6079 vms_delim = strpbrk(path,"]:>");
6081 if ((vms_delim != NULL) ||
6082 ((dirend = strrchr(path,'/')) == NULL)) {
6084 /* VMS special characters found! */
6086 if (path[0] == '.') {
6087 if (path[1] == '\0') strcpy(rslt,"[]");
6088 else if (path[1] == '.' && path[2] == '\0')
6091 /* Dot preceeding a device or directory ? */
6093 /* If not in POSIX mode, pass it through and hope it works */
6094 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6095 if (!decc_posix_compliant_pathnames)
6096 strcpy(rslt,path); /* probably garbage */
6098 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6100 strcpy(rslt,path); /* probably garbage */
6106 /* If no VMS characters and in POSIX mode, convert it!
6107 * This is the easiest way to get directory specifications
6108 * handled correctly in POSIX mode
6110 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6111 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6112 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6114 /* No unix path separators - presume VMS already */
6118 strcpy(rslt,path); /* probably garbage */
6124 /* If POSIX mode active, handle the conversion */
6125 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6126 if (decc_posix_compliant_pathnames) {
6127 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6132 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
6133 if (!*(dirend+2)) dirend +=2;
6134 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6135 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6140 lastdot = strrchr(cp2,'.');
6146 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6148 if (decc_disable_posix_root) {
6149 strcpy(rslt,"sys$disk:[000000]");
6152 strcpy(rslt,"sys$posix_root:[000000]");
6156 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6158 Newx(trndev, VMS_MAXRSS, char);
6159 islnm = my_trnlnm(rslt,trndev,0);
6161 /* DECC special handling */
6163 if (strcmp(rslt,"bin") == 0) {
6164 strcpy(rslt,"sys$system");
6167 islnm = my_trnlnm(rslt,trndev,0);
6169 else if (strcmp(rslt,"tmp") == 0) {
6170 strcpy(rslt,"sys$scratch");
6173 islnm = my_trnlnm(rslt,trndev,0);
6175 else if (!decc_disable_posix_root) {
6176 strcpy(rslt, "sys$posix_root");
6180 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6181 islnm = my_trnlnm(rslt,trndev,0);
6183 else if (strcmp(rslt,"dev") == 0) {
6184 if (strncmp(cp2,"/null", 5) == 0) {
6185 if ((cp2[5] == 0) || (cp2[5] == '/')) {
6186 strcpy(rslt,"NLA0");
6190 islnm = my_trnlnm(rslt,trndev,0);
6196 trnend = islnm ? strlen(trndev) - 1 : 0;
6197 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6198 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6199 /* If the first element of the path is a logical name, determine
6200 * whether it has to be translated so we can add more directories. */
6201 if (!islnm || rooted) {
6204 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6208 if (cp2 != dirend) {
6209 strcpy(rslt,trndev);
6210 cp1 = rslt + trnend;
6217 if (decc_disable_posix_root) {
6228 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6229 cp2 += 2; /* skip over "./" - it's redundant */
6230 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
6232 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6233 *(cp1++) = '-'; /* "../" --> "-" */
6236 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6237 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6238 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6239 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6242 else if ((cp2 != lastdot) || (lastdot < dirend)) {
6243 /* Escape the extra dots in EFS file specifications */
6246 if (cp2 > dirend) cp2 = dirend;
6248 else *(cp1++) = '.';
6250 for (; cp2 < dirend; cp2++) {
6252 if (*(cp2-1) == '/') continue;
6253 if (*(cp1-1) != '.') *(cp1++) = '.';
6256 else if (!infront && *cp2 == '.') {
6257 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6258 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
6259 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6260 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6261 else if (*(cp1-2) == '[') *(cp1-1) = '-';
6262 else { /* back up over previous directory name */
6264 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6265 if (*(cp1-1) == '[') {
6266 memcpy(cp1,"000000.",7);
6271 if (cp2 == dirend) break;
6273 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6274 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6275 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6276 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6278 *(cp1++) = '.'; /* Simulate trailing '/' */
6279 cp2 += 2; /* for loop will incr this to == dirend */
6281 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
6284 if (decc_efs_charset == 0)
6285 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
6287 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
6293 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
6295 if (decc_efs_charset == 0)
6302 else *(cp1++) = *cp2;
6306 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6307 if (hasdir) *(cp1++) = ']';
6308 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
6309 /* fixme for ODS5 */
6324 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6325 decc_readdir_dropdotnotype) {
6330 /* trailing dot ==> '^..' on VMS */
6337 *(cp1++) = *(cp2++);
6365 *(cp1++) = *(cp2++);
6368 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6369 * which is wrong. UNIX notation should be ".dir. unless
6370 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6371 * changing this behavior could break more things at this time.
6372 * efs character set effectively does not allow "." to be a version
6373 * delimiter as a further complication about changing this.
6375 if (decc_filename_unix_report != 0) {
6378 *(cp1++) = *(cp2++);
6381 *(cp1++) = *(cp2++);
6384 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6388 /* Fix me for "^]", but that requires making sure that you do
6389 * not back up past the start of the filename
6391 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6398 } /* end of do_tovmsspec() */
6400 /* External entry points */
6401 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6402 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6404 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6405 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6406 static char __tovmspath_retbuf[VMS_MAXRSS];
6408 char *pathified, *vmsified, *cp;
6410 if (path == NULL) return NULL;
6411 Newx(pathified, VMS_MAXRSS, char);
6412 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6413 Safefree(pathified);
6416 Newx(vmsified, VMS_MAXRSS, char);
6417 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6418 Safefree(pathified);
6422 Safefree(pathified);
6428 vmslen = strlen(vmsified);
6429 Newx(cp,vmslen+1,char);
6430 memcpy(cp,vmsified,vmslen);
6436 strcpy(__tovmspath_retbuf,vmsified);
6438 return __tovmspath_retbuf;
6441 } /* end of do_tovmspath() */
6443 /* External entry points */
6444 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6445 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6448 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6449 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6450 static char __tounixpath_retbuf[VMS_MAXRSS];
6452 char *pathified, *unixified, *cp;
6454 if (path == NULL) return NULL;
6455 Newx(pathified, VMS_MAXRSS, char);
6456 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6457 Safefree(pathified);
6460 Newx(unixified, VMS_MAXRSS, char);
6461 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6462 Safefree(pathified);
6463 Safefree(unixified);
6466 Safefree(pathified);
6468 Safefree(unixified);
6472 unixlen = strlen(unixified);
6473 Newx(cp,unixlen+1,char);
6474 memcpy(cp,unixified,unixlen);
6476 Safefree(unixified);
6480 strcpy(__tounixpath_retbuf,unixified);
6481 Safefree(unixified);
6482 return __tounixpath_retbuf;
6485 } /* end of do_tounixpath() */
6487 /* External entry points */
6488 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6489 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6492 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
6494 *****************************************************************************
6496 * Copyright (C) 1989-1994 by *
6497 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
6499 * Permission is hereby granted for the reproduction of this software, *
6500 * on condition that this copyright notice is included in the reproduction, *
6501 * and that such reproduction is not for purposes of profit or material *
6504 * 27-Aug-1994 Modified for inclusion in perl5 *
6505 * by Charles Bailey bailey@newman.upenn.edu *
6506 *****************************************************************************
6510 * getredirection() is intended to aid in porting C programs
6511 * to VMS (Vax-11 C). The native VMS environment does not support
6512 * '>' and '<' I/O redirection, or command line wild card expansion,
6513 * or a command line pipe mechanism using the '|' AND background
6514 * command execution '&'. All of these capabilities are provided to any
6515 * C program which calls this procedure as the first thing in the
6517 * The piping mechanism will probably work with almost any 'filter' type
6518 * of program. With suitable modification, it may useful for other
6519 * portability problems as well.
6521 * Author: Mark Pizzolato mark@infocomm.com
6525 struct list_item *next;
6529 static void add_item(struct list_item **head,
6530 struct list_item **tail,
6534 static void mp_expand_wild_cards(pTHX_ char *item,
6535 struct list_item **head,
6536 struct list_item **tail,
6539 static int background_process(pTHX_ int argc, char **argv);
6541 static void pipe_and_fork(pTHX_ char **cmargv);
6543 /*{{{ void getredirection(int *ac, char ***av)*/
6545 mp_getredirection(pTHX_ int *ac, char ***av)
6547 * Process vms redirection arg's. Exit if any error is seen.
6548 * If getredirection() processes an argument, it is erased
6549 * from the vector. getredirection() returns a new argc and argv value.
6550 * In the event that a background command is requested (by a trailing "&"),
6551 * this routine creates a background subprocess, and simply exits the program.
6553 * Warning: do not try to simplify the code for vms. The code
6554 * presupposes that getredirection() is called before any data is
6555 * read from stdin or written to stdout.
6557 * Normal usage is as follows:
6563 * getredirection(&argc, &argv);
6567 int argc = *ac; /* Argument Count */
6568 char **argv = *av; /* Argument Vector */
6569 char *ap; /* Argument pointer */
6570 int j; /* argv[] index */
6571 int item_count = 0; /* Count of Items in List */
6572 struct list_item *list_head = 0; /* First Item in List */
6573 struct list_item *list_tail; /* Last Item in List */
6574 char *in = NULL; /* Input File Name */
6575 char *out = NULL; /* Output File Name */
6576 char *outmode = "w"; /* Mode to Open Output File */
6577 char *err = NULL; /* Error File Name */
6578 char *errmode = "w"; /* Mode to Open Error File */
6579 int cmargc = 0; /* Piped Command Arg Count */
6580 char **cmargv = NULL;/* Piped Command Arg Vector */
6583 * First handle the case where the last thing on the line ends with
6584 * a '&'. This indicates the desire for the command to be run in a
6585 * subprocess, so we satisfy that desire.
6588 if (0 == strcmp("&", ap))
6589 exit(background_process(aTHX_ --argc, argv));
6590 if (*ap && '&' == ap[strlen(ap)-1])
6592 ap[strlen(ap)-1] = '\0';
6593 exit(background_process(aTHX_ argc, argv));
6596 * Now we handle the general redirection cases that involve '>', '>>',
6597 * '<', and pipes '|'.
6599 for (j = 0; j < argc; ++j)
6601 if (0 == strcmp("<", argv[j]))
6605 fprintf(stderr,"No input file after < on command line");
6606 exit(LIB$_WRONUMARG);
6611 if ('<' == *(ap = argv[j]))
6616 if (0 == strcmp(">", ap))
6620 fprintf(stderr,"No output file after > on command line");
6621 exit(LIB$_WRONUMARG);
6640 fprintf(stderr,"No output file after > or >> on command line");
6641 exit(LIB$_WRONUMARG);
6645 if (('2' == *ap) && ('>' == ap[1]))
6662 fprintf(stderr,"No output file after 2> or 2>> on command line");
6663 exit(LIB$_WRONUMARG);
6667 if (0 == strcmp("|", argv[j]))
6671 fprintf(stderr,"No command into which to pipe on command line");
6672 exit(LIB$_WRONUMARG);
6674 cmargc = argc-(j+1);
6675 cmargv = &argv[j+1];
6679 if ('|' == *(ap = argv[j]))
6687 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6690 * Allocate and fill in the new argument vector, Some Unix's terminate
6691 * the list with an extra null pointer.
6693 Newx(argv, item_count+1, char *);
6694 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6696 for (j = 0; j < item_count; ++j, list_head = list_head->next)
6697 argv[j] = list_head->value;
6703 fprintf(stderr,"'|' and '>' may not both be specified on command line");
6704 exit(LIB$_INVARGORD);
6706 pipe_and_fork(aTHX_ cmargv);
6709 /* Check for input from a pipe (mailbox) */
6711 if (in == NULL && 1 == isapipe(0))
6713 char mbxname[L_tmpnam];
6715 long int dvi_item = DVI$_DEVBUFSIZ;
6716 $DESCRIPTOR(mbxnam, "");
6717 $DESCRIPTOR(mbxdevnam, "");
6719 /* Input from a pipe, reopen it in binary mode to disable */
6720 /* carriage control processing. */
6722 fgetname(stdin, mbxname);
6723 mbxnam.dsc$a_pointer = mbxname;
6724 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6725 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6726 mbxdevnam.dsc$a_pointer = mbxname;
6727 mbxdevnam.dsc$w_length = sizeof(mbxname);
6728 dvi_item = DVI$_DEVNAM;
6729 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6730 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6733 freopen(mbxname, "rb", stdin);
6736 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6740 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6742 fprintf(stderr,"Can't open input file %s as stdin",in);
6745 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6747 fprintf(stderr,"Can't open output file %s as stdout",out);
6750 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6753 if (strcmp(err,"&1") == 0) {
6754 dup2(fileno(stdout), fileno(stderr));
6755 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6758 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6760 fprintf(stderr,"Can't open error file %s as stderr",err);
6764 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6768 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6771 #ifdef ARGPROC_DEBUG
6772 PerlIO_printf(Perl_debug_log, "Arglist:\n");
6773 for (j = 0; j < *ac; ++j)
6774 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6776 /* Clear errors we may have hit expanding wildcards, so they don't
6777 show up in Perl's $! later */
6778 set_errno(0); set_vaxc_errno(1);
6779 } /* end of getredirection() */
6782 static void add_item(struct list_item **head,
6783 struct list_item **tail,
6789 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6793 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
6794 *tail = (*tail)->next;
6796 (*tail)->value = value;
6800 static void mp_expand_wild_cards(pTHX_ char *item,
6801 struct list_item **head,
6802 struct list_item **tail,
6806 unsigned long int context = 0;
6814 $DESCRIPTOR(filespec, "");
6815 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
6816 $DESCRIPTOR(resultspec, "");
6817 unsigned long int lff_flags = 0;
6820 #ifdef VMS_LONGNAME_SUPPORT
6821 lff_flags = LIB$M_FIL_LONG_NAMES;
6824 for (cp = item; *cp; cp++) {
6825 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
6826 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
6828 if (!*cp || isspace(*cp))
6830 add_item(head, tail, item, count);
6835 /* "double quoted" wild card expressions pass as is */
6836 /* From DCL that means using e.g.: */
6837 /* perl program """perl.*""" */
6838 item_len = strlen(item);
6839 if ( '"' == *item && '"' == item[item_len-1] )
6842 item[item_len-2] = '\0';
6843 add_item(head, tail, item, count);
6847 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
6848 resultspec.dsc$b_class = DSC$K_CLASS_D;
6849 resultspec.dsc$a_pointer = NULL;
6850 Newx(vmsspec, VMS_MAXRSS, char);
6851 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
6852 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
6853 if (!isunix || !filespec.dsc$a_pointer)
6854 filespec.dsc$a_pointer = item;
6855 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
6857 * Only return version specs, if the caller specified a version
6859 had_version = strchr(item, ';');
6861 * Only return device and directory specs, if the caller specifed either.
6863 had_device = strchr(item, ':');
6864 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
6866 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
6867 (&filespec, &resultspec, &context,
6868 &defaultspec, 0, 0, &lff_flags)))
6873 Newx(string,resultspec.dsc$w_length+1,char);
6874 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
6875 string[resultspec.dsc$w_length] = '\0';
6876 if (NULL == had_version)
6877 *(strrchr(string, ';')) = '\0';
6878 if ((!had_directory) && (had_device == NULL))
6880 if (NULL == (devdir = strrchr(string, ']')))
6881 devdir = strrchr(string, '>');
6882 strcpy(string, devdir + 1);
6885 * Be consistent with what the C RTL has already done to the rest of
6886 * the argv items and lowercase all of these names.
6888 if (!decc_efs_case_preserve) {
6889 for (c = string; *c; ++c)
6893 if (isunix) trim_unixpath(string,item,1);
6894 add_item(head, tail, string, count);
6898 if (sts != RMS$_NMF)
6900 set_vaxc_errno(sts);
6903 case RMS$_FNF: case RMS$_DNF:
6904 set_errno(ENOENT); break;
6906 set_errno(ENOTDIR); break;
6908 set_errno(ENODEV); break;
6909 case RMS$_FNM: case RMS$_SYN:
6910 set_errno(EINVAL); break;
6912 set_errno(EACCES); break;
6914 _ckvmssts_noperl(sts);
6918 add_item(head, tail, item, count);
6919 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
6920 _ckvmssts_noperl(lib$find_file_end(&context));
6923 static int child_st[2];/* Event Flag set when child process completes */
6925 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
6927 static unsigned long int exit_handler(int *status)
6931 if (0 == child_st[0])
6933 #ifdef ARGPROC_DEBUG
6934 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
6936 fflush(stdout); /* Have to flush pipe for binary data to */
6937 /* terminate properly -- <tp@mccall.com> */
6938 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
6939 sys$dassgn(child_chan);
6941 sys$synch(0, child_st);
6946 static void sig_child(int chan)
6948 #ifdef ARGPROC_DEBUG
6949 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
6951 if (child_st[0] == 0)
6955 static struct exit_control_block exit_block =
6960 &exit_block.exit_status,
6965 pipe_and_fork(pTHX_ char **cmargv)
6968 struct dsc$descriptor_s *vmscmd;
6969 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
6970 int sts, j, l, ismcr, quote, tquote = 0;
6972 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
6973 vms_execfree(vmscmd);
6978 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
6979 && toupper(*(q+2)) == 'R' && !*(q+3);
6981 while (q && l < MAX_DCL_LINE_LENGTH) {
6983 if (j > 0 && quote) {
6989 if (ismcr && j > 1) quote = 1;
6990 tquote = (strchr(q,' ')) != NULL || *q == '\0';
6993 if (quote || tquote) {
6999 if ((quote||tquote) && *q == '"') {
7009 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7011 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7015 static int background_process(pTHX_ int argc, char **argv)
7017 char command[MAX_DCL_SYMBOL + 1] = "$";
7018 $DESCRIPTOR(value, "");
7019 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7020 static $DESCRIPTOR(null, "NLA0:");
7021 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7023 $DESCRIPTOR(pidstr, "");
7025 unsigned long int flags = 17, one = 1, retsts;
7028 strcat(command, argv[0]);
7029 len = strlen(command);
7030 while (--argc && (len < MAX_DCL_SYMBOL))
7032 strcat(command, " \"");
7033 strcat(command, *(++argv));
7034 strcat(command, "\"");
7035 len = strlen(command);
7037 value.dsc$a_pointer = command;
7038 value.dsc$w_length = strlen(value.dsc$a_pointer);
7039 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7040 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7041 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7042 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7045 _ckvmssts_noperl(retsts);
7047 #ifdef ARGPROC_DEBUG
7048 PerlIO_printf(Perl_debug_log, "%s\n", command);
7050 sprintf(pidstring, "%08X", pid);
7051 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7052 pidstr.dsc$a_pointer = pidstring;
7053 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7054 lib$set_symbol(&pidsymbol, &pidstr);
7058 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7061 /* OS-specific initialization at image activation (not thread startup) */
7062 /* Older VAXC header files lack these constants */
7063 #ifndef JPI$_RIGHTS_SIZE
7064 # define JPI$_RIGHTS_SIZE 817
7066 #ifndef KGB$M_SUBSYSTEM
7067 # define KGB$M_SUBSYSTEM 0x8
7070 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7072 /*{{{void vms_image_init(int *, char ***)*/
7074 vms_image_init(int *argcp, char ***argvp)
7076 char eqv[LNM$C_NAMLENGTH+1] = "";
7077 unsigned int len, tabct = 8, tabidx = 0;
7078 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7079 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7080 unsigned short int dummy, rlen;
7081 struct dsc$descriptor_s **tabvec;
7082 #if defined(PERL_IMPLICIT_CONTEXT)
7085 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
7086 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
7087 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7090 #ifdef KILL_BY_SIGPRC
7091 Perl_csighandler_init();
7094 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7095 _ckvmssts_noperl(iosb[0]);
7096 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7097 if (iprv[i]) { /* Running image installed with privs? */
7098 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
7103 /* Rights identifiers might trigger tainting as well. */
7104 if (!will_taint && (rlen || rsz)) {
7105 while (rlen < rsz) {
7106 /* We didn't get all the identifiers on the first pass. Allocate a
7107 * buffer much larger than $GETJPI wants (rsz is size in bytes that
7108 * were needed to hold all identifiers at time of last call; we'll
7109 * allocate that many unsigned long ints), and go back and get 'em.
7110 * If it gave us less than it wanted to despite ample buffer space,
7111 * something's broken. Is your system missing a system identifier?
7113 if (rsz <= jpilist[1].buflen) {
7114 /* Perl_croak accvios when used this early in startup. */
7115 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7116 rsz, (unsigned long) jpilist[1].buflen,
7117 "Check your rights database for corruption.\n");
7120 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7121 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7122 jpilist[1].buflen = rsz * sizeof(unsigned long int);
7123 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7124 _ckvmssts_noperl(iosb[0]);
7126 mask = jpilist[1].bufadr;
7127 /* Check attribute flags for each identifier (2nd longword); protected
7128 * subsystem identifiers trigger tainting.
7130 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7131 if (mask[i] & KGB$M_SUBSYSTEM) {
7136 if (mask != rlst) Safefree(mask);
7139 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7140 * logical, some versions of the CRTL will add a phanthom /000000/
7141 * directory. This needs to be removed.
7143 if (decc_filename_unix_report) {
7146 ulen = strlen(argvp[0][0]);
7148 zeros = strstr(argvp[0][0], "/000000/");
7149 if (zeros != NULL) {
7151 mlen = ulen - (zeros - argvp[0][0]) - 7;
7152 memmove(zeros, &zeros[7], mlen);
7154 argvp[0][0][ulen] = '\0';
7157 /* It also may have a trailing dot that needs to be removed otherwise
7158 * it will be converted to VMS mode incorrectly.
7161 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7162 argvp[0][0][ulen] = '\0';
7165 /* We need to use this hack to tell Perl it should run with tainting,
7166 * since its tainting flag may be part of the PL_curinterp struct, which
7167 * hasn't been allocated when vms_image_init() is called.
7170 char **newargv, **oldargv;
7172 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7173 newargv[0] = oldargv[0];
7174 newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
7175 strcpy(newargv[1], "-T");
7176 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7178 newargv[*argcp] = NULL;
7179 /* We orphan the old argv, since we don't know where it's come from,
7180 * so we don't know how to free it.
7184 else { /* Did user explicitly request tainting? */
7186 char *cp, **av = *argvp;
7187 for (i = 1; i < *argcp; i++) {
7188 if (*av[i] != '-') break;
7189 for (cp = av[i]+1; *cp; cp++) {
7190 if (*cp == 'T') { will_taint = 1; break; }
7191 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7192 strchr("DFIiMmx",*cp)) break;
7194 if (will_taint) break;
7199 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7201 if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7202 else if (tabidx >= tabct) {
7204 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7206 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7207 tabvec[tabidx]->dsc$w_length = 0;
7208 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
7209 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
7210 tabvec[tabidx]->dsc$a_pointer = NULL;
7211 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7213 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7215 getredirection(argcp,argvp);
7216 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7218 # include <reentrancy.h>
7219 decc$set_reentrancy(C$C_MULTITHREAD);
7228 * Trim Unix-style prefix off filespec, so it looks like what a shell
7229 * glob expansion would return (i.e. from specified prefix on, not
7230 * full path). Note that returned filespec is Unix-style, regardless
7231 * of whether input filespec was VMS-style or Unix-style.
7233 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7234 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
7235 * vector of options; at present, only bit 0 is used, and if set tells
7236 * trim unixpath to try the current default directory as a prefix when
7237 * presented with a possibly ambiguous ... wildcard.
7239 * Returns !=0 on success, with trimmed filespec replacing contents of
7240 * fspec, and 0 on failure, with contents of fpsec unchanged.
7242 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7244 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7246 char *unixified, *unixwild,
7247 *template, *base, *end, *cp1, *cp2;
7248 register int tmplen, reslen = 0, dirs = 0;
7250 Newx(unixwild, VMS_MAXRSS, char);
7251 if (!wildspec || !fspec) return 0;
7252 template = unixwild;
7253 if (strpbrk(wildspec,"]>:") != NULL) {
7254 if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7260 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7261 unixwild[VMS_MAXRSS-1] = 0;
7263 Newx(unixified, VMS_MAXRSS, char);
7264 if (strpbrk(fspec,"]>:") != NULL) {
7265 if (do_tounixspec(fspec,unixified,0) == NULL) {
7267 Safefree(unixified);
7270 else base = unixified;
7271 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7272 * check to see that final result fits into (isn't longer than) fspec */
7273 reslen = strlen(fspec);
7277 /* No prefix or absolute path on wildcard, so nothing to remove */
7278 if (!*template || *template == '/') {
7280 if (base == fspec) {
7281 Safefree(unixified);
7284 tmplen = strlen(unixified);
7285 if (tmplen > reslen) {
7286 Safefree(unixified);
7287 return 0; /* not enough space */
7289 /* Copy unixified resultant, including trailing NUL */
7290 memmove(fspec,unixified,tmplen+1);
7291 Safefree(unixified);
7295 for (end = base; *end; end++) ; /* Find end of resultant filespec */
7296 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7297 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7298 for (cp1 = end ;cp1 >= base; cp1--)
7299 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7301 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7302 Safefree(unixified);
7308 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7309 int ells = 1, totells, segdirs, match;
7310 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7311 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7313 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7315 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7316 Newx(tpl, VMS_MAXRSS, char);
7317 if (ellipsis == template && opts & 1) {
7318 /* Template begins with an ellipsis. Since we can't tell how many
7319 * directory names at the front of the resultant to keep for an
7320 * arbitrary starting point, we arbitrarily choose the current
7321 * default directory as a starting point. If it's there as a prefix,
7322 * clip it off. If not, fall through and act as if the leading
7323 * ellipsis weren't there (i.e. return shortest possible path that
7324 * could match template).
7326 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7328 Safefree(unixified);
7332 if (!decc_efs_case_preserve) {
7333 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7334 if (_tolower(*cp1) != _tolower(*cp2)) break;
7336 segdirs = dirs - totells; /* Min # of dirs we must have left */
7337 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7338 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7339 memmove(fspec,cp2+1,end - cp2);
7340 Safefree(unixified);
7346 /* First off, back up over constant elements at end of path */
7348 for (front = end ; front >= base; front--)
7349 if (*front == '/' && !dirs--) { front++; break; }
7351 Newx(lcres, VMS_MAXRSS, char);
7352 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7354 if (!decc_efs_case_preserve) {
7355 *cp2 = _tolower(*cp1); /* Make lc copy for match */
7362 Safefree(unixified);
7366 return 0; /* Path too long. */
7369 *cp2 = '\0'; /* Pick up with memcpy later */
7370 lcfront = lcres + (front - base);
7371 /* Now skip over each ellipsis and try to match the path in front of it. */
7373 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7374 if (*(cp1) == '.' && *(cp1+1) == '.' &&
7375 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
7376 if (cp1 < template) break; /* template started with an ellipsis */
7377 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7378 ellipsis = cp1; continue;
7380 wilddsc.dsc$a_pointer = tpl;
7381 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7383 for (segdirs = 0, cp2 = tpl;
7384 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7386 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7388 if (!decc_efs_case_preserve) {
7389 *cp2 = _tolower(*cp1); /* else lowercase for match */
7392 *cp2 = *cp1; /* else preserve case for match */
7395 if (*cp2 == '/') segdirs++;
7397 if (cp1 != ellipsis - 1) {
7398 Safefree(unixified);
7402 return 0; /* Path too long */
7404 /* Back up at least as many dirs as in template before matching */
7405 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7406 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7407 for (match = 0; cp1 > lcres;) {
7408 resdsc.dsc$a_pointer = cp1;
7409 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7411 if (match == 1) lcfront = cp1;
7413 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7416 Safefree(unixified);
7420 return 0; /* Can't find prefix ??? */
7422 if (match > 1 && opts & 1) {
7423 /* This ... wildcard could cover more than one set of dirs (i.e.
7424 * a set of similar dir names is repeated). If the template
7425 * contains more than 1 ..., upstream elements could resolve the
7426 * ambiguity, but it's not worth a full backtracking setup here.
7427 * As a quick heuristic, clip off the current default directory
7428 * if it's present to find the trimmed spec, else use the
7429 * shortest string that this ... could cover.
7431 char def[NAM$C_MAXRSS+1], *st;
7433 if (getcwd(def, sizeof def,0) == NULL) {
7434 Safefree(unixified);
7440 if (!decc_efs_case_preserve) {
7441 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7442 if (_tolower(*cp1) != _tolower(*cp2)) break;
7444 segdirs = dirs - totells; /* Min # of dirs we must have left */
7445 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7446 if (*cp1 == '\0' && *cp2 == '/') {
7447 memmove(fspec,cp2+1,end - cp2);
7449 Safefree(unixified);
7454 /* Nope -- stick with lcfront from above and keep going. */
7457 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7458 Safefree(unixified);
7466 } /* end of trim_unixpath() */
7471 * VMS readdir() routines.
7472 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7474 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
7475 * Minor modifications to original routines.
7478 /* readdir may have been redefined by reentr.h, so make sure we get
7479 * the local version for what we do here.
7484 #if !defined(PERL_IMPLICIT_CONTEXT)
7485 # define readdir Perl_readdir
7487 # define readdir(a) Perl_readdir(aTHX_ a)
7490 /* Number of elements in vms_versions array */
7491 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
7494 * Open a directory, return a handle for later use.
7496 /*{{{ DIR *opendir(char*name) */
7498 Perl_opendir(pTHX_ const char *name)
7501 char dir[NAM$C_MAXRSS+1];
7504 if (do_tovmspath(name,dir,0) == NULL) {
7507 /* Check access before stat; otherwise stat does not
7508 * accurately report whether it's a directory.
7510 if (!cando_by_name(S_IRUSR,0,dir)) {
7511 /* cando_by_name has already set errno */
7514 if (flex_stat(dir,&sb) == -1) return NULL;
7515 if (!S_ISDIR(sb.st_mode)) {
7516 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
7519 /* Get memory for the handle, and the pattern. */
7521 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7523 /* Fill in the fields; mainly playing with the descriptor. */
7524 sprintf(dd->pattern, "%s*.*",dir);
7527 dd->vms_wantversions = 0;
7528 dd->pat.dsc$a_pointer = dd->pattern;
7529 dd->pat.dsc$w_length = strlen(dd->pattern);
7530 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7531 dd->pat.dsc$b_class = DSC$K_CLASS_S;
7532 #if defined(USE_ITHREADS)
7533 Newx(dd->mutex,1,perl_mutex);
7534 MUTEX_INIT( (perl_mutex *) dd->mutex );
7540 } /* end of opendir() */
7544 * Set the flag to indicate we want versions or not.
7546 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7548 vmsreaddirversions(MY_DIR *dd, int flag)
7550 dd->vms_wantversions = flag;
7555 * Free up an opened directory.
7557 /*{{{ void closedir(DIR *dd)*/
7559 Perl_closedir(MY_DIR *dd)
7563 sts = lib$find_file_end(&dd->context);
7564 Safefree(dd->pattern);
7565 #if defined(USE_ITHREADS)
7566 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7567 Safefree(dd->mutex);
7574 * Collect all the version numbers for the current file.
7577 collectversions(pTHX_ MY_DIR *dd)
7579 struct dsc$descriptor_s pat;
7580 struct dsc$descriptor_s res;
7581 struct my_dirent *e;
7582 char *p, *text, buff[sizeof dd->entry.d_name];
7584 unsigned long context, tmpsts;
7586 /* Convenient shorthand. */
7589 /* Add the version wildcard, ignoring the "*.*" put on before */
7590 i = strlen(dd->pattern);
7591 Newx(text,i + e->d_namlen + 3,char);
7592 strcpy(text, dd->pattern);
7593 sprintf(&text[i - 3], "%s;*", e->d_name);
7595 /* Set up the pattern descriptor. */
7596 pat.dsc$a_pointer = text;
7597 pat.dsc$w_length = i + e->d_namlen - 1;
7598 pat.dsc$b_dtype = DSC$K_DTYPE_T;
7599 pat.dsc$b_class = DSC$K_CLASS_S;
7601 /* Set up result descriptor. */
7602 res.dsc$a_pointer = buff;
7603 res.dsc$w_length = sizeof buff - 2;
7604 res.dsc$b_dtype = DSC$K_DTYPE_T;
7605 res.dsc$b_class = DSC$K_CLASS_S;
7607 /* Read files, collecting versions. */
7608 for (context = 0, e->vms_verscount = 0;
7609 e->vms_verscount < VERSIZE(e);
7610 e->vms_verscount++) {
7611 tmpsts = lib$find_file(&pat, &res, &context);
7612 if (tmpsts == RMS$_NMF || context == 0) break;
7614 buff[sizeof buff - 1] = '\0';
7615 if ((p = strchr(buff, ';')))
7616 e->vms_versions[e->vms_verscount] = atoi(p + 1);
7618 e->vms_versions[e->vms_verscount] = -1;
7621 _ckvmssts(lib$find_file_end(&context));
7624 } /* end of collectversions() */
7627 * Read the next entry from the directory.
7629 /*{{{ struct dirent *readdir(DIR *dd)*/
7631 Perl_readdir(pTHX_ MY_DIR *dd)
7633 struct dsc$descriptor_s res;
7634 char *p, buff[sizeof dd->entry.d_name];
7635 unsigned long int tmpsts;
7637 /* Set up result descriptor, and get next file. */
7638 res.dsc$a_pointer = buff;
7639 res.dsc$w_length = sizeof buff - 2;
7640 res.dsc$b_dtype = DSC$K_DTYPE_T;
7641 res.dsc$b_class = DSC$K_CLASS_S;
7642 tmpsts = lib$find_file(&dd->pat, &res, &dd->context);
7643 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
7644 if (!(tmpsts & 1)) {
7645 set_vaxc_errno(tmpsts);
7648 set_errno(EACCES); break;
7650 set_errno(ENODEV); break;
7652 set_errno(ENOTDIR); break;
7653 case RMS$_FNF: case RMS$_DNF:
7654 set_errno(ENOENT); break;
7661 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7662 if (!decc_efs_case_preserve) {
7663 buff[sizeof buff - 1] = '\0';
7664 for (p = buff; *p; p++) *p = _tolower(*p);
7665 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7669 /* we don't want to force to lowercase, just null terminate */
7670 buff[res.dsc$w_length] = '\0';
7672 for (p = buff; *p; p++) *p = _tolower(*p);
7673 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7676 /* Skip any directory component and just copy the name. */
7677 if ((p = strchr(buff, ']'))) strcpy(dd->entry.d_name, p + 1);
7678 else strcpy(dd->entry.d_name, buff);
7680 /* Clobber the version. */
7681 if ((p = strchr(dd->entry.d_name, ';'))) *p = '\0';
7683 dd->entry.d_namlen = strlen(dd->entry.d_name);
7684 dd->entry.vms_verscount = 0;
7685 if (dd->vms_wantversions) collectversions(aTHX_ dd);
7688 } /* end of readdir() */
7692 * Read the next entry from the directory -- thread-safe version.
7694 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
7696 Perl_readdir_r(pTHX_ MY_DIR *dd, struct my_dirent *entry, struct my_dirent **result)
7700 MUTEX_LOCK( (perl_mutex *) dd->mutex );
7702 entry = readdir(dd);
7704 retval = ( *result == NULL ? errno : 0 );
7706 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
7710 } /* end of readdir_r() */
7714 * Return something that can be used in a seekdir later.
7716 /*{{{ long telldir(DIR *dd)*/
7718 Perl_telldir(MY_DIR *dd)
7725 * Return to a spot where we used to be. Brute force.
7727 /*{{{ void seekdir(DIR *dd,long count)*/
7729 Perl_seekdir(pTHX_ MY_DIR *dd, long count)
7731 int vms_wantversions;
7733 /* If we haven't done anything yet... */
7737 /* Remember some state, and clear it. */
7738 vms_wantversions = dd->vms_wantversions;
7739 dd->vms_wantversions = 0;
7740 _ckvmssts(lib$find_file_end(&dd->context));
7743 /* The increment is in readdir(). */
7744 for (dd->count = 0; dd->count < count; )
7747 dd->vms_wantversions = vms_wantversions;
7749 } /* end of seekdir() */
7752 /* VMS subprocess management
7754 * my_vfork() - just a vfork(), after setting a flag to record that
7755 * the current script is trying a Unix-style fork/exec.
7757 * vms_do_aexec() and vms_do_exec() are called in response to the
7758 * perl 'exec' function. If this follows a vfork call, then they
7759 * call out the regular perl routines in doio.c which do an
7760 * execvp (for those who really want to try this under VMS).
7761 * Otherwise, they do exactly what the perl docs say exec should
7762 * do - terminate the current script and invoke a new command
7763 * (See below for notes on command syntax.)
7765 * do_aspawn() and do_spawn() implement the VMS side of the perl
7766 * 'system' function.
7768 * Note on command arguments to perl 'exec' and 'system': When handled
7769 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
7770 * are concatenated to form a DCL command string. If the first arg
7771 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
7772 * the command string is handed off to DCL directly. Otherwise,
7773 * the first token of the command is taken as the filespec of an image
7774 * to run. The filespec is expanded using a default type of '.EXE' and
7775 * the process defaults for device, directory, etc., and if found, the resultant
7776 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
7777 * the command string as parameters. This is perhaps a bit complicated,
7778 * but I hope it will form a happy medium between what VMS folks expect
7779 * from lib$spawn and what Unix folks expect from exec.
7782 static int vfork_called;
7784 /*{{{int my_vfork()*/
7795 vms_execfree(struct dsc$descriptor_s *vmscmd)
7798 if (vmscmd->dsc$a_pointer) {
7799 Safefree(vmscmd->dsc$a_pointer);
7806 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
7808 char *junk, *tmps = Nullch;
7809 register size_t cmdlen = 0;
7816 tmps = SvPV(really,rlen);
7823 for (idx++; idx <= sp; idx++) {
7825 junk = SvPVx(*idx,rlen);
7826 cmdlen += rlen ? rlen + 1 : 0;
7829 Newx(PL_Cmd,cmdlen+1,char);
7831 if (tmps && *tmps) {
7832 strcpy(PL_Cmd,tmps);
7835 else *PL_Cmd = '\0';
7836 while (++mark <= sp) {
7838 char *s = SvPVx(*mark,n_a);
7840 if (*PL_Cmd) strcat(PL_Cmd," ");
7846 } /* end of setup_argstr() */
7849 static unsigned long int
7850 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
7851 struct dsc$descriptor_s **pvmscmd)
7853 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
7854 char image_name[NAM$C_MAXRSS+1];
7855 char image_argv[NAM$C_MAXRSS+1];
7856 $DESCRIPTOR(defdsc,".EXE");
7857 $DESCRIPTOR(defdsc2,".");
7858 $DESCRIPTOR(resdsc,resspec);
7859 struct dsc$descriptor_s *vmscmd;
7860 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7861 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
7862 register char *s, *rest, *cp, *wordbreak;
7867 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
7869 /* Make a copy for modification */
7870 cmdlen = strlen(incmd);
7871 Newx(cmd, cmdlen+1, char);
7872 strncpy(cmd, incmd, cmdlen);
7877 vmscmd->dsc$a_pointer = NULL;
7878 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
7879 vmscmd->dsc$b_class = DSC$K_CLASS_S;
7880 vmscmd->dsc$w_length = 0;
7881 if (pvmscmd) *pvmscmd = vmscmd;
7883 if (suggest_quote) *suggest_quote = 0;
7885 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
7886 return CLI$_BUFOVF; /* continuation lines currently unsupported */
7892 while (*s && isspace(*s)) s++;
7894 if (*s == '@' || *s == '$') {
7895 vmsspec[0] = *s; rest = s + 1;
7896 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
7898 else { cp = vmsspec; rest = s; }
7899 if (*rest == '.' || *rest == '/') {
7902 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
7903 rest++, cp2++) *cp2 = *rest;
7905 if (do_tovmsspec(resspec,cp,0)) {
7908 for (cp2 = vmsspec + strlen(vmsspec);
7909 *rest && cp2 - vmsspec < sizeof vmsspec;
7910 rest++, cp2++) *cp2 = *rest;
7915 /* Intuit whether verb (first word of cmd) is a DCL command:
7916 * - if first nonspace char is '@', it's a DCL indirection
7918 * - if verb contains a filespec separator, it's not a DCL command
7919 * - if it doesn't, caller tells us whether to default to a DCL
7920 * command, or to a local image unless told it's DCL (by leading '$')
7924 if (suggest_quote) *suggest_quote = 1;
7926 register char *filespec = strpbrk(s,":<[.;");
7927 rest = wordbreak = strpbrk(s," \"\t/");
7928 if (!wordbreak) wordbreak = s + strlen(s);
7929 if (*s == '$') check_img = 0;
7930 if (filespec && (filespec < wordbreak)) isdcl = 0;
7931 else isdcl = !check_img;
7935 imgdsc.dsc$a_pointer = s;
7936 imgdsc.dsc$w_length = wordbreak - s;
7937 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7939 _ckvmssts(lib$find_file_end(&cxt));
7940 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7941 if (!(retsts & 1) && *s == '$') {
7942 _ckvmssts(lib$find_file_end(&cxt));
7943 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
7944 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
7946 _ckvmssts(lib$find_file_end(&cxt));
7947 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
7951 _ckvmssts(lib$find_file_end(&cxt));
7956 while (*s && !isspace(*s)) s++;
7959 /* check that it's really not DCL with no file extension */
7960 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
7962 char b[256] = {0,0,0,0};
7963 read(fileno(fp), b, 256);
7964 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
7968 /* Check for script */
7970 if ((b[0] == '#') && (b[1] == '!'))
7972 #ifdef ALTERNATE_SHEBANG
7974 shebang_len = strlen(ALTERNATE_SHEBANG);
7975 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
7977 perlstr = strstr("perl",b);
7978 if (perlstr == NULL)
7986 if (shebang_len > 0) {
7989 char tmpspec[NAM$C_MAXRSS + 1];
7992 /* Image is following after white space */
7993 /*--------------------------------------*/
7994 while (isprint(b[i]) && isspace(b[i]))
7998 while (isprint(b[i]) && !isspace(b[i])) {
7999 tmpspec[j++] = b[i++];
8000 if (j >= NAM$C_MAXRSS)
8005 /* There may be some default parameters to the image */
8006 /*---------------------------------------------------*/
8008 while (isprint(b[i])) {
8009 image_argv[j++] = b[i++];
8010 if (j >= NAM$C_MAXRSS)
8013 while ((j > 0) && !isprint(image_argv[j-1]))
8017 /* It will need to be converted to VMS format and validated */
8018 if (tmpspec[0] != '\0') {
8021 /* Try to find the exact program requested to be run */
8022 /*---------------------------------------------------*/
8023 iname = do_rmsexpand
8024 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8025 if (iname != NULL) {
8026 if (cando_by_name(S_IXUSR,0,image_name)) {
8027 /* MCR prefix needed */
8031 /* Try again with a null type */
8032 /*----------------------------*/
8033 iname = do_rmsexpand
8034 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8035 if (iname != NULL) {
8036 if (cando_by_name(S_IXUSR,0,image_name)) {
8037 /* MCR prefix needed */
8043 /* Did we find the image to run the script? */
8044 /*------------------------------------------*/
8048 /* Assume DCL or foreign command exists */
8049 /*--------------------------------------*/
8050 tchr = strrchr(tmpspec, '/');
8057 strcpy(image_name, tchr);
8065 if (check_img && isdcl) return RMS$_FNF;
8067 if (cando_by_name(S_IXUSR,0,resspec)) {
8068 Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8070 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8071 if (image_name[0] != 0) {
8072 strcat(vmscmd->dsc$a_pointer, image_name);
8073 strcat(vmscmd->dsc$a_pointer, " ");
8075 } else if (image_name[0] != 0) {
8076 strcpy(vmscmd->dsc$a_pointer, image_name);
8077 strcat(vmscmd->dsc$a_pointer, " ");
8079 strcpy(vmscmd->dsc$a_pointer,"@");
8081 if (suggest_quote) *suggest_quote = 1;
8083 /* If there is an image name, use original command */
8084 if (image_name[0] == 0)
8085 strcat(vmscmd->dsc$a_pointer,resspec);
8088 while (*rest && isspace(*rest)) rest++;
8091 if (image_argv[0] != 0) {
8092 strcat(vmscmd->dsc$a_pointer,image_argv);
8093 strcat(vmscmd->dsc$a_pointer, " ");
8099 rest_len = strlen(rest);
8100 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8101 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8102 strcat(vmscmd->dsc$a_pointer,rest);
8104 retsts = CLI$_BUFOVF;
8106 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8108 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8110 else retsts = RMS$_PRV;
8113 /* It's either a DCL command or we couldn't find a suitable image */
8114 vmscmd->dsc$w_length = strlen(cmd);
8115 /* if (cmd == PL_Cmd) {
8116 vmscmd->dsc$a_pointer = PL_Cmd;
8117 if (suggest_quote) *suggest_quote = 1;
8120 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
8124 /* check if it's a symbol (for quoting purposes) */
8125 if (suggest_quote && !*suggest_quote) {
8127 char equiv[LNM$C_NAMLENGTH];
8128 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8129 eqvdsc.dsc$a_pointer = equiv;
8131 iss = lib$get_symbol(vmscmd,&eqvdsc);
8132 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8134 if (!(retsts & 1)) {
8135 /* just hand off status values likely to be due to user error */
8136 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8137 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8138 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8139 else { _ckvmssts(retsts); }
8142 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8144 } /* end of setup_cmddsc() */
8147 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8149 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8152 if (vfork_called) { /* this follows a vfork - act Unixish */
8154 if (vfork_called < 0) {
8155 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8158 else return do_aexec(really,mark,sp);
8160 /* no vfork - act VMSish */
8161 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
8166 } /* end of vms_do_aexec() */
8169 /* {{{bool vms_do_exec(char *cmd) */
8171 Perl_vms_do_exec(pTHX_ const char *cmd)
8173 struct dsc$descriptor_s *vmscmd;
8175 if (vfork_called) { /* this follows a vfork - act Unixish */
8177 if (vfork_called < 0) {
8178 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8181 else return do_exec(cmd);
8184 { /* no vfork - act VMSish */
8185 unsigned long int retsts;
8188 TAINT_PROPER("exec");
8189 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8190 retsts = lib$do_command(vmscmd);
8193 case RMS$_FNF: case RMS$_DNF:
8194 set_errno(ENOENT); break;
8196 set_errno(ENOTDIR); break;
8198 set_errno(ENODEV); break;
8200 set_errno(EACCES); break;
8202 set_errno(EINVAL); break;
8203 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8204 set_errno(E2BIG); break;
8205 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8206 _ckvmssts(retsts); /* fall through */
8207 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8210 set_vaxc_errno(retsts);
8211 if (ckWARN(WARN_EXEC)) {
8212 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8213 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8215 vms_execfree(vmscmd);
8220 } /* end of vms_do_exec() */
8223 unsigned long int Perl_do_spawn(pTHX_ const char *);
8225 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8227 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8229 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
8232 } /* end of do_aspawn() */
8235 /* {{{unsigned long int do_spawn(char *cmd) */
8237 Perl_do_spawn(pTHX_ const char *cmd)
8239 unsigned long int sts, substs;
8242 TAINT_PROPER("spawn");
8243 if (!cmd || !*cmd) {
8244 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8247 case RMS$_FNF: case RMS$_DNF:
8248 set_errno(ENOENT); break;
8250 set_errno(ENOTDIR); break;
8252 set_errno(ENODEV); break;
8254 set_errno(EACCES); break;
8256 set_errno(EINVAL); break;
8257 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8258 set_errno(E2BIG); break;
8259 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8260 _ckvmssts(sts); /* fall through */
8261 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8264 set_vaxc_errno(sts);
8265 if (ckWARN(WARN_EXEC)) {
8266 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8274 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8279 } /* end of do_spawn() */
8283 static unsigned int *sockflags, sockflagsize;
8286 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8287 * routines found in some versions of the CRTL can't deal with sockets.
8288 * We don't shim the other file open routines since a socket isn't
8289 * likely to be opened by a name.
8291 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8292 FILE *my_fdopen(int fd, const char *mode)
8294 FILE *fp = fdopen(fd, mode);
8297 unsigned int fdoff = fd / sizeof(unsigned int);
8298 Stat_t sbuf; /* native stat; we don't need flex_stat */
8299 if (!sockflagsize || fdoff > sockflagsize) {
8300 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
8301 else Newx (sockflags,fdoff+2,unsigned int);
8302 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8303 sockflagsize = fdoff + 2;
8305 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8306 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8315 * Clear the corresponding bit when the (possibly) socket stream is closed.
8316 * There still a small hole: we miss an implicit close which might occur
8317 * via freopen(). >> Todo
8319 /*{{{ int my_fclose(FILE *fp)*/
8320 int my_fclose(FILE *fp) {
8322 unsigned int fd = fileno(fp);
8323 unsigned int fdoff = fd / sizeof(unsigned int);
8325 if (sockflagsize && fdoff <= sockflagsize)
8326 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8334 * A simple fwrite replacement which outputs itmsz*nitm chars without
8335 * introducing record boundaries every itmsz chars.
8336 * We are using fputs, which depends on a terminating null. We may
8337 * well be writing binary data, so we need to accommodate not only
8338 * data with nulls sprinkled in the middle but also data with no null
8341 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8343 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8345 register char *cp, *end, *cpd, *data;
8346 register unsigned int fd = fileno(dest);
8347 register unsigned int fdoff = fd / sizeof(unsigned int);
8349 int bufsize = itmsz * nitm + 1;
8351 if (fdoff < sockflagsize &&
8352 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8353 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8357 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8358 memcpy( data, src, itmsz*nitm );
8359 data[itmsz*nitm] = '\0';
8361 end = data + itmsz * nitm;
8362 retval = (int) nitm; /* on success return # items written */
8365 while (cpd <= end) {
8366 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8367 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8369 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8373 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8376 } /* end of my_fwrite() */
8379 /*{{{ int my_flush(FILE *fp)*/
8381 Perl_my_flush(pTHX_ FILE *fp)
8384 if ((res = fflush(fp)) == 0 && fp) {
8385 #ifdef VMS_DO_SOCKETS
8387 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8389 res = fsync(fileno(fp));
8392 * If the flush succeeded but set end-of-file, we need to clear
8393 * the error because our caller may check ferror(). BTW, this
8394 * probably means we just flushed an empty file.
8396 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8403 * Here are replacements for the following Unix routines in the VMS environment:
8404 * getpwuid Get information for a particular UIC or UID
8405 * getpwnam Get information for a named user
8406 * getpwent Get information for each user in the rights database
8407 * setpwent Reset search to the start of the rights database
8408 * endpwent Finish searching for users in the rights database
8410 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8411 * (defined in pwd.h), which contains the following fields:-
8413 * char *pw_name; Username (in lower case)
8414 * char *pw_passwd; Hashed password
8415 * unsigned int pw_uid; UIC
8416 * unsigned int pw_gid; UIC group number
8417 * char *pw_unixdir; Default device/directory (VMS-style)
8418 * char *pw_gecos; Owner name
8419 * char *pw_dir; Default device/directory (Unix-style)
8420 * char *pw_shell; Default CLI name (eg. DCL)
8422 * If the specified user does not exist, getpwuid and getpwnam return NULL.
8424 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8425 * not the UIC member number (eg. what's returned by getuid()),
8426 * getpwuid() can accept either as input (if uid is specified, the caller's
8427 * UIC group is used), though it won't recognise gid=0.
8429 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8430 * information about other users in your group or in other groups, respectively.
8431 * If the required privilege is not available, then these routines fill only
8432 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8435 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8438 /* sizes of various UAF record fields */
8439 #define UAI$S_USERNAME 12
8440 #define UAI$S_IDENT 31
8441 #define UAI$S_OWNER 31
8442 #define UAI$S_DEFDEV 31
8443 #define UAI$S_DEFDIR 63
8444 #define UAI$S_DEFCLI 31
8447 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
8448 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8449 (uic).uic$v_group != UIC$K_WILD_GROUP)
8451 static char __empty[]= "";
8452 static struct passwd __passwd_empty=
8453 {(char *) __empty, (char *) __empty, 0, 0,
8454 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8455 static int contxt= 0;
8456 static struct passwd __pwdcache;
8457 static char __pw_namecache[UAI$S_IDENT+1];
8460 * This routine does most of the work extracting the user information.
8462 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8465 unsigned char length;
8466 char pw_gecos[UAI$S_OWNER+1];
8468 static union uicdef uic;
8470 unsigned char length;
8471 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8474 unsigned char length;
8475 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8478 unsigned char length;
8479 char pw_shell[UAI$S_DEFCLI+1];
8481 static char pw_passwd[UAI$S_PWD+1];
8483 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8484 struct dsc$descriptor_s name_desc;
8485 unsigned long int sts;
8487 static struct itmlst_3 itmlst[]= {
8488 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
8489 {sizeof(uic), UAI$_UIC, &uic, &luic},
8490 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
8491 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
8492 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
8493 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
8494 {0, 0, NULL, NULL}};
8496 name_desc.dsc$w_length= strlen(name);
8497 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8498 name_desc.dsc$b_class= DSC$K_CLASS_S;
8499 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8501 /* Note that sys$getuai returns many fields as counted strings. */
8502 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8503 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8504 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8506 else { _ckvmssts(sts); }
8507 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
8509 if ((int) owner.length < lowner) lowner= (int) owner.length;
8510 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8511 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8512 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8513 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8514 owner.pw_gecos[lowner]= '\0';
8515 defdev.pw_dir[ldefdev+ldefdir]= '\0';
8516 defcli.pw_shell[ldefcli]= '\0';
8517 if (valid_uic(uic)) {
8518 pwd->pw_uid= uic.uic$l_uic;
8519 pwd->pw_gid= uic.uic$v_group;
8522 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8523 pwd->pw_passwd= pw_passwd;
8524 pwd->pw_gecos= owner.pw_gecos;
8525 pwd->pw_dir= defdev.pw_dir;
8526 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8527 pwd->pw_shell= defcli.pw_shell;
8528 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8530 ldir= strlen(pwd->pw_unixdir) - 1;
8531 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8534 strcpy(pwd->pw_unixdir, pwd->pw_dir);
8535 if (!decc_efs_case_preserve)
8536 __mystrtolower(pwd->pw_unixdir);
8541 * Get information for a named user.
8543 /*{{{struct passwd *getpwnam(char *name)*/
8544 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8546 struct dsc$descriptor_s name_desc;
8548 unsigned long int status, sts;
8550 __pwdcache = __passwd_empty;
8551 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8552 /* We still may be able to determine pw_uid and pw_gid */
8553 name_desc.dsc$w_length= strlen(name);
8554 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8555 name_desc.dsc$b_class= DSC$K_CLASS_S;
8556 name_desc.dsc$a_pointer= (char *) name;
8557 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8558 __pwdcache.pw_uid= uic.uic$l_uic;
8559 __pwdcache.pw_gid= uic.uic$v_group;
8562 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8563 set_vaxc_errno(sts);
8564 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8567 else { _ckvmssts(sts); }
8570 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8571 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8572 __pwdcache.pw_name= __pw_namecache;
8574 } /* end of my_getpwnam() */
8578 * Get information for a particular UIC or UID.
8579 * Called by my_getpwent with uid=-1 to list all users.
8581 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8582 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8584 const $DESCRIPTOR(name_desc,__pw_namecache);
8585 unsigned short lname;
8587 unsigned long int status;
8589 if (uid == (unsigned int) -1) {
8591 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8592 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8593 set_vaxc_errno(status);
8594 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8598 else { _ckvmssts(status); }
8599 } while (!valid_uic (uic));
8603 if (!uic.uic$v_group)
8604 uic.uic$v_group= PerlProc_getgid();
8606 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8607 else status = SS$_IVIDENT;
8608 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8609 status == RMS$_PRV) {
8610 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8613 else { _ckvmssts(status); }
8615 __pw_namecache[lname]= '\0';
8616 __mystrtolower(__pw_namecache);
8618 __pwdcache = __passwd_empty;
8619 __pwdcache.pw_name = __pw_namecache;
8621 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8622 The identifier's value is usually the UIC, but it doesn't have to be,
8623 so if we can, we let fillpasswd update this. */
8624 __pwdcache.pw_uid = uic.uic$l_uic;
8625 __pwdcache.pw_gid = uic.uic$v_group;
8627 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8630 } /* end of my_getpwuid() */
8634 * Get information for next user.
8636 /*{{{struct passwd *my_getpwent()*/
8637 struct passwd *Perl_my_getpwent(pTHX)
8639 return (my_getpwuid((unsigned int) -1));
8644 * Finish searching rights database for users.
8646 /*{{{void my_endpwent()*/
8647 void Perl_my_endpwent(pTHX)
8650 _ckvmssts(sys$finish_rdb(&contxt));
8656 #ifdef HOMEGROWN_POSIX_SIGNALS
8657 /* Signal handling routines, pulled into the core from POSIX.xs.
8659 * We need these for threads, so they've been rolled into the core,
8660 * rather than left in POSIX.xs.
8662 * (DRS, Oct 23, 1997)
8665 /* sigset_t is atomic under VMS, so these routines are easy */
8666 /*{{{int my_sigemptyset(sigset_t *) */
8667 int my_sigemptyset(sigset_t *set) {
8668 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8674 /*{{{int my_sigfillset(sigset_t *)*/
8675 int my_sigfillset(sigset_t *set) {
8677 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8678 for (i = 0; i < NSIG; i++) *set |= (1 << i);
8684 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
8685 int my_sigaddset(sigset_t *set, int sig) {
8686 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8687 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8688 *set |= (1 << (sig - 1));
8694 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
8695 int my_sigdelset(sigset_t *set, int sig) {
8696 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8697 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8698 *set &= ~(1 << (sig - 1));
8704 /*{{{int my_sigismember(sigset_t *set, int sig)*/
8705 int my_sigismember(sigset_t *set, int sig) {
8706 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
8707 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
8708 return *set & (1 << (sig - 1));
8713 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
8714 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
8717 /* If set and oset are both null, then things are badly wrong. Bail out. */
8718 if ((oset == NULL) && (set == NULL)) {
8719 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
8723 /* If set's null, then we're just handling a fetch. */
8725 tempmask = sigblock(0);
8730 tempmask = sigsetmask(*set);
8733 tempmask = sigblock(*set);
8736 tempmask = sigblock(0);
8737 sigsetmask(*oset & ~tempmask);
8740 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
8745 /* Did they pass us an oset? If so, stick our holding mask into it */
8752 #endif /* HOMEGROWN_POSIX_SIGNALS */
8755 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
8756 * my_utime(), and flex_stat(), all of which operate on UTC unless
8757 * VMSISH_TIMES is true.
8759 /* method used to handle UTC conversions:
8760 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
8762 static int gmtime_emulation_type;
8763 /* number of secs to add to UTC POSIX-style time to get local time */
8764 static long int utc_offset_secs;
8766 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
8767 * in vmsish.h. #undef them here so we can call the CRTL routines
8776 * DEC C previous to 6.0 corrupts the behavior of the /prefix
8777 * qualifier with the extern prefix pragma. This provisional
8778 * hack circumvents this prefix pragma problem in previous
8781 #if defined(__VMS_VER) && __VMS_VER >= 70000000
8782 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
8783 # pragma __extern_prefix save
8784 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
8785 # define gmtime decc$__utctz_gmtime
8786 # define localtime decc$__utctz_localtime
8787 # define time decc$__utc_time
8788 # pragma __extern_prefix restore
8790 struct tm *gmtime(), *localtime();
8796 static time_t toutc_dst(time_t loc) {
8799 if ((rsltmp = localtime(&loc)) == NULL) return -1;
8800 loc -= utc_offset_secs;
8801 if (rsltmp->tm_isdst) loc -= 3600;
8804 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
8805 ((gmtime_emulation_type || my_time(NULL)), \
8806 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
8807 ((secs) - utc_offset_secs))))
8809 static time_t toloc_dst(time_t utc) {
8812 utc += utc_offset_secs;
8813 if ((rsltmp = localtime(&utc)) == NULL) return -1;
8814 if (rsltmp->tm_isdst) utc += 3600;
8817 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
8818 ((gmtime_emulation_type || my_time(NULL)), \
8819 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
8820 ((secs) + utc_offset_secs))))
8822 #ifndef RTL_USES_UTC
8825 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
8826 DST starts on 1st sun of april at 02:00 std time
8827 ends on last sun of october at 02:00 dst time
8828 see the UCX management command reference, SET CONFIG TIMEZONE
8829 for formatting info.
8831 No, it's not as general as it should be, but then again, NOTHING
8832 will handle UK times in a sensible way.
8837 parse the DST start/end info:
8838 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
8842 tz_parse_startend(char *s, struct tm *w, int *past)
8844 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
8845 int ly, dozjd, d, m, n, hour, min, sec, j, k;
8850 if (!past) return 0;
8853 if (w->tm_year % 4 == 0) ly = 1;
8854 if (w->tm_year % 100 == 0) ly = 0;
8855 if (w->tm_year+1900 % 400 == 0) ly = 1;
8858 dozjd = isdigit(*s);
8859 if (*s == 'J' || *s == 'j' || dozjd) {
8860 if (!dozjd && !isdigit(*++s)) return 0;
8863 d = d*10 + *s++ - '0';
8865 d = d*10 + *s++ - '0';
8868 if (d == 0) return 0;
8869 if (d > 366) return 0;
8871 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
8874 } else if (*s == 'M' || *s == 'm') {
8875 if (!isdigit(*++s)) return 0;
8877 if (isdigit(*s)) m = 10*m + *s++ - '0';
8878 if (*s != '.') return 0;
8879 if (!isdigit(*++s)) return 0;
8881 if (n < 1 || n > 5) return 0;
8882 if (*s != '.') return 0;
8883 if (!isdigit(*++s)) return 0;
8885 if (d > 6) return 0;
8889 if (!isdigit(*++s)) return 0;
8891 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
8893 if (!isdigit(*++s)) return 0;
8895 if (isdigit(*s)) min = 10*min + *s++ - '0';
8897 if (!isdigit(*++s)) return 0;
8899 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
8909 if (w->tm_yday < d) goto before;
8910 if (w->tm_yday > d) goto after;
8912 if (w->tm_mon+1 < m) goto before;
8913 if (w->tm_mon+1 > m) goto after;
8915 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
8916 k = d - j; /* mday of first d */
8918 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
8919 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
8920 if (w->tm_mday < k) goto before;
8921 if (w->tm_mday > k) goto after;
8924 if (w->tm_hour < hour) goto before;
8925 if (w->tm_hour > hour) goto after;
8926 if (w->tm_min < min) goto before;
8927 if (w->tm_min > min) goto after;
8928 if (w->tm_sec < sec) goto before;
8942 /* parse the offset: (+|-)hh[:mm[:ss]] */
8945 tz_parse_offset(char *s, int *offset)
8947 int hour = 0, min = 0, sec = 0;
8950 if (!offset) return 0;
8952 if (*s == '-') {neg++; s++;}
8954 if (!isdigit(*s)) return 0;
8956 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
8957 if (hour > 24) return 0;
8959 if (!isdigit(*++s)) return 0;
8961 if (isdigit(*s)) min = min*10 + (*s++ - '0');
8962 if (min > 59) return 0;
8964 if (!isdigit(*++s)) return 0;
8966 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
8967 if (sec > 59) return 0;
8971 *offset = (hour*60+min)*60 + sec;
8972 if (neg) *offset = -*offset;
8977 input time is w, whatever type of time the CRTL localtime() uses.
8978 sets dst, the zone, and the gmtoff (seconds)
8980 caches the value of TZ and UCX$TZ env variables; note that
8981 my_setenv looks for these and sets a flag if they're changed
8984 We have to watch out for the "australian" case (dst starts in
8985 october, ends in april)...flagged by "reverse" and checked by
8986 scanning through the months of the previous year.
8991 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
8996 char *dstzone, *tz, *s_start, *s_end;
8997 int std_off, dst_off, isdst;
8998 int y, dststart, dstend;
8999 static char envtz[1025]; /* longer than any logical, symbol, ... */
9000 static char ucxtz[1025];
9001 static char reversed = 0;
9007 reversed = -1; /* flag need to check */
9008 envtz[0] = ucxtz[0] = '\0';
9009 tz = my_getenv("TZ",0);
9010 if (tz) strcpy(envtz, tz);
9011 tz = my_getenv("UCX$TZ",0);
9012 if (tz) strcpy(ucxtz, tz);
9013 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
9016 if (!*tz) tz = ucxtz;
9019 while (isalpha(*s)) s++;
9020 s = tz_parse_offset(s, &std_off);
9022 if (!*s) { /* no DST, hurray we're done! */
9028 while (isalpha(*s)) s++;
9029 s2 = tz_parse_offset(s, &dst_off);
9033 dst_off = std_off - 3600;
9036 if (!*s) { /* default dst start/end?? */
9037 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
9038 s = strchr(ucxtz,',');
9040 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
9042 if (*s != ',') return 0;
9045 when = _toutc(when); /* convert to utc */
9046 when = when - std_off; /* convert to pseudolocal time*/
9048 w2 = localtime(&when);
9051 s = tz_parse_startend(s_start,w2,&dststart);
9053 if (*s != ',') return 0;
9056 when = _toutc(when); /* convert to utc */
9057 when = when - dst_off; /* convert to pseudolocal time*/
9058 w2 = localtime(&when);
9059 if (w2->tm_year != y) { /* spans a year, just check one time */
9060 when += dst_off - std_off;
9061 w2 = localtime(&when);
9064 s = tz_parse_startend(s_end,w2,&dstend);
9067 if (reversed == -1) { /* need to check if start later than end */
9071 if (when < 2*365*86400) {
9072 when += 2*365*86400;
9076 w2 =localtime(&when);
9077 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
9079 for (j = 0; j < 12; j++) {
9080 w2 =localtime(&when);
9081 tz_parse_startend(s_start,w2,&ds);
9082 tz_parse_startend(s_end,w2,&de);
9083 if (ds != de) break;
9087 if (de && !ds) reversed = 1;
9090 isdst = dststart && !dstend;
9091 if (reversed) isdst = dststart || !dstend;
9094 if (dst) *dst = isdst;
9095 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9096 if (isdst) tz = dstzone;
9098 while(isalpha(*tz)) *zone++ = *tz++;
9104 #endif /* !RTL_USES_UTC */
9106 /* my_time(), my_localtime(), my_gmtime()
9107 * By default traffic in UTC time values, using CRTL gmtime() or
9108 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9109 * Note: We need to use these functions even when the CRTL has working
9110 * UTC support, since they also handle C<use vmsish qw(times);>
9112 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
9113 * Modified by Charles Bailey <bailey@newman.upenn.edu>
9116 /*{{{time_t my_time(time_t *timep)*/
9117 time_t Perl_my_time(pTHX_ time_t *timep)
9122 if (gmtime_emulation_type == 0) {
9124 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
9125 /* results of calls to gmtime() and localtime() */
9126 /* for same &base */
9128 gmtime_emulation_type++;
9129 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9130 char off[LNM$C_NAMLENGTH+1];;
9132 gmtime_emulation_type++;
9133 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9134 gmtime_emulation_type++;
9135 utc_offset_secs = 0;
9136 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9138 else { utc_offset_secs = atol(off); }
9140 else { /* We've got a working gmtime() */
9141 struct tm gmt, local;
9144 tm_p = localtime(&base);
9146 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
9147 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9148 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
9149 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
9155 # ifdef RTL_USES_UTC
9156 if (VMSISH_TIME) when = _toloc(when);
9158 if (!VMSISH_TIME) when = _toutc(when);
9161 if (timep != NULL) *timep = when;
9164 } /* end of my_time() */
9168 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9170 Perl_my_gmtime(pTHX_ const time_t *timep)
9176 if (timep == NULL) {
9177 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9180 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9184 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9186 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
9187 return gmtime(&when);
9189 /* CRTL localtime() wants local time as input, so does no tz correction */
9190 rsltmp = localtime(&when);
9191 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
9194 } /* end of my_gmtime() */
9198 /*{{{struct tm *my_localtime(const time_t *timep)*/
9200 Perl_my_localtime(pTHX_ const time_t *timep)
9202 time_t when, whenutc;
9206 if (timep == NULL) {
9207 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9210 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9211 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9214 # ifdef RTL_USES_UTC
9216 if (VMSISH_TIME) when = _toutc(when);
9218 /* CRTL localtime() wants UTC as input, does tz correction itself */
9219 return localtime(&when);
9221 # else /* !RTL_USES_UTC */
9224 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
9225 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
9228 #ifndef RTL_USES_UTC
9229 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
9230 when = whenutc - offset; /* pseudolocal time*/
9233 /* CRTL localtime() wants local time as input, so does no tz correction */
9234 rsltmp = localtime(&when);
9235 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9239 } /* end of my_localtime() */
9242 /* Reset definitions for later calls */
9243 #define gmtime(t) my_gmtime(t)
9244 #define localtime(t) my_localtime(t)
9245 #define time(t) my_time(t)
9248 /* my_utime - update modification time of a file
9249 * calling sequence is identical to POSIX utime(), but under
9250 * VMS only the modification time is changed; ODS-2 does not
9251 * maintain access times. Restrictions differ from the POSIX
9252 * definition in that the time can be changed as long as the
9253 * caller has permission to execute the necessary IO$_MODIFY $QIO;
9254 * no separate checks are made to insure that the caller is the
9255 * owner of the file or has special privs enabled.
9256 * Code here is based on Joe Meadows' FILE utility.
9259 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9260 * to VMS epoch (01-JAN-1858 00:00:00.00)
9261 * in 100 ns intervals.
9263 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9265 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9266 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9267 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9269 return utime(file, utimes);
9272 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9276 long int bintime[2], len = 2, lowbit, unixtime,
9277 secscale = 10000000; /* seconds --> 100 ns intervals */
9278 unsigned long int chan, iosb[2], retsts;
9279 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9280 struct FAB myfab = cc$rms_fab;
9281 struct NAM mynam = cc$rms_nam;
9282 #if defined (__DECC) && defined (__VAX)
9283 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9284 * at least through VMS V6.1, which causes a type-conversion warning.
9286 # pragma message save
9287 # pragma message disable cvtdiftypes
9289 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9290 struct fibdef myfib;
9291 #if defined (__DECC) && defined (__VAX)
9292 /* This should be right after the declaration of myatr, but due
9293 * to a bug in VAX DEC C, this takes effect a statement early.
9295 # pragma message restore
9297 /* cast ok for read only parameter */
9298 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9299 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9300 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9302 if (file == NULL || *file == '\0') {
9304 set_vaxc_errno(LIB$_INVARG);
9307 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9309 if (utimes != NULL) {
9310 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
9311 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9312 * Since time_t is unsigned long int, and lib$emul takes a signed long int
9313 * as input, we force the sign bit to be clear by shifting unixtime right
9314 * one bit, then multiplying by an extra factor of 2 in lib$emul().
9316 lowbit = (utimes->modtime & 1) ? secscale : 0;
9317 unixtime = (long int) utimes->modtime;
9319 /* If input was UTC; convert to local for sys svc */
9320 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9322 unixtime >>= 1; secscale <<= 1;
9323 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9324 if (!(retsts & 1)) {
9326 set_vaxc_errno(retsts);
9329 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9330 if (!(retsts & 1)) {
9332 set_vaxc_errno(retsts);
9337 /* Just get the current time in VMS format directly */
9338 retsts = sys$gettim(bintime);
9339 if (!(retsts & 1)) {
9341 set_vaxc_errno(retsts);
9346 myfab.fab$l_fna = vmsspec;
9347 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9348 myfab.fab$l_nam = &mynam;
9349 mynam.nam$l_esa = esa;
9350 mynam.nam$b_ess = (unsigned char) sizeof esa;
9351 mynam.nam$l_rsa = rsa;
9352 mynam.nam$b_rss = (unsigned char) sizeof rsa;
9353 if (decc_efs_case_preserve)
9354 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9356 /* Look for the file to be affected, letting RMS parse the file
9357 * specification for us as well. I have set errno using only
9358 * values documented in the utime() man page for VMS POSIX.
9360 retsts = sys$parse(&myfab,0,0);
9361 if (!(retsts & 1)) {
9362 set_vaxc_errno(retsts);
9363 if (retsts == RMS$_PRV) set_errno(EACCES);
9364 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9365 else set_errno(EVMSERR);
9368 retsts = sys$search(&myfab,0,0);
9369 if (!(retsts & 1)) {
9370 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9371 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9372 set_vaxc_errno(retsts);
9373 if (retsts == RMS$_PRV) set_errno(EACCES);
9374 else if (retsts == RMS$_FNF) set_errno(ENOENT);
9375 else set_errno(EVMSERR);
9379 devdsc.dsc$w_length = mynam.nam$b_dev;
9380 /* cast ok for read only parameter */
9381 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9383 retsts = sys$assign(&devdsc,&chan,0,0);
9384 if (!(retsts & 1)) {
9385 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9386 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9387 set_vaxc_errno(retsts);
9388 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
9389 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
9390 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
9391 else set_errno(EVMSERR);
9395 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9396 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9398 memset((void *) &myfib, 0, sizeof myfib);
9399 #if defined(__DECC) || defined(__DECCXX)
9400 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9401 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9402 /* This prevents the revision time of the file being reset to the current
9403 * time as a result of our IO$_MODIFY $QIO. */
9404 myfib.fib$l_acctl = FIB$M_NORECORD;
9406 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9407 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9408 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9410 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9411 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9412 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9413 _ckvmssts(sys$dassgn(chan));
9414 if (retsts & 1) retsts = iosb[0];
9415 if (!(retsts & 1)) {
9416 set_vaxc_errno(retsts);
9417 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9418 else set_errno(EVMSERR);
9423 } /* end of my_utime() */
9428 * flex_stat, flex_lstat, flex_fstat
9429 * basic stat, but gets it right when asked to stat
9430 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9433 #ifndef _USE_STD_STAT
9434 /* encode_dev packs a VMS device name string into an integer to allow
9435 * simple comparisons. This can be used, for example, to check whether two
9436 * files are located on the same device, by comparing their encoded device
9437 * names. Even a string comparison would not do, because stat() reuses the
9438 * device name buffer for each call; so without encode_dev, it would be
9439 * necessary to save the buffer and use strcmp (this would mean a number of
9440 * changes to the standard Perl code, to say nothing of what a Perl script
9443 * The device lock id, if it exists, should be unique (unless perhaps compared
9444 * with lock ids transferred from other nodes). We have a lock id if the disk is
9445 * mounted cluster-wide, which is when we tend to get long (host-qualified)
9446 * device names. Thus we use the lock id in preference, and only if that isn't
9447 * available, do we try to pack the device name into an integer (flagged by
9448 * the sign bit (LOCKID_MASK) being set).
9450 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9451 * name and its encoded form, but it seems very unlikely that we will find
9452 * two files on different disks that share the same encoded device names,
9453 * and even more remote that they will share the same file id (if the test
9454 * is to check for the same file).
9456 * A better method might be to use sys$device_scan on the first call, and to
9457 * search for the device, returning an index into the cached array.
9458 * The number returned would be more intelligable.
9459 * This is probably not worth it, and anyway would take quite a bit longer
9460 * on the first call.
9462 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
9463 static mydev_t encode_dev (pTHX_ const char *dev)
9466 unsigned long int f;
9471 if (!dev || !dev[0]) return 0;
9475 struct dsc$descriptor_s dev_desc;
9476 unsigned long int status, lockid, item = DVI$_LOCKID;
9478 /* For cluster-mounted disks, the disk lock identifier is unique, so we
9479 can try that first. */
9480 dev_desc.dsc$w_length = strlen (dev);
9481 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
9482 dev_desc.dsc$b_class = DSC$K_CLASS_S;
9483 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
9484 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9485 if (lockid) return (lockid & ~LOCKID_MASK);
9489 /* Otherwise we try to encode the device name */
9493 for (q = dev + strlen(dev); q--; q >= dev) {
9496 else if (isalpha (toupper (*q)))
9497 c= toupper (*q) - 'A' + (char)10;
9499 continue; /* Skip '$'s */
9501 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
9503 enc += f * (unsigned long int) c;
9505 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
9507 } /* end of encode_dev() */
9510 static char namecache[NAM$C_MAXRSS+1];
9513 is_null_device(name)
9516 if (decc_bug_devnull != 0) {
9517 if (strcmp("/dev/null", name) == 0) /* temp hack */
9520 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9521 The underscore prefix, controller letter, and unit number are
9522 independently optional; for our purposes, the colon punctuation
9523 is not. The colon can be trailed by optional directory and/or
9524 filename, but two consecutive colons indicates a nodename rather
9525 than a device. [pr] */
9526 if (*name == '_') ++name;
9527 if (tolower(*name++) != 'n') return 0;
9528 if (tolower(*name++) != 'l') return 0;
9529 if (tolower(*name) == 'a') ++name;
9530 if (*name == '0') ++name;
9531 return (*name++ == ':') && (*name != ':');
9534 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
9535 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9536 * subset of the applicable information.
9539 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9541 char fname_phdev[NAM$C_MAXRSS+1];
9542 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9543 /* Namecache not workable with symbolic links, as symbolic links do
9544 * not have extensions and directories do in VMS mode. So in order
9545 * to test this, the did and ino_t must be used.
9547 * Fix-me - Hide the information in the new stat structure
9548 * Get rid of the namecache.
9550 if (decc_posix_compliant_pathnames == 0)
9552 if (statbufp == &PL_statcache)
9553 return cando_by_name(bit,effective,namecache);
9555 char fname[NAM$C_MAXRSS+1];
9556 unsigned long int retsts;
9557 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9558 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9560 /* If the struct mystat is stale, we're OOL; stat() overwrites the
9561 device name on successive calls */
9562 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9563 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9564 namdsc.dsc$a_pointer = fname;
9565 namdsc.dsc$w_length = sizeof fname - 1;
9567 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9568 &namdsc,&namdsc.dsc$w_length,0,0);
9570 fname[namdsc.dsc$w_length] = '\0';
9572 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9573 * but if someone has redefined that logical, Perl gets very lost. Since
9574 * we have the physical device name from the stat buffer, just paste it on.
9576 strcpy( fname_phdev, statbufp->st_devnam );
9577 strcat( fname_phdev, strrchr(fname, ':') );
9579 return cando_by_name(bit,effective,fname_phdev);
9581 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9582 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9586 return FALSE; /* Should never get to here */
9588 } /* end of cando() */
9592 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9594 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9596 static char usrname[L_cuserid];
9597 static struct dsc$descriptor_s usrdsc =
9598 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9599 char vmsname[NAM$C_MAXRSS+1], fileified[NAM$C_MAXRSS+1];
9600 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9601 unsigned short int retlen, trnlnm_iter_count;
9602 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9603 union prvdef curprv;
9604 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9605 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9606 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9607 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9609 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9611 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9613 if (!fname || !*fname) return FALSE;
9614 /* Make sure we expand logical names, since sys$check_access doesn't */
9615 if (!strpbrk(fname,"/]>:")) {
9616 strcpy(fileified,fname);
9617 trnlnm_iter_count = 0;
9618 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9619 trnlnm_iter_count++;
9620 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9624 if (!do_tovmsspec(fname,vmsname,1)) return FALSE;
9625 retlen = namdsc.dsc$w_length = strlen(vmsname);
9626 namdsc.dsc$a_pointer = vmsname;
9627 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9628 vmsname[retlen-1] == ':') {
9629 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9630 namdsc.dsc$w_length = strlen(fileified);
9631 namdsc.dsc$a_pointer = fileified;
9635 case S_IXUSR: case S_IXGRP: case S_IXOTH:
9636 access = ARM$M_EXECUTE; break;
9637 case S_IRUSR: case S_IRGRP: case S_IROTH:
9638 access = ARM$M_READ; break;
9639 case S_IWUSR: case S_IWGRP: case S_IWOTH:
9640 access = ARM$M_WRITE; break;
9641 case S_IDUSR: case S_IDGRP: case S_IDOTH:
9642 access = ARM$M_DELETE; break;
9647 /* Before we call $check_access, create a user profile with the current
9648 * process privs since otherwise it just uses the default privs from the
9649 * UAF and might give false positives or negatives. This only works on
9650 * VMS versions v6.0 and later since that's when sys$create_user_profile
9654 /* get current process privs and username */
9655 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9658 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9660 /* find out the space required for the profile */
9661 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9662 &usrprodsc.dsc$w_length,0));
9664 /* allocate space for the profile and get it filled in */
9665 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
9666 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
9667 &usrprodsc.dsc$w_length,0));
9669 /* use the profile to check access to the file; free profile & analyze results */
9670 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
9671 Safefree(usrprodsc.dsc$a_pointer);
9672 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
9676 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
9680 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
9681 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
9682 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
9683 set_vaxc_errno(retsts);
9684 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9685 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
9686 else set_errno(ENOENT);
9689 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
9694 return FALSE; /* Should never get here */
9696 } /* end of cando_by_name() */
9700 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
9702 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
9704 if (!fstat(fd,(stat_t *) statbufp)) {
9705 if (statbufp == (Stat_t *) &PL_statcache) {
9708 /* Save name for cando by name in VMS format */
9709 cptr = getname(fd, namecache, 1);
9711 /* This should not happen, but just in case */
9713 namecache[0] = '\0';
9715 #ifdef _USE_STD_STAT
9716 memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9718 memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9720 #ifndef _USE_STD_STAT
9721 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9722 statbufp->st_devnam[63] = 0;
9723 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9726 * The device is only encoded so that Perl_cando can use it to
9727 * look up ACLS. So rmsexpand it to the 255 character version
9728 * and store it in ->st_devnam. rmsexpand needs to be fixed
9729 * for long filenames and symbolic links first. This also seems
9730 * to remove the need for a namecache that could be stale.
9734 # ifdef RTL_USES_UTC
9737 statbufp->st_mtime = _toloc(statbufp->st_mtime);
9738 statbufp->st_atime = _toloc(statbufp->st_atime);
9739 statbufp->st_ctime = _toloc(statbufp->st_ctime);
9744 if (!VMSISH_TIME) { /* Return UTC instead of local time */
9748 statbufp->st_mtime = _toutc(statbufp->st_mtime);
9749 statbufp->st_atime = _toutc(statbufp->st_atime);
9750 statbufp->st_ctime = _toutc(statbufp->st_ctime);
9757 } /* end of flex_fstat() */
9760 #if !defined(__VAX) && __CRTL_VER >= 80200000
9768 #define lstat(_x, _y) stat(_x, _y)
9771 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
9774 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
9776 char fileified[NAM$C_MAXRSS+1];
9777 char temp_fspec[NAM$C_MAXRSS+300];
9779 int saved_errno, saved_vaxc_errno;
9781 if (!fspec) return retval;
9782 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
9783 strcpy(temp_fspec, fspec);
9784 if (statbufp == (Stat_t *) &PL_statcache)
9785 do_tovmsspec(temp_fspec,namecache,0);
9786 if (decc_bug_devnull != 0) {
9787 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
9788 memset(statbufp,0,sizeof *statbufp);
9789 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
9790 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
9791 statbufp->st_uid = 0x00010001;
9792 statbufp->st_gid = 0x0001;
9793 time((time_t *)&statbufp->st_mtime);
9794 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
9799 /* Try for a directory name first. If fspec contains a filename without
9800 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
9801 * and sea:[wine.dark]water. exist, we prefer the directory here.
9802 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
9803 * not sea:[wine.dark]., if the latter exists. If the intended target is
9804 * the file with null type, specify this by calling flex_stat() with
9805 * a '.' at the end of fspec.
9807 * If we are in Posix filespec mode, accept the filename as is.
9809 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9810 if (decc_posix_compliant_pathnames == 0) {
9812 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
9813 if (lstat_flag == 0)
9814 retval = stat(fileified,(stat_t *) statbufp);
9816 retval = lstat(fileified,(stat_t *) statbufp);
9817 if (!retval && statbufp == (Stat_t *) &PL_statcache)
9818 strcpy(namecache,fileified);
9821 if (lstat_flag == 0)
9822 retval = stat(temp_fspec,(stat_t *) statbufp);
9824 retval = lstat(temp_fspec,(stat_t *) statbufp);
9826 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9828 if (lstat_flag == 0)
9829 retval = stat(temp_fspec,(stat_t *) statbufp);
9831 retval = lstat(temp_fspec,(stat_t *) statbufp);
9835 #ifdef _USE_STD_STAT
9836 memcpy(&statbufp->st_ino, &statbufp->crtl_stat.st_ino, 8);
9838 memcpy(&statbufp->st_ino, statbufp->crtl_stat.st_ino, 8);
9840 #ifndef _USE_STD_STAT
9841 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
9842 statbufp->st_devnam[63] = 0;
9843 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
9846 * The device is only encoded so that Perl_cando can use it to
9847 * look up ACLS. So rmsexpand it to the 255 character version
9848 * and store it in ->st_devnam. rmsexpand needs to be fixed
9849 * for long filenames and symbolic links first. This also seems
9850 * to remove the need for a namecache that could be stale.
9853 # ifdef RTL_USES_UTC
9856 statbufp->st_mtime = _toloc(statbufp->st_mtime);
9857 statbufp->st_atime = _toloc(statbufp->st_atime);
9858 statbufp->st_ctime = _toloc(statbufp->st_ctime);
9863 if (!VMSISH_TIME) { /* Return UTC instead of local time */
9867 statbufp->st_mtime = _toutc(statbufp->st_mtime);
9868 statbufp->st_atime = _toutc(statbufp->st_atime);
9869 statbufp->st_ctime = _toutc(statbufp->st_ctime);
9873 /* If we were successful, leave errno where we found it */
9874 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
9877 } /* end of flex_stat_int() */
9880 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
9882 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
9884 return flex_stat_int(fspec, statbufp, 0);
9888 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
9890 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
9892 return flex_stat_int(fspec, statbufp, 1);
9897 /*{{{char *my_getlogin()*/
9898 /* VMS cuserid == Unix getlogin, except calling sequence */
9902 static char user[L_cuserid];
9903 return cuserid(user);
9908 /* rmscopy - copy a file using VMS RMS routines
9910 * Copies contents and attributes of spec_in to spec_out, except owner
9911 * and protection information. Name and type of spec_in are used as
9912 * defaults for spec_out. The third parameter specifies whether rmscopy()
9913 * should try to propagate timestamps from the input file to the output file.
9914 * If it is less than 0, no timestamps are preserved. If it is 0, then
9915 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
9916 * propagated to the output file at creation iff the output file specification
9917 * did not contain an explicit name or type, and the revision date is always
9918 * updated at the end of the copy operation. If it is greater than 0, then
9919 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
9920 * other than the revision date should be propagated, and bit 1 indicates
9921 * that the revision date should be propagated.
9923 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
9925 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
9926 * Incorporates, with permission, some code from EZCOPY by Tim Adye
9927 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
9928 * as part of the Perl standard distribution under the terms of the
9929 * GNU General Public License or the Perl Artistic License. Copies
9930 * of each may be found in the Perl standard distribution.
9932 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
9933 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
9935 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
9937 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
9938 rsa[NAM$C_MAXRSS], ubf[32256];
9939 unsigned long int i, sts, sts2;
9940 struct FAB fab_in, fab_out;
9941 struct RAB rab_in, rab_out;
9943 struct XABDAT xabdat;
9944 struct XABFHC xabfhc;
9945 struct XABRDT xabrdt;
9946 struct XABSUM xabsum;
9948 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
9949 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
9950 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9954 fab_in = cc$rms_fab;
9955 fab_in.fab$l_fna = vmsin;
9956 fab_in.fab$b_fns = strlen(vmsin);
9957 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
9958 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
9959 fab_in.fab$l_fop = FAB$M_SQO;
9960 fab_in.fab$l_nam = &nam;
9961 fab_in.fab$l_xab = (void *) &xabdat;
9964 nam.nam$l_rsa = rsa;
9965 nam.nam$b_rss = sizeof(rsa);
9966 nam.nam$l_esa = esa;
9967 nam.nam$b_ess = sizeof (esa);
9968 nam.nam$b_esl = nam.nam$b_rsl = 0;
9969 #ifdef NAM$M_NO_SHORT_UPCASE
9970 if (decc_efs_case_preserve)
9971 nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9974 xabdat = cc$rms_xabdat; /* To get creation date */
9975 xabdat.xab$l_nxt = (void *) &xabfhc;
9977 xabfhc = cc$rms_xabfhc; /* To get record length */
9978 xabfhc.xab$l_nxt = (void *) &xabsum;
9980 xabsum = cc$rms_xabsum; /* To get key and area information */
9982 if (!((sts = sys$open(&fab_in)) & 1)) {
9983 set_vaxc_errno(sts);
9985 case RMS$_FNF: case RMS$_DNF:
9986 set_errno(ENOENT); break;
9988 set_errno(ENOTDIR); break;
9990 set_errno(ENODEV); break;
9992 set_errno(EINVAL); break;
9994 set_errno(EACCES); break;
10002 fab_out.fab$w_ifi = 0;
10003 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10004 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10005 fab_out.fab$l_fop = FAB$M_SQO;
10006 fab_out.fab$l_fna = vmsout;
10007 fab_out.fab$b_fns = strlen(vmsout);
10008 fab_out.fab$l_dna = nam.nam$l_name;
10009 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10011 if (preserve_dates == 0) { /* Act like DCL COPY */
10012 nam.nam$b_nop |= NAM$M_SYNCHK;
10013 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10014 if (!((sts = sys$parse(&fab_out)) & 1)) {
10015 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10016 set_vaxc_errno(sts);
10019 fab_out.fab$l_xab = (void *) &xabdat;
10020 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10022 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
10023 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10024 preserve_dates =0; /* bitmask from this point forward */
10026 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10027 if (!((sts = sys$create(&fab_out)) & 1)) {
10028 set_vaxc_errno(sts);
10031 set_errno(ENOENT); break;
10033 set_errno(ENOTDIR); break;
10035 set_errno(ENODEV); break;
10037 set_errno(EINVAL); break;
10039 set_errno(EACCES); break;
10041 set_errno(EVMSERR);
10045 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10046 if (preserve_dates & 2) {
10047 /* sys$close() will process xabrdt, not xabdat */
10048 xabrdt = cc$rms_xabrdt;
10050 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10052 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10053 * is unsigned long[2], while DECC & VAXC use a struct */
10054 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10056 fab_out.fab$l_xab = (void *) &xabrdt;
10059 rab_in = cc$rms_rab;
10060 rab_in.rab$l_fab = &fab_in;
10061 rab_in.rab$l_rop = RAB$M_BIO;
10062 rab_in.rab$l_ubf = ubf;
10063 rab_in.rab$w_usz = sizeof ubf;
10064 if (!((sts = sys$connect(&rab_in)) & 1)) {
10065 sys$close(&fab_in); sys$close(&fab_out);
10066 set_errno(EVMSERR); set_vaxc_errno(sts);
10070 rab_out = cc$rms_rab;
10071 rab_out.rab$l_fab = &fab_out;
10072 rab_out.rab$l_rbf = ubf;
10073 if (!((sts = sys$connect(&rab_out)) & 1)) {
10074 sys$close(&fab_in); sys$close(&fab_out);
10075 set_errno(EVMSERR); set_vaxc_errno(sts);
10079 while ((sts = sys$read(&rab_in))) { /* always true */
10080 if (sts == RMS$_EOF) break;
10081 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10082 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10083 sys$close(&fab_in); sys$close(&fab_out);
10084 set_errno(EVMSERR); set_vaxc_errno(sts);
10089 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10090 sys$close(&fab_in); sys$close(&fab_out);
10091 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10093 set_errno(EVMSERR); set_vaxc_errno(sts);
10099 } /* end of rmscopy() */
10101 /* ODS-5 support version */
10103 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10105 char *vmsin, * vmsout, *esa, *esa_out,
10107 unsigned long int i, sts, sts2;
10108 struct FAB fab_in, fab_out;
10109 struct RAB rab_in, rab_out;
10111 struct NAML nam_out;
10112 struct XABDAT xabdat;
10113 struct XABFHC xabfhc;
10114 struct XABRDT xabrdt;
10115 struct XABSUM xabsum;
10117 Newx(vmsin, VMS_MAXRSS, char);
10118 Newx(vmsout, VMS_MAXRSS, char);
10119 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10120 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10123 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10127 Newx(esa, VMS_MAXRSS, char);
10129 fab_in = cc$rms_fab;
10130 fab_in.fab$l_fna = (char *) -1;
10131 fab_in.fab$b_fns = 0;
10132 nam.naml$l_long_filename = vmsin;
10133 nam.naml$l_long_filename_size = strlen(vmsin);
10134 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10135 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10136 fab_in.fab$l_fop = FAB$M_SQO;
10137 fab_in.fab$l_naml = &nam;
10138 fab_in.fab$l_xab = (void *) &xabdat;
10140 Newx(rsa, VMS_MAXRSS, char);
10141 nam.naml$l_rsa = NULL;
10142 nam.naml$b_rss = 0;
10143 nam.naml$l_long_result = rsa;
10144 nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10145 nam.naml$l_esa = NULL;
10146 nam.naml$b_ess = 0;
10147 nam.naml$l_long_expand = esa;
10148 nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10149 nam.naml$b_esl = nam.naml$b_rsl = 0;
10150 nam.naml$l_long_expand_size = 0;
10151 nam.naml$l_long_result_size = 0;
10152 #ifdef NAM$M_NO_SHORT_UPCASE
10153 if (decc_efs_case_preserve)
10154 nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10157 xabdat = cc$rms_xabdat; /* To get creation date */
10158 xabdat.xab$l_nxt = (void *) &xabfhc;
10160 xabfhc = cc$rms_xabfhc; /* To get record length */
10161 xabfhc.xab$l_nxt = (void *) &xabsum;
10163 xabsum = cc$rms_xabsum; /* To get key and area information */
10165 if (!((sts = sys$open(&fab_in)) & 1)) {
10170 set_vaxc_errno(sts);
10172 case RMS$_FNF: case RMS$_DNF:
10173 set_errno(ENOENT); break;
10175 set_errno(ENOTDIR); break;
10177 set_errno(ENODEV); break;
10179 set_errno(EINVAL); break;
10181 set_errno(EACCES); break;
10183 set_errno(EVMSERR);
10190 fab_out.fab$w_ifi = 0;
10191 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10192 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10193 fab_out.fab$l_fop = FAB$M_SQO;
10194 fab_out.fab$l_naml = &nam_out;
10195 fab_out.fab$l_fna = (char *) -1;
10196 fab_out.fab$b_fns = 0;
10197 nam_out.naml$l_long_filename = vmsout;
10198 nam_out.naml$l_long_filename_size = strlen(vmsout);
10199 fab_out.fab$l_dna = (char *) -1;
10200 fab_out.fab$b_dns = 0;
10201 nam_out.naml$l_long_defname = nam.naml$l_long_name;
10202 nam_out.naml$l_long_defname_size =
10203 nam.naml$l_long_name ?
10204 nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10206 Newx(esa_out, VMS_MAXRSS, char);
10207 nam_out.naml$l_rsa = NULL;
10208 nam_out.naml$b_rss = 0;
10209 nam_out.naml$l_long_result = NULL;
10210 nam_out.naml$l_long_result_alloc = 0;
10211 nam_out.naml$l_esa = NULL;
10212 nam_out.naml$b_ess = 0;
10213 nam_out.naml$l_long_expand = esa_out;
10214 nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10216 if (preserve_dates == 0) { /* Act like DCL COPY */
10217 nam_out.naml$b_nop |= NAM$M_SYNCHK;
10218 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10219 if (!((sts = sys$parse(&fab_out)) & 1)) {
10225 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10226 set_vaxc_errno(sts);
10229 fab_out.fab$l_xab = (void *) &xabdat;
10230 if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10232 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10233 preserve_dates =0; /* bitmask from this point forward */
10235 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10236 if (!((sts = sys$create(&fab_out)) & 1)) {
10242 set_vaxc_errno(sts);
10245 set_errno(ENOENT); break;
10247 set_errno(ENOTDIR); break;
10249 set_errno(ENODEV); break;
10251 set_errno(EINVAL); break;
10253 set_errno(EACCES); break;
10255 set_errno(EVMSERR);
10259 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10260 if (preserve_dates & 2) {
10261 /* sys$close() will process xabrdt, not xabdat */
10262 xabrdt = cc$rms_xabrdt;
10264 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10266 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10267 * is unsigned long[2], while DECC & VAXC use a struct */
10268 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10270 fab_out.fab$l_xab = (void *) &xabrdt;
10273 Newx(ubf, 32256, char);
10274 rab_in = cc$rms_rab;
10275 rab_in.rab$l_fab = &fab_in;
10276 rab_in.rab$l_rop = RAB$M_BIO;
10277 rab_in.rab$l_ubf = ubf;
10278 rab_in.rab$w_usz = 32256;
10279 if (!((sts = sys$connect(&rab_in)) & 1)) {
10280 sys$close(&fab_in); sys$close(&fab_out);
10287 set_errno(EVMSERR); set_vaxc_errno(sts);
10291 rab_out = cc$rms_rab;
10292 rab_out.rab$l_fab = &fab_out;
10293 rab_out.rab$l_rbf = ubf;
10294 if (!((sts = sys$connect(&rab_out)) & 1)) {
10295 sys$close(&fab_in); sys$close(&fab_out);
10302 set_errno(EVMSERR); set_vaxc_errno(sts);
10306 while ((sts = sys$read(&rab_in))) { /* always true */
10307 if (sts == RMS$_EOF) break;
10308 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10309 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10310 sys$close(&fab_in); sys$close(&fab_out);
10317 set_errno(EVMSERR); set_vaxc_errno(sts);
10323 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10324 sys$close(&fab_in); sys$close(&fab_out);
10325 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10333 set_errno(EVMSERR); set_vaxc_errno(sts);
10345 } /* end of rmscopy() */
10350 /*** The following glue provides 'hooks' to make some of the routines
10351 * from this file available from Perl. These routines are sufficiently
10352 * basic, and are required sufficiently early in the build process,
10353 * that's it's nice to have them available to miniperl as well as the
10354 * full Perl, so they're set up here instead of in an extension. The
10355 * Perl code which handles importation of these names into a given
10356 * package lives in [.VMS]Filespec.pm in @INC.
10360 rmsexpand_fromperl(pTHX_ CV *cv)
10363 char *fspec, *defspec = NULL, *rslt;
10366 if (!items || items > 2)
10367 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10368 fspec = SvPV(ST(0),n_a);
10369 if (!fspec || !*fspec) XSRETURN_UNDEF;
10370 if (items == 2) defspec = SvPV(ST(1),n_a);
10372 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10373 ST(0) = sv_newmortal();
10374 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10379 vmsify_fromperl(pTHX_ CV *cv)
10385 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10386 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10387 ST(0) = sv_newmortal();
10388 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10393 unixify_fromperl(pTHX_ CV *cv)
10399 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10400 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10401 ST(0) = sv_newmortal();
10402 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10407 fileify_fromperl(pTHX_ CV *cv)
10413 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10414 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10415 ST(0) = sv_newmortal();
10416 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10421 pathify_fromperl(pTHX_ CV *cv)
10427 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10428 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10429 ST(0) = sv_newmortal();
10430 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10435 vmspath_fromperl(pTHX_ CV *cv)
10441 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10442 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10443 ST(0) = sv_newmortal();
10444 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10449 unixpath_fromperl(pTHX_ CV *cv)
10455 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10456 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10457 ST(0) = sv_newmortal();
10458 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10463 candelete_fromperl(pTHX_ CV *cv)
10466 char fspec[NAM$C_MAXRSS+1], *fsp;
10471 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10473 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10474 if (SvTYPE(mysv) == SVt_PVGV) {
10475 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10476 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10483 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10484 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10490 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10495 rmscopy_fromperl(pTHX_ CV *cv)
10498 char *inspec, *outspec, *inp, *outp;
10500 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10501 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10502 unsigned long int sts;
10507 if (items < 2 || items > 3)
10508 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10510 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10511 Newx(inspec, VMS_MAXRSS, char);
10512 if (SvTYPE(mysv) == SVt_PVGV) {
10513 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10514 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10522 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10523 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10529 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10530 Newx(outspec, VMS_MAXRSS, char);
10531 if (SvTYPE(mysv) == SVt_PVGV) {
10532 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10533 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10542 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10543 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10550 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10552 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10558 /* The mod2fname is limited to shorter filenames by design, so it should
10559 * not be modified to support longer EFS pathnames
10562 mod2fname(pTHX_ CV *cv)
10565 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10566 workbuff[NAM$C_MAXRSS*1 + 1];
10567 int total_namelen = 3, counter, num_entries;
10568 /* ODS-5 ups this, but we want to be consistent, so... */
10569 int max_name_len = 39;
10570 AV *in_array = (AV *)SvRV(ST(0));
10572 num_entries = av_len(in_array);
10574 /* All the names start with PL_. */
10575 strcpy(ultimate_name, "PL_");
10577 /* Clean up our working buffer */
10578 Zero(work_name, sizeof(work_name), char);
10580 /* Run through the entries and build up a working name */
10581 for(counter = 0; counter <= num_entries; counter++) {
10582 /* If it's not the first name then tack on a __ */
10584 strcat(work_name, "__");
10586 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10590 /* Check to see if we actually have to bother...*/
10591 if (strlen(work_name) + 3 <= max_name_len) {
10592 strcat(ultimate_name, work_name);
10594 /* It's too darned big, so we need to go strip. We use the same */
10595 /* algorithm as xsubpp does. First, strip out doubled __ */
10596 char *source, *dest, last;
10599 for (source = work_name; *source; source++) {
10600 if (last == *source && last == '_') {
10606 /* Go put it back */
10607 strcpy(work_name, workbuff);
10608 /* Is it still too big? */
10609 if (strlen(work_name) + 3 > max_name_len) {
10610 /* Strip duplicate letters */
10613 for (source = work_name; *source; source++) {
10614 if (last == toupper(*source)) {
10618 last = toupper(*source);
10620 strcpy(work_name, workbuff);
10623 /* Is it *still* too big? */
10624 if (strlen(work_name) + 3 > max_name_len) {
10625 /* Too bad, we truncate */
10626 work_name[max_name_len - 2] = 0;
10628 strcat(ultimate_name, work_name);
10631 /* Okay, return it */
10632 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10637 hushexit_fromperl(pTHX_ CV *cv)
10642 VMSISH_HUSHED = SvTRUE(ST(0));
10644 ST(0) = boolSV(VMSISH_HUSHED);
10650 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10653 vms_realpath_fromperl(pTHX_ CV *cv)
10656 char *fspec, *rslt_spec, *rslt;
10659 if (!items || items != 1)
10660 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
10662 fspec = SvPV(ST(0),n_a);
10663 if (!fspec || !*fspec) XSRETURN_UNDEF;
10665 Newx(rslt_spec, VMS_MAXRSS + 1, char);
10666 rslt = do_vms_realpath(fspec, rslt_spec);
10667 ST(0) = sv_newmortal();
10669 sv_usepvn(ST(0),rslt,strlen(rslt));
10671 Safefree(rslt_spec);
10676 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10677 int do_vms_case_tolerant(void);
10680 vms_case_tolerant_fromperl(pTHX_ CV *cv)
10683 ST(0) = boolSV(do_vms_case_tolerant());
10689 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
10690 struct interp_intern *dst)
10692 memcpy(dst,src,sizeof(struct interp_intern));
10696 Perl_sys_intern_clear(pTHX)
10701 Perl_sys_intern_init(pTHX)
10703 unsigned int ix = RAND_MAX;
10708 /* fix me later to track running under GNV */
10709 /* this allows some limited testing */
10710 MY_POSIX_EXIT = decc_filename_unix_report;
10713 MY_INV_RAND_MAX = 1./x;
10717 init_os_extras(void)
10720 char* file = __FILE__;
10721 char temp_buff[512];
10722 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
10723 no_translate_barewords = TRUE;
10725 no_translate_barewords = FALSE;
10728 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
10729 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
10730 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
10731 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
10732 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
10733 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
10734 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
10735 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
10736 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
10737 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
10738 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
10740 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
10742 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10743 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
10746 store_pipelocs(aTHX); /* will redo any earlier attempts */
10753 #if __CRTL_VER == 80200000
10754 /* This missed getting in to the DECC SDK for 8.2 */
10755 char *realpath(const char *file_name, char * resolved_name, ...);
10758 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
10759 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
10760 * The perl fallback routine to provide realpath() is not as efficient
10764 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10766 return realpath(filespec, outbuf);
10770 /* External entry points */
10771 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10772 { return do_vms_realpath(filespec, outbuf); }
10774 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
10779 #if __CRTL_VER >= 70301000 && !defined(__VAX)
10780 /* case_tolerant */
10782 /*{{{int do_vms_case_tolerant(void)*/
10783 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
10784 * controlled by a process setting.
10786 int do_vms_case_tolerant(void)
10788 return vms_process_case_tolerant;
10791 /* External entry points */
10792 int Perl_vms_case_tolerant(void)
10793 { return do_vms_case_tolerant(); }
10795 int Perl_vms_case_tolerant(void)
10796 { return vms_process_case_tolerant; }
10800 /* Start of DECC RTL Feature handling */
10802 static int sys_trnlnm
10803 (const char * logname,
10807 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
10808 const unsigned long attr = LNM$M_CASE_BLIND;
10809 struct dsc$descriptor_s name_dsc;
10811 unsigned short result;
10812 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
10815 name_dsc.dsc$w_length = strlen(logname);
10816 name_dsc.dsc$a_pointer = (char *)logname;
10817 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10818 name_dsc.dsc$b_class = DSC$K_CLASS_S;
10820 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
10822 if ($VMS_STATUS_SUCCESS(status)) {
10824 /* Null terminate and return the string */
10825 /*--------------------------------------*/
10832 static int sys_crelnm
10833 (const char * logname,
10834 const char * value)
10837 const char * proc_table = "LNM$PROCESS_TABLE";
10838 struct dsc$descriptor_s proc_table_dsc;
10839 struct dsc$descriptor_s logname_dsc;
10840 struct itmlst_3 item_list[2];
10842 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
10843 proc_table_dsc.dsc$w_length = strlen(proc_table);
10844 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10845 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
10847 logname_dsc.dsc$a_pointer = (char *) logname;
10848 logname_dsc.dsc$w_length = strlen(logname);
10849 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
10850 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
10852 item_list[0].buflen = strlen(value);
10853 item_list[0].itmcode = LNM$_STRING;
10854 item_list[0].bufadr = (char *)value;
10855 item_list[0].retlen = NULL;
10857 item_list[1].buflen = 0;
10858 item_list[1].itmcode = 0;
10860 ret_val = sys$crelnm
10862 (const struct dsc$descriptor_s *)&proc_table_dsc,
10863 (const struct dsc$descriptor_s *)&logname_dsc,
10865 (const struct item_list_3 *) item_list);
10871 /* C RTL Feature settings */
10873 static int set_features
10874 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
10875 int (* cli_routine)(void), /* Not documented */
10876 void *image_info) /* Not documented */
10883 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
10884 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
10885 unsigned long case_perm;
10886 unsigned long case_image;
10888 /* hacks to see if known bugs are still present for testing */
10890 /* Readdir is returning filenames in VMS syntax always */
10891 decc_bug_readdir_efs1 = 1;
10892 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
10893 if ($VMS_STATUS_SUCCESS(status)) {
10894 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10895 decc_bug_readdir_efs1 = 1;
10897 decc_bug_readdir_efs1 = 0;
10900 /* PCP mode requires creating /dev/null special device file */
10901 decc_bug_devnull = 0;
10902 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
10903 if ($VMS_STATUS_SUCCESS(status)) {
10904 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10905 decc_bug_devnull = 1;
10908 /* fgetname returning a VMS name in UNIX mode */
10909 decc_bug_fgetname = 1;
10910 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
10911 if ($VMS_STATUS_SUCCESS(status)) {
10912 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10913 decc_bug_fgetname = 1;
10915 decc_bug_fgetname = 0;
10918 /* UNIX directory names with no paths are broken in a lot of places */
10919 decc_dir_barename = 1;
10920 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
10921 if ($VMS_STATUS_SUCCESS(status)) {
10922 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
10923 decc_dir_barename = 1;
10925 decc_dir_barename = 0;
10928 #if __CRTL_VER >= 70300000 && !defined(__VAX)
10929 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
10931 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
10932 if (decc_disable_to_vms_logname_translation < 0)
10933 decc_disable_to_vms_logname_translation = 0;
10936 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
10938 decc_efs_case_preserve = decc$feature_get_value(s, 1);
10939 if (decc_efs_case_preserve < 0)
10940 decc_efs_case_preserve = 0;
10943 s = decc$feature_get_index("DECC$EFS_CHARSET");
10945 decc_efs_charset = decc$feature_get_value(s, 1);
10946 if (decc_efs_charset < 0)
10947 decc_efs_charset = 0;
10950 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
10952 decc_filename_unix_report = decc$feature_get_value(s, 1);
10953 if (decc_filename_unix_report > 0)
10954 decc_filename_unix_report = 1;
10956 decc_filename_unix_report = 0;
10959 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
10961 decc_filename_unix_only = decc$feature_get_value(s, 1);
10962 if (decc_filename_unix_only > 0) {
10963 decc_filename_unix_only = 1;
10966 decc_filename_unix_only = 0;
10970 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
10972 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
10973 if (decc_filename_unix_no_version < 0)
10974 decc_filename_unix_no_version = 0;
10977 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
10979 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
10980 if (decc_readdir_dropdotnotype < 0)
10981 decc_readdir_dropdotnotype = 0;
10984 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
10985 if ($VMS_STATUS_SUCCESS(status)) {
10986 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
10988 dflt = decc$feature_get_value(s, 4);
10990 decc_disable_posix_root = decc$feature_get_value(s, 1);
10991 if (decc_disable_posix_root <= 0) {
10992 decc$feature_set_value(s, 1, 1);
10993 decc_disable_posix_root = 1;
10997 /* Traditionally Perl assumes this is off */
10998 decc_disable_posix_root = 1;
10999 decc$feature_set_value(s, 1, 1);
11004 #if __CRTL_VER >= 80200000
11005 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11007 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11008 if (decc_posix_compliant_pathnames < 0)
11009 decc_posix_compliant_pathnames = 0;
11010 if (decc_posix_compliant_pathnames > 4)
11011 decc_posix_compliant_pathnames = 0;
11016 status = sys_trnlnm
11017 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11018 if ($VMS_STATUS_SUCCESS(status)) {
11019 val_str[0] = _toupper(val_str[0]);
11020 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11021 decc_disable_to_vms_logname_translation = 1;
11026 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11027 if ($VMS_STATUS_SUCCESS(status)) {
11028 val_str[0] = _toupper(val_str[0]);
11029 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11030 decc_efs_case_preserve = 1;
11035 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11036 if ($VMS_STATUS_SUCCESS(status)) {
11037 val_str[0] = _toupper(val_str[0]);
11038 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11039 decc_filename_unix_report = 1;
11042 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11043 if ($VMS_STATUS_SUCCESS(status)) {
11044 val_str[0] = _toupper(val_str[0]);
11045 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11046 decc_filename_unix_only = 1;
11047 decc_filename_unix_report = 1;
11050 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11051 if ($VMS_STATUS_SUCCESS(status)) {
11052 val_str[0] = _toupper(val_str[0]);
11053 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11054 decc_filename_unix_no_version = 1;
11057 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11058 if ($VMS_STATUS_SUCCESS(status)) {
11059 val_str[0] = _toupper(val_str[0]);
11060 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11061 decc_readdir_dropdotnotype = 1;
11068 /* Report true case tolerance */
11069 /*----------------------------*/
11070 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11071 if (!$VMS_STATUS_SUCCESS(status))
11072 case_perm = PPROP$K_CASE_BLIND;
11073 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11074 if (!$VMS_STATUS_SUCCESS(status))
11075 case_image = PPROP$K_CASE_BLIND;
11076 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11077 (case_image == PPROP$K_CASE_SENSITIVE))
11078 vms_process_case_tolerant = 0;
11083 /* CRTL can be initialized past this point, but not before. */
11084 /* DECC$CRTL_INIT(); */
11090 /* DECC dependent attributes */
11091 #if __DECC_VER < 60560002
11093 #define not_executable
11095 #define relative ,rel
11096 #define not_executable ,noexe
11099 #pragma extern_model save
11100 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11102 const __align (LONGWORD) int spare[8] = {0};
11103 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11106 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11107 nowrt,noshr relative not_executable
11109 const long vms_cc_features = (const long)set_features;
11112 ** Force a reference to LIB$INITIALIZE to ensure it
11113 ** exists in the image.
11115 int lib$initialize(void);
11117 #pragma extern_model strict_refdef
11119 int lib_init_ref = (int) lib$initialize;
11122 #pragma extern_model restore