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>
51 /* Set the maximum filespec size here as it is larger for EFS file
53 * Not fully implemented at this time because the larger size
54 * will likely impact the stack local storage requirements of
55 * threaded code, and probably cause hard to diagnose failures.
56 * To implement the larger sizes, all places where filename
57 * storage is put on the stack need to be changed to use
58 * New()/SafeFree() instead.
63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
64 #ifndef VMS_LONGNAME_SUPPORT
65 #define VMS_LONGNAME_SUPPORT 1
66 #endif /* VMS_LONGNAME_SUPPORT */
67 #endif /* NAML$C_MAXRSS */
68 #endif /* VMS_MAXRSS */
71 /* temporary hack until support is complete */
72 #ifdef VMS_LONGNAME_SUPPORT
73 #undef VMS_LONGNAME_SUPPORT
76 /* end of temporary hack until support is complete */
79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
82 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
83 int decc$feature_get_index(const char *name);
84 char* decc$feature_get_name(int index);
85 int decc$feature_get_value(int index, int mode);
86 int decc$feature_set_value(int index, int mode, int value);
91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
93 static int set_feature_default(const char *name, int value)
98 index = decc$feature_get_index(name);
100 status = decc$feature_set_value(index, 1, value);
101 if (index == -1 || (status == -1)) {
105 status = decc$feature_get_value(index, 1);
106 if (status != value) {
114 /* Older versions of ssdef.h don't have these */
115 #ifndef SS$_INVFILFOROP
116 # define SS$_INVFILFOROP 3930
118 #ifndef SS$_NOSUCHOBJECT
119 # define SS$_NOSUCHOBJECT 2696
122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
123 #define PERLIO_NOT_STDIO 0
125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
126 * code below needs to get to the underlying CRTL routines. */
127 #define DONT_MASK_RTL_CALLS
131 /* Anticipating future expansion in lexical warnings . . . */
132 #ifndef WARN_INTERNAL
133 # define WARN_INTERNAL WARN_MISC
136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
137 # define RTL_USES_UTC 1
141 /* gcc's header files don't #define direct access macros
142 * corresponding to VAXC's variant structs */
144 # define uic$v_format uic$r_uic_form.uic$v_format
145 # define uic$v_group uic$r_uic_form.uic$v_group
146 # define uic$v_member uic$r_uic_form.uic$v_member
147 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
148 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
149 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
150 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
153 #if defined(NEED_AN_H_ERRNO)
158 #pragma message disable pragma
159 #pragma member_alignment save
160 #pragma nomember_alignment longword
162 #pragma message disable misalgndmem
165 unsigned short int buflen;
166 unsigned short int itmcode;
168 unsigned short int *retlen;
171 struct filescan_itmlst_2 {
172 unsigned short length;
173 unsigned short itmcode;
178 #pragma message restore
179 #pragma member_alignment restore
182 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
183 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
184 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
185 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
186 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
187 #define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
188 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
189 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
190 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
191 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
192 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
194 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
195 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
196 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
197 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
199 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
200 #define PERL_LNM_MAX_ALLOWED_INDEX 127
202 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
203 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
206 #define PERL_LNM_MAX_ITER 10
208 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
209 #if __CRTL_VER >= 70302000 && !defined(__VAX)
210 #define MAX_DCL_SYMBOL (8192)
211 #define MAX_DCL_LINE_LENGTH (4096 - 4)
213 #define MAX_DCL_SYMBOL (1024)
214 #define MAX_DCL_LINE_LENGTH (1024 - 4)
217 static char *__mystrtolower(char *str)
219 if (str) for (; *str; ++str) *str= tolower(*str);
223 static struct dsc$descriptor_s fildevdsc =
224 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
225 static struct dsc$descriptor_s crtlenvdsc =
226 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
227 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
228 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
229 static struct dsc$descriptor_s **env_tables = defenv;
230 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
232 /* True if we shouldn't treat barewords as logicals during directory */
234 static int no_translate_barewords;
237 static int tz_updated = 1;
240 /* DECC Features that may need to affect how Perl interprets
241 * displays filename information
243 static int decc_disable_to_vms_logname_translation = 1;
244 static int decc_disable_posix_root = 1;
245 int decc_efs_case_preserve = 0;
246 static int decc_efs_charset = 0;
247 static int decc_filename_unix_no_version = 0;
248 static int decc_filename_unix_only = 0;
249 int decc_filename_unix_report = 0;
250 int decc_posix_compliant_pathnames = 0;
251 int decc_readdir_dropdotnotype = 0;
252 static int vms_process_case_tolerant = 1;
254 /* bug workarounds if needed */
255 int decc_bug_readdir_efs1 = 0;
256 int decc_bug_devnull = 1;
257 int decc_bug_fgetname = 0;
258 int decc_dir_barename = 0;
260 static int vms_debug_on_exception = 0;
262 /* Is this a UNIX file specification?
263 * No longer a simple check with EFS file specs
264 * For now, not a full check, but need to
265 * handle POSIX ^UP^ specifications
266 * Fixing to handle ^/ cases would require
267 * changes to many other conversion routines.
270 static int is_unix_filespec(const char *path)
276 if (strncmp(path,"\"^UP^",5) != 0) {
277 pch1 = strchr(path, '/');
282 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
283 if (decc_filename_unix_report || decc_filename_unix_only) {
284 if (strcmp(path,".") == 0)
292 /* This handles the expansion of a '^' prefix to the proper character
293 * in a UNIX file specification.
295 * The output count variable contains the number of characters added
296 * to the output string.
298 * The return value is the number of characters read from the input
301 static int copy_expand_vms_filename_escape
302 (char *outspec, const char *inspec, int *output_cnt)
309 if (*inspec == '^') {
313 /* Non trailing dots should just be passed through */
318 case '_': /* space */
324 case 'U': /* Unicode */
327 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
329 scnt = sscanf(inspec, "%2x%2x", outspec, &outspec[1]);
336 /* Error - do best we can to continue */
346 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
349 scnt = sscanf(inspec, "%2x", outspec);
372 (const struct dsc$descriptor_s * srcstr,
373 struct filescan_itmlst_2 * valuelist,
374 unsigned long * fldflags,
375 struct dsc$descriptor_s *auxout,
376 unsigned short * retlen);
378 /* vms_split_path - Verify that the input file specification is a
379 * VMS format file specification, and provide pointers to the components of
380 * it. With EFS format filenames, this is virtually the only way to
381 * parse a VMS path specification into components.
383 * If the sum of the components do not add up to the length of the
384 * string, then the passed file specification is probably a UNIX style
387 static int vms_split_path
389 const char ** volume,
399 const char ** version,
402 struct dsc$descriptor path_desc;
406 struct filescan_itmlst_2 item_list[9];
407 const int filespec = 0;
408 const int nodespec = 1;
409 const int devspec = 2;
410 const int rootspec = 3;
411 const int dirspec = 4;
412 const int namespec = 5;
413 const int typespec = 6;
414 const int verspec = 7;
416 /* Assume the worst for an easy exit */
431 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
432 path_desc.dsc$w_length = strlen(path);
433 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
434 path_desc.dsc$b_class = DSC$K_CLASS_S;
436 /* Get the total length, if it is shorter than the string passed
437 * then this was probably not a VMS formatted file specification
439 item_list[filespec].itmcode = FSCN$_FILESPEC;
440 item_list[filespec].length = 0;
441 item_list[filespec].component = NULL;
443 /* If the node is present, then it gets considered as part of the
444 * volume name to hopefully make things simple.
446 item_list[nodespec].itmcode = FSCN$_NODE;
447 item_list[nodespec].length = 0;
448 item_list[nodespec].component = NULL;
450 item_list[devspec].itmcode = FSCN$_DEVICE;
451 item_list[devspec].length = 0;
452 item_list[devspec].component = NULL;
454 /* root is a special case, adding it to either the directory or
455 * the device components will probalby complicate things for the
456 * callers of this routine, so leave it separate.
458 item_list[rootspec].itmcode = FSCN$_ROOT;
459 item_list[rootspec].length = 0;
460 item_list[rootspec].component = NULL;
462 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
463 item_list[dirspec].length = 0;
464 item_list[dirspec].component = NULL;
466 item_list[namespec].itmcode = FSCN$_NAME;
467 item_list[namespec].length = 0;
468 item_list[namespec].component = NULL;
470 item_list[typespec].itmcode = FSCN$_TYPE;
471 item_list[typespec].length = 0;
472 item_list[typespec].component = NULL;
474 item_list[verspec].itmcode = FSCN$_VERSION;
475 item_list[verspec].length = 0;
476 item_list[verspec].component = NULL;
478 item_list[8].itmcode = 0;
479 item_list[8].length = 0;
480 item_list[8].component = NULL;
482 status = SYS$FILESCAN
483 ((const struct dsc$descriptor_s *)&path_desc, item_list,
485 _ckvmssts(status); /* All failure status values indicate a coding error */
487 /* If we parsed it successfully these two lengths should be the same */
488 if (path_desc.dsc$w_length != item_list[filespec].length)
491 /* If we got here, then it is a VMS file specification */
494 /* set the volume name */
495 if (item_list[nodespec].length > 0) {
496 *volume = item_list[nodespec].component;
497 *vol_len = item_list[nodespec].length + item_list[devspec].length;
500 *volume = item_list[devspec].component;
501 *vol_len = item_list[devspec].length;
504 *root = item_list[rootspec].component;
505 *root_len = item_list[rootspec].length;
507 *dir = item_list[dirspec].component;
508 *dir_len = item_list[dirspec].length;
510 /* Now fun with versions and EFS file specifications
511 * The parser can not tell the difference when a "." is a version
512 * delimiter or a part of the file specification.
514 if ((decc_efs_charset) &&
515 (item_list[verspec].length > 0) &&
516 (item_list[verspec].component[0] == '.')) {
517 *name = item_list[namespec].component;
518 *name_len = item_list[namespec].length + item_list[typespec].length;
519 *ext = item_list[verspec].component;
520 *ext_len = item_list[verspec].length;
525 *name = item_list[namespec].component;
526 *name_len = item_list[namespec].length;
527 *ext = item_list[typespec].component;
528 *ext_len = item_list[typespec].length;
529 *version = item_list[verspec].component;
530 *ver_len = item_list[verspec].length;
537 * Routine to retrieve the maximum equivalence index for an input
538 * logical name. Some calls to this routine have no knowledge if
539 * the variable is a logical or not. So on error we return a max
542 /*{{{int my_maxidx(const char *lnm) */
544 my_maxidx(const char *lnm)
548 int attr = LNM$M_CASE_BLIND;
549 struct dsc$descriptor lnmdsc;
550 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
553 lnmdsc.dsc$w_length = strlen(lnm);
554 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
555 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
556 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
558 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
559 if ((status & 1) == 0)
566 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
568 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
569 struct dsc$descriptor_s **tabvec, unsigned long int flags)
572 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
573 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
574 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
576 unsigned char acmode;
577 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
578 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
579 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
580 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
582 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
583 #if defined(PERL_IMPLICIT_CONTEXT)
586 aTHX = PERL_GET_INTERP;
592 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
593 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
595 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
596 *cp2 = _toupper(*cp1);
597 if (cp1 - lnm > LNM$C_NAMLENGTH) {
598 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
602 lnmdsc.dsc$w_length = cp1 - lnm;
603 lnmdsc.dsc$a_pointer = uplnm;
604 uplnm[lnmdsc.dsc$w_length] = '\0';
605 secure = flags & PERL__TRNENV_SECURE;
606 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
607 if (!tabvec || !*tabvec) tabvec = env_tables;
609 for (curtab = 0; tabvec[curtab]; curtab++) {
610 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
611 if (!ivenv && !secure) {
616 Perl_warn(aTHX_ "Can't read CRTL environ\n");
619 retsts = SS$_NOLOGNAM;
620 for (i = 0; environ[i]; i++) {
621 if ((eq = strchr(environ[i],'=')) &&
622 lnmdsc.dsc$w_length == (eq - environ[i]) &&
623 !strncmp(environ[i],uplnm,eq - environ[i])) {
625 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
626 if (!eqvlen) continue;
631 if (retsts != SS$_NOLOGNAM) break;
634 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
635 !str$case_blind_compare(&tmpdsc,&clisym)) {
636 if (!ivsym && !secure) {
637 unsigned short int deflen = LNM$C_NAMLENGTH;
638 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
639 /* dynamic dsc to accomodate possible long value */
640 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
641 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
643 if (eqvlen > MAX_DCL_SYMBOL) {
644 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
645 eqvlen = MAX_DCL_SYMBOL;
646 /* Special hack--we might be called before the interpreter's */
647 /* fully initialized, in which case either thr or PL_curcop */
648 /* might be bogus. We have to check, since ckWARN needs them */
649 /* both to be valid if running threaded */
650 if (ckWARN(WARN_MISC)) {
651 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
654 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
656 _ckvmssts(lib$sfree1_dd(&eqvdsc));
657 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
658 if (retsts == LIB$_NOSUCHSYM) continue;
663 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
664 midx = my_maxidx(lnm);
665 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
666 lnmlst[1].bufadr = cp2;
668 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
669 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
670 if (retsts == SS$_NOLOGNAM) break;
671 /* PPFs have a prefix */
674 *((int *)uplnm) == *((int *)"SYS$") &&
676 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
677 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
678 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
679 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
680 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
681 memmove(eqv,eqv+4,eqvlen-4);
687 if ((retsts == SS$_IVLOGNAM) ||
688 (retsts == SS$_NOLOGNAM)) { continue; }
691 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
692 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
693 if (retsts == SS$_NOLOGNAM) continue;
696 eqvlen = strlen(eqv);
700 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
701 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
702 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
703 retsts == SS$_NOLOGNAM) {
704 set_errno(EINVAL); set_vaxc_errno(retsts);
706 else _ckvmssts(retsts);
708 } /* end of vmstrnenv */
711 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
712 /* Define as a function so we can access statics. */
713 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
715 return vmstrnenv(lnm,eqv,idx,fildev,
716 #ifdef SECURE_INTERNAL_GETENV
717 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
726 * Note: Uses Perl temp to store result so char * can be returned to
727 * caller; this pointer will be invalidated at next Perl statement
729 * We define this as a function rather than a macro in terms of my_getenv_len()
730 * so that it'll work when PL_curinterp is undefined (and we therefore can't
733 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
735 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
738 static char *__my_getenv_eqv = NULL;
739 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
740 unsigned long int idx = 0;
741 int trnsuccess, success, secure, saverr, savvmserr;
745 midx = my_maxidx(lnm) + 1;
747 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
748 /* Set up a temporary buffer for the return value; Perl will
749 * clean it up at the next statement transition */
750 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
751 if (!tmpsv) return NULL;
755 /* Assume no interpreter ==> single thread */
756 if (__my_getenv_eqv != NULL) {
757 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
760 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
762 eqv = __my_getenv_eqv;
765 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
766 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
768 getcwd(eqv,LNM$C_NAMLENGTH);
772 /* Get rid of "000000/ in rooted filespecs */
775 zeros = strstr(eqv, "/000000/");
778 mlen = len - (zeros - eqv) - 7;
779 memmove(zeros, &zeros[7], mlen);
787 /* Impose security constraints only if tainting */
789 /* Impose security constraints only if tainting */
790 secure = PL_curinterp ? PL_tainting : will_taint;
791 saverr = errno; savvmserr = vaxc$errno;
798 #ifdef SECURE_INTERNAL_GETENV
799 secure ? PERL__TRNENV_SECURE : 0
805 /* For the getenv interface we combine all the equivalence names
806 * of a search list logical into one value to acquire a maximum
807 * value length of 255*128 (assuming %ENV is using logicals).
809 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
811 /* If the name contains a semicolon-delimited index, parse it
812 * off and make sure we only retrieve the equivalence name for
814 if ((cp2 = strchr(lnm,';')) != NULL) {
816 uplnm[cp2-lnm] = '\0';
817 idx = strtoul(cp2+1,NULL,0);
819 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
822 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
824 /* Discard NOLOGNAM on internal calls since we're often looking
825 * for an optional name, and this "error" often shows up as the
826 * (bogus) exit status for a die() call later on. */
827 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
828 return success ? eqv : Nullch;
831 } /* end of my_getenv() */
835 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
837 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
841 unsigned long idx = 0;
843 static char *__my_getenv_len_eqv = NULL;
844 int secure, saverr, savvmserr;
847 midx = my_maxidx(lnm) + 1;
849 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
850 /* Set up a temporary buffer for the return value; Perl will
851 * clean it up at the next statement transition */
852 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
853 if (!tmpsv) return NULL;
857 /* Assume no interpreter ==> single thread */
858 if (__my_getenv_len_eqv != NULL) {
859 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
862 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
864 buf = __my_getenv_len_eqv;
867 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
868 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
871 getcwd(buf,LNM$C_NAMLENGTH);
874 /* Get rid of "000000/ in rooted filespecs */
876 zeros = strstr(buf, "/000000/");
879 mlen = *len - (zeros - buf) - 7;
880 memmove(zeros, &zeros[7], mlen);
889 /* Impose security constraints only if tainting */
890 secure = PL_curinterp ? PL_tainting : will_taint;
891 saverr = errno; savvmserr = vaxc$errno;
898 #ifdef SECURE_INTERNAL_GETENV
899 secure ? PERL__TRNENV_SECURE : 0
905 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
907 if ((cp2 = strchr(lnm,';')) != NULL) {
910 idx = strtoul(cp2+1,NULL,0);
912 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
915 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
917 /* Get rid of "000000/ in rooted filespecs */
920 zeros = strstr(buf, "/000000/");
923 mlen = *len - (zeros - buf) - 7;
924 memmove(zeros, &zeros[7], mlen);
930 /* Discard NOLOGNAM on internal calls since we're often looking
931 * for an optional name, and this "error" often shows up as the
932 * (bogus) exit status for a die() call later on. */
933 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
934 return *len ? buf : Nullch;
937 } /* end of my_getenv_len() */
940 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
942 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
944 /*{{{ void prime_env_iter() */
947 /* Fill the %ENV associative array with all logical names we can
948 * find, in preparation for iterating over it.
951 static int primed = 0;
952 HV *seenhv = NULL, *envhv;
954 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
955 unsigned short int chan;
956 #ifndef CLI$M_TRUSTED
957 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
959 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
960 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
962 bool have_sym = FALSE, have_lnm = FALSE;
963 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
964 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
965 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
966 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
967 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
968 #if defined(PERL_IMPLICIT_CONTEXT)
971 #if defined(USE_ITHREADS)
972 static perl_mutex primenv_mutex;
973 MUTEX_INIT(&primenv_mutex);
976 #if defined(PERL_IMPLICIT_CONTEXT)
977 /* We jump through these hoops because we can be called at */
978 /* platform-specific initialization time, which is before anything is */
979 /* set up--we can't even do a plain dTHX since that relies on the */
980 /* interpreter structure to be initialized */
982 aTHX = PERL_GET_INTERP;
988 if (primed || !PL_envgv) return;
989 MUTEX_LOCK(&primenv_mutex);
990 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
991 envhv = GvHVn(PL_envgv);
992 /* Perform a dummy fetch as an lval to insure that the hash table is
993 * set up. Otherwise, the hv_store() will turn into a nullop. */
994 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
996 for (i = 0; env_tables[i]; i++) {
997 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
998 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
999 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1001 if (have_sym || have_lnm) {
1002 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1003 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1004 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1005 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1008 for (i--; i >= 0; i--) {
1009 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1012 for (j = 0; environ[j]; j++) {
1013 if (!(start = strchr(environ[j],'='))) {
1014 if (ckWARN(WARN_INTERNAL))
1015 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1019 sv = newSVpv(start,0);
1021 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1026 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1027 !str$case_blind_compare(&tmpdsc,&clisym)) {
1028 strcpy(cmd,"Show Symbol/Global *");
1029 cmddsc.dsc$w_length = 20;
1030 if (env_tables[i]->dsc$w_length == 12 &&
1031 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1032 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1033 flags = defflags | CLI$M_NOLOGNAM;
1036 strcpy(cmd,"Show Logical *");
1037 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1038 strcat(cmd," /Table=");
1039 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1040 cmddsc.dsc$w_length = strlen(cmd);
1042 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1043 flags = defflags | CLI$M_NOCLISYM;
1046 /* Create a new subprocess to execute each command, to exclude the
1047 * remote possibility that someone could subvert a mbx or file used
1048 * to write multiple commands to a single subprocess.
1051 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1052 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1053 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1054 defflags &= ~CLI$M_TRUSTED;
1055 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1057 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1058 if (seenhv) SvREFCNT_dec(seenhv);
1061 char *cp1, *cp2, *key;
1062 unsigned long int sts, iosb[2], retlen, keylen;
1065 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1066 if (sts & 1) sts = iosb[0] & 0xffff;
1067 if (sts == SS$_ENDOFFILE) {
1069 while (substs == 0) { sys$hiber(); wakect++;}
1070 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1075 retlen = iosb[0] >> 16;
1076 if (!retlen) continue; /* blank line */
1078 if (iosb[1] != subpid) {
1080 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1084 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1085 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1087 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1088 if (*cp1 == '(' || /* Logical name table name */
1089 *cp1 == '=' /* Next eqv of searchlist */) continue;
1090 if (*cp1 == '"') cp1++;
1091 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1092 key = cp1; keylen = cp2 - cp1;
1093 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1094 while (*cp2 && *cp2 != '=') cp2++;
1095 while (*cp2 && *cp2 == '=') cp2++;
1096 while (*cp2 && *cp2 == ' ') cp2++;
1097 if (*cp2 == '"') { /* String translation; may embed "" */
1098 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1099 cp2++; cp1--; /* Skip "" surrounding translation */
1101 else { /* Numeric translation */
1102 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1103 cp1--; /* stop on last non-space char */
1105 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1106 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1109 PERL_HASH(hash,key,keylen);
1111 if (cp1 == cp2 && *cp2 == '.') {
1112 /* A single dot usually means an unprintable character, such as a null
1113 * to indicate a zero-length value. Get the actual value to make sure.
1115 char lnm[LNM$C_NAMLENGTH+1];
1116 char eqv[MAX_DCL_SYMBOL+1];
1117 strncpy(lnm, key, keylen);
1118 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1119 sv = newSVpvn(eqv, strlen(eqv));
1122 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1126 hv_store(envhv,key,keylen,sv,hash);
1127 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1129 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1130 /* get the PPFs for this process, not the subprocess */
1131 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1132 char eqv[LNM$C_NAMLENGTH+1];
1134 for (i = 0; ppfs[i]; i++) {
1135 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1136 sv = newSVpv(eqv,trnlen);
1138 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1143 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1144 if (buf) Safefree(buf);
1145 if (seenhv) SvREFCNT_dec(seenhv);
1146 MUTEX_UNLOCK(&primenv_mutex);
1149 } /* end of prime_env_iter */
1153 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1154 /* Define or delete an element in the same "environment" as
1155 * vmstrnenv(). If an element is to be deleted, it's removed from
1156 * the first place it's found. If it's to be set, it's set in the
1157 * place designated by the first element of the table vector.
1158 * Like setenv() returns 0 for success, non-zero on error.
1161 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1164 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1165 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1167 unsigned long int retsts, usermode = PSL$C_USER;
1168 struct itmlst_3 *ile, *ilist;
1169 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1170 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1171 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1172 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1173 $DESCRIPTOR(local,"_LOCAL");
1176 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1177 return SS$_IVLOGNAM;
1180 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1181 *cp2 = _toupper(*cp1);
1182 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1183 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1184 return SS$_IVLOGNAM;
1187 lnmdsc.dsc$w_length = cp1 - lnm;
1188 if (!tabvec || !*tabvec) tabvec = env_tables;
1190 if (!eqv) { /* we're deleting n element */
1191 for (curtab = 0; tabvec[curtab]; curtab++) {
1192 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1194 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1195 if ((cp1 = strchr(environ[i],'=')) &&
1196 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1197 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1199 return setenv(lnm,"",1) ? vaxc$errno : 0;
1202 ivenv = 1; retsts = SS$_NOLOGNAM;
1204 if (ckWARN(WARN_INTERNAL))
1205 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1206 ivenv = 1; retsts = SS$_NOSUCHPGM;
1212 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1213 !str$case_blind_compare(&tmpdsc,&clisym)) {
1214 unsigned int symtype;
1215 if (tabvec[curtab]->dsc$w_length == 12 &&
1216 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1217 !str$case_blind_compare(&tmpdsc,&local))
1218 symtype = LIB$K_CLI_LOCAL_SYM;
1219 else symtype = LIB$K_CLI_GLOBAL_SYM;
1220 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1221 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1222 if (retsts == LIB$_NOSUCHSYM) continue;
1226 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1227 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1228 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1229 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1230 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1234 else { /* we're defining a value */
1235 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1237 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1239 if (ckWARN(WARN_INTERNAL))
1240 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1241 retsts = SS$_NOSUCHPGM;
1245 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1246 eqvdsc.dsc$w_length = strlen(eqv);
1247 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1248 !str$case_blind_compare(&tmpdsc,&clisym)) {
1249 unsigned int symtype;
1250 if (tabvec[0]->dsc$w_length == 12 &&
1251 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1252 !str$case_blind_compare(&tmpdsc,&local))
1253 symtype = LIB$K_CLI_LOCAL_SYM;
1254 else symtype = LIB$K_CLI_GLOBAL_SYM;
1255 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1258 if (!*eqv) eqvdsc.dsc$w_length = 1;
1259 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1261 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1262 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1263 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1264 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1265 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1266 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1269 Newx(ilist,nseg+1,struct itmlst_3);
1272 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1275 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1277 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1278 ile->itmcode = LNM$_STRING;
1280 if ((j+1) == nseg) {
1281 ile->buflen = strlen(c);
1282 /* in case we are truncating one that's too long */
1283 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1286 ile->buflen = LNM$C_NAMLENGTH;
1290 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1294 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1299 if (!(retsts & 1)) {
1301 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1302 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1303 set_errno(EVMSERR); break;
1304 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1305 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1306 set_errno(EINVAL); break;
1313 set_vaxc_errno(retsts);
1314 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1317 /* We reset error values on success because Perl does an hv_fetch()
1318 * before each hv_store(), and if the thing we're setting didn't
1319 * previously exist, we've got a leftover error message. (Of course,
1320 * this fails in the face of
1321 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1322 * in that the error reported in $! isn't spurious,
1323 * but it's right more often than not.)
1325 set_errno(0); set_vaxc_errno(retsts);
1329 } /* end of vmssetenv() */
1332 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1333 /* This has to be a function since there's a prototype for it in proto.h */
1335 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1338 int len = strlen(lnm);
1342 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1343 if (!strcmp(uplnm,"DEFAULT")) {
1344 if (eqv && *eqv) my_chdir(eqv);
1348 #ifndef RTL_USES_UTC
1349 if (len == 6 || len == 2) {
1352 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1354 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1355 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1359 (void) vmssetenv(lnm,eqv,NULL);
1363 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1365 * sets a user-mode logical in the process logical name table
1366 * used for redirection of sys$error
1369 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1371 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1372 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1373 unsigned long int iss, attr = LNM$M_CONFINE;
1374 unsigned char acmode = PSL$C_USER;
1375 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1377 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1378 d_name.dsc$w_length = strlen(name);
1380 lnmlst[0].buflen = strlen(eqv);
1381 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1383 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1384 if (!(iss&1)) lib$signal(iss);
1389 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1390 /* my_crypt - VMS password hashing
1391 * my_crypt() provides an interface compatible with the Unix crypt()
1392 * C library function, and uses sys$hash_password() to perform VMS
1393 * password hashing. The quadword hashed password value is returned
1394 * as a NUL-terminated 8 character string. my_crypt() does not change
1395 * the case of its string arguments; in order to match the behavior
1396 * of LOGINOUT et al., alphabetic characters in both arguments must
1397 * be upcased by the caller.
1399 * - fix me to call ACM services when available
1402 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1404 # ifndef UAI$C_PREFERRED_ALGORITHM
1405 # define UAI$C_PREFERRED_ALGORITHM 127
1407 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1408 unsigned short int salt = 0;
1409 unsigned long int sts;
1411 unsigned short int dsc$w_length;
1412 unsigned char dsc$b_type;
1413 unsigned char dsc$b_class;
1414 const char * dsc$a_pointer;
1415 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1416 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1417 struct itmlst_3 uailst[3] = {
1418 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1419 { sizeof salt, UAI$_SALT, &salt, 0},
1420 { 0, 0, NULL, NULL}};
1421 static char hash[9];
1423 usrdsc.dsc$w_length = strlen(usrname);
1424 usrdsc.dsc$a_pointer = usrname;
1425 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1427 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1431 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1436 set_vaxc_errno(sts);
1437 if (sts != RMS$_RNF) return NULL;
1440 txtdsc.dsc$w_length = strlen(textpasswd);
1441 txtdsc.dsc$a_pointer = textpasswd;
1442 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1443 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1446 return (char *) hash;
1448 } /* end of my_crypt() */
1452 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1453 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1454 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1456 /* fixup barenames that are directories for internal use.
1457 * There have been problems with the consistent handling of UNIX
1458 * style directory names when routines are presented with a name that
1459 * has no directory delimitors at all. So this routine will eventually
1462 static char * fixup_bare_dirnames(const char * name)
1464 if (decc_disable_to_vms_logname_translation) {
1471 * A little hack to get around a bug in some implemenation of remove()
1472 * that do not know how to delete a directory
1474 * Delete any file to which user has control access, regardless of whether
1475 * delete access is explicitly allowed.
1476 * Limitations: User must have write access to parent directory.
1477 * Does not block signals or ASTs; if interrupted in midstream
1478 * may leave file with an altered ACL.
1481 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1483 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1485 char *vmsname, *rspec;
1487 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1488 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1489 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1491 unsigned char myace$b_length;
1492 unsigned char myace$b_type;
1493 unsigned short int myace$w_flags;
1494 unsigned long int myace$l_access;
1495 unsigned long int myace$l_ident;
1496 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1497 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1498 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1500 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1501 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1502 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1503 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1504 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1505 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1507 /* Expand the input spec using RMS, since the CRTL remove() and
1508 * system services won't do this by themselves, so we may miss
1509 * a file "hiding" behind a logical name or search list. */
1510 Newx(vmsname, NAM$C_MAXRSS+1, char);
1511 if (do_tovmsspec(name,vmsname,0) == NULL) {
1516 if (decc_posix_compliant_pathnames) {
1517 /* In POSIX mode, we prefer to remove the UNIX name */
1519 remove_name = (char *)name;
1522 Newx(rspec, NAM$C_MAXRSS+1, char);
1523 if (do_rmsexpand(vmsname, rspec, 1, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1529 remove_name = rspec;
1532 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1534 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1535 Newx(remove_name, NAM$C_MAXRSS+1, char);
1536 do_pathify_dirspec(name, remove_name, 0);
1537 if (!rmdir(remove_name)) {
1539 Safefree(remove_name);
1541 return 0; /* Can we just get rid of it? */
1545 if (!rmdir(remove_name)) {
1547 return 0; /* Can we just get rid of it? */
1553 if (!remove(remove_name)) {
1555 return 0; /* Can we just get rid of it? */
1558 /* If not, can changing protections help? */
1559 if (vaxc$errno != RMS$_PRV) {
1564 /* No, so we get our own UIC to use as a rights identifier,
1565 * and the insert an ACE at the head of the ACL which allows us
1566 * to delete the file.
1568 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1569 fildsc.dsc$w_length = strlen(rspec);
1570 fildsc.dsc$a_pointer = rspec;
1572 newace.myace$l_ident = oldace.myace$l_ident;
1573 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1575 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1576 set_errno(ENOENT); break;
1578 set_errno(ENOTDIR); break;
1580 set_errno(ENODEV); break;
1581 case RMS$_SYN: case SS$_INVFILFOROP:
1582 set_errno(EINVAL); break;
1584 set_errno(EACCES); break;
1588 set_vaxc_errno(aclsts);
1592 /* Grab any existing ACEs with this identifier in case we fail */
1593 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1594 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1595 || fndsts == SS$_NOMOREACE ) {
1596 /* Add the new ACE . . . */
1597 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1600 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1602 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1603 Newx(remove_name, NAM$C_MAXRSS+1, char);
1604 do_pathify_dirspec(name, remove_name, 0);
1605 rmsts = rmdir(remove_name);
1606 Safefree(remove_name);
1609 rmsts = rmdir(remove_name);
1613 rmsts = remove(remove_name);
1615 /* We blew it - dir with files in it, no write priv for
1616 * parent directory, etc. Put things back the way they were. */
1617 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1620 addlst[0].bufadr = &oldace;
1621 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1628 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1629 /* We just deleted it, so of course it's not there. Some versions of
1630 * VMS seem to return success on the unlock operation anyhow (after all
1631 * the unlock is successful), but others don't.
1633 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1634 if (aclsts & 1) aclsts = fndsts;
1635 if (!(aclsts & 1)) {
1637 set_vaxc_errno(aclsts);
1645 } /* end of kill_file() */
1649 /*{{{int do_rmdir(char *name)*/
1651 Perl_do_rmdir(pTHX_ const char *name)
1653 char dirfile[NAM$C_MAXRSS+1];
1657 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1658 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1659 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1662 } /* end of do_rmdir */
1666 * Delete any file to which user has control access, regardless of whether
1667 * delete access is explicitly allowed.
1668 * Limitations: User must have write access to parent directory.
1669 * Does not block signals or ASTs; if interrupted in midstream
1670 * may leave file with an altered ACL.
1673 /*{{{int kill_file(char *name)*/
1675 Perl_kill_file(pTHX_ const char *name)
1677 char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
1678 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1679 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1680 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1682 unsigned char myace$b_length;
1683 unsigned char myace$b_type;
1684 unsigned short int myace$w_flags;
1685 unsigned long int myace$l_access;
1686 unsigned long int myace$l_ident;
1687 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1688 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1689 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1691 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1692 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1693 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1694 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1695 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1696 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1698 /* Expand the input spec using RMS, since the CRTL remove() and
1699 * system services won't do this by themselves, so we may miss
1700 * a file "hiding" behind a logical name or search list. */
1701 if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
1702 if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
1703 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1704 /* If not, can changing protections help? */
1705 if (vaxc$errno != RMS$_PRV) return -1;
1707 /* No, so we get our own UIC to use as a rights identifier,
1708 * and the insert an ACE at the head of the ACL which allows us
1709 * to delete the file.
1711 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1712 fildsc.dsc$w_length = strlen(rspec);
1713 fildsc.dsc$a_pointer = rspec;
1715 newace.myace$l_ident = oldace.myace$l_ident;
1716 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1718 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1719 set_errno(ENOENT); break;
1721 set_errno(ENOTDIR); break;
1723 set_errno(ENODEV); break;
1724 case RMS$_SYN: case SS$_INVFILFOROP:
1725 set_errno(EINVAL); break;
1727 set_errno(EACCES); break;
1731 set_vaxc_errno(aclsts);
1734 /* Grab any existing ACEs with this identifier in case we fail */
1735 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1736 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1737 || fndsts == SS$_NOMOREACE ) {
1738 /* Add the new ACE . . . */
1739 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1741 if ((rmsts = remove(name))) {
1742 /* We blew it - dir with files in it, no write priv for
1743 * parent directory, etc. Put things back the way they were. */
1744 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1747 addlst[0].bufadr = &oldace;
1748 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1755 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1756 /* We just deleted it, so of course it's not there. Some versions of
1757 * VMS seem to return success on the unlock operation anyhow (after all
1758 * the unlock is successful), but others don't.
1760 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1761 if (aclsts & 1) aclsts = fndsts;
1762 if (!(aclsts & 1)) {
1764 set_vaxc_errno(aclsts);
1770 } /* end of kill_file() */
1774 /*{{{int my_mkdir(char *,Mode_t)*/
1776 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1778 STRLEN dirlen = strlen(dir);
1780 /* zero length string sometimes gives ACCVIO */
1781 if (dirlen == 0) return -1;
1783 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1784 * null file name/type. However, it's commonplace under Unix,
1785 * so we'll allow it for a gain in portability.
1787 if (dir[dirlen-1] == '/') {
1788 char *newdir = savepvn(dir,dirlen-1);
1789 int ret = mkdir(newdir,mode);
1793 else return mkdir(dir,mode);
1794 } /* end of my_mkdir */
1797 /*{{{int my_chdir(char *)*/
1799 Perl_my_chdir(pTHX_ const char *dir)
1801 STRLEN dirlen = strlen(dir);
1803 /* zero length string sometimes gives ACCVIO */
1804 if (dirlen == 0) return -1;
1807 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1808 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1809 * so that existing scripts do not need to be changed.
1812 while ((dirlen > 0) && (*dir1 == ' ')) {
1817 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1819 * null file name/type. However, it's commonplace under Unix,
1820 * so we'll allow it for a gain in portability.
1822 * - Preview- '/' will be valid soon on VMS
1824 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1825 char *newdir = savepvn(dir,dirlen-1);
1826 int ret = chdir(newdir);
1830 else return chdir(dir);
1831 } /* end of my_chdir */
1835 /*{{{FILE *my_tmpfile()*/
1842 if ((fp = tmpfile())) return fp;
1844 Newx(cp,L_tmpnam+24,char);
1845 if (decc_filename_unix_only == 0)
1846 strcpy(cp,"Sys$Scratch:");
1849 tmpnam(cp+strlen(cp));
1850 strcat(cp,".Perltmp");
1851 fp = fopen(cp,"w+","fop=dlt");
1858 #ifndef HOMEGROWN_POSIX_SIGNALS
1860 * The C RTL's sigaction fails to check for invalid signal numbers so we
1861 * help it out a bit. The docs are correct, but the actual routine doesn't
1862 * do what the docs say it will.
1864 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1866 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1867 struct sigaction* oact)
1869 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1870 SETERRNO(EINVAL, SS$_INVARG);
1873 return sigaction(sig, act, oact);
1878 #ifdef KILL_BY_SIGPRC
1879 #include <errnodef.h>
1881 /* We implement our own kill() using the undocumented system service
1882 sys$sigprc for one of two reasons:
1884 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1885 target process to do a sys$exit, which usually can't be handled
1886 gracefully...certainly not by Perl and the %SIG{} mechanism.
1888 2.) If the kill() in the CRTL can't be called from a signal
1889 handler without disappearing into the ether, i.e., the signal
1890 it purportedly sends is never trapped. Still true as of VMS 7.3.
1892 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1893 in the target process rather than calling sys$exit.
1895 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1896 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1897 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1898 with condition codes C$_SIG0+nsig*8, catching the exception on the
1899 target process and resignaling with appropriate arguments.
1901 But we don't have that VMS 7.0+ exception handler, so if you
1902 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1904 Also note that SIGTERM is listed in the docs as being "unimplemented",
1905 yet always seems to be signaled with a VMS condition code of 4 (and
1906 correctly handled for that code). So we hardwire it in.
1908 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1909 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1910 than signalling with an unrecognized (and unhandled by CRTL) code.
1913 #define _MY_SIG_MAX 17
1916 Perl_sig_to_vmscondition_int(int sig)
1918 static unsigned int sig_code[_MY_SIG_MAX+1] =
1921 SS$_HANGUP, /* 1 SIGHUP */
1922 SS$_CONTROLC, /* 2 SIGINT */
1923 SS$_CONTROLY, /* 3 SIGQUIT */
1924 SS$_RADRMOD, /* 4 SIGILL */
1925 SS$_BREAK, /* 5 SIGTRAP */
1926 SS$_OPCCUS, /* 6 SIGABRT */
1927 SS$_COMPAT, /* 7 SIGEMT */
1929 SS$_FLTOVF, /* 8 SIGFPE VAX */
1931 SS$_HPARITH, /* 8 SIGFPE AXP */
1933 SS$_ABORT, /* 9 SIGKILL */
1934 SS$_ACCVIO, /* 10 SIGBUS */
1935 SS$_ACCVIO, /* 11 SIGSEGV */
1936 SS$_BADPARAM, /* 12 SIGSYS */
1937 SS$_NOMBX, /* 13 SIGPIPE */
1938 SS$_ASTFLT, /* 14 SIGALRM */
1944 #if __VMS_VER >= 60200000
1945 static int initted = 0;
1948 sig_code[16] = C$_SIGUSR1;
1949 sig_code[17] = C$_SIGUSR2;
1953 if (sig < _SIG_MIN) return 0;
1954 if (sig > _MY_SIG_MAX) return 0;
1955 return sig_code[sig];
1959 Perl_sig_to_vmscondition(int sig)
1962 if (vms_debug_on_exception != 0)
1963 lib$signal(SS$_DEBUG);
1965 return Perl_sig_to_vmscondition_int(sig);
1970 Perl_my_kill(int pid, int sig)
1975 int sys$sigprc(unsigned int *pidadr,
1976 struct dsc$descriptor_s *prcname,
1979 /* sig 0 means validate the PID */
1980 /*------------------------------*/
1982 const unsigned long int jpicode = JPI$_PID;
1985 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
1986 if ($VMS_STATUS_SUCCESS(status))
1989 case SS$_NOSUCHNODE:
1990 case SS$_UNREACHABLE:
2004 code = Perl_sig_to_vmscondition_int(sig);
2007 SETERRNO(EINVAL, SS$_BADPARAM);
2011 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2012 * signals are to be sent to multiple processes.
2013 * pid = 0 - all processes in group except ones that the system exempts
2014 * pid = -1 - all processes except ones that the system exempts
2015 * pid = -n - all processes in group (abs(n)) except ...
2016 * For now, just report as not supported.
2020 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2024 iss = sys$sigprc((unsigned int *)&pid,0,code);
2025 if (iss&1) return 0;
2029 set_errno(EPERM); break;
2031 case SS$_NOSUCHNODE:
2032 case SS$_UNREACHABLE:
2033 set_errno(ESRCH); break;
2035 set_errno(ENOMEM); break;
2040 set_vaxc_errno(iss);
2046 /* Routine to convert a VMS status code to a UNIX status code.
2047 ** More tricky than it appears because of conflicting conventions with
2050 ** VMS status codes are a bit mask, with the least significant bit set for
2053 ** Special UNIX status of EVMSERR indicates that no translation is currently
2054 ** available, and programs should check the VMS status code.
2056 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2060 #ifndef C_FACILITY_NO
2061 #define C_FACILITY_NO 0x350000
2064 #define DCL_IVVERB 0x38090
2067 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2075 /* Assume the best or the worst */
2076 if (vms_status & STS$M_SUCCESS)
2079 unix_status = EVMSERR;
2081 msg_status = vms_status & ~STS$M_CONTROL;
2083 facility = vms_status & STS$M_FAC_NO;
2084 fac_sp = vms_status & STS$M_FAC_SP;
2085 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2087 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2093 unix_status = EFAULT;
2095 case SS$_DEVOFFLINE:
2096 unix_status = EBUSY;
2099 unix_status = ENOTCONN;
2107 case SS$_INVFILFOROP:
2111 unix_status = EINVAL;
2113 case SS$_UNSUPPORTED:
2114 unix_status = ENOTSUP;
2119 unix_status = EACCES;
2121 case SS$_DEVICEFULL:
2122 unix_status = ENOSPC;
2125 unix_status = ENODEV;
2127 case SS$_NOSUCHFILE:
2128 case SS$_NOSUCHOBJECT:
2129 unix_status = ENOENT;
2131 case SS$_ABORT: /* Fatal case */
2132 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2133 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2134 unix_status = EINTR;
2137 unix_status = E2BIG;
2140 unix_status = ENOMEM;
2143 unix_status = EPERM;
2145 case SS$_NOSUCHNODE:
2146 case SS$_UNREACHABLE:
2147 unix_status = ESRCH;
2150 unix_status = ECHILD;
2153 if ((facility == 0) && (msg_no < 8)) {
2154 /* These are not real VMS status codes so assume that they are
2155 ** already UNIX status codes
2157 unix_status = msg_no;
2163 /* Translate a POSIX exit code to a UNIX exit code */
2164 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2165 unix_status = (msg_no & 0x07F8) >> 3;
2169 /* Documented traditional behavior for handling VMS child exits */
2170 /*--------------------------------------------------------------*/
2171 if (child_flag != 0) {
2173 /* Success / Informational return 0 */
2174 /*----------------------------------*/
2175 if (msg_no & STS$K_SUCCESS)
2178 /* Warning returns 1 */
2179 /*-------------------*/
2180 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2183 /* Everything else pass through the severity bits */
2184 /*------------------------------------------------*/
2185 return (msg_no & STS$M_SEVERITY);
2188 /* Normal VMS status to ERRNO mapping attempt */
2189 /*--------------------------------------------*/
2190 switch(msg_status) {
2191 /* case RMS$_EOF: */ /* End of File */
2192 case RMS$_FNF: /* File Not Found */
2193 case RMS$_DNF: /* Dir Not Found */
2194 unix_status = ENOENT;
2196 case RMS$_RNF: /* Record Not Found */
2197 unix_status = ESRCH;
2200 unix_status = ENOTDIR;
2203 unix_status = ENODEV;
2208 unix_status = EBADF;
2211 unix_status = EEXIST;
2215 case LIB$_INVSTRDES:
2217 case LIB$_NOSUCHSYM:
2218 case LIB$_INVSYMNAM:
2220 unix_status = EINVAL;
2226 unix_status = E2BIG;
2228 case RMS$_PRV: /* No privilege */
2229 case RMS$_ACC: /* ACP file access failed */
2230 case RMS$_WLK: /* Device write locked */
2231 unix_status = EACCES;
2233 /* case RMS$_NMF: */ /* No more files */
2241 /* Try to guess at what VMS error status should go with a UNIX errno
2242 * value. This is hard to do as there could be many possible VMS
2243 * error statuses that caused the errno value to be set.
2246 int Perl_unix_status_to_vms(int unix_status)
2248 int test_unix_status;
2250 /* Trivial cases first */
2251 /*---------------------*/
2252 if (unix_status == EVMSERR)
2255 /* Is vaxc$errno sane? */
2256 /*---------------------*/
2257 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2258 if (test_unix_status == unix_status)
2261 /* If way out of range, must be VMS code already */
2262 /*-----------------------------------------------*/
2263 if (unix_status > EVMSERR)
2266 /* If out of range, punt */
2267 /*-----------------------*/
2268 if (unix_status > __ERRNO_MAX)
2272 /* Ok, now we have to do it the hard way. */
2273 /*----------------------------------------*/
2274 switch(unix_status) {
2275 case 0: return SS$_NORMAL;
2276 case EPERM: return SS$_NOPRIV;
2277 case ENOENT: return SS$_NOSUCHOBJECT;
2278 case ESRCH: return SS$_UNREACHABLE;
2279 case EINTR: return SS$_ABORT;
2282 case E2BIG: return SS$_BUFFEROVF;
2284 case EBADF: return RMS$_IFI;
2285 case ECHILD: return SS$_NONEXPR;
2287 case ENOMEM: return SS$_INSFMEM;
2288 case EACCES: return SS$_FILACCERR;
2289 case EFAULT: return SS$_ACCVIO;
2291 case EBUSY: return SS$_DEVOFFLINE;
2292 case EEXIST: return RMS$_FEX;
2294 case ENODEV: return SS$_NOSUCHDEV;
2295 case ENOTDIR: return RMS$_DIR;
2297 case EINVAL: return SS$_INVARG;
2303 case ENOSPC: return SS$_DEVICEFULL;
2304 case ESPIPE: return LIB$_INVARG;
2309 case ERANGE: return LIB$_INVARG;
2310 /* case EWOULDBLOCK */
2311 /* case EINPROGRESS */
2314 /* case EDESTADDRREQ */
2316 /* case EPROTOTYPE */
2317 /* case ENOPROTOOPT */
2318 /* case EPROTONOSUPPORT */
2319 /* case ESOCKTNOSUPPORT */
2320 /* case EOPNOTSUPP */
2321 /* case EPFNOSUPPORT */
2322 /* case EAFNOSUPPORT */
2323 /* case EADDRINUSE */
2324 /* case EADDRNOTAVAIL */
2326 /* case ENETUNREACH */
2327 /* case ENETRESET */
2328 /* case ECONNABORTED */
2329 /* case ECONNRESET */
2332 case ENOTCONN: return SS$_CLEARED;
2333 /* case ESHUTDOWN */
2334 /* case ETOOMANYREFS */
2335 /* case ETIMEDOUT */
2336 /* case ECONNREFUSED */
2338 /* case ENAMETOOLONG */
2339 /* case EHOSTDOWN */
2340 /* case EHOSTUNREACH */
2341 /* case ENOTEMPTY */
2353 /* case ECANCELED */
2357 return SS$_UNSUPPORTED;
2363 /* case EABANDONED */
2365 return SS$_ABORT; /* punt */
2368 return SS$_ABORT; /* Should not get here */
2372 /* default piping mailbox size */
2373 #define PERL_BUFSIZ 512
2377 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2379 unsigned long int mbxbufsiz;
2380 static unsigned long int syssize = 0;
2381 unsigned long int dviitm = DVI$_DEVNAM;
2382 char csize[LNM$C_NAMLENGTH+1];
2386 unsigned long syiitm = SYI$_MAXBUF;
2388 * Get the SYSGEN parameter MAXBUF
2390 * If the logical 'PERL_MBX_SIZE' is defined
2391 * use the value of the logical instead of PERL_BUFSIZ, but
2392 * keep the size between 128 and MAXBUF.
2395 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2398 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2399 mbxbufsiz = atoi(csize);
2401 mbxbufsiz = PERL_BUFSIZ;
2403 if (mbxbufsiz < 128) mbxbufsiz = 128;
2404 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2406 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2408 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2409 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2411 } /* end of create_mbx() */
2414 /*{{{ my_popen and my_pclose*/
2416 typedef struct _iosb IOSB;
2417 typedef struct _iosb* pIOSB;
2418 typedef struct _pipe Pipe;
2419 typedef struct _pipe* pPipe;
2420 typedef struct pipe_details Info;
2421 typedef struct pipe_details* pInfo;
2422 typedef struct _srqp RQE;
2423 typedef struct _srqp* pRQE;
2424 typedef struct _tochildbuf CBuf;
2425 typedef struct _tochildbuf* pCBuf;
2428 unsigned short status;
2429 unsigned short count;
2430 unsigned long dvispec;
2433 #pragma member_alignment save
2434 #pragma nomember_alignment quadword
2435 struct _srqp { /* VMS self-relative queue entry */
2436 unsigned long qptr[2];
2438 #pragma member_alignment restore
2439 static RQE RQE_ZERO = {0,0};
2441 struct _tochildbuf {
2444 unsigned short size;
2452 unsigned short chan_in;
2453 unsigned short chan_out;
2455 unsigned int bufsize;
2467 #if defined(PERL_IMPLICIT_CONTEXT)
2468 void *thx; /* Either a thread or an interpreter */
2469 /* pointer, depending on how we're built */
2477 PerlIO *fp; /* file pointer to pipe mailbox */
2478 int useFILE; /* using stdio, not perlio */
2479 int pid; /* PID of subprocess */
2480 int mode; /* == 'r' if pipe open for reading */
2481 int done; /* subprocess has completed */
2482 int waiting; /* waiting for completion/closure */
2483 int closing; /* my_pclose is closing this pipe */
2484 unsigned long completion; /* termination status of subprocess */
2485 pPipe in; /* pipe in to sub */
2486 pPipe out; /* pipe out of sub */
2487 pPipe err; /* pipe of sub's sys$error */
2488 int in_done; /* true when in pipe finished */
2493 struct exit_control_block
2495 struct exit_control_block *flink;
2496 unsigned long int (*exit_routine)();
2497 unsigned long int arg_count;
2498 unsigned long int *status_address;
2499 unsigned long int exit_status;
2502 typedef struct _closed_pipes Xpipe;
2503 typedef struct _closed_pipes* pXpipe;
2505 struct _closed_pipes {
2506 int pid; /* PID of subprocess */
2507 unsigned long completion; /* termination status of subprocess */
2509 #define NKEEPCLOSED 50
2510 static Xpipe closed_list[NKEEPCLOSED];
2511 static int closed_index = 0;
2512 static int closed_num = 0;
2514 #define RETRY_DELAY "0 ::0.20"
2515 #define MAX_RETRY 50
2517 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2518 static unsigned long mypid;
2519 static unsigned long delaytime[2];
2521 static pInfo open_pipes = NULL;
2522 static $DESCRIPTOR(nl_desc, "NL:");
2524 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2528 static unsigned long int
2529 pipe_exit_routine(pTHX)
2532 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2533 int sts, did_stuff, need_eof, j;
2536 flush any pending i/o
2542 PerlIO_flush(info->fp); /* first, flush data */
2544 fflush((FILE *)info->fp);
2550 next we try sending an EOF...ignore if doesn't work, make sure we
2558 _ckvmssts_noperl(sys$setast(0));
2559 if (info->in && !info->in->shut_on_empty) {
2560 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2565 _ckvmssts_noperl(sys$setast(1));
2569 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2571 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2576 _ckvmssts_noperl(sys$setast(0));
2577 if (info->waiting && info->done)
2579 nwait += info->waiting;
2580 _ckvmssts_noperl(sys$setast(1));
2590 _ckvmssts_noperl(sys$setast(0));
2591 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2592 sts = sys$forcex(&info->pid,0,&abort);
2593 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2596 _ckvmssts_noperl(sys$setast(1));
2600 /* again, wait for effect */
2602 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2607 _ckvmssts_noperl(sys$setast(0));
2608 if (info->waiting && info->done)
2610 nwait += info->waiting;
2611 _ckvmssts_noperl(sys$setast(1));
2620 _ckvmssts_noperl(sys$setast(0));
2621 if (!info->done) { /* We tried to be nice . . . */
2622 sts = sys$delprc(&info->pid,0);
2623 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2625 _ckvmssts_noperl(sys$setast(1));
2630 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2631 else if (!(sts & 1)) retsts = sts;
2636 static struct exit_control_block pipe_exitblock =
2637 {(struct exit_control_block *) 0,
2638 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2640 static void pipe_mbxtofd_ast(pPipe p);
2641 static void pipe_tochild1_ast(pPipe p);
2642 static void pipe_tochild2_ast(pPipe p);
2645 popen_completion_ast(pInfo info)
2647 pInfo i = open_pipes;
2652 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2653 closed_list[closed_index].pid = info->pid;
2654 closed_list[closed_index].completion = info->completion;
2656 if (closed_index == NKEEPCLOSED)
2661 if (i == info) break;
2664 if (!i) return; /* unlinked, probably freed too */
2669 Writing to subprocess ...
2670 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2672 chan_out may be waiting for "done" flag, or hung waiting
2673 for i/o completion to child...cancel the i/o. This will
2674 put it into "snarf mode" (done but no EOF yet) that discards
2677 Output from subprocess (stdout, stderr) needs to be flushed and
2678 shut down. We try sending an EOF, but if the mbx is full the pipe
2679 routine should still catch the "shut_on_empty" flag, telling it to
2680 use immediate-style reads so that "mbx empty" -> EOF.
2684 if (info->in && !info->in_done) { /* only for mode=w */
2685 if (info->in->shut_on_empty && info->in->need_wake) {
2686 info->in->need_wake = FALSE;
2687 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2689 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2693 if (info->out && !info->out_done) { /* were we also piping output? */
2694 info->out->shut_on_empty = TRUE;
2695 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2696 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2697 _ckvmssts_noperl(iss);
2700 if (info->err && !info->err_done) { /* we were piping stderr */
2701 info->err->shut_on_empty = TRUE;
2702 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2703 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2704 _ckvmssts_noperl(iss);
2706 _ckvmssts_noperl(sys$setef(pipe_ef));
2710 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2711 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2714 we actually differ from vmstrnenv since we use this to
2715 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2716 are pointing to the same thing
2719 static unsigned short
2720 popen_translate(pTHX_ char *logical, char *result)
2723 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2724 $DESCRIPTOR(d_log,"");
2726 unsigned short length;
2727 unsigned short code;
2729 unsigned short *retlenaddr;
2731 unsigned short l, ifi;
2733 d_log.dsc$a_pointer = logical;
2734 d_log.dsc$w_length = strlen(logical);
2736 itmlst[0].code = LNM$_STRING;
2737 itmlst[0].length = 255;
2738 itmlst[0].buffer_addr = result;
2739 itmlst[0].retlenaddr = &l;
2742 itmlst[1].length = 0;
2743 itmlst[1].buffer_addr = 0;
2744 itmlst[1].retlenaddr = 0;
2746 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2747 if (iss == SS$_NOLOGNAM) {
2751 if (!(iss&1)) lib$signal(iss);
2754 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2755 strip it off and return the ifi, if any
2758 if (result[0] == 0x1b && result[1] == 0x00) {
2759 memmove(&ifi,result+2,2);
2760 strcpy(result,result+4);
2762 return ifi; /* this is the RMS internal file id */
2765 static void pipe_infromchild_ast(pPipe p);
2768 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2769 inside an AST routine without worrying about reentrancy and which Perl
2770 memory allocator is being used.
2772 We read data and queue up the buffers, then spit them out one at a
2773 time to the output mailbox when the output mailbox is ready for one.
2776 #define INITIAL_TOCHILDQUEUE 2
2779 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2783 char mbx1[64], mbx2[64];
2784 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2785 DSC$K_CLASS_S, mbx1},
2786 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2787 DSC$K_CLASS_S, mbx2};
2788 unsigned int dviitm = DVI$_DEVBUFSIZ;
2792 _ckvmssts(lib$get_vm(&n, &p));
2794 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2795 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2796 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2799 p->shut_on_empty = FALSE;
2800 p->need_wake = FALSE;
2803 p->iosb.status = SS$_NORMAL;
2804 p->iosb2.status = SS$_NORMAL;
2810 #ifdef PERL_IMPLICIT_CONTEXT
2814 n = sizeof(CBuf) + p->bufsize;
2816 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2817 _ckvmssts(lib$get_vm(&n, &b));
2818 b->buf = (char *) b + sizeof(CBuf);
2819 _ckvmssts(lib$insqhi(b, &p->free));
2822 pipe_tochild2_ast(p);
2823 pipe_tochild1_ast(p);
2829 /* reads the MBX Perl is writing, and queues */
2832 pipe_tochild1_ast(pPipe p)
2835 int iss = p->iosb.status;
2836 int eof = (iss == SS$_ENDOFFILE);
2838 #ifdef PERL_IMPLICIT_CONTEXT
2844 p->shut_on_empty = TRUE;
2846 _ckvmssts(sys$dassgn(p->chan_in));
2852 b->size = p->iosb.count;
2853 _ckvmssts(sts = lib$insqhi(b, &p->wait));
2855 p->need_wake = FALSE;
2856 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2859 p->retry = 1; /* initial call */
2862 if (eof) { /* flush the free queue, return when done */
2863 int n = sizeof(CBuf) + p->bufsize;
2865 iss = lib$remqti(&p->free, &b);
2866 if (iss == LIB$_QUEWASEMP) return;
2868 _ckvmssts(lib$free_vm(&n, &b));
2872 iss = lib$remqti(&p->free, &b);
2873 if (iss == LIB$_QUEWASEMP) {
2874 int n = sizeof(CBuf) + p->bufsize;
2875 _ckvmssts(lib$get_vm(&n, &b));
2876 b->buf = (char *) b + sizeof(CBuf);
2882 iss = sys$qio(0,p->chan_in,
2883 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2885 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2886 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2891 /* writes queued buffers to output, waits for each to complete before
2895 pipe_tochild2_ast(pPipe p)
2898 int iss = p->iosb2.status;
2899 int n = sizeof(CBuf) + p->bufsize;
2900 int done = (p->info && p->info->done) ||
2901 iss == SS$_CANCEL || iss == SS$_ABORT;
2902 #if defined(PERL_IMPLICIT_CONTEXT)
2907 if (p->type) { /* type=1 has old buffer, dispose */
2908 if (p->shut_on_empty) {
2909 _ckvmssts(lib$free_vm(&n, &b));
2911 _ckvmssts(lib$insqhi(b, &p->free));
2916 iss = lib$remqti(&p->wait, &b);
2917 if (iss == LIB$_QUEWASEMP) {
2918 if (p->shut_on_empty) {
2920 _ckvmssts(sys$dassgn(p->chan_out));
2921 *p->pipe_done = TRUE;
2922 _ckvmssts(sys$setef(pipe_ef));
2924 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2925 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2929 p->need_wake = TRUE;
2939 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2940 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2942 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2943 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2952 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2955 char mbx1[64], mbx2[64];
2956 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2957 DSC$K_CLASS_S, mbx1},
2958 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2959 DSC$K_CLASS_S, mbx2};
2960 unsigned int dviitm = DVI$_DEVBUFSIZ;
2962 int n = sizeof(Pipe);
2963 _ckvmssts(lib$get_vm(&n, &p));
2964 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2965 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2967 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2968 n = p->bufsize * sizeof(char);
2969 _ckvmssts(lib$get_vm(&n, &p->buf));
2970 p->shut_on_empty = FALSE;
2973 p->iosb.status = SS$_NORMAL;
2974 #if defined(PERL_IMPLICIT_CONTEXT)
2977 pipe_infromchild_ast(p);
2985 pipe_infromchild_ast(pPipe p)
2987 int iss = p->iosb.status;
2988 int eof = (iss == SS$_ENDOFFILE);
2989 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
2990 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
2991 #if defined(PERL_IMPLICIT_CONTEXT)
2995 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
2996 _ckvmssts(sys$dassgn(p->chan_out));
3001 input shutdown if EOF from self (done or shut_on_empty)
3002 output shutdown if closing flag set (my_pclose)
3003 send data/eof from child or eof from self
3004 otherwise, re-read (snarf of data from child)
3009 if (myeof && p->chan_in) { /* input shutdown */
3010 _ckvmssts(sys$dassgn(p->chan_in));
3015 if (myeof || kideof) { /* pass EOF to parent */
3016 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3017 pipe_infromchild_ast, p,
3020 } else if (eof) { /* eat EOF --- fall through to read*/
3022 } else { /* transmit data */
3023 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3024 pipe_infromchild_ast,p,
3025 p->buf, p->iosb.count, 0, 0, 0, 0));
3031 /* everything shut? flag as done */
3033 if (!p->chan_in && !p->chan_out) {
3034 *p->pipe_done = TRUE;
3035 _ckvmssts(sys$setef(pipe_ef));
3039 /* write completed (or read, if snarfing from child)
3040 if still have input active,
3041 queue read...immediate mode if shut_on_empty so we get EOF if empty
3043 check if Perl reading, generate EOFs as needed
3049 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3050 pipe_infromchild_ast,p,
3051 p->buf, p->bufsize, 0, 0, 0, 0);
3052 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3054 } else { /* send EOFs for extra reads */
3055 p->iosb.status = SS$_ENDOFFILE;
3056 p->iosb.dvispec = 0;
3057 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3059 pipe_infromchild_ast, p, 0, 0, 0, 0));
3065 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3069 unsigned long dviitm = DVI$_DEVBUFSIZ;
3071 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3072 DSC$K_CLASS_S, mbx};
3073 int n = sizeof(Pipe);
3075 /* things like terminals and mbx's don't need this filter */
3076 if (fd && fstat(fd,&s) == 0) {
3077 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3078 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
3079 DSC$K_CLASS_S, s.st_dev};
3081 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
3082 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
3083 strcpy(out, s.st_dev);
3088 _ckvmssts(lib$get_vm(&n, &p));
3089 p->fd_out = dup(fd);
3090 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3091 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3092 n = (p->bufsize+1) * sizeof(char);
3093 _ckvmssts(lib$get_vm(&n, &p->buf));
3094 p->shut_on_empty = FALSE;
3099 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3100 pipe_mbxtofd_ast, p,
3101 p->buf, p->bufsize, 0, 0, 0, 0));
3107 pipe_mbxtofd_ast(pPipe p)
3109 int iss = p->iosb.status;
3110 int done = p->info->done;
3112 int eof = (iss == SS$_ENDOFFILE);
3113 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3114 int err = !(iss&1) && !eof;
3115 #if defined(PERL_IMPLICIT_CONTEXT)
3119 if (done && myeof) { /* end piping */
3121 sys$dassgn(p->chan_in);
3122 *p->pipe_done = TRUE;
3123 _ckvmssts(sys$setef(pipe_ef));
3127 if (!err && !eof) { /* good data to send to file */
3128 p->buf[p->iosb.count] = '\n';
3129 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3132 if (p->retry < MAX_RETRY) {
3133 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3143 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3144 pipe_mbxtofd_ast, p,
3145 p->buf, p->bufsize, 0, 0, 0, 0);
3146 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3151 typedef struct _pipeloc PLOC;
3152 typedef struct _pipeloc* pPLOC;
3156 char dir[NAM$C_MAXRSS+1];
3158 static pPLOC head_PLOC = 0;
3161 free_pipelocs(pTHX_ void *head)
3164 pPLOC *pHead = (pPLOC *)head;
3176 store_pipelocs(pTHX)
3185 char temp[NAM$C_MAXRSS+1];
3189 free_pipelocs(aTHX_ &head_PLOC);
3191 /* the . directory from @INC comes last */
3193 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3194 p->next = head_PLOC;
3196 strcpy(p->dir,"./");
3198 /* get the directory from $^X */
3200 #ifdef PERL_IMPLICIT_CONTEXT
3201 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3203 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3205 strcpy(temp, PL_origargv[0]);
3206 x = strrchr(temp,']');
3208 x = strrchr(temp,'>');
3210 /* It could be a UNIX path */
3211 x = strrchr(temp,'/');
3217 /* Got a bare name, so use default directory */
3222 if ((unixdir = tounixpath(temp, Nullch)) != Nullch) {
3223 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3224 p->next = head_PLOC;
3226 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3227 p->dir[NAM$C_MAXRSS] = '\0';
3231 /* reverse order of @INC entries, skip "." since entered above */
3233 #ifdef PERL_IMPLICIT_CONTEXT
3236 if (PL_incgv) av = GvAVn(PL_incgv);
3238 for (i = 0; av && i <= AvFILL(av); i++) {
3239 dirsv = *av_fetch(av,i,TRUE);
3241 if (SvROK(dirsv)) continue;
3242 dir = SvPVx(dirsv,n_a);
3243 if (strcmp(dir,".") == 0) continue;
3244 if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3247 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3248 p->next = head_PLOC;
3250 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3251 p->dir[NAM$C_MAXRSS] = '\0';
3254 /* most likely spot (ARCHLIB) put first in the list */
3257 if ((unixdir = tounixpath(ARCHLIB_EXP, Nullch)) != Nullch) {
3258 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3259 p->next = head_PLOC;
3261 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3262 p->dir[NAM$C_MAXRSS] = '\0';
3271 static int vmspipe_file_status = 0;
3272 static char vmspipe_file[NAM$C_MAXRSS+1];
3274 /* already found? Check and use ... need read+execute permission */
3276 if (vmspipe_file_status == 1) {
3277 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3278 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3279 return vmspipe_file;
3281 vmspipe_file_status = 0;
3284 /* scan through stored @INC, $^X */
3286 if (vmspipe_file_status == 0) {
3287 char file[NAM$C_MAXRSS+1];
3288 pPLOC p = head_PLOC;
3291 strcpy(file, p->dir);
3292 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3293 file[NAM$C_MAXRSS] = '\0';
3296 if (!do_tovmsspec(file,vmspipe_file,0)) continue;
3298 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3299 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3300 vmspipe_file_status = 1;
3301 return vmspipe_file;
3304 vmspipe_file_status = -1; /* failed, use tempfiles */
3311 vmspipe_tempfile(pTHX)
3313 char file[NAM$C_MAXRSS+1];
3315 static int index = 0;
3319 /* create a tempfile */
3321 /* we can't go from W, shr=get to R, shr=get without
3322 an intermediate vulnerable state, so don't bother trying...
3324 and lib$spawn doesn't shr=put, so have to close the write
3326 So... match up the creation date/time and the FID to
3327 make sure we're dealing with the same file
3332 if (!decc_filename_unix_only) {
3333 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3334 fp = fopen(file,"w");
3336 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3337 fp = fopen(file,"w");
3339 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3340 fp = fopen(file,"w");
3345 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3346 fp = fopen(file,"w");
3348 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3349 fp = fopen(file,"w");
3351 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3352 fp = fopen(file,"w");
3356 if (!fp) return 0; /* we're hosed */
3358 fprintf(fp,"$! 'f$verify(0)'\n");
3359 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3360 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3361 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3362 fprintf(fp,"$ perl_on = \"set noon\"\n");
3363 fprintf(fp,"$ perl_exit = \"exit\"\n");
3364 fprintf(fp,"$ perl_del = \"delete\"\n");
3365 fprintf(fp,"$ pif = \"if\"\n");
3366 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3367 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3368 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3369 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3370 fprintf(fp,"$! --- build command line to get max possible length\n");
3371 fprintf(fp,"$c=perl_popen_cmd0\n");
3372 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3373 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3374 fprintf(fp,"$x=perl_popen_cmd3\n");
3375 fprintf(fp,"$c=c+x\n");
3376 fprintf(fp,"$ perl_on\n");
3377 fprintf(fp,"$ 'c'\n");
3378 fprintf(fp,"$ perl_status = $STATUS\n");
3379 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3380 fprintf(fp,"$ perl_exit 'perl_status'\n");
3383 fgetname(fp, file, 1);
3384 fstat(fileno(fp), (struct stat *)&s0);
3387 if (decc_filename_unix_only)
3388 do_tounixspec(file, file, 0);
3389 fp = fopen(file,"r","shr=get");
3391 fstat(fileno(fp), (struct stat *)&s1);
3393 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3394 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3405 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3407 static int handler_set_up = FALSE;
3408 unsigned long int sts, flags = CLI$M_NOWAIT;
3409 /* The use of a GLOBAL table (as was done previously) rendered
3410 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3411 * environment. Hence we've switched to LOCAL symbol table.
3413 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3415 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3416 char in[512], out[512], err[512], mbx[512];
3418 char tfilebuf[NAM$C_MAXRSS+1];
3420 char cmd_sym_name[20];
3421 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3422 DSC$K_CLASS_S, symbol};
3423 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3425 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3426 DSC$K_CLASS_S, cmd_sym_name};
3427 struct dsc$descriptor_s *vmscmd;
3428 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3429 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3430 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3432 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3434 /* once-per-program initialization...
3435 note that the SETAST calls and the dual test of pipe_ef
3436 makes sure that only the FIRST thread through here does
3437 the initialization...all other threads wait until it's
3440 Yeah, uglier than a pthread call, it's got all the stuff inline
3441 rather than in a separate routine.
3445 _ckvmssts(sys$setast(0));
3447 unsigned long int pidcode = JPI$_PID;
3448 $DESCRIPTOR(d_delay, RETRY_DELAY);
3449 _ckvmssts(lib$get_ef(&pipe_ef));
3450 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3451 _ckvmssts(sys$bintim(&d_delay, delaytime));
3453 if (!handler_set_up) {
3454 _ckvmssts(sys$dclexh(&pipe_exitblock));
3455 handler_set_up = TRUE;
3457 _ckvmssts(sys$setast(1));
3460 /* see if we can find a VMSPIPE.COM */
3463 vmspipe = find_vmspipe(aTHX);
3465 strcpy(tfilebuf+1,vmspipe);
3466 } else { /* uh, oh...we're in tempfile hell */
3467 tpipe = vmspipe_tempfile(aTHX);
3468 if (!tpipe) { /* a fish popular in Boston */
3469 if (ckWARN(WARN_PIPE)) {
3470 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3474 fgetname(tpipe,tfilebuf+1,1);
3476 vmspipedsc.dsc$a_pointer = tfilebuf;
3477 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3479 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3482 case RMS$_FNF: case RMS$_DNF:
3483 set_errno(ENOENT); break;
3485 set_errno(ENOTDIR); break;
3487 set_errno(ENODEV); break;
3489 set_errno(EACCES); break;
3491 set_errno(EINVAL); break;
3492 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3493 set_errno(E2BIG); break;
3494 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3495 _ckvmssts(sts); /* fall through */
3496 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3499 set_vaxc_errno(sts);
3500 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3501 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3507 _ckvmssts(lib$get_vm(&n, &info));
3509 strcpy(mode,in_mode);
3512 info->completion = 0;
3513 info->closing = FALSE;
3520 info->in_done = TRUE;
3521 info->out_done = TRUE;
3522 info->err_done = TRUE;
3523 in[0] = out[0] = err[0] = '\0';
3525 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3529 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3534 if (*mode == 'r') { /* piping from subroutine */
3536 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3538 info->out->pipe_done = &info->out_done;
3539 info->out_done = FALSE;
3540 info->out->info = info;
3542 if (!info->useFILE) {
3543 info->fp = PerlIO_open(mbx, mode);
3545 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3546 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3549 if (!info->fp && info->out) {
3550 sys$cancel(info->out->chan_out);
3552 while (!info->out_done) {
3554 _ckvmssts(sys$setast(0));
3555 done = info->out_done;
3556 if (!done) _ckvmssts(sys$clref(pipe_ef));
3557 _ckvmssts(sys$setast(1));
3558 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3561 if (info->out->buf) {
3562 n = info->out->bufsize * sizeof(char);
3563 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3566 _ckvmssts(lib$free_vm(&n, &info->out));
3568 _ckvmssts(lib$free_vm(&n, &info));
3573 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3575 info->err->pipe_done = &info->err_done;
3576 info->err_done = FALSE;
3577 info->err->info = info;
3580 } else if (*mode == 'w') { /* piping to subroutine */
3582 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3584 info->out->pipe_done = &info->out_done;
3585 info->out_done = FALSE;
3586 info->out->info = info;
3589 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3591 info->err->pipe_done = &info->err_done;
3592 info->err_done = FALSE;
3593 info->err->info = info;
3596 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3597 if (!info->useFILE) {
3598 info->fp = PerlIO_open(mbx, mode);
3600 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3601 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3605 info->in->pipe_done = &info->in_done;
3606 info->in_done = FALSE;
3607 info->in->info = info;
3611 if (!info->fp && info->in) {
3613 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3614 0, 0, 0, 0, 0, 0, 0, 0));
3616 while (!info->in_done) {
3618 _ckvmssts(sys$setast(0));
3619 done = info->in_done;
3620 if (!done) _ckvmssts(sys$clref(pipe_ef));
3621 _ckvmssts(sys$setast(1));
3622 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3625 if (info->in->buf) {
3626 n = info->in->bufsize * sizeof(char);
3627 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3630 _ckvmssts(lib$free_vm(&n, &info->in));
3632 _ckvmssts(lib$free_vm(&n, &info));
3638 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3639 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3641 info->out->pipe_done = &info->out_done;
3642 info->out_done = FALSE;
3643 info->out->info = info;
3646 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3648 info->err->pipe_done = &info->err_done;
3649 info->err_done = FALSE;
3650 info->err->info = info;
3654 symbol[MAX_DCL_SYMBOL] = '\0';
3656 strncpy(symbol, in, MAX_DCL_SYMBOL);
3657 d_symbol.dsc$w_length = strlen(symbol);
3658 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3660 strncpy(symbol, err, MAX_DCL_SYMBOL);
3661 d_symbol.dsc$w_length = strlen(symbol);
3662 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3664 strncpy(symbol, out, MAX_DCL_SYMBOL);
3665 d_symbol.dsc$w_length = strlen(symbol);
3666 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3668 p = vmscmd->dsc$a_pointer;
3669 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3670 if (*p == '$') p++; /* remove leading $ */
3671 while (*p == ' ' || *p == '\t') p++;
3673 for (j = 0; j < 4; j++) {
3674 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3675 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3677 strncpy(symbol, p, MAX_DCL_SYMBOL);
3678 d_symbol.dsc$w_length = strlen(symbol);
3679 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3681 if (strlen(p) > MAX_DCL_SYMBOL) {
3682 p += MAX_DCL_SYMBOL;
3687 _ckvmssts(sys$setast(0));
3688 info->next=open_pipes; /* prepend to list */
3690 _ckvmssts(sys$setast(1));
3691 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3692 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3693 * have SYS$COMMAND if we need it.
3695 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3696 0, &info->pid, &info->completion,
3697 0, popen_completion_ast,info,0,0,0));
3699 /* if we were using a tempfile, close it now */
3701 if (tpipe) fclose(tpipe);
3703 /* once the subprocess is spawned, it has copied the symbols and
3704 we can get rid of ours */
3706 for (j = 0; j < 4; j++) {
3707 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3708 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3709 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3711 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3712 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3713 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3714 vms_execfree(vmscmd);
3716 #ifdef PERL_IMPLICIT_CONTEXT
3719 PL_forkprocess = info->pid;
3724 _ckvmssts(sys$setast(0));
3726 if (!done) _ckvmssts(sys$clref(pipe_ef));
3727 _ckvmssts(sys$setast(1));
3728 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3730 *psts = info->completion;
3731 /* Caller thinks it is open and tries to close it. */
3732 /* This causes some problems, as it changes the error status */
3733 /* my_pclose(info->fp); */
3738 } /* end of safe_popen */
3741 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3743 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3747 TAINT_PROPER("popen");
3748 PERL_FLUSHALL_FOR_CHILD;
3749 return safe_popen(aTHX_ cmd,mode,&sts);
3754 /*{{{ I32 my_pclose(PerlIO *fp)*/
3755 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3757 pInfo info, last = NULL;
3758 unsigned long int retsts;
3761 for (info = open_pipes; info != NULL; last = info, info = info->next)
3762 if (info->fp == fp) break;
3764 if (info == NULL) { /* no such pipe open */
3765 set_errno(ECHILD); /* quoth POSIX */
3766 set_vaxc_errno(SS$_NONEXPR);
3770 /* If we were writing to a subprocess, insure that someone reading from
3771 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
3772 * produce an EOF record in the mailbox.
3774 * well, at least sometimes it *does*, so we have to watch out for
3775 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3779 PerlIO_flush(info->fp); /* first, flush data */
3781 fflush((FILE *)info->fp);
3784 _ckvmssts(sys$setast(0));
3785 info->closing = TRUE;
3786 done = info->done && info->in_done && info->out_done && info->err_done;
3787 /* hanging on write to Perl's input? cancel it */
3788 if (info->mode == 'r' && info->out && !info->out_done) {
3789 if (info->out->chan_out) {
3790 _ckvmssts(sys$cancel(info->out->chan_out));
3791 if (!info->out->chan_in) { /* EOF generation, need AST */
3792 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3796 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3797 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3799 _ckvmssts(sys$setast(1));
3802 PerlIO_close(info->fp);
3804 fclose((FILE *)info->fp);
3807 we have to wait until subprocess completes, but ALSO wait until all
3808 the i/o completes...otherwise we'll be freeing the "info" structure
3809 that the i/o ASTs could still be using...
3813 _ckvmssts(sys$setast(0));
3814 done = info->done && info->in_done && info->out_done && info->err_done;
3815 if (!done) _ckvmssts(sys$clref(pipe_ef));
3816 _ckvmssts(sys$setast(1));
3817 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3819 retsts = info->completion;
3821 /* remove from list of open pipes */
3822 _ckvmssts(sys$setast(0));
3823 if (last) last->next = info->next;
3824 else open_pipes = info->next;
3825 _ckvmssts(sys$setast(1));
3827 /* free buffers and structures */
3830 if (info->in->buf) {
3831 n = info->in->bufsize * sizeof(char);
3832 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3835 _ckvmssts(lib$free_vm(&n, &info->in));
3838 if (info->out->buf) {
3839 n = info->out->bufsize * sizeof(char);
3840 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3843 _ckvmssts(lib$free_vm(&n, &info->out));
3846 if (info->err->buf) {
3847 n = info->err->bufsize * sizeof(char);
3848 _ckvmssts(lib$free_vm(&n, &info->err->buf));
3851 _ckvmssts(lib$free_vm(&n, &info->err));
3854 _ckvmssts(lib$free_vm(&n, &info));
3858 } /* end of my_pclose() */
3860 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3861 /* Roll our own prototype because we want this regardless of whether
3862 * _VMS_WAIT is defined.
3864 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3866 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3867 created with popen(); otherwise partially emulate waitpid() unless
3868 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3869 Also check processes not considered by the CRTL waitpid().
3871 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3873 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3880 if (statusp) *statusp = 0;
3882 for (info = open_pipes; info != NULL; info = info->next)
3883 if (info->pid == pid) break;
3885 if (info != NULL) { /* we know about this child */
3886 while (!info->done) {
3887 _ckvmssts(sys$setast(0));
3889 if (!done) _ckvmssts(sys$clref(pipe_ef));
3890 _ckvmssts(sys$setast(1));
3891 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3894 if (statusp) *statusp = info->completion;
3898 /* child that already terminated? */
3900 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3901 if (closed_list[j].pid == pid) {
3902 if (statusp) *statusp = closed_list[j].completion;
3907 /* fall through if this child is not one of our own pipe children */
3909 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3911 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3912 * in 7.2 did we get a version that fills in the VMS completion
3913 * status as Perl has always tried to do.
3916 sts = __vms_waitpid( pid, statusp, flags );
3918 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3921 /* If the real waitpid tells us the child does not exist, we
3922 * fall through here to implement waiting for a child that
3923 * was created by some means other than exec() (say, spawned
3924 * from DCL) or to wait for a process that is not a subprocess
3925 * of the current process.
3928 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3931 $DESCRIPTOR(intdsc,"0 00:00:01");
3932 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3933 unsigned long int pidcode = JPI$_PID, mypid;
3934 unsigned long int interval[2];
3935 unsigned int jpi_iosb[2];
3936 struct itmlst_3 jpilist[2] = {
3937 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
3942 /* Sorry folks, we don't presently implement rooting around for
3943 the first child we can find, and we definitely don't want to
3944 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3950 /* Get the owner of the child so I can warn if it's not mine. If the
3951 * process doesn't exist or I don't have the privs to look at it,
3952 * I can go home early.
3954 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3955 if (sts & 1) sts = jpi_iosb[0];
3967 set_vaxc_errno(sts);
3971 if (ckWARN(WARN_EXEC)) {
3972 /* remind folks they are asking for non-standard waitpid behavior */
3973 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3974 if (ownerpid != mypid)
3975 Perl_warner(aTHX_ packWARN(WARN_EXEC),
3976 "waitpid: process %x is not a child of process %x",
3980 /* simply check on it once a second until it's not there anymore. */
3982 _ckvmssts(sys$bintim(&intdsc,interval));
3983 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
3984 _ckvmssts(sys$schdwk(0,0,interval,0));
3985 _ckvmssts(sys$hiber());
3987 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
3992 } /* end of waitpid() */
3997 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
3999 my_gconvert(double val, int ndig, int trail, char *buf)
4001 static char __gcvtbuf[DBL_DIG+1];
4004 loc = buf ? buf : __gcvtbuf;
4006 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4008 sprintf(loc,"%.*g",ndig,val);
4014 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4015 return gcvt(val,ndig,loc);
4018 loc[0] = '0'; loc[1] = '\0';
4025 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
4026 static int rms_free_search_context(struct FAB * fab)
4030 nam = fab->fab$l_nam;
4031 nam->nam$b_nop |= NAM$M_SYNCHK;
4032 nam->nam$l_rlf = NULL;
4034 return sys$parse(fab, NULL, NULL);
4037 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4038 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4039 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4040 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4041 #define rms_nam_esll(nam) nam.nam$b_esl
4042 #define rms_nam_esl(nam) nam.nam$b_esl
4043 #define rms_nam_name(nam) nam.nam$l_name
4044 #define rms_nam_namel(nam) nam.nam$l_name
4045 #define rms_nam_type(nam) nam.nam$l_type
4046 #define rms_nam_typel(nam) nam.nam$l_type
4047 #define rms_nam_ver(nam) nam.nam$l_ver
4048 #define rms_nam_verl(nam) nam.nam$l_ver
4049 #define rms_nam_rsll(nam) nam.nam$b_rsl
4050 #define rms_nam_rsl(nam) nam.nam$b_rsl
4051 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4052 #define rms_set_fna(fab, nam, name, size) \
4053 fab.fab$b_fns = size; fab.fab$l_fna = name;
4054 #define rms_get_fna(fab, nam) fab.fab$l_fna
4055 #define rms_set_dna(fab, nam, name, size) \
4056 fab.fab$b_dns = size; fab.fab$l_dna = name;
4057 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
4058 #define rms_set_esa(fab, nam, name, size) \
4059 nam.nam$b_ess = size; nam.nam$l_esa = name;
4060 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4061 nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
4062 #define rms_set_rsa(nam, name, size) \
4063 nam.nam$l_rsa = name; nam.nam$b_rss = size;
4064 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4065 nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
4068 static int rms_free_search_context(struct FAB * fab)
4072 nam = fab->fab$l_naml;
4073 nam->naml$b_nop |= NAM$M_SYNCHK;
4074 nam->naml$l_rlf = NULL;
4075 nam->naml$l_long_defname_size = 0;
4077 return sys$parse(fab, NULL, NULL);
4080 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4081 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4082 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4083 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4084 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4085 #define rms_nam_esl(nam) nam.naml$b_esl
4086 #define rms_nam_name(nam) nam.naml$l_name
4087 #define rms_nam_namel(nam) nam.naml$l_long_name
4088 #define rms_nam_type(nam) nam.naml$l_type
4089 #define rms_nam_typel(nam) nam.naml$l_long_type
4090 #define rms_nam_ver(nam) nam.naml$l_ver
4091 #define rms_nam_verl(nam) nam.naml$l_long_ver
4092 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4093 #define rms_nam_rsl(nam) nam.naml$b_rsl
4094 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4095 #define rms_set_fna(fab, nam, name, size) \
4096 fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4097 nam.naml$l_long_filename_size = size; \
4098 nam.naml$l_long_filename = name
4099 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4100 #define rms_set_dna(fab, nam, name, size) \
4101 fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4102 nam.naml$l_long_defname_size = size; \
4103 nam.naml$l_long_defname = name
4104 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4105 #define rms_set_esa(fab, nam, name, size) \
4106 nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4107 nam.naml$l_long_expand_alloc = size; \
4108 nam.naml$l_long_expand = name
4109 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4110 nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4111 nam.naml$l_long_expand = l_name; \
4112 nam.naml$l_long_expand_alloc = l_size;
4113 #define rms_set_rsa(nam, name, size) \
4114 nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4115 nam.naml$l_long_result = name; \
4116 nam.naml$l_long_result_alloc = size;
4117 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4118 nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4119 nam.naml$l_long_result = l_name; \
4120 nam.naml$l_long_result_alloc = l_size;
4125 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4126 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4127 * to expand file specification. Allows for a single default file
4128 * specification and a simple mask of options. If outbuf is non-NULL,
4129 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4130 * the resultant file specification is placed. If outbuf is NULL, the
4131 * resultant file specification is placed into a static buffer.
4132 * The third argument, if non-NULL, is taken to be a default file
4133 * specification string. The fourth argument is unused at present.
4134 * rmesexpand() returns the address of the resultant string if
4135 * successful, and NULL on error.
4137 * New functionality for previously unused opts value:
4138 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4140 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4142 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4143 /* ODS-2 only version */
4145 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4147 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
4148 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
4149 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
4150 struct FAB myfab = cc$rms_fab;
4151 struct NAM mynam = cc$rms_nam;
4153 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4156 if (!filespec || !*filespec) {
4157 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4161 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
4162 else outbuf = __rmsexpand_retbuf;
4164 isunix = is_unix_filespec(filespec);
4166 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4171 filespec = vmsfspec;
4174 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
4175 myfab.fab$b_fns = strlen(filespec);
4176 myfab.fab$l_nam = &mynam;
4178 if (defspec && *defspec) {
4179 if (strchr(defspec,'/') != NULL) {
4180 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4187 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
4188 myfab.fab$b_dns = strlen(defspec);
4191 mynam.nam$l_esa = esa;
4192 mynam.nam$b_ess = sizeof esa;
4193 mynam.nam$l_rsa = outbuf;
4194 mynam.nam$b_rss = NAM$C_MAXRSS;
4196 #ifdef NAM$M_NO_SHORT_UPCASE
4197 if (decc_efs_case_preserve)
4198 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4201 retsts = sys$parse(&myfab,0,0);
4202 if (!(retsts & 1)) {
4203 mynam.nam$b_nop |= NAM$M_SYNCHK;
4204 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4205 retsts = sys$parse(&myfab,0,0);
4206 if (retsts & 1) goto expanded;
4208 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
4209 sts = sys$parse(&myfab,0,0); /* Free search context */
4210 if (out) Safefree(out);
4211 set_vaxc_errno(retsts);
4212 if (retsts == RMS$_PRV) set_errno(EACCES);
4213 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4214 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4215 else set_errno(EVMSERR);
4218 retsts = sys$search(&myfab,0,0);
4219 if (!(retsts & 1) && retsts != RMS$_FNF) {
4220 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4221 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4222 if (out) Safefree(out);
4223 set_vaxc_errno(retsts);
4224 if (retsts == RMS$_PRV) set_errno(EACCES);
4225 else set_errno(EVMSERR);
4229 /* If the input filespec contained any lowercase characters,
4230 * downcase the result for compatibility with Unix-minded code. */
4232 if (!decc_efs_case_preserve) {
4233 for (out = myfab.fab$l_fna; *out; out++)
4234 if (islower(*out)) { haslower = 1; break; }
4236 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
4237 else { out = esa; speclen = mynam.nam$b_esl; }
4238 /* Trim off null fields added by $PARSE
4239 * If type > 1 char, must have been specified in original or default spec
4240 * (not true for version; $SEARCH may have added version of existing file).
4242 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
4243 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
4244 (mynam.nam$l_ver - mynam.nam$l_type == 1);
4245 if (trimver || trimtype) {
4246 if (defspec && *defspec) {
4247 char defesa[NAM$C_MAXRSS];
4248 struct FAB deffab = cc$rms_fab;
4249 struct NAM defnam = cc$rms_nam;
4251 deffab.fab$l_nam = &defnam;
4252 /* cast below ok for read only pointer */
4253 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
4254 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
4255 defnam.nam$b_nop = NAM$M_SYNCHK;
4256 #ifdef NAM$M_NO_SHORT_UPCASE
4257 if (decc_efs_case_preserve)
4258 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4260 if (sys$parse(&deffab,0,0) & 1) {
4261 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4262 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4266 if (*mynam.nam$l_ver != '\"')
4267 speclen = mynam.nam$l_ver - out;
4270 /* If we didn't already trim version, copy down */
4271 if (speclen > mynam.nam$l_ver - out)
4272 memmove(mynam.nam$l_type, mynam.nam$l_ver,
4273 speclen - (mynam.nam$l_ver - out));
4274 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4277 /* If we just had a directory spec on input, $PARSE "helpfully"
4278 * adds an empty name and type for us */
4279 if (mynam.nam$l_name == mynam.nam$l_type &&
4280 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
4281 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4282 speclen = mynam.nam$l_name - out;
4284 /* Posix format specifications must have matching quotes */
4285 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4286 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4287 out[speclen] = '\"';
4292 out[speclen] = '\0';
4293 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4295 /* Have we been working with an expanded, but not resultant, spec? */
4296 /* Also, convert back to Unix syntax if necessary. */
4297 if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4300 if (!mynam.nam$b_rsl) {
4302 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4304 else strcpy(outbuf,esa);
4307 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4308 strcpy(outbuf,tmpfspec);
4310 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4311 mynam.nam$l_rsa = NULL;
4312 mynam.nam$b_rss = 0;
4313 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4317 /* ODS-5 supporting routine */
4319 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4321 static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4322 char * vmsfspec, *tmpfspec;
4323 char * esa, *cp, *out = NULL;
4326 struct FAB myfab = cc$rms_fab;
4327 rms_setup_nam(mynam);
4329 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4332 if (!filespec || !*filespec) {
4333 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4337 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4338 else outbuf = __rmsexpand_retbuf;
4344 isunix = is_unix_filespec(filespec);
4346 Newx(vmsfspec, VMS_MAXRSS, char);
4347 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4353 filespec = vmsfspec;
4355 /* Unless we are forcing to VMS format, a UNIX input means
4356 * UNIX output, and that requires long names to be used
4358 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4359 opts |= PERL_RMSEXPAND_M_LONG;
4365 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4366 rms_bind_fab_nam(myfab, mynam);
4368 if (defspec && *defspec) {
4370 t_isunix = is_unix_filespec(defspec);
4372 Newx(tmpfspec, VMS_MAXRSS, char);
4373 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4375 if (vmsfspec != NULL)
4383 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4386 Newx(esa, NAM$C_MAXRSS + 1, char);
4387 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4388 Newx(esal, NAML$C_MAXRSS + 1, char);
4390 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4392 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4393 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4396 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4397 Newx(outbufl, VMS_MAXRSS, char);
4398 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4400 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4404 #ifdef NAM$M_NO_SHORT_UPCASE
4405 if (decc_efs_case_preserve)
4406 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4409 /* First attempt to parse as an existing file */
4410 retsts = sys$parse(&myfab,0,0);
4411 if (!(retsts & STS$K_SUCCESS)) {
4413 /* Could not find the file, try as syntax only if error is not fatal */
4414 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4415 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4416 retsts = sys$parse(&myfab,0,0);
4417 if (retsts & STS$K_SUCCESS) goto expanded;
4420 /* Still could not parse the file specification */
4421 /*----------------------------------------------*/
4422 sts = rms_free_search_context(&myfab); /* Free search context */
4423 if (out) Safefree(out);
4424 if (tmpfspec != NULL)
4426 if (vmsfspec != NULL)
4430 set_vaxc_errno(retsts);
4431 if (retsts == RMS$_PRV) set_errno(EACCES);
4432 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4433 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4434 else set_errno(EVMSERR);
4437 retsts = sys$search(&myfab,0,0);
4438 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4439 sts = rms_free_search_context(&myfab); /* Free search context */
4440 if (out) Safefree(out);
4441 if (tmpfspec != NULL)
4443 if (vmsfspec != NULL)
4447 set_vaxc_errno(retsts);
4448 if (retsts == RMS$_PRV) set_errno(EACCES);
4449 else set_errno(EVMSERR);
4453 /* If the input filespec contained any lowercase characters,
4454 * downcase the result for compatibility with Unix-minded code. */
4456 if (!decc_efs_case_preserve) {
4457 for (out = rms_get_fna(myfab, mynam); *out; out++)
4458 if (islower(*out)) { haslower = 1; break; }
4461 /* Is a long or a short name expected */
4462 /*------------------------------------*/
4463 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4464 if (rms_nam_rsll(mynam)) {
4466 speclen = rms_nam_rsll(mynam);
4469 out = esal; /* Not esa */
4470 speclen = rms_nam_esll(mynam);
4474 if (rms_nam_rsl(mynam)) {
4476 speclen = rms_nam_rsl(mynam);
4479 out = esa; /* Not esal */
4480 speclen = rms_nam_esl(mynam);
4483 /* Trim off null fields added by $PARSE
4484 * If type > 1 char, must have been specified in original or default spec
4485 * (not true for version; $SEARCH may have added version of existing file).
4487 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4488 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4489 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4490 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4493 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4494 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4496 if (trimver || trimtype) {
4497 if (defspec && *defspec) {
4498 char *defesal = NULL;
4499 Newx(defesal, NAML$C_MAXRSS + 1, char);
4500 if (defesal != NULL) {
4501 struct FAB deffab = cc$rms_fab;
4502 rms_setup_nam(defnam);
4504 rms_bind_fab_nam(deffab, defnam);
4508 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4510 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4512 rms_set_nam_nop(defnam, 0);
4513 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4514 #ifdef NAM$M_NO_SHORT_UPCASE
4515 if (decc_efs_case_preserve)
4516 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4518 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4520 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4523 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4530 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4531 if (*(rms_nam_verl(mynam)) != '\"')
4532 speclen = rms_nam_verl(mynam) - out;
4535 if (*(rms_nam_ver(mynam)) != '\"')
4536 speclen = rms_nam_ver(mynam) - out;
4540 /* If we didn't already trim version, copy down */
4541 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4542 if (speclen > rms_nam_verl(mynam) - out)
4544 (rms_nam_typel(mynam),
4545 rms_nam_verl(mynam),
4546 speclen - (rms_nam_verl(mynam) - out));
4547 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4550 if (speclen > rms_nam_ver(mynam) - out)
4552 (rms_nam_type(mynam),
4554 speclen - (rms_nam_ver(mynam) - out));
4555 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4560 /* Done with these copies of the input files */
4561 /*-------------------------------------------*/
4562 if (vmsfspec != NULL)
4564 if (tmpfspec != NULL)
4567 /* If we just had a directory spec on input, $PARSE "helpfully"
4568 * adds an empty name and type for us */
4569 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4570 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4571 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4572 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4573 speclen = rms_nam_namel(mynam) - out;
4576 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4577 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4578 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4579 speclen = rms_nam_name(mynam) - out;
4582 /* Posix format specifications must have matching quotes */
4583 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4584 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4585 out[speclen] = '\"';
4589 out[speclen] = '\0';
4590 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4592 /* Have we been working with an expanded, but not resultant, spec? */
4593 /* Also, convert back to Unix syntax if necessary. */
4595 if (!rms_nam_rsll(mynam)) {
4597 if (do_tounixspec(esa,outbuf,0) == NULL) {
4603 else strcpy(outbuf,esa);
4606 Newx(tmpfspec, VMS_MAXRSS, char);
4607 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4613 strcpy(outbuf,tmpfspec);
4617 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4618 sts = rms_free_search_context(&myfab); /* Free search context */
4625 /* External entry points */
4626 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4627 { return do_rmsexpand(spec,buf,0,def,opt); }
4628 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4629 { return do_rmsexpand(spec,buf,1,def,opt); }
4633 ** The following routines are provided to make life easier when
4634 ** converting among VMS-style and Unix-style directory specifications.
4635 ** All will take input specifications in either VMS or Unix syntax. On
4636 ** failure, all return NULL. If successful, the routines listed below
4637 ** return a pointer to a buffer containing the appropriately
4638 ** reformatted spec (and, therefore, subsequent calls to that routine
4639 ** will clobber the result), while the routines of the same names with
4640 ** a _ts suffix appended will return a pointer to a mallocd string
4641 ** containing the appropriately reformatted spec.
4642 ** In all cases, only explicit syntax is altered; no check is made that
4643 ** the resulting string is valid or that the directory in question
4646 ** fileify_dirspec() - convert a directory spec into the name of the
4647 ** directory file (i.e. what you can stat() to see if it's a dir).
4648 ** The style (VMS or Unix) of the result is the same as the style
4649 ** of the parameter passed in.
4650 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4651 ** what you prepend to a filename to indicate what directory it's in).
4652 ** The style (VMS or Unix) of the result is the same as the style
4653 ** of the parameter passed in.
4654 ** tounixpath() - convert a directory spec into a Unix-style path.
4655 ** tovmspath() - convert a directory spec into a VMS-style path.
4656 ** tounixspec() - convert any file spec into a Unix-style file spec.
4657 ** tovmsspec() - convert any file spec into a VMS-style spec.
4659 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4660 ** Permission is given to distribute this code as part of the Perl
4661 ** standard distribution under the terms of the GNU General Public
4662 ** License or the Perl Artistic License. Copies of each may be
4663 ** found in the Perl standard distribution.
4666 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4667 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4669 static char __fileify_retbuf[VMS_MAXRSS];
4670 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4671 char *retspec, *cp1, *cp2, *lastdir;
4672 char *trndir, *vmsdir;
4673 unsigned short int trnlnm_iter_count;
4676 if (!dir || !*dir) {
4677 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4679 dirlen = strlen(dir);
4680 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4681 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4682 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4689 if (dirlen > (VMS_MAXRSS - 1)) {
4690 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4693 Newx(trndir, VMS_MAXRSS + 1, char);
4694 if (!strpbrk(dir+1,"/]>:") &&
4695 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4696 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4697 trnlnm_iter_count = 0;
4698 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4699 trnlnm_iter_count++;
4700 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4702 dirlen = strlen(trndir);
4705 strncpy(trndir,dir,dirlen);
4706 trndir[dirlen] = '\0';
4709 /* At this point we are done with *dir and use *trndir which is a
4710 * copy that can be modified. *dir must not be modified.
4713 /* If we were handed a rooted logical name or spec, treat it like a
4714 * simple directory, so that
4715 * $ Define myroot dev:[dir.]
4716 * ... do_fileify_dirspec("myroot",buf,1) ...
4717 * does something useful.
4719 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4720 trndir[--dirlen] = '\0';
4721 trndir[dirlen-1] = ']';
4723 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4724 trndir[--dirlen] = '\0';
4725 trndir[dirlen-1] = '>';
4728 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4729 /* If we've got an explicit filename, we can just shuffle the string. */
4730 if (*(cp1+1)) hasfilename = 1;
4731 /* Similarly, we can just back up a level if we've got multiple levels
4732 of explicit directories in a VMS spec which ends with directories. */
4734 for (cp2 = cp1; cp2 > trndir; cp2--) {
4736 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4737 /* fix-me, can not scan EFS file specs backward like this */
4738 *cp2 = *cp1; *cp1 = '\0';
4743 if (*cp2 == '[' || *cp2 == '<') break;
4748 Newx(vmsdir, VMS_MAXRSS + 1, char);
4749 cp1 = strpbrk(trndir,"]:>");
4750 if (hasfilename || !cp1) { /* Unix-style path or filename */
4751 if (trndir[0] == '.') {
4752 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4755 return do_fileify_dirspec("[]",buf,ts);
4757 else if (trndir[1] == '.' &&
4758 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4761 return do_fileify_dirspec("[-]",buf,ts);
4764 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4765 dirlen -= 1; /* to last element */
4766 lastdir = strrchr(trndir,'/');
4768 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4769 /* If we have "/." or "/..", VMSify it and let the VMS code
4770 * below expand it, rather than repeating the code to handle
4771 * relative components of a filespec here */
4773 if (*(cp1+2) == '.') cp1++;
4774 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4776 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4781 if (strchr(vmsdir,'/') != NULL) {
4782 /* If do_tovmsspec() returned it, it must have VMS syntax
4783 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4784 * the time to check this here only so we avoid a recursion
4785 * loop; otherwise, gigo.
4789 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4792 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4797 ret_chr = do_tounixspec(trndir,buf,ts);
4803 } while ((cp1 = strstr(cp1,"/.")) != NULL);
4804 lastdir = strrchr(trndir,'/');
4806 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4808 /* Ditto for specs that end in an MFD -- let the VMS code
4809 * figure out whether it's a real device or a rooted logical. */
4811 /* This should not happen any more. Allowing the fake /000000
4812 * in a UNIX pathname causes all sorts of problems when trying
4813 * to run in UNIX emulation. So the VMS to UNIX conversions
4814 * now remove the fake /000000 directories.
4817 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4818 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4823 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4828 ret_chr = do_tounixspec(trndir,buf,ts);
4835 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4836 !(lastdir = cp1 = strrchr(trndir,']')) &&
4837 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4838 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
4841 /* For EFS or ODS-5 look for the last dot */
4842 if (decc_efs_charset) {
4843 cp2 = strrchr(cp1,'.');
4845 if (vms_process_case_tolerant) {
4846 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4847 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4848 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4849 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4850 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4851 (ver || *cp3)))))) {
4855 set_vaxc_errno(RMS$_DIR);
4860 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4861 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4862 !*(cp2+3) || *(cp2+3) != 'R' ||
4863 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4864 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4865 (ver || *cp3)))))) {
4869 set_vaxc_errno(RMS$_DIR);
4873 dirlen = cp2 - trndir;
4877 retlen = dirlen + 6;
4878 if (buf) retspec = buf;
4879 else if (ts) Newx(retspec,retlen+1,char);
4880 else retspec = __fileify_retbuf;
4881 memcpy(retspec,trndir,dirlen);
4882 retspec[dirlen] = '\0';
4884 /* We've picked up everything up to the directory file name.
4885 Now just add the type and version, and we're set. */
4886 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4887 strcat(retspec,".dir;1");
4889 strcat(retspec,".DIR;1");
4894 else { /* VMS-style directory spec */
4896 char *esa, term, *cp;
4897 unsigned long int sts, cmplen, haslower = 0;
4898 unsigned int nam_fnb;
4900 struct FAB dirfab = cc$rms_fab;
4901 rms_setup_nam(savnam);
4902 rms_setup_nam(dirnam);
4904 Newx(esa, VMS_MAXRSS + 1, char);
4905 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4906 rms_bind_fab_nam(dirfab, dirnam);
4907 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4908 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4909 #ifdef NAM$M_NO_SHORT_UPCASE
4910 if (decc_efs_case_preserve)
4911 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4914 for (cp = trndir; *cp; cp++)
4915 if (islower(*cp)) { haslower = 1; break; }
4916 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4917 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4918 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4919 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4926 set_vaxc_errno(dirfab.fab$l_sts);
4932 /* Does the file really exist? */
4933 if (sys$search(&dirfab)& STS$K_SUCCESS) {
4934 /* Yes; fake the fnb bits so we'll check type below */
4935 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4937 else { /* No; just work with potential name */
4938 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4943 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
4944 sts = rms_free_search_context(&dirfab);
4949 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4950 cp1 = strchr(esa,']');
4951 if (!cp1) cp1 = strchr(esa,'>');
4952 if (cp1) { /* Should always be true */
4953 rms_nam_esll(dirnam) -= cp1 - esa - 1;
4954 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4957 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
4958 /* Yep; check version while we're at it, if it's there. */
4959 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4960 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4961 /* Something other than .DIR[;1]. Bzzt. */
4962 sts = rms_free_search_context(&dirfab);
4967 set_vaxc_errno(RMS$_DIR);
4971 esa[rms_nam_esll(dirnam)] = '\0';
4972 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4973 /* They provided at least the name; we added the type, if necessary, */
4974 if (buf) retspec = buf; /* in sys$parse() */
4975 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4976 else retspec = __fileify_retbuf;
4977 strcpy(retspec,esa);
4978 sts = rms_free_search_context(&dirfab);
4984 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4985 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4987 rms_nam_esll(dirnam) -= 9;
4989 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4990 if (cp1 == NULL) { /* should never happen */
4991 sts = rms_free_search_context(&dirfab);
4999 retlen = strlen(esa);
5000 cp1 = strrchr(esa,'.');
5001 /* ODS-5 directory specifications can have extra "." in them. */
5002 /* Fix-me, can not scan EFS file specifications backwards */
5003 while (cp1 != NULL) {
5004 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5008 while ((cp1 > esa) && (*cp1 != '.'))
5015 if ((cp1) != NULL) {
5016 /* There's more than one directory in the path. Just roll back. */
5018 if (buf) retspec = buf;
5019 else if (ts) Newx(retspec,retlen+7,char);
5020 else retspec = __fileify_retbuf;
5021 strcpy(retspec,esa);
5024 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5025 /* Go back and expand rooted logical name */
5026 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5027 #ifdef NAM$M_NO_SHORT_UPCASE
5028 if (decc_efs_case_preserve)
5029 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5031 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5032 sts = rms_free_search_context(&dirfab);
5037 set_vaxc_errno(dirfab.fab$l_sts);
5040 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5041 if (buf) retspec = buf;
5042 else if (ts) Newx(retspec,retlen+16,char);
5043 else retspec = __fileify_retbuf;
5044 cp1 = strstr(esa,"][");
5045 if (!cp1) cp1 = strstr(esa,"]<");
5047 memcpy(retspec,esa,dirlen);
5048 if (!strncmp(cp1+2,"000000]",7)) {
5049 retspec[dirlen-1] = '\0';
5050 /* fix-me Not full ODS-5, just extra dots in directories for now */
5051 cp1 = retspec + dirlen - 1;
5052 while (cp1 > retspec)
5057 if (*(cp1-1) != '^')
5062 if (*cp1 == '.') *cp1 = ']';
5064 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5065 memmove(cp1+1,"000000]",7);
5069 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5070 retspec[retlen] = '\0';
5071 /* Convert last '.' to ']' */
5072 cp1 = retspec+retlen-1;
5073 while (*cp != '[') {
5076 /* Do not trip on extra dots in ODS-5 directories */
5077 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5081 if (*cp1 == '.') *cp1 = ']';
5083 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5084 memmove(cp1+1,"000000]",7);
5088 else { /* This is a top-level dir. Add the MFD to the path. */
5089 if (buf) retspec = buf;
5090 else if (ts) Newx(retspec,retlen+16,char);
5091 else retspec = __fileify_retbuf;
5094 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5095 strcpy(cp2,":[000000]");
5100 sts = rms_free_search_context(&dirfab);
5101 /* We've set up the string up through the filename. Add the
5102 type and version, and we're done. */
5103 strcat(retspec,".DIR;1");
5105 /* $PARSE may have upcased filespec, so convert output to lower
5106 * case if input contained any lowercase characters. */
5107 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5113 } /* end of do_fileify_dirspec() */
5115 /* External entry points */
5116 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5117 { return do_fileify_dirspec(dir,buf,0); }
5118 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5119 { return do_fileify_dirspec(dir,buf,1); }
5121 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5122 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5124 static char __pathify_retbuf[VMS_MAXRSS];
5125 unsigned long int retlen;
5126 char *retpath, *cp1, *cp2, *trndir;
5127 unsigned short int trnlnm_iter_count;
5131 if (!dir || !*dir) {
5132 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5135 Newx(trndir, VMS_MAXRSS, char);
5136 if (*dir) strcpy(trndir,dir);
5137 else getcwd(trndir,VMS_MAXRSS - 1);
5139 trnlnm_iter_count = 0;
5140 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5141 && my_trnlnm(trndir,trndir,0)) {
5142 trnlnm_iter_count++;
5143 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5144 trnlen = strlen(trndir);
5146 /* Trap simple rooted lnms, and return lnm:[000000] */
5147 if (!strcmp(trndir+trnlen-2,".]")) {
5148 if (buf) retpath = buf;
5149 else if (ts) Newx(retpath,strlen(dir)+10,char);
5150 else retpath = __pathify_retbuf;
5151 strcpy(retpath,dir);
5152 strcat(retpath,":[000000]");
5158 /* At this point we do not work with *dir, but the copy in
5159 * *trndir that is modifiable.
5162 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5163 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5164 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5165 retlen = 2 + (*(trndir+1) != '\0');
5167 if ( !(cp1 = strrchr(trndir,'/')) &&
5168 !(cp1 = strrchr(trndir,']')) &&
5169 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5170 if ((cp2 = strchr(cp1,'.')) != NULL &&
5171 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5172 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5173 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5174 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5177 /* For EFS or ODS-5 look for the last dot */
5178 if (decc_efs_charset) {
5179 cp2 = strrchr(cp1,'.');
5181 if (vms_process_case_tolerant) {
5182 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5183 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5184 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5185 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5186 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5187 (ver || *cp3)))))) {
5190 set_vaxc_errno(RMS$_DIR);
5195 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5196 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5197 !*(cp2+3) || *(cp2+3) != 'R' ||
5198 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5199 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5200 (ver || *cp3)))))) {
5203 set_vaxc_errno(RMS$_DIR);
5207 retlen = cp2 - trndir + 1;
5209 else { /* No file type present. Treat the filename as a directory. */
5210 retlen = strlen(trndir) + 1;
5213 if (buf) retpath = buf;
5214 else if (ts) Newx(retpath,retlen+1,char);
5215 else retpath = __pathify_retbuf;
5216 strncpy(retpath, trndir, retlen-1);
5217 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5218 retpath[retlen-1] = '/'; /* with '/', add it. */
5219 retpath[retlen] = '\0';
5221 else retpath[retlen-1] = '\0';
5223 else { /* VMS-style directory spec */
5225 unsigned long int sts, cmplen, haslower;
5226 struct FAB dirfab = cc$rms_fab;
5228 rms_setup_nam(savnam);
5229 rms_setup_nam(dirnam);
5231 /* If we've got an explicit filename, we can just shuffle the string. */
5232 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5233 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5234 if ((cp2 = strchr(cp1,'.')) != NULL) {
5236 if (vms_process_case_tolerant) {
5237 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5238 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5239 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5240 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5241 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5242 (ver || *cp3)))))) {
5245 set_vaxc_errno(RMS$_DIR);
5250 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5251 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5252 !*(cp2+3) || *(cp2+3) != 'R' ||
5253 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5254 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5255 (ver || *cp3)))))) {
5258 set_vaxc_errno(RMS$_DIR);
5263 else { /* No file type, so just draw name into directory part */
5264 for (cp2 = cp1; *cp2; cp2++) ;
5267 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5269 /* We've now got a VMS 'path'; fall through */
5272 dirlen = strlen(trndir);
5273 if (trndir[dirlen-1] == ']' ||
5274 trndir[dirlen-1] == '>' ||
5275 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5276 if (buf) retpath = buf;
5277 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5278 else retpath = __pathify_retbuf;
5279 strcpy(retpath,trndir);
5283 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5284 Newx(esa, VMS_MAXRSS, char);
5285 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5286 rms_bind_fab_nam(dirfab, dirnam);
5287 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5288 #ifdef NAM$M_NO_SHORT_UPCASE
5289 if (decc_efs_case_preserve)
5290 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5293 for (cp = trndir; *cp; cp++)
5294 if (islower(*cp)) { haslower = 1; break; }
5296 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5297 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5298 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5299 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5305 set_vaxc_errno(dirfab.fab$l_sts);
5311 /* Does the file really exist? */
5312 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5313 if (dirfab.fab$l_sts != RMS$_FNF) {
5315 sts1 = rms_free_search_context(&dirfab);
5319 set_vaxc_errno(dirfab.fab$l_sts);
5322 dirnam = savnam; /* No; just work with potential name */
5325 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5326 /* Yep; check version while we're at it, if it's there. */
5327 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5328 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5330 /* Something other than .DIR[;1]. Bzzt. */
5331 sts2 = rms_free_search_context(&dirfab);
5335 set_vaxc_errno(RMS$_DIR);
5339 /* OK, the type was fine. Now pull any file name into the
5341 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5343 cp1 = strrchr(esa,'>');
5344 *(rms_nam_typel(dirnam)) = '>';
5347 *(rms_nam_typel(dirnam) + 1) = '\0';
5348 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5349 if (buf) retpath = buf;
5350 else if (ts) Newx(retpath,retlen,char);
5351 else retpath = __pathify_retbuf;
5352 strcpy(retpath,esa);
5354 sts = rms_free_search_context(&dirfab);
5355 /* $PARSE may have upcased filespec, so convert output to lower
5356 * case if input contained any lowercase characters. */
5357 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5362 } /* end of do_pathify_dirspec() */
5364 /* External entry points */
5365 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5366 { return do_pathify_dirspec(dir,buf,0); }
5367 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5368 { return do_pathify_dirspec(dir,buf,1); }
5370 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5371 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5373 static char __tounixspec_retbuf[VMS_MAXRSS];
5374 char *dirend, *rslt, *cp1, *cp3, tmp[VMS_MAXRSS];
5376 int devlen, dirlen, retlen = VMS_MAXRSS;
5377 int expand = 1; /* guarantee room for leading and trailing slashes */
5378 unsigned short int trnlnm_iter_count;
5381 if (spec == NULL) return NULL;
5382 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5383 if (buf) rslt = buf;
5385 retlen = strlen(spec);
5386 cp1 = strchr(spec,'[');
5387 if (!cp1) cp1 = strchr(spec,'<');
5389 for (cp1++; *cp1; cp1++) {
5390 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
5391 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5392 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5395 Newx(rslt,retlen+2+2*expand,char);
5397 else rslt = __tounixspec_retbuf;
5399 /* New VMS specific format needs translation
5400 * glob passes filenames with trailing '\n' and expects this preserved.
5402 if (decc_posix_compliant_pathnames) {
5403 if (strncmp(spec, "\"^UP^", 5) == 0) {
5409 Newx(tunix, VMS_MAXRSS + 1,char);
5410 strcpy(tunix, spec);
5411 tunix_len = strlen(tunix);
5413 if (tunix[tunix_len - 1] == '\n') {
5414 tunix[tunix_len - 1] = '\"';
5415 tunix[tunix_len] = '\0';
5419 uspec = decc$translate_vms(tunix);
5421 if ((int)uspec > 0) {
5427 /* If we can not translate it, makemaker wants as-is */
5435 cmp_rslt = 0; /* Presume VMS */
5436 cp1 = strchr(spec, '/');
5440 /* Look for EFS ^/ */
5441 if (decc_efs_charset) {
5442 while (cp1 != NULL) {
5445 /* Found illegal VMS, assume UNIX */
5450 cp1 = strchr(cp1, '/');
5454 /* Look for "." and ".." */
5455 if (decc_filename_unix_report) {
5456 if (spec[0] == '.') {
5457 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5461 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5467 /* This is already UNIX or at least nothing VMS understands */
5475 dirend = strrchr(spec,']');
5476 if (dirend == NULL) dirend = strrchr(spec,'>');
5477 if (dirend == NULL) dirend = strchr(spec,':');
5478 if (dirend == NULL) {
5483 /* Special case 1 - sys$posix_root = / */
5484 #if __CRTL_VER >= 70000000
5485 if (!decc_disable_posix_root) {
5486 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5494 /* Special case 2 - Convert NLA0: to /dev/null */
5495 #if __CRTL_VER < 70000000
5496 cmp_rslt = strncmp(spec,"NLA0:", 5);
5498 cmp_rslt = strncmp(spec,"nla0:", 5);
5500 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5502 if (cmp_rslt == 0) {
5503 strcpy(rslt, "/dev/null");
5506 if (spec[6] != '\0') {
5513 /* Also handle special case "SYS$SCRATCH:" */
5514 #if __CRTL_VER < 70000000
5515 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5517 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5519 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5521 if (cmp_rslt == 0) {
5524 islnm = my_trnlnm(tmp, "TMP", 0);
5526 strcpy(rslt, "/tmp");
5529 if (spec[12] != '\0') {
5537 if (*cp2 != '[' && *cp2 != '<') {
5540 else { /* the VMS spec begins with directories */
5542 if (*cp2 == ']' || *cp2 == '>') {
5543 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5546 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5547 if (getcwd(tmp,sizeof tmp,1) == NULL) {
5548 if (ts) Safefree(rslt);
5551 trnlnm_iter_count = 0;
5554 while (*cp3 != ':' && *cp3) cp3++;
5556 if (strchr(cp3,']') != NULL) break;
5557 trnlnm_iter_count++;
5558 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5559 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5561 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5562 retlen = devlen + dirlen;
5563 Renew(rslt,retlen+1+2*expand,char);
5569 *(cp1++) = *(cp3++);
5570 if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
5574 if ((*cp2 == '^')) {
5575 /* EFS file escape, pass the next character as is */
5576 /* Fix me: HEX encoding for UNICODE not implemented */
5579 else if ( *cp2 == '.') {
5580 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5581 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5587 for (; cp2 <= dirend; cp2++) {
5588 if ((*cp2 == '^')) {
5589 /* EFS file escape, pass the next character as is */
5590 /* Fix me: HEX encoding for UNICODE not implemented */
5596 if (*(cp2+1) == '[') cp2++;
5598 else if (*cp2 == ']' || *cp2 == '>') {
5599 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5601 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5603 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5604 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5605 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5606 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5607 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5609 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5610 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5614 else if (*cp2 == '-') {
5615 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5616 while (*cp2 == '-') {
5618 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5620 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5621 if (ts) Safefree(rslt); /* filespecs like */
5622 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5626 else *(cp1++) = *cp2;
5628 else *(cp1++) = *cp2;
5630 while (*cp2) *(cp1++) = *(cp2++);
5633 /* This still leaves /000000/ when working with a
5634 * VMS device root or concealed root.
5640 ulen = strlen(rslt);
5642 /* Get rid of "000000/ in rooted filespecs */
5644 zeros = strstr(rslt, "/000000/");
5645 if (zeros != NULL) {
5647 mlen = ulen - (zeros - rslt) - 7;
5648 memmove(zeros, &zeros[7], mlen);
5657 } /* end of do_tounixspec() */
5659 /* External entry points */
5660 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5661 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5663 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5665 static int posix_to_vmsspec
5666 (char *vmspath, int vmspath_len, const char *unixpath) {
5668 struct FAB myfab = cc$rms_fab;
5669 struct NAML mynam = cc$rms_naml;
5670 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5671 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5677 /* If not a posix spec already, convert it */
5679 unixlen = strlen(unixpath);
5684 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5685 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5688 /* This is already a VMS specification, no conversion */
5690 strncpy(vmspath,unixpath, vmspath_len);
5692 vmspath[vmspath_len] = 0;
5693 if (unixpath[unixlen - 1] == '/')
5695 Newx(esa, VMS_MAXRSS, char);
5696 myfab.fab$l_fna = vmspath;
5697 myfab.fab$b_fns = strlen(vmspath);
5698 myfab.fab$l_naml = &mynam;
5699 mynam.naml$l_esa = NULL;
5700 mynam.naml$b_ess = 0;
5701 mynam.naml$l_long_expand = esa;
5702 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5703 mynam.naml$l_rsa = NULL;
5704 mynam.naml$b_rss = 0;
5705 if (decc_efs_case_preserve)
5706 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5707 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5709 /* Set up the remaining naml fields */
5710 sts = sys$parse(&myfab);
5712 /* It failed! Try again as a UNIX filespec */
5718 /* get the Device ID and the FID */
5719 sts = sys$search(&myfab);
5720 /* on any failure, returned the POSIX ^UP^ filespec */
5725 specdsc.dsc$a_pointer = vmspath;
5726 specdsc.dsc$w_length = vmspath_len;
5728 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5729 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5730 sts = lib$fid_to_name
5731 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5733 /* on any failure, returned the POSIX ^UP^ filespec */
5735 /* This can happen if user does not have permission to read directories */
5736 if (strncmp(unixpath,"\"^UP^",5) != 0)
5737 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5739 strcpy(vmspath, unixpath);
5742 vmspath[specdsc.dsc$w_length] = 0;
5744 /* Are we expecting a directory? */
5745 if (dir_flag != 0) {
5751 i = specdsc.dsc$w_length - 1;
5755 /* Version must be '1' */
5756 if (vmspath[i--] != '1')
5758 /* Version delimiter is one of ".;" */
5759 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5762 if (vmspath[i--] != 'R')
5764 if (vmspath[i--] != 'I')
5766 if (vmspath[i--] != 'D')
5768 if (vmspath[i--] != '.')
5770 eptr = &vmspath[i+1];
5772 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5773 if (vmspath[i-1] != '^') {
5781 /* Get rid of 6 imaginary zero directory filename */
5782 vmspath[i+1] = '\0';
5786 if (vmspath[i] == '0')
5800 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5801 static int posix_to_vmsspec_hardway
5802 (char *vmspath, int vmspath_len, const char *unixpath) {
5805 const char *unixptr;
5807 const char *lastslash;
5808 const char *lastdot;
5819 /* Ignore leading "/" characters */
5820 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5823 unixlen = strlen(unixptr);
5825 /* Do nothing with blank paths */
5831 lastslash = strrchr(unixptr,'/');
5832 lastdot = strrchr(unixptr,'.');
5835 /* last dot is last dot or past end of string */
5836 if (lastdot == NULL)
5837 lastdot = unixptr + unixlen;
5839 /* if no directories, set last slash to beginning of string */
5840 if (lastslash == NULL) {
5841 lastslash = unixptr;
5844 /* Watch out for trailing "." after last slash, still a directory */
5845 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5846 lastslash = unixptr + unixlen;
5849 /* Watch out for traiing ".." after last slash, still a directory */
5850 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5851 lastslash = unixptr + unixlen;
5854 /* dots in directories are aways escaped */
5855 if (lastdot < lastslash)
5856 lastdot = unixptr + unixlen;
5859 /* if (unixptr < lastslash) then we are in a directory */
5867 /* This could have a "^UP^ on the front */
5868 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5873 /* Start with the UNIX path */
5874 if (*unixptr != '/') {
5875 /* relative paths */
5876 if (lastslash > unixptr) {
5879 /* skip leading ./ */
5881 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5887 /* Are we still in a directory? */
5888 if (unixptr <= lastslash) {
5893 /* if not backing up, then it is relative forward. */
5894 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5895 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5903 /* Perl wants an empty directory here to tell the difference
5904 * between a DCL commmand and a filename
5913 /* Handle two special files . and .. */
5914 if (unixptr[0] == '.') {
5915 if (unixptr[1] == '\0') {
5922 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5933 else { /* Absolute PATH handling */
5937 /* Need to find out where root is */
5939 /* In theory, this procedure should never get an absolute POSIX pathname
5940 * that can not be found on the POSIX root.
5941 * In practice, that can not be relied on, and things will show up
5942 * here that are a VMS device name or concealed logical name instead.
5943 * So to make things work, this procedure must be tolerant.
5945 Newx(esa, vmspath_len, char);
5948 nextslash = strchr(&unixptr[1],'/');
5950 if (nextslash != NULL) {
5951 seg_len = nextslash - &unixptr[1];
5952 strncpy(vmspath, unixptr, seg_len + 1);
5953 vmspath[seg_len+1] = 0;
5954 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5958 /* This is verified to be a real path */
5960 sts = posix_to_vmsspec(esa, vmspath_len, "/");
5961 strcpy(vmspath, esa);
5962 vmslen = strlen(vmspath);
5963 vmsptr = vmspath + vmslen;
5965 if (unixptr < lastslash) {
5974 cmp = strcmp(rptr,"000000.");
5979 } /* removing 6 zeros */
5980 } /* vmslen < 7, no 6 zeros possible */
5981 } /* Not in a directory */
5982 } /* end of verified real path handling */
5987 /* Ok, we have a device or a concealed root that is not in POSIX
5988 * or we have garbage. Make the best of it.
5991 /* Posix to VMS destroyed this, so copy it again */
5992 strncpy(vmspath, &unixptr[1], seg_len);
5993 vmspath[seg_len] = 0;
5995 vmsptr = &vmsptr[vmslen];
5998 /* Now do we need to add the fake 6 zero directory to it? */
6000 if ((*lastslash == '/') && (nextslash < lastslash)) {
6001 /* No there is another directory */
6007 /* now we have foo:bar or foo:[000000]bar to decide from */
6008 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6009 trnend = islnm ? islnm - 1 : 0;
6011 /* if this was a logical name, ']' or '>' must be present */
6012 /* if not a logical name, then assume a device and hope. */
6013 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6015 /* if log name and trailing '.' then rooted - treat as device */
6016 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6018 /* Fix me, if not a logical name, a device lookup should be
6019 * done to see if the device is file structured. If the device
6020 * is not file structured, the 6 zeros should not be put on.
6022 * As it is, perl is occasionally looking for dev:[000000]tty.
6023 * which looks a little strange.
6026 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
6027 /* No real directory present */
6032 /* Put the device delimiter on */
6035 unixptr = nextslash;
6038 /* Start directory if needed */
6039 if (!islnm || add_6zero) {
6045 /* add fake 000000] if needed */
6058 } /* non-POSIX translation */
6060 } /* End of relative/absolute path handling */
6062 while ((*unixptr) && (vmslen < vmspath_len)){
6067 if (dir_start != 0) {
6069 /* First characters in a directory are handled special */
6070 while ((*unixptr == '/') ||
6071 ((*unixptr == '.') &&
6072 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6077 /* Skip redundant / in specification */
6078 while ((*unixptr == '/') && (dir_start != 0)) {
6081 if (unixptr == lastslash)
6084 if (unixptr == lastslash)
6087 /* Skip redundant ./ characters */
6088 while ((*unixptr == '.') &&
6089 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6092 if (unixptr == lastslash)
6094 if (*unixptr == '/')
6097 if (unixptr == lastslash)
6100 /* Skip redundant ../ characters */
6101 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6102 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6103 /* Set the backing up flag */
6109 unixptr++; /* first . */
6110 unixptr++; /* second . */
6111 if (unixptr == lastslash)
6113 if (*unixptr == '/') /* The slash */
6116 if (unixptr == lastslash)
6119 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6120 /* Not needed when VMS is pretending to be UNIX. */
6122 /* Is this loop stuck because of too many dots? */
6123 if (loop_flag == 0) {
6124 /* Exit the loop and pass the rest through */
6129 /* Are we done with directories yet? */
6130 if (unixptr >= lastslash) {
6132 /* Watch out for trailing dots */
6141 if (*unixptr == '/')
6145 /* Have we stopped backing up? */
6150 /* dir_start continues to be = 1 */
6152 if (*unixptr == '-') {
6154 *vmsptr++ = *unixptr++;
6158 /* Now are we done with directories yet? */
6159 if (unixptr >= lastslash) {
6161 /* Watch out for trailing dots */
6177 if (*unixptr == '\0')
6180 /* Normal characters - More EFS work probably needed */
6186 /* remove multiple / */
6187 while (unixptr[1] == '/') {
6190 if (unixptr == lastslash) {
6191 /* Watch out for trailing dots */
6203 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6204 /* Not needed when VMS is pretending to be UNIX. */
6208 if (*unixptr != '\0')
6224 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6230 /* trailing dot ==> '^..' on VMS */
6231 if (*unixptr == '\0') {
6235 *vmsptr++ = *unixptr++;
6238 if (quoted && (unixptr[1] == '\0')) {
6243 *vmsptr++ = *unixptr++;
6250 *vmsptr++ = *unixptr++;
6254 if (*unixptr != '\0') {
6255 *vmsptr++ = *unixptr++;
6262 /* Make sure directory is closed */
6263 if (unixptr == lastslash) {
6265 vmsptr2 = vmsptr - 1;
6267 if (*vmsptr2 != ']') {
6270 /* directories do not end in a dot bracket */
6271 if (*vmsptr2 == '.') {
6275 if (*vmsptr2 != '^') {
6276 vmsptr--; /* back up over the dot */
6284 /* Add a trailing dot if a file with no extension */
6285 vmsptr2 = vmsptr - 1;
6286 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6287 (*lastdot != '.')) {
6298 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6299 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6300 static char __tovmsspec_retbuf[VMS_MAXRSS];
6301 char *rslt, *dirend;
6306 unsigned long int infront = 0, hasdir = 1;
6310 if (path == NULL) return NULL;
6311 rslt_len = VMS_MAXRSS;
6312 if (buf) rslt = buf;
6313 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6314 else rslt = __tovmsspec_retbuf;
6315 if (strpbrk(path,"]:>") ||
6316 (dirend = strrchr(path,'/')) == NULL) {
6317 if (path[0] == '.') {
6318 if (path[1] == '\0') strcpy(rslt,"[]");
6319 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6320 else strcpy(rslt,path); /* probably garbage */
6322 else strcpy(rslt,path);
6326 /* Posix specifications are now a native VMS format */
6327 /*--------------------------------------------------*/
6328 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6329 if (decc_posix_compliant_pathnames) {
6330 if (strncmp(path,"\"^UP^",5) == 0) {
6331 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6337 vms_delim = strpbrk(path,"]:>");
6339 if ((vms_delim != NULL) ||
6340 ((dirend = strrchr(path,'/')) == NULL)) {
6342 /* VMS special characters found! */
6344 if (path[0] == '.') {
6345 if (path[1] == '\0') strcpy(rslt,"[]");
6346 else if (path[1] == '.' && path[2] == '\0')
6349 /* Dot preceeding a device or directory ? */
6351 /* If not in POSIX mode, pass it through and hope it works */
6352 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6353 if (!decc_posix_compliant_pathnames)
6354 strcpy(rslt,path); /* probably garbage */
6356 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6358 strcpy(rslt,path); /* probably garbage */
6364 /* If no VMS characters and in POSIX mode, convert it!
6365 * This is the easiest way to get directory specifications
6366 * handled correctly in POSIX mode
6368 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6369 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6370 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6372 /* No unix path separators - presume VMS already */
6376 strcpy(rslt,path); /* probably garbage */
6382 /* If POSIX mode active, handle the conversion */
6383 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6384 if (decc_posix_compliant_pathnames) {
6385 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6390 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
6391 if (!*(dirend+2)) dirend +=2;
6392 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6393 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6398 lastdot = strrchr(cp2,'.');
6404 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6406 if (decc_disable_posix_root) {
6407 strcpy(rslt,"sys$disk:[000000]");
6410 strcpy(rslt,"sys$posix_root:[000000]");
6414 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6416 Newx(trndev, VMS_MAXRSS, char);
6417 islnm = my_trnlnm(rslt,trndev,0);
6419 /* DECC special handling */
6421 if (strcmp(rslt,"bin") == 0) {
6422 strcpy(rslt,"sys$system");
6425 islnm = my_trnlnm(rslt,trndev,0);
6427 else if (strcmp(rslt,"tmp") == 0) {
6428 strcpy(rslt,"sys$scratch");
6431 islnm = my_trnlnm(rslt,trndev,0);
6433 else if (!decc_disable_posix_root) {
6434 strcpy(rslt, "sys$posix_root");
6438 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6439 islnm = my_trnlnm(rslt,trndev,0);
6441 else if (strcmp(rslt,"dev") == 0) {
6442 if (strncmp(cp2,"/null", 5) == 0) {
6443 if ((cp2[5] == 0) || (cp2[5] == '/')) {
6444 strcpy(rslt,"NLA0");
6448 islnm = my_trnlnm(rslt,trndev,0);
6454 trnend = islnm ? strlen(trndev) - 1 : 0;
6455 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6456 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6457 /* If the first element of the path is a logical name, determine
6458 * whether it has to be translated so we can add more directories. */
6459 if (!islnm || rooted) {
6462 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6466 if (cp2 != dirend) {
6467 strcpy(rslt,trndev);
6468 cp1 = rslt + trnend;
6475 if (decc_disable_posix_root) {
6486 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6487 cp2 += 2; /* skip over "./" - it's redundant */
6488 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
6490 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6491 *(cp1++) = '-'; /* "../" --> "-" */
6494 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6495 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6496 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6497 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6500 else if ((cp2 != lastdot) || (lastdot < dirend)) {
6501 /* Escape the extra dots in EFS file specifications */
6504 if (cp2 > dirend) cp2 = dirend;
6506 else *(cp1++) = '.';
6508 for (; cp2 < dirend; cp2++) {
6510 if (*(cp2-1) == '/') continue;
6511 if (*(cp1-1) != '.') *(cp1++) = '.';
6514 else if (!infront && *cp2 == '.') {
6515 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6516 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
6517 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6518 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6519 else if (*(cp1-2) == '[') *(cp1-1) = '-';
6520 else { /* back up over previous directory name */
6522 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6523 if (*(cp1-1) == '[') {
6524 memcpy(cp1,"000000.",7);
6529 if (cp2 == dirend) break;
6531 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6532 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6533 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6534 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6536 *(cp1++) = '.'; /* Simulate trailing '/' */
6537 cp2 += 2; /* for loop will incr this to == dirend */
6539 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
6542 if (decc_efs_charset == 0)
6543 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
6545 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
6551 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
6553 if (decc_efs_charset == 0)
6560 else *(cp1++) = *cp2;
6564 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6565 if (hasdir) *(cp1++) = ']';
6566 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
6567 /* fixme for ODS5 */
6582 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6583 decc_readdir_dropdotnotype) {
6588 /* trailing dot ==> '^..' on VMS */
6595 *(cp1++) = *(cp2++);
6623 *(cp1++) = *(cp2++);
6626 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6627 * which is wrong. UNIX notation should be ".dir." unless
6628 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6629 * changing this behavior could break more things at this time.
6630 * efs character set effectively does not allow "." to be a version
6631 * delimiter as a further complication about changing this.
6633 if (decc_filename_unix_report != 0) {
6636 *(cp1++) = *(cp2++);
6639 *(cp1++) = *(cp2++);
6642 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6646 /* Fix me for "^]", but that requires making sure that you do
6647 * not back up past the start of the filename
6649 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6656 } /* end of do_tovmsspec() */
6658 /* External entry points */
6659 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6660 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6662 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6663 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6664 static char __tovmspath_retbuf[VMS_MAXRSS];
6666 char *pathified, *vmsified, *cp;
6668 if (path == NULL) return NULL;
6669 Newx(pathified, VMS_MAXRSS, char);
6670 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6671 Safefree(pathified);
6674 Newx(vmsified, VMS_MAXRSS, char);
6675 if (do_tovmsspec(pathified,buf ? buf : vmsified,0) == NULL) {
6676 Safefree(pathified);
6680 Safefree(pathified);
6686 vmslen = strlen(vmsified);
6687 Newx(cp,vmslen+1,char);
6688 memcpy(cp,vmsified,vmslen);
6694 strcpy(__tovmspath_retbuf,vmsified);
6696 return __tovmspath_retbuf;
6699 } /* end of do_tovmspath() */
6701 /* External entry points */
6702 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6703 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6706 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6707 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6708 static char __tounixpath_retbuf[VMS_MAXRSS];
6710 char *pathified, *unixified, *cp;
6712 if (path == NULL) return NULL;
6713 Newx(pathified, VMS_MAXRSS, char);
6714 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6715 Safefree(pathified);
6718 Newx(unixified, VMS_MAXRSS, char);
6719 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6720 Safefree(pathified);
6721 Safefree(unixified);
6724 Safefree(pathified);
6726 Safefree(unixified);
6730 unixlen = strlen(unixified);
6731 Newx(cp,unixlen+1,char);
6732 memcpy(cp,unixified,unixlen);
6734 Safefree(unixified);
6738 strcpy(__tounixpath_retbuf,unixified);
6739 Safefree(unixified);
6740 return __tounixpath_retbuf;
6743 } /* end of do_tounixpath() */
6745 /* External entry points */
6746 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6747 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6750 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
6752 *****************************************************************************
6754 * Copyright (C) 1989-1994 by *
6755 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
6757 * Permission is hereby granted for the reproduction of this software, *
6758 * on condition that this copyright notice is included in the reproduction, *
6759 * and that such reproduction is not for purposes of profit or material *
6762 * 27-Aug-1994 Modified for inclusion in perl5 *
6763 * by Charles Bailey bailey@newman.upenn.edu *
6764 *****************************************************************************
6768 * getredirection() is intended to aid in porting C programs
6769 * to VMS (Vax-11 C). The native VMS environment does not support
6770 * '>' and '<' I/O redirection, or command line wild card expansion,
6771 * or a command line pipe mechanism using the '|' AND background
6772 * command execution '&'. All of these capabilities are provided to any
6773 * C program which calls this procedure as the first thing in the
6775 * The piping mechanism will probably work with almost any 'filter' type
6776 * of program. With suitable modification, it may useful for other
6777 * portability problems as well.
6779 * Author: Mark Pizzolato mark@infocomm.com
6783 struct list_item *next;
6787 static void add_item(struct list_item **head,
6788 struct list_item **tail,
6792 static void mp_expand_wild_cards(pTHX_ char *item,
6793 struct list_item **head,
6794 struct list_item **tail,
6797 static int background_process(pTHX_ int argc, char **argv);
6799 static void pipe_and_fork(pTHX_ char **cmargv);
6801 /*{{{ void getredirection(int *ac, char ***av)*/
6803 mp_getredirection(pTHX_ int *ac, char ***av)
6805 * Process vms redirection arg's. Exit if any error is seen.
6806 * If getredirection() processes an argument, it is erased
6807 * from the vector. getredirection() returns a new argc and argv value.
6808 * In the event that a background command is requested (by a trailing "&"),
6809 * this routine creates a background subprocess, and simply exits the program.
6811 * Warning: do not try to simplify the code for vms. The code
6812 * presupposes that getredirection() is called before any data is
6813 * read from stdin or written to stdout.
6815 * Normal usage is as follows:
6821 * getredirection(&argc, &argv);
6825 int argc = *ac; /* Argument Count */
6826 char **argv = *av; /* Argument Vector */
6827 char *ap; /* Argument pointer */
6828 int j; /* argv[] index */
6829 int item_count = 0; /* Count of Items in List */
6830 struct list_item *list_head = 0; /* First Item in List */
6831 struct list_item *list_tail; /* Last Item in List */
6832 char *in = NULL; /* Input File Name */
6833 char *out = NULL; /* Output File Name */
6834 char *outmode = "w"; /* Mode to Open Output File */
6835 char *err = NULL; /* Error File Name */
6836 char *errmode = "w"; /* Mode to Open Error File */
6837 int cmargc = 0; /* Piped Command Arg Count */
6838 char **cmargv = NULL;/* Piped Command Arg Vector */
6841 * First handle the case where the last thing on the line ends with
6842 * a '&'. This indicates the desire for the command to be run in a
6843 * subprocess, so we satisfy that desire.
6846 if (0 == strcmp("&", ap))
6847 exit(background_process(aTHX_ --argc, argv));
6848 if (*ap && '&' == ap[strlen(ap)-1])
6850 ap[strlen(ap)-1] = '\0';
6851 exit(background_process(aTHX_ argc, argv));
6854 * Now we handle the general redirection cases that involve '>', '>>',
6855 * '<', and pipes '|'.
6857 for (j = 0; j < argc; ++j)
6859 if (0 == strcmp("<", argv[j]))
6863 fprintf(stderr,"No input file after < on command line");
6864 exit(LIB$_WRONUMARG);
6869 if ('<' == *(ap = argv[j]))
6874 if (0 == strcmp(">", ap))
6878 fprintf(stderr,"No output file after > on command line");
6879 exit(LIB$_WRONUMARG);
6898 fprintf(stderr,"No output file after > or >> on command line");
6899 exit(LIB$_WRONUMARG);
6903 if (('2' == *ap) && ('>' == ap[1]))
6920 fprintf(stderr,"No output file after 2> or 2>> on command line");
6921 exit(LIB$_WRONUMARG);
6925 if (0 == strcmp("|", argv[j]))
6929 fprintf(stderr,"No command into which to pipe on command line");
6930 exit(LIB$_WRONUMARG);
6932 cmargc = argc-(j+1);
6933 cmargv = &argv[j+1];
6937 if ('|' == *(ap = argv[j]))
6945 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6948 * Allocate and fill in the new argument vector, Some Unix's terminate
6949 * the list with an extra null pointer.
6951 Newx(argv, item_count+1, char *);
6952 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6954 for (j = 0; j < item_count; ++j, list_head = list_head->next)
6955 argv[j] = list_head->value;
6961 fprintf(stderr,"'|' and '>' may not both be specified on command line");
6962 exit(LIB$_INVARGORD);
6964 pipe_and_fork(aTHX_ cmargv);
6967 /* Check for input from a pipe (mailbox) */
6969 if (in == NULL && 1 == isapipe(0))
6971 char mbxname[L_tmpnam];
6973 long int dvi_item = DVI$_DEVBUFSIZ;
6974 $DESCRIPTOR(mbxnam, "");
6975 $DESCRIPTOR(mbxdevnam, "");
6977 /* Input from a pipe, reopen it in binary mode to disable */
6978 /* carriage control processing. */
6980 fgetname(stdin, mbxname);
6981 mbxnam.dsc$a_pointer = mbxname;
6982 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6983 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6984 mbxdevnam.dsc$a_pointer = mbxname;
6985 mbxdevnam.dsc$w_length = sizeof(mbxname);
6986 dvi_item = DVI$_DEVNAM;
6987 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6988 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6991 freopen(mbxname, "rb", stdin);
6994 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6998 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7000 fprintf(stderr,"Can't open input file %s as stdin",in);
7003 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7005 fprintf(stderr,"Can't open output file %s as stdout",out);
7008 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7011 if (strcmp(err,"&1") == 0) {
7012 dup2(fileno(stdout), fileno(stderr));
7013 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7016 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7018 fprintf(stderr,"Can't open error file %s as stderr",err);
7022 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7026 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7029 #ifdef ARGPROC_DEBUG
7030 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7031 for (j = 0; j < *ac; ++j)
7032 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7034 /* Clear errors we may have hit expanding wildcards, so they don't
7035 show up in Perl's $! later */
7036 set_errno(0); set_vaxc_errno(1);
7037 } /* end of getredirection() */
7040 static void add_item(struct list_item **head,
7041 struct list_item **tail,
7047 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7051 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7052 *tail = (*tail)->next;
7054 (*tail)->value = value;
7058 static void mp_expand_wild_cards(pTHX_ char *item,
7059 struct list_item **head,
7060 struct list_item **tail,
7064 unsigned long int context = 0;
7072 $DESCRIPTOR(filespec, "");
7073 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7074 $DESCRIPTOR(resultspec, "");
7075 unsigned long int lff_flags = 0;
7078 #ifdef VMS_LONGNAME_SUPPORT
7079 lff_flags = LIB$M_FIL_LONG_NAMES;
7082 for (cp = item; *cp; cp++) {
7083 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7084 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7086 if (!*cp || isspace(*cp))
7088 add_item(head, tail, item, count);
7093 /* "double quoted" wild card expressions pass as is */
7094 /* From DCL that means using e.g.: */
7095 /* perl program """perl.*""" */
7096 item_len = strlen(item);
7097 if ( '"' == *item && '"' == item[item_len-1] )
7100 item[item_len-2] = '\0';
7101 add_item(head, tail, item, count);
7105 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7106 resultspec.dsc$b_class = DSC$K_CLASS_D;
7107 resultspec.dsc$a_pointer = NULL;
7108 Newx(vmsspec, VMS_MAXRSS, char);
7109 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7110 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7111 if (!isunix || !filespec.dsc$a_pointer)
7112 filespec.dsc$a_pointer = item;
7113 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7115 * Only return version specs, if the caller specified a version
7117 had_version = strchr(item, ';');
7119 * Only return device and directory specs, if the caller specifed either.
7121 had_device = strchr(item, ':');
7122 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7124 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7125 (&filespec, &resultspec, &context,
7126 &defaultspec, 0, 0, &lff_flags)))
7131 Newx(string,resultspec.dsc$w_length+1,char);
7132 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7133 string[resultspec.dsc$w_length] = '\0';
7134 if (NULL == had_version)
7135 *(strrchr(string, ';')) = '\0';
7136 if ((!had_directory) && (had_device == NULL))
7138 if (NULL == (devdir = strrchr(string, ']')))
7139 devdir = strrchr(string, '>');
7140 strcpy(string, devdir + 1);
7143 * Be consistent with what the C RTL has already done to the rest of
7144 * the argv items and lowercase all of these names.
7146 if (!decc_efs_case_preserve) {
7147 for (c = string; *c; ++c)
7151 if (isunix) trim_unixpath(string,item,1);
7152 add_item(head, tail, string, count);
7156 if (sts != RMS$_NMF)
7158 set_vaxc_errno(sts);
7161 case RMS$_FNF: case RMS$_DNF:
7162 set_errno(ENOENT); break;
7164 set_errno(ENOTDIR); break;
7166 set_errno(ENODEV); break;
7167 case RMS$_FNM: case RMS$_SYN:
7168 set_errno(EINVAL); break;
7170 set_errno(EACCES); break;
7172 _ckvmssts_noperl(sts);
7176 add_item(head, tail, item, count);
7177 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7178 _ckvmssts_noperl(lib$find_file_end(&context));
7181 static int child_st[2];/* Event Flag set when child process completes */
7183 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
7185 static unsigned long int exit_handler(int *status)
7189 if (0 == child_st[0])
7191 #ifdef ARGPROC_DEBUG
7192 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7194 fflush(stdout); /* Have to flush pipe for binary data to */
7195 /* terminate properly -- <tp@mccall.com> */
7196 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7197 sys$dassgn(child_chan);
7199 sys$synch(0, child_st);
7204 static void sig_child(int chan)
7206 #ifdef ARGPROC_DEBUG
7207 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7209 if (child_st[0] == 0)
7213 static struct exit_control_block exit_block =
7218 &exit_block.exit_status,
7223 pipe_and_fork(pTHX_ char **cmargv)
7226 struct dsc$descriptor_s *vmscmd;
7227 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7228 int sts, j, l, ismcr, quote, tquote = 0;
7230 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
7231 vms_execfree(vmscmd);
7236 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7237 && toupper(*(q+2)) == 'R' && !*(q+3);
7239 while (q && l < MAX_DCL_LINE_LENGTH) {
7241 if (j > 0 && quote) {
7247 if (ismcr && j > 1) quote = 1;
7248 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7251 if (quote || tquote) {
7257 if ((quote||tquote) && *q == '"') {
7267 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7269 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7273 static int background_process(pTHX_ int argc, char **argv)
7275 char command[MAX_DCL_SYMBOL + 1] = "$";
7276 $DESCRIPTOR(value, "");
7277 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7278 static $DESCRIPTOR(null, "NLA0:");
7279 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7281 $DESCRIPTOR(pidstr, "");
7283 unsigned long int flags = 17, one = 1, retsts;
7286 strcat(command, argv[0]);
7287 len = strlen(command);
7288 while (--argc && (len < MAX_DCL_SYMBOL))
7290 strcat(command, " \"");
7291 strcat(command, *(++argv));
7292 strcat(command, "\"");
7293 len = strlen(command);
7295 value.dsc$a_pointer = command;
7296 value.dsc$w_length = strlen(value.dsc$a_pointer);
7297 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7298 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7299 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7300 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7303 _ckvmssts_noperl(retsts);
7305 #ifdef ARGPROC_DEBUG
7306 PerlIO_printf(Perl_debug_log, "%s\n", command);
7308 sprintf(pidstring, "%08X", pid);
7309 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7310 pidstr.dsc$a_pointer = pidstring;
7311 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7312 lib$set_symbol(&pidsymbol, &pidstr);
7316 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7319 /* OS-specific initialization at image activation (not thread startup) */
7320 /* Older VAXC header files lack these constants */
7321 #ifndef JPI$_RIGHTS_SIZE
7322 # define JPI$_RIGHTS_SIZE 817
7324 #ifndef KGB$M_SUBSYSTEM
7325 # define KGB$M_SUBSYSTEM 0x8
7328 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7330 /*{{{void vms_image_init(int *, char ***)*/
7332 vms_image_init(int *argcp, char ***argvp)
7334 char eqv[LNM$C_NAMLENGTH+1] = "";
7335 unsigned int len, tabct = 8, tabidx = 0;
7336 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7337 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7338 unsigned short int dummy, rlen;
7339 struct dsc$descriptor_s **tabvec;
7340 #if defined(PERL_IMPLICIT_CONTEXT)
7343 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
7344 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
7345 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7348 #ifdef KILL_BY_SIGPRC
7349 Perl_csighandler_init();
7352 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7353 _ckvmssts_noperl(iosb[0]);
7354 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7355 if (iprv[i]) { /* Running image installed with privs? */
7356 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
7361 /* Rights identifiers might trigger tainting as well. */
7362 if (!will_taint && (rlen || rsz)) {
7363 while (rlen < rsz) {
7364 /* We didn't get all the identifiers on the first pass. Allocate a
7365 * buffer much larger than $GETJPI wants (rsz is size in bytes that
7366 * were needed to hold all identifiers at time of last call; we'll
7367 * allocate that many unsigned long ints), and go back and get 'em.
7368 * If it gave us less than it wanted to despite ample buffer space,
7369 * something's broken. Is your system missing a system identifier?
7371 if (rsz <= jpilist[1].buflen) {
7372 /* Perl_croak accvios when used this early in startup. */
7373 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7374 rsz, (unsigned long) jpilist[1].buflen,
7375 "Check your rights database for corruption.\n");
7378 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7379 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7380 jpilist[1].buflen = rsz * sizeof(unsigned long int);
7381 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7382 _ckvmssts_noperl(iosb[0]);
7384 mask = jpilist[1].bufadr;
7385 /* Check attribute flags for each identifier (2nd longword); protected
7386 * subsystem identifiers trigger tainting.
7388 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7389 if (mask[i] & KGB$M_SUBSYSTEM) {
7394 if (mask != rlst) Safefree(mask);
7397 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7398 * logical, some versions of the CRTL will add a phanthom /000000/
7399 * directory. This needs to be removed.
7401 if (decc_filename_unix_report) {
7404 ulen = strlen(argvp[0][0]);
7406 zeros = strstr(argvp[0][0], "/000000/");
7407 if (zeros != NULL) {
7409 mlen = ulen - (zeros - argvp[0][0]) - 7;
7410 memmove(zeros, &zeros[7], mlen);
7412 argvp[0][0][ulen] = '\0';
7415 /* It also may have a trailing dot that needs to be removed otherwise
7416 * it will be converted to VMS mode incorrectly.
7419 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7420 argvp[0][0][ulen] = '\0';
7423 /* We need to use this hack to tell Perl it should run with tainting,
7424 * since its tainting flag may be part of the PL_curinterp struct, which
7425 * hasn't been allocated when vms_image_init() is called.
7428 char **newargv, **oldargv;
7430 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7431 newargv[0] = oldargv[0];
7432 newargv[1] = (char *) PerlMem_malloc(3 * sizeof(char));
7433 strcpy(newargv[1], "-T");
7434 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7436 newargv[*argcp] = NULL;
7437 /* We orphan the old argv, since we don't know where it's come from,
7438 * so we don't know how to free it.
7442 else { /* Did user explicitly request tainting? */
7444 char *cp, **av = *argvp;
7445 for (i = 1; i < *argcp; i++) {
7446 if (*av[i] != '-') break;
7447 for (cp = av[i]+1; *cp; cp++) {
7448 if (*cp == 'T') { will_taint = 1; break; }
7449 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7450 strchr("DFIiMmx",*cp)) break;
7452 if (will_taint) break;
7457 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7459 if (!tabidx) tabvec = (struct dsc$descriptor_s **) PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7460 else if (tabidx >= tabct) {
7462 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7464 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7465 tabvec[tabidx]->dsc$w_length = 0;
7466 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
7467 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
7468 tabvec[tabidx]->dsc$a_pointer = NULL;
7469 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7471 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7473 getredirection(argcp,argvp);
7474 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7476 # include <reentrancy.h>
7477 decc$set_reentrancy(C$C_MULTITHREAD);
7486 * Trim Unix-style prefix off filespec, so it looks like what a shell
7487 * glob expansion would return (i.e. from specified prefix on, not
7488 * full path). Note that returned filespec is Unix-style, regardless
7489 * of whether input filespec was VMS-style or Unix-style.
7491 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7492 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
7493 * vector of options; at present, only bit 0 is used, and if set tells
7494 * trim unixpath to try the current default directory as a prefix when
7495 * presented with a possibly ambiguous ... wildcard.
7497 * Returns !=0 on success, with trimmed filespec replacing contents of
7498 * fspec, and 0 on failure, with contents of fpsec unchanged.
7500 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7502 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7504 char *unixified, *unixwild,
7505 *template, *base, *end, *cp1, *cp2;
7506 register int tmplen, reslen = 0, dirs = 0;
7508 Newx(unixwild, VMS_MAXRSS, char);
7509 if (!wildspec || !fspec) return 0;
7510 template = unixwild;
7511 if (strpbrk(wildspec,"]>:") != NULL) {
7512 if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7518 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7519 unixwild[VMS_MAXRSS-1] = 0;
7521 Newx(unixified, VMS_MAXRSS, char);
7522 if (strpbrk(fspec,"]>:") != NULL) {
7523 if (do_tounixspec(fspec,unixified,0) == NULL) {
7525 Safefree(unixified);
7528 else base = unixified;
7529 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7530 * check to see that final result fits into (isn't longer than) fspec */
7531 reslen = strlen(fspec);
7535 /* No prefix or absolute path on wildcard, so nothing to remove */
7536 if (!*template || *template == '/') {
7538 if (base == fspec) {
7539 Safefree(unixified);
7542 tmplen = strlen(unixified);
7543 if (tmplen > reslen) {
7544 Safefree(unixified);
7545 return 0; /* not enough space */
7547 /* Copy unixified resultant, including trailing NUL */
7548 memmove(fspec,unixified,tmplen+1);
7549 Safefree(unixified);
7553 for (end = base; *end; end++) ; /* Find end of resultant filespec */
7554 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7555 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7556 for (cp1 = end ;cp1 >= base; cp1--)
7557 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7559 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7560 Safefree(unixified);
7566 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7567 int ells = 1, totells, segdirs, match;
7568 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7569 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7571 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7573 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7574 Newx(tpl, VMS_MAXRSS, char);
7575 if (ellipsis == template && opts & 1) {
7576 /* Template begins with an ellipsis. Since we can't tell how many
7577 * directory names at the front of the resultant to keep for an
7578 * arbitrary starting point, we arbitrarily choose the current
7579 * default directory as a starting point. If it's there as a prefix,
7580 * clip it off. If not, fall through and act as if the leading
7581 * ellipsis weren't there (i.e. return shortest possible path that
7582 * could match template).
7584 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7586 Safefree(unixified);
7590 if (!decc_efs_case_preserve) {
7591 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7592 if (_tolower(*cp1) != _tolower(*cp2)) break;
7594 segdirs = dirs - totells; /* Min # of dirs we must have left */
7595 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7596 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7597 memmove(fspec,cp2+1,end - cp2);
7598 Safefree(unixified);
7604 /* First off, back up over constant elements at end of path */
7606 for (front = end ; front >= base; front--)
7607 if (*front == '/' && !dirs--) { front++; break; }
7609 Newx(lcres, VMS_MAXRSS, char);
7610 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7612 if (!decc_efs_case_preserve) {
7613 *cp2 = _tolower(*cp1); /* Make lc copy for match */
7620 Safefree(unixified);
7624 return 0; /* Path too long. */
7627 *cp2 = '\0'; /* Pick up with memcpy later */
7628 lcfront = lcres + (front - base);
7629 /* Now skip over each ellipsis and try to match the path in front of it. */
7631 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7632 if (*(cp1) == '.' && *(cp1+1) == '.' &&
7633 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
7634 if (cp1 < template) break; /* template started with an ellipsis */
7635 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7636 ellipsis = cp1; continue;
7638 wilddsc.dsc$a_pointer = tpl;
7639 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7641 for (segdirs = 0, cp2 = tpl;
7642 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7644 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7646 if (!decc_efs_case_preserve) {
7647 *cp2 = _tolower(*cp1); /* else lowercase for match */
7650 *cp2 = *cp1; /* else preserve case for match */
7653 if (*cp2 == '/') segdirs++;
7655 if (cp1 != ellipsis - 1) {
7656 Safefree(unixified);
7660 return 0; /* Path too long */
7662 /* Back up at least as many dirs as in template before matching */
7663 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7664 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7665 for (match = 0; cp1 > lcres;) {
7666 resdsc.dsc$a_pointer = cp1;
7667 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7669 if (match == 1) lcfront = cp1;
7671 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7674 Safefree(unixified);
7678 return 0; /* Can't find prefix ??? */
7680 if (match > 1 && opts & 1) {
7681 /* This ... wildcard could cover more than one set of dirs (i.e.
7682 * a set of similar dir names is repeated). If the template
7683 * contains more than 1 ..., upstream elements could resolve the
7684 * ambiguity, but it's not worth a full backtracking setup here.
7685 * As a quick heuristic, clip off the current default directory
7686 * if it's present to find the trimmed spec, else use the
7687 * shortest string that this ... could cover.
7689 char def[NAM$C_MAXRSS+1], *st;
7691 if (getcwd(def, sizeof def,0) == NULL) {
7692 Safefree(unixified);
7698 if (!decc_efs_case_preserve) {
7699 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7700 if (_tolower(*cp1) != _tolower(*cp2)) break;
7702 segdirs = dirs - totells; /* Min # of dirs we must have left */
7703 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7704 if (*cp1 == '\0' && *cp2 == '/') {
7705 memmove(fspec,cp2+1,end - cp2);
7707 Safefree(unixified);
7712 /* Nope -- stick with lcfront from above and keep going. */
7715 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7716 Safefree(unixified);
7724 } /* end of trim_unixpath() */
7729 * VMS readdir() routines.
7730 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7732 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
7733 * Minor modifications to original routines.
7736 /* readdir may have been redefined by reentr.h, so make sure we get
7737 * the local version for what we do here.
7742 #if !defined(PERL_IMPLICIT_CONTEXT)
7743 # define readdir Perl_readdir
7745 # define readdir(a) Perl_readdir(aTHX_ a)
7748 /* Number of elements in vms_versions array */
7749 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
7752 * Open a directory, return a handle for later use.
7754 /*{{{ DIR *opendir(char*name) */
7756 Perl_opendir(pTHX_ const char *name)
7764 if (decc_efs_charset) {
7765 unix_flag = is_unix_filespec(name);
7768 Newx(dir, VMS_MAXRSS, char);
7769 if (do_tovmspath(name,dir,0) == NULL) {
7773 /* Check access before stat; otherwise stat does not
7774 * accurately report whether it's a directory.
7776 if (!cando_by_name(S_IRUSR,0,dir)) {
7777 /* cando_by_name has already set errno */
7781 if (flex_stat(dir,&sb) == -1) return NULL;
7782 if (!S_ISDIR(sb.st_mode)) {
7784 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
7787 /* Get memory for the handle, and the pattern. */
7789 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7791 /* Fill in the fields; mainly playing with the descriptor. */
7792 sprintf(dd->pattern, "%s*.*",dir);
7798 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7799 dd->pat.dsc$a_pointer = dd->pattern;
7800 dd->pat.dsc$w_length = strlen(dd->pattern);
7801 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7802 dd->pat.dsc$b_class = DSC$K_CLASS_S;
7803 #if defined(USE_ITHREADS)
7804 Newx(dd->mutex,1,perl_mutex);
7805 MUTEX_INIT( (perl_mutex *) dd->mutex );
7811 } /* end of opendir() */
7815 * Set the flag to indicate we want versions or not.
7817 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7819 vmsreaddirversions(DIR *dd, int flag)
7822 dd->flags |= PERL_VMSDIR_M_VERSIONS;
7824 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7829 * Free up an opened directory.
7831 /*{{{ void closedir(DIR *dd)*/
7833 Perl_closedir(DIR *dd)
7837 sts = lib$find_file_end(&dd->context);
7838 Safefree(dd->pattern);
7839 #if defined(USE_ITHREADS)
7840 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7841 Safefree(dd->mutex);
7848 * Collect all the version numbers for the current file.
7851 collectversions(pTHX_ DIR *dd)
7853 struct dsc$descriptor_s pat;
7854 struct dsc$descriptor_s res;
7856 char *p, *text, *buff;
7858 unsigned long context, tmpsts;
7860 /* Convenient shorthand. */
7863 /* Add the version wildcard, ignoring the "*.*" put on before */
7864 i = strlen(dd->pattern);
7865 Newx(text,i + e->d_namlen + 3,char);
7866 strcpy(text, dd->pattern);
7867 sprintf(&text[i - 3], "%s;*", e->d_name);
7869 /* Set up the pattern descriptor. */
7870 pat.dsc$a_pointer = text;
7871 pat.dsc$w_length = i + e->d_namlen - 1;
7872 pat.dsc$b_dtype = DSC$K_DTYPE_T;
7873 pat.dsc$b_class = DSC$K_CLASS_S;
7875 /* Set up result descriptor. */
7876 Newx(buff, VMS_MAXRSS, char);
7877 res.dsc$a_pointer = buff;
7878 res.dsc$w_length = VMS_MAXRSS - 1;
7879 res.dsc$b_dtype = DSC$K_DTYPE_T;
7880 res.dsc$b_class = DSC$K_CLASS_S;
7882 /* Read files, collecting versions. */
7883 for (context = 0, e->vms_verscount = 0;
7884 e->vms_verscount < VERSIZE(e);
7885 e->vms_verscount++) {
7887 unsigned long flags = 0;
7889 #ifdef VMS_LONGNAME_SUPPORT
7890 flags = LIB$M_FIL_LONG_NAMES
7892 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
7893 if (tmpsts == RMS$_NMF || context == 0) break;
7895 buff[VMS_MAXRSS - 1] = '\0';
7896 if ((p = strchr(buff, ';')))
7897 e->vms_versions[e->vms_verscount] = atoi(p + 1);
7899 e->vms_versions[e->vms_verscount] = -1;
7902 _ckvmssts(lib$find_file_end(&context));
7906 } /* end of collectversions() */
7909 * Read the next entry from the directory.
7911 /*{{{ struct dirent *readdir(DIR *dd)*/
7913 Perl_readdir(pTHX_ DIR *dd)
7915 struct dsc$descriptor_s res;
7917 unsigned long int tmpsts;
7919 unsigned long flags = 0;
7920 const char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7921 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7923 /* Set up result descriptor, and get next file. */
7924 Newx(buff, VMS_MAXRSS, char);
7925 res.dsc$a_pointer = buff;
7926 res.dsc$w_length = VMS_MAXRSS - 1;
7927 res.dsc$b_dtype = DSC$K_DTYPE_T;
7928 res.dsc$b_class = DSC$K_CLASS_S;
7930 #ifdef VMS_LONGNAME_SUPPORT
7931 flags = LIB$M_FIL_LONG_NAMES
7934 tmpsts = lib$find_file
7935 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
7936 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
7937 if (!(tmpsts & 1)) {
7938 set_vaxc_errno(tmpsts);
7941 set_errno(EACCES); break;
7943 set_errno(ENODEV); break;
7945 set_errno(ENOTDIR); break;
7946 case RMS$_FNF: case RMS$_DNF:
7947 set_errno(ENOENT); break;
7955 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7956 if (!decc_efs_case_preserve) {
7957 buff[VMS_MAXRSS - 1] = '\0';
7958 for (p = buff; *p; p++) *p = _tolower(*p);
7961 /* we don't want to force to lowercase, just null terminate */
7962 buff[res.dsc$w_length] = '\0';
7964 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7967 /* Skip any directory component and just copy the name. */
7968 sts = vms_split_path
7983 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
7984 dd->entry.d_name[n_len + e_len] = '\0';
7985 dd->entry.d_namlen = strlen(dd->entry.d_name);
7987 /* Convert the filename to UNIX format if needed */
7988 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
7990 /* Translate the encoded characters. */
7991 /* Fixme: unicode handling could result in embedded 0 characters */
7992 if (strchr(dd->entry.d_name, '^') != NULL) {
7996 p = dd->entry.d_name;
7999 if ((*p == '.') && (p[1] == 0) && decc_readdir_dropdotnotype) {
8000 /* Normally trailing dots should be dropped */
8005 x = copy_expand_vms_filename_escape(q, p, &y);
8009 /* if y > 1, then this is a wide file specification */
8010 /* Wide file specifications need to be passed in Perl */
8011 /* counted strings apparently with a unicode flag */
8015 strcpy(dd->entry.d_name, new_name);
8018 /* Remove a trailing "." if present and not preceded by a ^ */
8019 if ((dd->entry.d_name[dd->entry.d_namlen-1] == '.') &&
8020 decc_readdir_dropdotnotype) {
8021 dd->entry.d_namlen--;
8022 dd->entry.d_name[dd->entry.d_namlen] == 0;
8027 dd->entry.vms_verscount = 0;
8028 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8032 } /* end of readdir() */
8036 * Read the next entry from the directory -- thread-safe version.
8038 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8040 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8044 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8046 entry = readdir(dd);
8048 retval = ( *result == NULL ? errno : 0 );
8050 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8054 } /* end of readdir_r() */
8058 * Return something that can be used in a seekdir later.
8060 /*{{{ long telldir(DIR *dd)*/
8062 Perl_telldir(DIR *dd)
8069 * Return to a spot where we used to be. Brute force.
8071 /*{{{ void seekdir(DIR *dd,long count)*/
8073 Perl_seekdir(pTHX_ DIR *dd, long count)
8077 /* If we haven't done anything yet... */
8081 /* Remember some state, and clear it. */
8082 old_flags = dd->flags;
8083 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8084 _ckvmssts(lib$find_file_end(&dd->context));
8087 /* The increment is in readdir(). */
8088 for (dd->count = 0; dd->count < count; )
8091 dd->flags = old_flags;
8093 } /* end of seekdir() */
8096 /* VMS subprocess management
8098 * my_vfork() - just a vfork(), after setting a flag to record that
8099 * the current script is trying a Unix-style fork/exec.
8101 * vms_do_aexec() and vms_do_exec() are called in response to the
8102 * perl 'exec' function. If this follows a vfork call, then they
8103 * call out the regular perl routines in doio.c which do an
8104 * execvp (for those who really want to try this under VMS).
8105 * Otherwise, they do exactly what the perl docs say exec should
8106 * do - terminate the current script and invoke a new command
8107 * (See below for notes on command syntax.)
8109 * do_aspawn() and do_spawn() implement the VMS side of the perl
8110 * 'system' function.
8112 * Note on command arguments to perl 'exec' and 'system': When handled
8113 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8114 * are concatenated to form a DCL command string. If the first arg
8115 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8116 * the command string is handed off to DCL directly. Otherwise,
8117 * the first token of the command is taken as the filespec of an image
8118 * to run. The filespec is expanded using a default type of '.EXE' and
8119 * the process defaults for device, directory, etc., and if found, the resultant
8120 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8121 * the command string as parameters. This is perhaps a bit complicated,
8122 * but I hope it will form a happy medium between what VMS folks expect
8123 * from lib$spawn and what Unix folks expect from exec.
8126 static int vfork_called;
8128 /*{{{int my_vfork()*/
8139 vms_execfree(struct dsc$descriptor_s *vmscmd)
8142 if (vmscmd->dsc$a_pointer) {
8143 Safefree(vmscmd->dsc$a_pointer);
8150 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8152 char *junk, *tmps = Nullch;
8153 register size_t cmdlen = 0;
8160 tmps = SvPV(really,rlen);
8167 for (idx++; idx <= sp; idx++) {
8169 junk = SvPVx(*idx,rlen);
8170 cmdlen += rlen ? rlen + 1 : 0;
8173 Newx(PL_Cmd,cmdlen+1,char);
8175 if (tmps && *tmps) {
8176 strcpy(PL_Cmd,tmps);
8179 else *PL_Cmd = '\0';
8180 while (++mark <= sp) {
8182 char *s = SvPVx(*mark,n_a);
8184 if (*PL_Cmd) strcat(PL_Cmd," ");
8190 } /* end of setup_argstr() */
8193 static unsigned long int
8194 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8195 struct dsc$descriptor_s **pvmscmd)
8197 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8198 char image_name[NAM$C_MAXRSS+1];
8199 char image_argv[NAM$C_MAXRSS+1];
8200 $DESCRIPTOR(defdsc,".EXE");
8201 $DESCRIPTOR(defdsc2,".");
8202 $DESCRIPTOR(resdsc,resspec);
8203 struct dsc$descriptor_s *vmscmd;
8204 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8205 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8206 register char *s, *rest, *cp, *wordbreak;
8211 Newx(vmscmd,sizeof(struct dsc$descriptor_s),struct dsc$descriptor_s);
8213 /* Make a copy for modification */
8214 cmdlen = strlen(incmd);
8215 Newx(cmd, cmdlen+1, char);
8216 strncpy(cmd, incmd, cmdlen);
8221 vmscmd->dsc$a_pointer = NULL;
8222 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8223 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8224 vmscmd->dsc$w_length = 0;
8225 if (pvmscmd) *pvmscmd = vmscmd;
8227 if (suggest_quote) *suggest_quote = 0;
8229 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8230 return CLI$_BUFOVF; /* continuation lines currently unsupported */
8236 while (*s && isspace(*s)) s++;
8238 if (*s == '@' || *s == '$') {
8239 vmsspec[0] = *s; rest = s + 1;
8240 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8242 else { cp = vmsspec; rest = s; }
8243 if (*rest == '.' || *rest == '/') {
8246 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8247 rest++, cp2++) *cp2 = *rest;
8249 if (do_tovmsspec(resspec,cp,0)) {
8252 for (cp2 = vmsspec + strlen(vmsspec);
8253 *rest && cp2 - vmsspec < sizeof vmsspec;
8254 rest++, cp2++) *cp2 = *rest;
8259 /* Intuit whether verb (first word of cmd) is a DCL command:
8260 * - if first nonspace char is '@', it's a DCL indirection
8262 * - if verb contains a filespec separator, it's not a DCL command
8263 * - if it doesn't, caller tells us whether to default to a DCL
8264 * command, or to a local image unless told it's DCL (by leading '$')
8268 if (suggest_quote) *suggest_quote = 1;
8270 register char *filespec = strpbrk(s,":<[.;");
8271 rest = wordbreak = strpbrk(s," \"\t/");
8272 if (!wordbreak) wordbreak = s + strlen(s);
8273 if (*s == '$') check_img = 0;
8274 if (filespec && (filespec < wordbreak)) isdcl = 0;
8275 else isdcl = !check_img;
8279 imgdsc.dsc$a_pointer = s;
8280 imgdsc.dsc$w_length = wordbreak - s;
8281 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
8283 _ckvmssts(lib$find_file_end(&cxt));
8284 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
8285 if (!(retsts & 1) && *s == '$') {
8286 _ckvmssts(lib$find_file_end(&cxt));
8287 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8288 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,0,&flags);
8290 _ckvmssts(lib$find_file_end(&cxt));
8291 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,0,&flags);
8295 _ckvmssts(lib$find_file_end(&cxt));
8300 while (*s && !isspace(*s)) s++;
8303 /* check that it's really not DCL with no file extension */
8304 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8306 char b[256] = {0,0,0,0};
8307 read(fileno(fp), b, 256);
8308 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8312 /* Check for script */
8314 if ((b[0] == '#') && (b[1] == '!'))
8316 #ifdef ALTERNATE_SHEBANG
8318 shebang_len = strlen(ALTERNATE_SHEBANG);
8319 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8321 perlstr = strstr("perl",b);
8322 if (perlstr == NULL)
8330 if (shebang_len > 0) {
8333 char tmpspec[NAM$C_MAXRSS + 1];
8336 /* Image is following after white space */
8337 /*--------------------------------------*/
8338 while (isprint(b[i]) && isspace(b[i]))
8342 while (isprint(b[i]) && !isspace(b[i])) {
8343 tmpspec[j++] = b[i++];
8344 if (j >= NAM$C_MAXRSS)
8349 /* There may be some default parameters to the image */
8350 /*---------------------------------------------------*/
8352 while (isprint(b[i])) {
8353 image_argv[j++] = b[i++];
8354 if (j >= NAM$C_MAXRSS)
8357 while ((j > 0) && !isprint(image_argv[j-1]))
8361 /* It will need to be converted to VMS format and validated */
8362 if (tmpspec[0] != '\0') {
8365 /* Try to find the exact program requested to be run */
8366 /*---------------------------------------------------*/
8367 iname = do_rmsexpand
8368 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8369 if (iname != NULL) {
8370 if (cando_by_name(S_IXUSR,0,image_name)) {
8371 /* MCR prefix needed */
8375 /* Try again with a null type */
8376 /*----------------------------*/
8377 iname = do_rmsexpand
8378 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8379 if (iname != NULL) {
8380 if (cando_by_name(S_IXUSR,0,image_name)) {
8381 /* MCR prefix needed */
8387 /* Did we find the image to run the script? */
8388 /*------------------------------------------*/
8392 /* Assume DCL or foreign command exists */
8393 /*--------------------------------------*/
8394 tchr = strrchr(tmpspec, '/');
8401 strcpy(image_name, tchr);
8409 if (check_img && isdcl) return RMS$_FNF;
8411 if (cando_by_name(S_IXUSR,0,resspec)) {
8412 Newx(vmscmd->dsc$a_pointer, MAX_DCL_LINE_LENGTH ,char);
8414 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8415 if (image_name[0] != 0) {
8416 strcat(vmscmd->dsc$a_pointer, image_name);
8417 strcat(vmscmd->dsc$a_pointer, " ");
8419 } else if (image_name[0] != 0) {
8420 strcpy(vmscmd->dsc$a_pointer, image_name);
8421 strcat(vmscmd->dsc$a_pointer, " ");
8423 strcpy(vmscmd->dsc$a_pointer,"@");
8425 if (suggest_quote) *suggest_quote = 1;
8427 /* If there is an image name, use original command */
8428 if (image_name[0] == 0)
8429 strcat(vmscmd->dsc$a_pointer,resspec);
8432 while (*rest && isspace(*rest)) rest++;
8435 if (image_argv[0] != 0) {
8436 strcat(vmscmd->dsc$a_pointer,image_argv);
8437 strcat(vmscmd->dsc$a_pointer, " ");
8443 rest_len = strlen(rest);
8444 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8445 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8446 strcat(vmscmd->dsc$a_pointer,rest);
8448 retsts = CLI$_BUFOVF;
8450 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8452 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8454 else retsts = RMS$_PRV;
8457 /* It's either a DCL command or we couldn't find a suitable image */
8458 vmscmd->dsc$w_length = strlen(cmd);
8459 /* if (cmd == PL_Cmd) {
8460 vmscmd->dsc$a_pointer = PL_Cmd;
8461 if (suggest_quote) *suggest_quote = 1;
8464 vmscmd->dsc$a_pointer = savepvn(cmd,vmscmd->dsc$w_length);
8468 /* check if it's a symbol (for quoting purposes) */
8469 if (suggest_quote && !*suggest_quote) {
8471 char equiv[LNM$C_NAMLENGTH];
8472 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8473 eqvdsc.dsc$a_pointer = equiv;
8475 iss = lib$get_symbol(vmscmd,&eqvdsc);
8476 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8478 if (!(retsts & 1)) {
8479 /* just hand off status values likely to be due to user error */
8480 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8481 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8482 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8483 else { _ckvmssts(retsts); }
8486 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8488 } /* end of setup_cmddsc() */
8491 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8493 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8496 if (vfork_called) { /* this follows a vfork - act Unixish */
8498 if (vfork_called < 0) {
8499 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8502 else return do_aexec(really,mark,sp);
8504 /* no vfork - act VMSish */
8505 return vms_do_exec(setup_argstr(aTHX_ really,mark,sp));
8510 } /* end of vms_do_aexec() */
8513 /* {{{bool vms_do_exec(char *cmd) */
8515 Perl_vms_do_exec(pTHX_ const char *cmd)
8517 struct dsc$descriptor_s *vmscmd;
8519 if (vfork_called) { /* this follows a vfork - act Unixish */
8521 if (vfork_called < 0) {
8522 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8525 else return do_exec(cmd);
8528 { /* no vfork - act VMSish */
8529 unsigned long int retsts;
8532 TAINT_PROPER("exec");
8533 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8534 retsts = lib$do_command(vmscmd);
8537 case RMS$_FNF: case RMS$_DNF:
8538 set_errno(ENOENT); break;
8540 set_errno(ENOTDIR); break;
8542 set_errno(ENODEV); break;
8544 set_errno(EACCES); break;
8546 set_errno(EINVAL); break;
8547 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8548 set_errno(E2BIG); break;
8549 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8550 _ckvmssts(retsts); /* fall through */
8551 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8554 set_vaxc_errno(retsts);
8555 if (ckWARN(WARN_EXEC)) {
8556 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8557 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8559 vms_execfree(vmscmd);
8564 } /* end of vms_do_exec() */
8567 unsigned long int Perl_do_spawn(pTHX_ const char *);
8569 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8571 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8573 if (sp > mark) return do_spawn(setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp));
8576 } /* end of do_aspawn() */
8579 /* {{{unsigned long int do_spawn(char *cmd) */
8581 Perl_do_spawn(pTHX_ const char *cmd)
8583 unsigned long int sts, substs;
8586 TAINT_PROPER("spawn");
8587 if (!cmd || !*cmd) {
8588 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8591 case RMS$_FNF: case RMS$_DNF:
8592 set_errno(ENOENT); break;
8594 set_errno(ENOTDIR); break;
8596 set_errno(ENODEV); break;
8598 set_errno(EACCES); break;
8600 set_errno(EINVAL); break;
8601 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8602 set_errno(E2BIG); break;
8603 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8604 _ckvmssts(sts); /* fall through */
8605 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8608 set_vaxc_errno(sts);
8609 if (ckWARN(WARN_EXEC)) {
8610 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8618 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8623 } /* end of do_spawn() */
8627 static unsigned int *sockflags, sockflagsize;
8630 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8631 * routines found in some versions of the CRTL can't deal with sockets.
8632 * We don't shim the other file open routines since a socket isn't
8633 * likely to be opened by a name.
8635 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8636 FILE *my_fdopen(int fd, const char *mode)
8638 FILE *fp = fdopen(fd, mode);
8641 unsigned int fdoff = fd / sizeof(unsigned int);
8642 Stat_t sbuf; /* native stat; we don't need flex_stat */
8643 if (!sockflagsize || fdoff > sockflagsize) {
8644 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
8645 else Newx (sockflags,fdoff+2,unsigned int);
8646 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8647 sockflagsize = fdoff + 2;
8649 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8650 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8659 * Clear the corresponding bit when the (possibly) socket stream is closed.
8660 * There still a small hole: we miss an implicit close which might occur
8661 * via freopen(). >> Todo
8663 /*{{{ int my_fclose(FILE *fp)*/
8664 int my_fclose(FILE *fp) {
8666 unsigned int fd = fileno(fp);
8667 unsigned int fdoff = fd / sizeof(unsigned int);
8669 if (sockflagsize && fdoff <= sockflagsize)
8670 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8678 * A simple fwrite replacement which outputs itmsz*nitm chars without
8679 * introducing record boundaries every itmsz chars.
8680 * We are using fputs, which depends on a terminating null. We may
8681 * well be writing binary data, so we need to accommodate not only
8682 * data with nulls sprinkled in the middle but also data with no null
8685 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8687 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8689 register char *cp, *end, *cpd, *data;
8690 register unsigned int fd = fileno(dest);
8691 register unsigned int fdoff = fd / sizeof(unsigned int);
8693 int bufsize = itmsz * nitm + 1;
8695 if (fdoff < sockflagsize &&
8696 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8697 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8701 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8702 memcpy( data, src, itmsz*nitm );
8703 data[itmsz*nitm] = '\0';
8705 end = data + itmsz * nitm;
8706 retval = (int) nitm; /* on success return # items written */
8709 while (cpd <= end) {
8710 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8711 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8713 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8717 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8720 } /* end of my_fwrite() */
8723 /*{{{ int my_flush(FILE *fp)*/
8725 Perl_my_flush(pTHX_ FILE *fp)
8728 if ((res = fflush(fp)) == 0 && fp) {
8729 #ifdef VMS_DO_SOCKETS
8731 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8733 res = fsync(fileno(fp));
8736 * If the flush succeeded but set end-of-file, we need to clear
8737 * the error because our caller may check ferror(). BTW, this
8738 * probably means we just flushed an empty file.
8740 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8747 * Here are replacements for the following Unix routines in the VMS environment:
8748 * getpwuid Get information for a particular UIC or UID
8749 * getpwnam Get information for a named user
8750 * getpwent Get information for each user in the rights database
8751 * setpwent Reset search to the start of the rights database
8752 * endpwent Finish searching for users in the rights database
8754 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8755 * (defined in pwd.h), which contains the following fields:-
8757 * char *pw_name; Username (in lower case)
8758 * char *pw_passwd; Hashed password
8759 * unsigned int pw_uid; UIC
8760 * unsigned int pw_gid; UIC group number
8761 * char *pw_unixdir; Default device/directory (VMS-style)
8762 * char *pw_gecos; Owner name
8763 * char *pw_dir; Default device/directory (Unix-style)
8764 * char *pw_shell; Default CLI name (eg. DCL)
8766 * If the specified user does not exist, getpwuid and getpwnam return NULL.
8768 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8769 * not the UIC member number (eg. what's returned by getuid()),
8770 * getpwuid() can accept either as input (if uid is specified, the caller's
8771 * UIC group is used), though it won't recognise gid=0.
8773 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8774 * information about other users in your group or in other groups, respectively.
8775 * If the required privilege is not available, then these routines fill only
8776 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8779 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8782 /* sizes of various UAF record fields */
8783 #define UAI$S_USERNAME 12
8784 #define UAI$S_IDENT 31
8785 #define UAI$S_OWNER 31
8786 #define UAI$S_DEFDEV 31
8787 #define UAI$S_DEFDIR 63
8788 #define UAI$S_DEFCLI 31
8791 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
8792 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8793 (uic).uic$v_group != UIC$K_WILD_GROUP)
8795 static char __empty[]= "";
8796 static struct passwd __passwd_empty=
8797 {(char *) __empty, (char *) __empty, 0, 0,
8798 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8799 static int contxt= 0;
8800 static struct passwd __pwdcache;
8801 static char __pw_namecache[UAI$S_IDENT+1];
8804 * This routine does most of the work extracting the user information.
8806 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8809 unsigned char length;
8810 char pw_gecos[UAI$S_OWNER+1];
8812 static union uicdef uic;
8814 unsigned char length;
8815 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8818 unsigned char length;
8819 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8822 unsigned char length;
8823 char pw_shell[UAI$S_DEFCLI+1];
8825 static char pw_passwd[UAI$S_PWD+1];
8827 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8828 struct dsc$descriptor_s name_desc;
8829 unsigned long int sts;
8831 static struct itmlst_3 itmlst[]= {
8832 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
8833 {sizeof(uic), UAI$_UIC, &uic, &luic},
8834 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
8835 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
8836 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
8837 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
8838 {0, 0, NULL, NULL}};
8840 name_desc.dsc$w_length= strlen(name);
8841 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8842 name_desc.dsc$b_class= DSC$K_CLASS_S;
8843 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8845 /* Note that sys$getuai returns many fields as counted strings. */
8846 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8847 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8848 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8850 else { _ckvmssts(sts); }
8851 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
8853 if ((int) owner.length < lowner) lowner= (int) owner.length;
8854 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8855 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8856 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8857 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8858 owner.pw_gecos[lowner]= '\0';
8859 defdev.pw_dir[ldefdev+ldefdir]= '\0';
8860 defcli.pw_shell[ldefcli]= '\0';
8861 if (valid_uic(uic)) {
8862 pwd->pw_uid= uic.uic$l_uic;
8863 pwd->pw_gid= uic.uic$v_group;
8866 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8867 pwd->pw_passwd= pw_passwd;
8868 pwd->pw_gecos= owner.pw_gecos;
8869 pwd->pw_dir= defdev.pw_dir;
8870 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8871 pwd->pw_shell= defcli.pw_shell;
8872 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8874 ldir= strlen(pwd->pw_unixdir) - 1;
8875 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8878 strcpy(pwd->pw_unixdir, pwd->pw_dir);
8879 if (!decc_efs_case_preserve)
8880 __mystrtolower(pwd->pw_unixdir);
8885 * Get information for a named user.
8887 /*{{{struct passwd *getpwnam(char *name)*/
8888 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8890 struct dsc$descriptor_s name_desc;
8892 unsigned long int status, sts;
8894 __pwdcache = __passwd_empty;
8895 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8896 /* We still may be able to determine pw_uid and pw_gid */
8897 name_desc.dsc$w_length= strlen(name);
8898 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8899 name_desc.dsc$b_class= DSC$K_CLASS_S;
8900 name_desc.dsc$a_pointer= (char *) name;
8901 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8902 __pwdcache.pw_uid= uic.uic$l_uic;
8903 __pwdcache.pw_gid= uic.uic$v_group;
8906 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8907 set_vaxc_errno(sts);
8908 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8911 else { _ckvmssts(sts); }
8914 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8915 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8916 __pwdcache.pw_name= __pw_namecache;
8918 } /* end of my_getpwnam() */
8922 * Get information for a particular UIC or UID.
8923 * Called by my_getpwent with uid=-1 to list all users.
8925 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8926 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8928 const $DESCRIPTOR(name_desc,__pw_namecache);
8929 unsigned short lname;
8931 unsigned long int status;
8933 if (uid == (unsigned int) -1) {
8935 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8936 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8937 set_vaxc_errno(status);
8938 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8942 else { _ckvmssts(status); }
8943 } while (!valid_uic (uic));
8947 if (!uic.uic$v_group)
8948 uic.uic$v_group= PerlProc_getgid();
8950 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8951 else status = SS$_IVIDENT;
8952 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8953 status == RMS$_PRV) {
8954 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8957 else { _ckvmssts(status); }
8959 __pw_namecache[lname]= '\0';
8960 __mystrtolower(__pw_namecache);
8962 __pwdcache = __passwd_empty;
8963 __pwdcache.pw_name = __pw_namecache;
8965 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8966 The identifier's value is usually the UIC, but it doesn't have to be,
8967 so if we can, we let fillpasswd update this. */
8968 __pwdcache.pw_uid = uic.uic$l_uic;
8969 __pwdcache.pw_gid = uic.uic$v_group;
8971 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8974 } /* end of my_getpwuid() */
8978 * Get information for next user.
8980 /*{{{struct passwd *my_getpwent()*/
8981 struct passwd *Perl_my_getpwent(pTHX)
8983 return (my_getpwuid((unsigned int) -1));
8988 * Finish searching rights database for users.
8990 /*{{{void my_endpwent()*/
8991 void Perl_my_endpwent(pTHX)
8994 _ckvmssts(sys$finish_rdb(&contxt));
9000 #ifdef HOMEGROWN_POSIX_SIGNALS
9001 /* Signal handling routines, pulled into the core from POSIX.xs.
9003 * We need these for threads, so they've been rolled into the core,
9004 * rather than left in POSIX.xs.
9006 * (DRS, Oct 23, 1997)
9009 /* sigset_t is atomic under VMS, so these routines are easy */
9010 /*{{{int my_sigemptyset(sigset_t *) */
9011 int my_sigemptyset(sigset_t *set) {
9012 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9018 /*{{{int my_sigfillset(sigset_t *)*/
9019 int my_sigfillset(sigset_t *set) {
9021 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9022 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9028 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9029 int my_sigaddset(sigset_t *set, int sig) {
9030 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9031 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9032 *set |= (1 << (sig - 1));
9038 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9039 int my_sigdelset(sigset_t *set, int sig) {
9040 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9041 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9042 *set &= ~(1 << (sig - 1));
9048 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9049 int my_sigismember(sigset_t *set, int sig) {
9050 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9051 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9052 return *set & (1 << (sig - 1));
9057 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9058 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9061 /* If set and oset are both null, then things are badly wrong. Bail out. */
9062 if ((oset == NULL) && (set == NULL)) {
9063 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9067 /* If set's null, then we're just handling a fetch. */
9069 tempmask = sigblock(0);
9074 tempmask = sigsetmask(*set);
9077 tempmask = sigblock(*set);
9080 tempmask = sigblock(0);
9081 sigsetmask(*oset & ~tempmask);
9084 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9089 /* Did they pass us an oset? If so, stick our holding mask into it */
9096 #endif /* HOMEGROWN_POSIX_SIGNALS */
9099 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9100 * my_utime(), and flex_stat(), all of which operate on UTC unless
9101 * VMSISH_TIMES is true.
9103 /* method used to handle UTC conversions:
9104 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
9106 static int gmtime_emulation_type;
9107 /* number of secs to add to UTC POSIX-style time to get local time */
9108 static long int utc_offset_secs;
9110 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9111 * in vmsish.h. #undef them here so we can call the CRTL routines
9120 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9121 * qualifier with the extern prefix pragma. This provisional
9122 * hack circumvents this prefix pragma problem in previous
9125 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9126 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9127 # pragma __extern_prefix save
9128 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
9129 # define gmtime decc$__utctz_gmtime
9130 # define localtime decc$__utctz_localtime
9131 # define time decc$__utc_time
9132 # pragma __extern_prefix restore
9134 struct tm *gmtime(), *localtime();
9140 static time_t toutc_dst(time_t loc) {
9143 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9144 loc -= utc_offset_secs;
9145 if (rsltmp->tm_isdst) loc -= 3600;
9148 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9149 ((gmtime_emulation_type || my_time(NULL)), \
9150 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9151 ((secs) - utc_offset_secs))))
9153 static time_t toloc_dst(time_t utc) {
9156 utc += utc_offset_secs;
9157 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9158 if (rsltmp->tm_isdst) utc += 3600;
9161 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9162 ((gmtime_emulation_type || my_time(NULL)), \
9163 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9164 ((secs) + utc_offset_secs))))
9166 #ifndef RTL_USES_UTC
9169 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9170 DST starts on 1st sun of april at 02:00 std time
9171 ends on last sun of october at 02:00 dst time
9172 see the UCX management command reference, SET CONFIG TIMEZONE
9173 for formatting info.
9175 No, it's not as general as it should be, but then again, NOTHING
9176 will handle UK times in a sensible way.
9181 parse the DST start/end info:
9182 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9186 tz_parse_startend(char *s, struct tm *w, int *past)
9188 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9189 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9194 if (!past) return 0;
9197 if (w->tm_year % 4 == 0) ly = 1;
9198 if (w->tm_year % 100 == 0) ly = 0;
9199 if (w->tm_year+1900 % 400 == 0) ly = 1;
9202 dozjd = isdigit(*s);
9203 if (*s == 'J' || *s == 'j' || dozjd) {
9204 if (!dozjd && !isdigit(*++s)) return 0;
9207 d = d*10 + *s++ - '0';
9209 d = d*10 + *s++ - '0';
9212 if (d == 0) return 0;
9213 if (d > 366) return 0;
9215 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9218 } else if (*s == 'M' || *s == 'm') {
9219 if (!isdigit(*++s)) return 0;
9221 if (isdigit(*s)) m = 10*m + *s++ - '0';
9222 if (*s != '.') return 0;
9223 if (!isdigit(*++s)) return 0;
9225 if (n < 1 || n > 5) return 0;
9226 if (*s != '.') return 0;
9227 if (!isdigit(*++s)) return 0;
9229 if (d > 6) return 0;
9233 if (!isdigit(*++s)) return 0;
9235 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9237 if (!isdigit(*++s)) return 0;
9239 if (isdigit(*s)) min = 10*min + *s++ - '0';
9241 if (!isdigit(*++s)) return 0;
9243 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9253 if (w->tm_yday < d) goto before;
9254 if (w->tm_yday > d) goto after;
9256 if (w->tm_mon+1 < m) goto before;
9257 if (w->tm_mon+1 > m) goto after;
9259 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9260 k = d - j; /* mday of first d */
9262 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9263 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9264 if (w->tm_mday < k) goto before;
9265 if (w->tm_mday > k) goto after;
9268 if (w->tm_hour < hour) goto before;
9269 if (w->tm_hour > hour) goto after;
9270 if (w->tm_min < min) goto before;
9271 if (w->tm_min > min) goto after;
9272 if (w->tm_sec < sec) goto before;
9286 /* parse the offset: (+|-)hh[:mm[:ss]] */
9289 tz_parse_offset(char *s, int *offset)
9291 int hour = 0, min = 0, sec = 0;
9294 if (!offset) return 0;
9296 if (*s == '-') {neg++; s++;}
9298 if (!isdigit(*s)) return 0;
9300 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9301 if (hour > 24) return 0;
9303 if (!isdigit(*++s)) return 0;
9305 if (isdigit(*s)) min = min*10 + (*s++ - '0');
9306 if (min > 59) return 0;
9308 if (!isdigit(*++s)) return 0;
9310 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9311 if (sec > 59) return 0;
9315 *offset = (hour*60+min)*60 + sec;
9316 if (neg) *offset = -*offset;
9321 input time is w, whatever type of time the CRTL localtime() uses.
9322 sets dst, the zone, and the gmtoff (seconds)
9324 caches the value of TZ and UCX$TZ env variables; note that
9325 my_setenv looks for these and sets a flag if they're changed
9328 We have to watch out for the "australian" case (dst starts in
9329 october, ends in april)...flagged by "reverse" and checked by
9330 scanning through the months of the previous year.
9335 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9340 char *dstzone, *tz, *s_start, *s_end;
9341 int std_off, dst_off, isdst;
9342 int y, dststart, dstend;
9343 static char envtz[1025]; /* longer than any logical, symbol, ... */
9344 static char ucxtz[1025];
9345 static char reversed = 0;
9351 reversed = -1; /* flag need to check */
9352 envtz[0] = ucxtz[0] = '\0';
9353 tz = my_getenv("TZ",0);
9354 if (tz) strcpy(envtz, tz);
9355 tz = my_getenv("UCX$TZ",0);
9356 if (tz) strcpy(ucxtz, tz);
9357 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
9360 if (!*tz) tz = ucxtz;
9363 while (isalpha(*s)) s++;
9364 s = tz_parse_offset(s, &std_off);
9366 if (!*s) { /* no DST, hurray we're done! */
9372 while (isalpha(*s)) s++;
9373 s2 = tz_parse_offset(s, &dst_off);
9377 dst_off = std_off - 3600;
9380 if (!*s) { /* default dst start/end?? */
9381 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
9382 s = strchr(ucxtz,',');
9384 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
9386 if (*s != ',') return 0;
9389 when = _toutc(when); /* convert to utc */
9390 when = when - std_off; /* convert to pseudolocal time*/
9392 w2 = localtime(&when);
9395 s = tz_parse_startend(s_start,w2,&dststart);
9397 if (*s != ',') return 0;
9400 when = _toutc(when); /* convert to utc */
9401 when = when - dst_off; /* convert to pseudolocal time*/
9402 w2 = localtime(&when);
9403 if (w2->tm_year != y) { /* spans a year, just check one time */
9404 when += dst_off - std_off;
9405 w2 = localtime(&when);
9408 s = tz_parse_startend(s_end,w2,&dstend);
9411 if (reversed == -1) { /* need to check if start later than end */
9415 if (when < 2*365*86400) {
9416 when += 2*365*86400;
9420 w2 =localtime(&when);
9421 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
9423 for (j = 0; j < 12; j++) {
9424 w2 =localtime(&when);
9425 tz_parse_startend(s_start,w2,&ds);
9426 tz_parse_startend(s_end,w2,&de);
9427 if (ds != de) break;
9431 if (de && !ds) reversed = 1;
9434 isdst = dststart && !dstend;
9435 if (reversed) isdst = dststart || !dstend;
9438 if (dst) *dst = isdst;
9439 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9440 if (isdst) tz = dstzone;
9442 while(isalpha(*tz)) *zone++ = *tz++;
9448 #endif /* !RTL_USES_UTC */
9450 /* my_time(), my_localtime(), my_gmtime()
9451 * By default traffic in UTC time values, using CRTL gmtime() or
9452 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9453 * Note: We need to use these functions even when the CRTL has working
9454 * UTC support, since they also handle C<use vmsish qw(times);>
9456 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
9457 * Modified by Charles Bailey <bailey@newman.upenn.edu>
9460 /*{{{time_t my_time(time_t *timep)*/
9461 time_t Perl_my_time(pTHX_ time_t *timep)
9466 if (gmtime_emulation_type == 0) {
9468 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
9469 /* results of calls to gmtime() and localtime() */
9470 /* for same &base */
9472 gmtime_emulation_type++;
9473 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9474 char off[LNM$C_NAMLENGTH+1];;
9476 gmtime_emulation_type++;
9477 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9478 gmtime_emulation_type++;
9479 utc_offset_secs = 0;
9480 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9482 else { utc_offset_secs = atol(off); }
9484 else { /* We've got a working gmtime() */
9485 struct tm gmt, local;
9488 tm_p = localtime(&base);
9490 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
9491 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9492 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
9493 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
9499 # ifdef RTL_USES_UTC
9500 if (VMSISH_TIME) when = _toloc(when);
9502 if (!VMSISH_TIME) when = _toutc(when);
9505 if (timep != NULL) *timep = when;
9508 } /* end of my_time() */
9512 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9514 Perl_my_gmtime(pTHX_ const time_t *timep)
9520 if (timep == NULL) {
9521 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9524 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9528 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9530 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
9531 return gmtime(&when);
9533 /* CRTL localtime() wants local time as input, so does no tz correction */
9534 rsltmp = localtime(&when);
9535 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
9538 } /* end of my_gmtime() */
9542 /*{{{struct tm *my_localtime(const time_t *timep)*/
9544 Perl_my_localtime(pTHX_ const time_t *timep)
9546 time_t when, whenutc;
9550 if (timep == NULL) {
9551 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9554 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9555 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9558 # ifdef RTL_USES_UTC
9560 if (VMSISH_TIME) when = _toutc(when);
9562 /* CRTL localtime() wants UTC as input, does tz correction itself */
9563 return localtime(&when);
9565 # else /* !RTL_USES_UTC */
9568 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
9569 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
9572 #ifndef RTL_USES_UTC
9573 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
9574 when = whenutc - offset; /* pseudolocal time*/
9577 /* CRTL localtime() wants local time as input, so does no tz correction */
9578 rsltmp = localtime(&when);
9579 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9583 } /* end of my_localtime() */
9586 /* Reset definitions for later calls */
9587 #define gmtime(t) my_gmtime(t)
9588 #define localtime(t) my_localtime(t)
9589 #define time(t) my_time(t)
9592 /* my_utime - update modification time of a file
9593 * calling sequence is identical to POSIX utime(), but under
9594 * VMS only the modification time is changed; ODS-2 does not
9595 * maintain access times. Restrictions differ from the POSIX
9596 * definition in that the time can be changed as long as the
9597 * caller has permission to execute the necessary IO$_MODIFY $QIO;
9598 * no separate checks are made to insure that the caller is the
9599 * owner of the file or has special privs enabled.
9600 * Code here is based on Joe Meadows' FILE utility.
9603 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9604 * to VMS epoch (01-JAN-1858 00:00:00.00)
9605 * in 100 ns intervals.
9607 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9609 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9610 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9614 long int bintime[2], len = 2, lowbit, unixtime,
9615 secscale = 10000000; /* seconds --> 100 ns intervals */
9616 unsigned long int chan, iosb[2], retsts;
9617 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9618 struct FAB myfab = cc$rms_fab;
9619 struct NAM mynam = cc$rms_nam;
9620 #if defined (__DECC) && defined (__VAX)
9621 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9622 * at least through VMS V6.1, which causes a type-conversion warning.
9624 # pragma message save
9625 # pragma message disable cvtdiftypes
9627 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9628 struct fibdef myfib;
9629 #if defined (__DECC) && defined (__VAX)
9630 /* This should be right after the declaration of myatr, but due
9631 * to a bug in VAX DEC C, this takes effect a statement early.
9633 # pragma message restore
9635 /* cast ok for read only parameter */
9636 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9637 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9638 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9640 if (file == NULL || *file == '\0') {
9642 set_vaxc_errno(LIB$_INVARG);
9645 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9647 if (utimes != NULL) {
9648 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
9649 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9650 * Since time_t is unsigned long int, and lib$emul takes a signed long int
9651 * as input, we force the sign bit to be clear by shifting unixtime right
9652 * one bit, then multiplying by an extra factor of 2 in lib$emul().
9654 lowbit = (utimes->modtime & 1) ? secscale : 0;
9655 unixtime = (long int) utimes->modtime;
9657 /* If input was UTC; convert to local for sys svc */
9658 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9660 unixtime >>= 1; secscale <<= 1;
9661 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9662 if (!(retsts & 1)) {
9664 set_vaxc_errno(retsts);
9667 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9668 if (!(retsts & 1)) {
9670 set_vaxc_errno(retsts);
9675 /* Just get the current time in VMS format directly */
9676 retsts = sys$gettim(bintime);
9677 if (!(retsts & 1)) {
9679 set_vaxc_errno(retsts);
9684 myfab.fab$l_fna = vmsspec;
9685 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9686 myfab.fab$l_nam = &mynam;
9687 mynam.nam$l_esa = esa;
9688 mynam.nam$b_ess = (unsigned char) sizeof esa;
9689 mynam.nam$l_rsa = rsa;
9690 mynam.nam$b_rss = (unsigned char) sizeof rsa;
9691 if (decc_efs_case_preserve)
9692 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9694 /* Look for the file to be affected, letting RMS parse the file
9695 * specification for us as well. I have set errno using only
9696 * values documented in the utime() man page for VMS POSIX.
9698 retsts = sys$parse(&myfab,0,0);
9699 if (!(retsts & 1)) {
9700 set_vaxc_errno(retsts);
9701 if (retsts == RMS$_PRV) set_errno(EACCES);
9702 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9703 else set_errno(EVMSERR);
9706 retsts = sys$search(&myfab,0,0);
9707 if (!(retsts & 1)) {
9708 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9709 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9710 set_vaxc_errno(retsts);
9711 if (retsts == RMS$_PRV) set_errno(EACCES);
9712 else if (retsts == RMS$_FNF) set_errno(ENOENT);
9713 else set_errno(EVMSERR);
9717 devdsc.dsc$w_length = mynam.nam$b_dev;
9718 /* cast ok for read only parameter */
9719 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9721 retsts = sys$assign(&devdsc,&chan,0,0);
9722 if (!(retsts & 1)) {
9723 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9724 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9725 set_vaxc_errno(retsts);
9726 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
9727 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
9728 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
9729 else set_errno(EVMSERR);
9733 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9734 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9736 memset((void *) &myfib, 0, sizeof myfib);
9737 #if defined(__DECC) || defined(__DECCXX)
9738 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9739 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9740 /* This prevents the revision time of the file being reset to the current
9741 * time as a result of our IO$_MODIFY $QIO. */
9742 myfib.fib$l_acctl = FIB$M_NORECORD;
9744 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9745 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9746 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9748 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9749 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9750 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9751 _ckvmssts(sys$dassgn(chan));
9752 if (retsts & 1) retsts = iosb[0];
9753 if (!(retsts & 1)) {
9754 set_vaxc_errno(retsts);
9755 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9756 else set_errno(EVMSERR);
9761 } /* end of my_utime() */
9765 * flex_stat, flex_lstat, flex_fstat
9766 * basic stat, but gets it right when asked to stat
9767 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9770 #ifndef _USE_STD_STAT
9771 /* encode_dev packs a VMS device name string into an integer to allow
9772 * simple comparisons. This can be used, for example, to check whether two
9773 * files are located on the same device, by comparing their encoded device
9774 * names. Even a string comparison would not do, because stat() reuses the
9775 * device name buffer for each call; so without encode_dev, it would be
9776 * necessary to save the buffer and use strcmp (this would mean a number of
9777 * changes to the standard Perl code, to say nothing of what a Perl script
9780 * The device lock id, if it exists, should be unique (unless perhaps compared
9781 * with lock ids transferred from other nodes). We have a lock id if the disk is
9782 * mounted cluster-wide, which is when we tend to get long (host-qualified)
9783 * device names. Thus we use the lock id in preference, and only if that isn't
9784 * available, do we try to pack the device name into an integer (flagged by
9785 * the sign bit (LOCKID_MASK) being set).
9787 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9788 * name and its encoded form, but it seems very unlikely that we will find
9789 * two files on different disks that share the same encoded device names,
9790 * and even more remote that they will share the same file id (if the test
9791 * is to check for the same file).
9793 * A better method might be to use sys$device_scan on the first call, and to
9794 * search for the device, returning an index into the cached array.
9795 * The number returned would be more intelligable.
9796 * This is probably not worth it, and anyway would take quite a bit longer
9797 * on the first call.
9799 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
9800 static mydev_t encode_dev (pTHX_ const char *dev)
9803 unsigned long int f;
9808 if (!dev || !dev[0]) return 0;
9812 struct dsc$descriptor_s dev_desc;
9813 unsigned long int status, lockid, item = DVI$_LOCKID;
9815 /* For cluster-mounted disks, the disk lock identifier is unique, so we
9816 can try that first. */
9817 dev_desc.dsc$w_length = strlen (dev);
9818 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
9819 dev_desc.dsc$b_class = DSC$K_CLASS_S;
9820 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
9821 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9822 if (lockid) return (lockid & ~LOCKID_MASK);
9826 /* Otherwise we try to encode the device name */
9830 for (q = dev + strlen(dev); q--; q >= dev) {
9833 else if (isalpha (toupper (*q)))
9834 c= toupper (*q) - 'A' + (char)10;
9836 continue; /* Skip '$'s */
9838 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
9840 enc += f * (unsigned long int) c;
9842 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
9844 } /* end of encode_dev() */
9847 static char namecache[NAM$C_MAXRSS+1];
9850 is_null_device(name)
9853 if (decc_bug_devnull != 0) {
9854 if (strncmp("/dev/null", name, 9) == 0)
9857 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9858 The underscore prefix, controller letter, and unit number are
9859 independently optional; for our purposes, the colon punctuation
9860 is not. The colon can be trailed by optional directory and/or
9861 filename, but two consecutive colons indicates a nodename rather
9862 than a device. [pr] */
9863 if (*name == '_') ++name;
9864 if (tolower(*name++) != 'n') return 0;
9865 if (tolower(*name++) != 'l') return 0;
9866 if (tolower(*name) == 'a') ++name;
9867 if (*name == '0') ++name;
9868 return (*name++ == ':') && (*name != ':');
9871 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
9872 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9873 * subset of the applicable information.
9876 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9878 char fname_phdev[NAM$C_MAXRSS+1];
9879 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9880 /* Namecache not workable with symbolic links, as symbolic links do
9881 * not have extensions and directories do in VMS mode. So in order
9882 * to test this, the did and ino_t must be used.
9884 * Fix-me - Hide the information in the new stat structure
9885 * Get rid of the namecache.
9887 if (decc_posix_compliant_pathnames == 0)
9889 if (statbufp == &PL_statcache)
9890 return cando_by_name(bit,effective,namecache);
9892 char fname[NAM$C_MAXRSS+1];
9893 unsigned long int retsts;
9894 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9895 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9897 /* If the struct mystat is stale, we're OOL; stat() overwrites the
9898 device name on successive calls */
9899 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
9900 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
9901 namdsc.dsc$a_pointer = fname;
9902 namdsc.dsc$w_length = sizeof fname - 1;
9904 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
9905 &namdsc,&namdsc.dsc$w_length,0,0);
9907 fname[namdsc.dsc$w_length] = '\0';
9909 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
9910 * but if someone has redefined that logical, Perl gets very lost. Since
9911 * we have the physical device name from the stat buffer, just paste it on.
9913 strcpy( fname_phdev, statbufp->st_devnam );
9914 strcat( fname_phdev, strrchr(fname, ':') );
9916 return cando_by_name(bit,effective,fname_phdev);
9918 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
9919 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
9923 return FALSE; /* Should never get to here */
9925 } /* end of cando() */
9929 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
9931 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
9933 static char usrname[L_cuserid];
9934 static struct dsc$descriptor_s usrdsc =
9935 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9936 char vmsname[NAM$C_MAXRSS+1];
9938 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
9939 unsigned short int retlen, trnlnm_iter_count;
9940 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9941 union prvdef curprv;
9942 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9943 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
9944 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9945 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9947 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9949 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9951 if (!fname || !*fname) return FALSE;
9952 /* Make sure we expand logical names, since sys$check_access doesn't */
9953 Newx(fileified, VMS_MAXRSS, char);
9954 if (!strpbrk(fname,"/]>:")) {
9955 strcpy(fileified,fname);
9956 trnlnm_iter_count = 0;
9957 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9958 trnlnm_iter_count++;
9959 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9963 if (!do_rmsexpand(fname, vmsname, 1, NULL, PERL_RMSEXPAND_M_VMS)) {
9964 Safefree(fileified);
9967 retlen = namdsc.dsc$w_length = strlen(vmsname);
9968 namdsc.dsc$a_pointer = vmsname;
9969 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9970 vmsname[retlen-1] == ':') {
9971 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9972 namdsc.dsc$w_length = strlen(fileified);
9973 namdsc.dsc$a_pointer = fileified;
9977 case S_IXUSR: case S_IXGRP: case S_IXOTH:
9978 access = ARM$M_EXECUTE; break;
9979 case S_IRUSR: case S_IRGRP: case S_IROTH:
9980 access = ARM$M_READ; break;
9981 case S_IWUSR: case S_IWGRP: case S_IWOTH:
9982 access = ARM$M_WRITE; break;
9983 case S_IDUSR: case S_IDGRP: case S_IDOTH:
9984 access = ARM$M_DELETE; break;
9986 Safefree(fileified);
9990 /* Before we call $check_access, create a user profile with the current
9991 * process privs since otherwise it just uses the default privs from the
9992 * UAF and might give false positives or negatives. This only works on
9993 * VMS versions v6.0 and later since that's when sys$create_user_profile
9997 /* get current process privs and username */
9998 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10001 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10003 /* find out the space required for the profile */
10004 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10005 &usrprodsc.dsc$w_length,0));
10007 /* allocate space for the profile and get it filled in */
10008 Newx(usrprodsc.dsc$a_pointer,usrprodsc.dsc$w_length,char);
10009 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10010 &usrprodsc.dsc$w_length,0));
10012 /* use the profile to check access to the file; free profile & analyze results */
10013 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10014 Safefree(usrprodsc.dsc$a_pointer);
10015 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10019 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10023 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
10024 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10025 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10026 set_vaxc_errno(retsts);
10027 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10028 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10029 else set_errno(ENOENT);
10030 Safefree(fileified);
10033 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10034 Safefree(fileified);
10039 Safefree(fileified);
10040 return FALSE; /* Should never get here */
10042 } /* end of cando_by_name() */
10046 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10048 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10050 if (!fstat(fd,(stat_t *) statbufp)) {
10051 if (statbufp == (Stat_t *) &PL_statcache) {
10054 /* Save name for cando by name in VMS format */
10055 cptr = getname(fd, namecache, 1);
10057 /* This should not happen, but just in case */
10059 namecache[0] = '\0';
10062 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10063 #ifndef _USE_STD_STAT
10064 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10065 statbufp->st_devnam[63] = 0;
10066 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10069 * The device is only encoded so that Perl_cando can use it to
10070 * look up ACLS. So rmsexpand it to the 255 character version
10071 * and store it in ->st_devnam. rmsexpand needs to be fixed
10072 * for long filenames and symbolic links first. This also seems
10073 * to remove the need for a namecache that could be stale.
10077 # ifdef RTL_USES_UTC
10078 # ifdef VMSISH_TIME
10080 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10081 statbufp->st_atime = _toloc(statbufp->st_atime);
10082 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10086 # ifdef VMSISH_TIME
10087 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10091 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10092 statbufp->st_atime = _toutc(statbufp->st_atime);
10093 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10100 } /* end of flex_fstat() */
10103 #if !defined(__VAX) && __CRTL_VER >= 80200000
10111 #define lstat(_x, _y) stat(_x, _y)
10114 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10117 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10119 char fileified[NAM$C_MAXRSS+1];
10120 char temp_fspec[NAM$C_MAXRSS+300];
10122 int saved_errno, saved_vaxc_errno;
10124 if (!fspec) return retval;
10125 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10126 strcpy(temp_fspec, fspec);
10127 if (statbufp == (Stat_t *) &PL_statcache)
10128 do_tovmsspec(temp_fspec,namecache,0);
10129 if (decc_bug_devnull != 0) {
10130 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10131 memset(statbufp,0,sizeof *statbufp);
10132 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
10133 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10134 statbufp->st_uid = 0x00010001;
10135 statbufp->st_gid = 0x0001;
10136 time((time_t *)&statbufp->st_mtime);
10137 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10142 /* Try for a directory name first. If fspec contains a filename without
10143 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10144 * and sea:[wine.dark]water. exist, we prefer the directory here.
10145 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10146 * not sea:[wine.dark]., if the latter exists. If the intended target is
10147 * the file with null type, specify this by calling flex_stat() with
10148 * a '.' at the end of fspec.
10150 * If we are in Posix filespec mode, accept the filename as is.
10152 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10153 if (decc_posix_compliant_pathnames == 0) {
10155 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10156 if (lstat_flag == 0)
10157 retval = stat(fileified,(stat_t *) statbufp);
10159 retval = lstat(fileified,(stat_t *) statbufp);
10160 if (!retval && statbufp == (Stat_t *) &PL_statcache)
10161 strcpy(namecache,fileified);
10164 if (lstat_flag == 0)
10165 retval = stat(temp_fspec,(stat_t *) statbufp);
10167 retval = lstat(temp_fspec,(stat_t *) statbufp);
10169 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10171 if (lstat_flag == 0)
10172 retval = stat(temp_fspec,(stat_t *) statbufp);
10174 retval = lstat(temp_fspec,(stat_t *) statbufp);
10178 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10179 #ifndef _USE_STD_STAT
10180 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10181 statbufp->st_devnam[63] = 0;
10182 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10185 * The device is only encoded so that Perl_cando can use it to
10186 * look up ACLS. So rmsexpand it to the 255 character version
10187 * and store it in ->st_devnam. rmsexpand needs to be fixed
10188 * for long filenames and symbolic links first. This also seems
10189 * to remove the need for a namecache that could be stale.
10192 # ifdef RTL_USES_UTC
10193 # ifdef VMSISH_TIME
10195 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10196 statbufp->st_atime = _toloc(statbufp->st_atime);
10197 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10201 # ifdef VMSISH_TIME
10202 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10206 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10207 statbufp->st_atime = _toutc(statbufp->st_atime);
10208 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10212 /* If we were successful, leave errno where we found it */
10213 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10216 } /* end of flex_stat_int() */
10219 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10221 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10223 return flex_stat_int(fspec, statbufp, 0);
10227 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10229 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10231 return flex_stat_int(fspec, statbufp, 1);
10236 /*{{{char *my_getlogin()*/
10237 /* VMS cuserid == Unix getlogin, except calling sequence */
10241 static char user[L_cuserid];
10242 return cuserid(user);
10247 /* rmscopy - copy a file using VMS RMS routines
10249 * Copies contents and attributes of spec_in to spec_out, except owner
10250 * and protection information. Name and type of spec_in are used as
10251 * defaults for spec_out. The third parameter specifies whether rmscopy()
10252 * should try to propagate timestamps from the input file to the output file.
10253 * If it is less than 0, no timestamps are preserved. If it is 0, then
10254 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
10255 * propagated to the output file at creation iff the output file specification
10256 * did not contain an explicit name or type, and the revision date is always
10257 * updated at the end of the copy operation. If it is greater than 0, then
10258 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10259 * other than the revision date should be propagated, and bit 1 indicates
10260 * that the revision date should be propagated.
10262 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10264 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10265 * Incorporates, with permission, some code from EZCOPY by Tim Adye
10266 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
10267 * as part of the Perl standard distribution under the terms of the
10268 * GNU General Public License or the Perl Artistic License. Copies
10269 * of each may be found in the Perl standard distribution.
10271 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10272 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
10274 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10276 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
10277 rsa[NAM$C_MAXRSS], ubf[32256];
10278 unsigned long int i, sts, sts2;
10279 struct FAB fab_in, fab_out;
10280 struct RAB rab_in, rab_out;
10282 struct XABDAT xabdat;
10283 struct XABFHC xabfhc;
10284 struct XABRDT xabrdt;
10285 struct XABSUM xabsum;
10287 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10288 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10289 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10293 fab_in = cc$rms_fab;
10294 fab_in.fab$l_fna = vmsin;
10295 fab_in.fab$b_fns = strlen(vmsin);
10296 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10297 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10298 fab_in.fab$l_fop = FAB$M_SQO;
10299 fab_in.fab$l_nam = &nam;
10300 fab_in.fab$l_xab = (void *) &xabdat;
10303 nam.nam$l_rsa = rsa;
10304 nam.nam$b_rss = sizeof(rsa);
10305 nam.nam$l_esa = esa;
10306 nam.nam$b_ess = sizeof (esa);
10307 nam.nam$b_esl = nam.nam$b_rsl = 0;
10308 #ifdef NAM$M_NO_SHORT_UPCASE
10309 if (decc_efs_case_preserve)
10310 nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10313 xabdat = cc$rms_xabdat; /* To get creation date */
10314 xabdat.xab$l_nxt = (void *) &xabfhc;
10316 xabfhc = cc$rms_xabfhc; /* To get record length */
10317 xabfhc.xab$l_nxt = (void *) &xabsum;
10319 xabsum = cc$rms_xabsum; /* To get key and area information */
10321 if (!((sts = sys$open(&fab_in)) & 1)) {
10322 set_vaxc_errno(sts);
10324 case RMS$_FNF: case RMS$_DNF:
10325 set_errno(ENOENT); break;
10327 set_errno(ENOTDIR); break;
10329 set_errno(ENODEV); break;
10331 set_errno(EINVAL); break;
10333 set_errno(EACCES); break;
10335 set_errno(EVMSERR);
10341 fab_out.fab$w_ifi = 0;
10342 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10343 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10344 fab_out.fab$l_fop = FAB$M_SQO;
10345 fab_out.fab$l_fna = vmsout;
10346 fab_out.fab$b_fns = strlen(vmsout);
10347 fab_out.fab$l_dna = nam.nam$l_name;
10348 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10350 if (preserve_dates == 0) { /* Act like DCL COPY */
10351 nam.nam$b_nop |= NAM$M_SYNCHK;
10352 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10353 if (!((sts = sys$parse(&fab_out)) & 1)) {
10354 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10355 set_vaxc_errno(sts);
10358 fab_out.fab$l_xab = (void *) &xabdat;
10359 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10361 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
10362 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10363 preserve_dates =0; /* bitmask from this point forward */
10365 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10366 if (!((sts = sys$create(&fab_out)) & 1)) {
10367 set_vaxc_errno(sts);
10370 set_errno(ENOENT); break;
10372 set_errno(ENOTDIR); break;
10374 set_errno(ENODEV); break;
10376 set_errno(EINVAL); break;
10378 set_errno(EACCES); break;
10380 set_errno(EVMSERR);
10384 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10385 if (preserve_dates & 2) {
10386 /* sys$close() will process xabrdt, not xabdat */
10387 xabrdt = cc$rms_xabrdt;
10389 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10391 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10392 * is unsigned long[2], while DECC & VAXC use a struct */
10393 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10395 fab_out.fab$l_xab = (void *) &xabrdt;
10398 rab_in = cc$rms_rab;
10399 rab_in.rab$l_fab = &fab_in;
10400 rab_in.rab$l_rop = RAB$M_BIO;
10401 rab_in.rab$l_ubf = ubf;
10402 rab_in.rab$w_usz = sizeof ubf;
10403 if (!((sts = sys$connect(&rab_in)) & 1)) {
10404 sys$close(&fab_in); sys$close(&fab_out);
10405 set_errno(EVMSERR); set_vaxc_errno(sts);
10409 rab_out = cc$rms_rab;
10410 rab_out.rab$l_fab = &fab_out;
10411 rab_out.rab$l_rbf = ubf;
10412 if (!((sts = sys$connect(&rab_out)) & 1)) {
10413 sys$close(&fab_in); sys$close(&fab_out);
10414 set_errno(EVMSERR); set_vaxc_errno(sts);
10418 while ((sts = sys$read(&rab_in))) { /* always true */
10419 if (sts == RMS$_EOF) break;
10420 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10421 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10422 sys$close(&fab_in); sys$close(&fab_out);
10423 set_errno(EVMSERR); set_vaxc_errno(sts);
10428 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10429 sys$close(&fab_in); sys$close(&fab_out);
10430 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10432 set_errno(EVMSERR); set_vaxc_errno(sts);
10438 } /* end of rmscopy() */
10440 /* ODS-5 support version */
10442 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10444 char *vmsin, * vmsout, *esa, *esa_out,
10446 unsigned long int i, sts, sts2;
10447 struct FAB fab_in, fab_out;
10448 struct RAB rab_in, rab_out;
10450 struct NAML nam_out;
10451 struct XABDAT xabdat;
10452 struct XABFHC xabfhc;
10453 struct XABRDT xabrdt;
10454 struct XABSUM xabsum;
10456 Newx(vmsin, VMS_MAXRSS, char);
10457 Newx(vmsout, VMS_MAXRSS, char);
10458 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10459 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10462 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10466 Newx(esa, VMS_MAXRSS, char);
10468 fab_in = cc$rms_fab;
10469 fab_in.fab$l_fna = (char *) -1;
10470 fab_in.fab$b_fns = 0;
10471 nam.naml$l_long_filename = vmsin;
10472 nam.naml$l_long_filename_size = strlen(vmsin);
10473 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10474 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10475 fab_in.fab$l_fop = FAB$M_SQO;
10476 fab_in.fab$l_naml = &nam;
10477 fab_in.fab$l_xab = (void *) &xabdat;
10479 Newx(rsa, VMS_MAXRSS, char);
10480 nam.naml$l_rsa = NULL;
10481 nam.naml$b_rss = 0;
10482 nam.naml$l_long_result = rsa;
10483 nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10484 nam.naml$l_esa = NULL;
10485 nam.naml$b_ess = 0;
10486 nam.naml$l_long_expand = esa;
10487 nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10488 nam.naml$b_esl = nam.naml$b_rsl = 0;
10489 nam.naml$l_long_expand_size = 0;
10490 nam.naml$l_long_result_size = 0;
10491 #ifdef NAM$M_NO_SHORT_UPCASE
10492 if (decc_efs_case_preserve)
10493 nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10496 xabdat = cc$rms_xabdat; /* To get creation date */
10497 xabdat.xab$l_nxt = (void *) &xabfhc;
10499 xabfhc = cc$rms_xabfhc; /* To get record length */
10500 xabfhc.xab$l_nxt = (void *) &xabsum;
10502 xabsum = cc$rms_xabsum; /* To get key and area information */
10504 if (!((sts = sys$open(&fab_in)) & 1)) {
10509 set_vaxc_errno(sts);
10511 case RMS$_FNF: case RMS$_DNF:
10512 set_errno(ENOENT); break;
10514 set_errno(ENOTDIR); break;
10516 set_errno(ENODEV); break;
10518 set_errno(EINVAL); break;
10520 set_errno(EACCES); break;
10522 set_errno(EVMSERR);
10529 fab_out.fab$w_ifi = 0;
10530 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10531 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10532 fab_out.fab$l_fop = FAB$M_SQO;
10533 fab_out.fab$l_naml = &nam_out;
10534 fab_out.fab$l_fna = (char *) -1;
10535 fab_out.fab$b_fns = 0;
10536 nam_out.naml$l_long_filename = vmsout;
10537 nam_out.naml$l_long_filename_size = strlen(vmsout);
10538 fab_out.fab$l_dna = (char *) -1;
10539 fab_out.fab$b_dns = 0;
10540 nam_out.naml$l_long_defname = nam.naml$l_long_name;
10541 nam_out.naml$l_long_defname_size =
10542 nam.naml$l_long_name ?
10543 nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10545 Newx(esa_out, VMS_MAXRSS, char);
10546 nam_out.naml$l_rsa = NULL;
10547 nam_out.naml$b_rss = 0;
10548 nam_out.naml$l_long_result = NULL;
10549 nam_out.naml$l_long_result_alloc = 0;
10550 nam_out.naml$l_esa = NULL;
10551 nam_out.naml$b_ess = 0;
10552 nam_out.naml$l_long_expand = esa_out;
10553 nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10555 if (preserve_dates == 0) { /* Act like DCL COPY */
10556 nam_out.naml$b_nop |= NAM$M_SYNCHK;
10557 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10558 if (!((sts = sys$parse(&fab_out)) & 1)) {
10564 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10565 set_vaxc_errno(sts);
10568 fab_out.fab$l_xab = (void *) &xabdat;
10569 if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10571 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10572 preserve_dates =0; /* bitmask from this point forward */
10574 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10575 if (!((sts = sys$create(&fab_out)) & 1)) {
10581 set_vaxc_errno(sts);
10584 set_errno(ENOENT); break;
10586 set_errno(ENOTDIR); break;
10588 set_errno(ENODEV); break;
10590 set_errno(EINVAL); break;
10592 set_errno(EACCES); break;
10594 set_errno(EVMSERR);
10598 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10599 if (preserve_dates & 2) {
10600 /* sys$close() will process xabrdt, not xabdat */
10601 xabrdt = cc$rms_xabrdt;
10603 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10605 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10606 * is unsigned long[2], while DECC & VAXC use a struct */
10607 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10609 fab_out.fab$l_xab = (void *) &xabrdt;
10612 Newx(ubf, 32256, char);
10613 rab_in = cc$rms_rab;
10614 rab_in.rab$l_fab = &fab_in;
10615 rab_in.rab$l_rop = RAB$M_BIO;
10616 rab_in.rab$l_ubf = ubf;
10617 rab_in.rab$w_usz = 32256;
10618 if (!((sts = sys$connect(&rab_in)) & 1)) {
10619 sys$close(&fab_in); sys$close(&fab_out);
10626 set_errno(EVMSERR); set_vaxc_errno(sts);
10630 rab_out = cc$rms_rab;
10631 rab_out.rab$l_fab = &fab_out;
10632 rab_out.rab$l_rbf = ubf;
10633 if (!((sts = sys$connect(&rab_out)) & 1)) {
10634 sys$close(&fab_in); sys$close(&fab_out);
10641 set_errno(EVMSERR); set_vaxc_errno(sts);
10645 while ((sts = sys$read(&rab_in))) { /* always true */
10646 if (sts == RMS$_EOF) break;
10647 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10648 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10649 sys$close(&fab_in); sys$close(&fab_out);
10656 set_errno(EVMSERR); set_vaxc_errno(sts);
10662 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10663 sys$close(&fab_in); sys$close(&fab_out);
10664 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10672 set_errno(EVMSERR); set_vaxc_errno(sts);
10684 } /* end of rmscopy() */
10689 /*** The following glue provides 'hooks' to make some of the routines
10690 * from this file available from Perl. These routines are sufficiently
10691 * basic, and are required sufficiently early in the build process,
10692 * that's it's nice to have them available to miniperl as well as the
10693 * full Perl, so they're set up here instead of in an extension. The
10694 * Perl code which handles importation of these names into a given
10695 * package lives in [.VMS]Filespec.pm in @INC.
10699 rmsexpand_fromperl(pTHX_ CV *cv)
10702 char *fspec, *defspec = NULL, *rslt;
10705 if (!items || items > 2)
10706 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10707 fspec = SvPV(ST(0),n_a);
10708 if (!fspec || !*fspec) XSRETURN_UNDEF;
10709 if (items == 2) defspec = SvPV(ST(1),n_a);
10711 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10712 ST(0) = sv_newmortal();
10713 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10718 vmsify_fromperl(pTHX_ CV *cv)
10724 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10725 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10726 ST(0) = sv_newmortal();
10727 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10732 unixify_fromperl(pTHX_ CV *cv)
10738 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10739 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10740 ST(0) = sv_newmortal();
10741 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10746 fileify_fromperl(pTHX_ CV *cv)
10752 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10753 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10754 ST(0) = sv_newmortal();
10755 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10760 pathify_fromperl(pTHX_ CV *cv)
10766 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10767 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10768 ST(0) = sv_newmortal();
10769 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10774 vmspath_fromperl(pTHX_ CV *cv)
10780 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10781 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10782 ST(0) = sv_newmortal();
10783 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10788 unixpath_fromperl(pTHX_ CV *cv)
10794 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10795 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10796 ST(0) = sv_newmortal();
10797 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10802 candelete_fromperl(pTHX_ CV *cv)
10805 char fspec[NAM$C_MAXRSS+1], *fsp;
10810 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10812 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10813 if (SvTYPE(mysv) == SVt_PVGV) {
10814 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10815 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10822 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10823 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10829 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10834 rmscopy_fromperl(pTHX_ CV *cv)
10837 char *inspec, *outspec, *inp, *outp;
10839 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10840 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10841 unsigned long int sts;
10846 if (items < 2 || items > 3)
10847 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10849 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10850 Newx(inspec, VMS_MAXRSS, char);
10851 if (SvTYPE(mysv) == SVt_PVGV) {
10852 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10853 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10861 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10862 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10868 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10869 Newx(outspec, VMS_MAXRSS, char);
10870 if (SvTYPE(mysv) == SVt_PVGV) {
10871 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10872 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10881 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10882 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10889 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10891 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10897 /* The mod2fname is limited to shorter filenames by design, so it should
10898 * not be modified to support longer EFS pathnames
10901 mod2fname(pTHX_ CV *cv)
10904 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10905 workbuff[NAM$C_MAXRSS*1 + 1];
10906 int total_namelen = 3, counter, num_entries;
10907 /* ODS-5 ups this, but we want to be consistent, so... */
10908 int max_name_len = 39;
10909 AV *in_array = (AV *)SvRV(ST(0));
10911 num_entries = av_len(in_array);
10913 /* All the names start with PL_. */
10914 strcpy(ultimate_name, "PL_");
10916 /* Clean up our working buffer */
10917 Zero(work_name, sizeof(work_name), char);
10919 /* Run through the entries and build up a working name */
10920 for(counter = 0; counter <= num_entries; counter++) {
10921 /* If it's not the first name then tack on a __ */
10923 strcat(work_name, "__");
10925 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10929 /* Check to see if we actually have to bother...*/
10930 if (strlen(work_name) + 3 <= max_name_len) {
10931 strcat(ultimate_name, work_name);
10933 /* It's too darned big, so we need to go strip. We use the same */
10934 /* algorithm as xsubpp does. First, strip out doubled __ */
10935 char *source, *dest, last;
10938 for (source = work_name; *source; source++) {
10939 if (last == *source && last == '_') {
10945 /* Go put it back */
10946 strcpy(work_name, workbuff);
10947 /* Is it still too big? */
10948 if (strlen(work_name) + 3 > max_name_len) {
10949 /* Strip duplicate letters */
10952 for (source = work_name; *source; source++) {
10953 if (last == toupper(*source)) {
10957 last = toupper(*source);
10959 strcpy(work_name, workbuff);
10962 /* Is it *still* too big? */
10963 if (strlen(work_name) + 3 > max_name_len) {
10964 /* Too bad, we truncate */
10965 work_name[max_name_len - 2] = 0;
10967 strcat(ultimate_name, work_name);
10970 /* Okay, return it */
10971 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10976 hushexit_fromperl(pTHX_ CV *cv)
10981 VMSISH_HUSHED = SvTRUE(ST(0));
10983 ST(0) = boolSV(VMSISH_HUSHED);
10989 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10992 vms_realpath_fromperl(pTHX_ CV *cv)
10995 char *fspec, *rslt_spec, *rslt;
10998 if (!items || items != 1)
10999 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11001 fspec = SvPV(ST(0),n_a);
11002 if (!fspec || !*fspec) XSRETURN_UNDEF;
11004 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11005 rslt = do_vms_realpath(fspec, rslt_spec);
11006 ST(0) = sv_newmortal();
11008 sv_usepvn(ST(0),rslt,strlen(rslt));
11010 Safefree(rslt_spec);
11015 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11016 int do_vms_case_tolerant(void);
11019 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11022 ST(0) = boolSV(do_vms_case_tolerant());
11028 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11029 struct interp_intern *dst)
11031 memcpy(dst,src,sizeof(struct interp_intern));
11035 Perl_sys_intern_clear(pTHX)
11040 Perl_sys_intern_init(pTHX)
11042 unsigned int ix = RAND_MAX;
11047 /* fix me later to track running under GNV */
11048 /* this allows some limited testing */
11049 MY_POSIX_EXIT = decc_filename_unix_report;
11052 MY_INV_RAND_MAX = 1./x;
11056 init_os_extras(void)
11059 char* file = __FILE__;
11060 char temp_buff[512];
11061 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
11062 no_translate_barewords = TRUE;
11064 no_translate_barewords = FALSE;
11067 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11068 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11069 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11070 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11071 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11072 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11073 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11074 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11075 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11076 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11077 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11079 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11081 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11082 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11085 store_pipelocs(aTHX); /* will redo any earlier attempts */
11092 #if __CRTL_VER == 80200000
11093 /* This missed getting in to the DECC SDK for 8.2 */
11094 char *realpath(const char *file_name, char * resolved_name, ...);
11097 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11098 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11099 * The perl fallback routine to provide realpath() is not as efficient
11103 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11105 return realpath(filespec, outbuf);
11109 /* External entry points */
11110 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11111 { return do_vms_realpath(filespec, outbuf); }
11113 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11118 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11119 /* case_tolerant */
11121 /*{{{int do_vms_case_tolerant(void)*/
11122 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11123 * controlled by a process setting.
11125 int do_vms_case_tolerant(void)
11127 return vms_process_case_tolerant;
11130 /* External entry points */
11131 int Perl_vms_case_tolerant(void)
11132 { return do_vms_case_tolerant(); }
11134 int Perl_vms_case_tolerant(void)
11135 { return vms_process_case_tolerant; }
11139 /* Start of DECC RTL Feature handling */
11141 static int sys_trnlnm
11142 (const char * logname,
11146 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11147 const unsigned long attr = LNM$M_CASE_BLIND;
11148 struct dsc$descriptor_s name_dsc;
11150 unsigned short result;
11151 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11154 name_dsc.dsc$w_length = strlen(logname);
11155 name_dsc.dsc$a_pointer = (char *)logname;
11156 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11157 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11159 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11161 if ($VMS_STATUS_SUCCESS(status)) {
11163 /* Null terminate and return the string */
11164 /*--------------------------------------*/
11171 static int sys_crelnm
11172 (const char * logname,
11173 const char * value)
11176 const char * proc_table = "LNM$PROCESS_TABLE";
11177 struct dsc$descriptor_s proc_table_dsc;
11178 struct dsc$descriptor_s logname_dsc;
11179 struct itmlst_3 item_list[2];
11181 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11182 proc_table_dsc.dsc$w_length = strlen(proc_table);
11183 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11184 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11186 logname_dsc.dsc$a_pointer = (char *) logname;
11187 logname_dsc.dsc$w_length = strlen(logname);
11188 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11189 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11191 item_list[0].buflen = strlen(value);
11192 item_list[0].itmcode = LNM$_STRING;
11193 item_list[0].bufadr = (char *)value;
11194 item_list[0].retlen = NULL;
11196 item_list[1].buflen = 0;
11197 item_list[1].itmcode = 0;
11199 ret_val = sys$crelnm
11201 (const struct dsc$descriptor_s *)&proc_table_dsc,
11202 (const struct dsc$descriptor_s *)&logname_dsc,
11204 (const struct item_list_3 *) item_list);
11210 /* C RTL Feature settings */
11212 static int set_features
11213 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
11214 int (* cli_routine)(void), /* Not documented */
11215 void *image_info) /* Not documented */
11222 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11223 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11224 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11225 unsigned long case_perm;
11226 unsigned long case_image;
11229 /* Allow an exception to bring Perl into the VMS debugger */
11230 vms_debug_on_exception = 0;
11231 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11232 if ($VMS_STATUS_SUCCESS(status)) {
11233 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11234 vms_debug_on_exception = 1;
11236 vms_debug_on_exception = 0;
11240 /* hacks to see if known bugs are still present for testing */
11242 /* Readdir is returning filenames in VMS syntax always */
11243 decc_bug_readdir_efs1 = 1;
11244 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11245 if ($VMS_STATUS_SUCCESS(status)) {
11246 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11247 decc_bug_readdir_efs1 = 1;
11249 decc_bug_readdir_efs1 = 0;
11252 /* PCP mode requires creating /dev/null special device file */
11253 decc_bug_devnull = 1;
11254 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11255 if ($VMS_STATUS_SUCCESS(status)) {
11256 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11257 decc_bug_devnull = 1;
11259 decc_bug_devnull = 0;
11262 /* fgetname returning a VMS name in UNIX mode */
11263 decc_bug_fgetname = 1;
11264 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11265 if ($VMS_STATUS_SUCCESS(status)) {
11266 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11267 decc_bug_fgetname = 1;
11269 decc_bug_fgetname = 0;
11272 /* UNIX directory names with no paths are broken in a lot of places */
11273 decc_dir_barename = 1;
11274 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11275 if ($VMS_STATUS_SUCCESS(status)) {
11276 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11277 decc_dir_barename = 1;
11279 decc_dir_barename = 0;
11282 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11283 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11285 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11286 if (decc_disable_to_vms_logname_translation < 0)
11287 decc_disable_to_vms_logname_translation = 0;
11290 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11292 decc_efs_case_preserve = decc$feature_get_value(s, 1);
11293 if (decc_efs_case_preserve < 0)
11294 decc_efs_case_preserve = 0;
11297 s = decc$feature_get_index("DECC$EFS_CHARSET");
11299 decc_efs_charset = decc$feature_get_value(s, 1);
11300 if (decc_efs_charset < 0)
11301 decc_efs_charset = 0;
11304 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11306 decc_filename_unix_report = decc$feature_get_value(s, 1);
11307 if (decc_filename_unix_report > 0)
11308 decc_filename_unix_report = 1;
11310 decc_filename_unix_report = 0;
11313 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11315 decc_filename_unix_only = decc$feature_get_value(s, 1);
11316 if (decc_filename_unix_only > 0) {
11317 decc_filename_unix_only = 1;
11320 decc_filename_unix_only = 0;
11324 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11326 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11327 if (decc_filename_unix_no_version < 0)
11328 decc_filename_unix_no_version = 0;
11331 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11333 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11334 if (decc_readdir_dropdotnotype < 0)
11335 decc_readdir_dropdotnotype = 0;
11338 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11339 if ($VMS_STATUS_SUCCESS(status)) {
11340 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11342 dflt = decc$feature_get_value(s, 4);
11344 decc_disable_posix_root = decc$feature_get_value(s, 1);
11345 if (decc_disable_posix_root <= 0) {
11346 decc$feature_set_value(s, 1, 1);
11347 decc_disable_posix_root = 1;
11351 /* Traditionally Perl assumes this is off */
11352 decc_disable_posix_root = 1;
11353 decc$feature_set_value(s, 1, 1);
11358 #if __CRTL_VER >= 80200000
11359 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11361 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11362 if (decc_posix_compliant_pathnames < 0)
11363 decc_posix_compliant_pathnames = 0;
11364 if (decc_posix_compliant_pathnames > 4)
11365 decc_posix_compliant_pathnames = 0;
11370 status = sys_trnlnm
11371 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11372 if ($VMS_STATUS_SUCCESS(status)) {
11373 val_str[0] = _toupper(val_str[0]);
11374 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11375 decc_disable_to_vms_logname_translation = 1;
11380 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11381 if ($VMS_STATUS_SUCCESS(status)) {
11382 val_str[0] = _toupper(val_str[0]);
11383 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11384 decc_efs_case_preserve = 1;
11389 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11390 if ($VMS_STATUS_SUCCESS(status)) {
11391 val_str[0] = _toupper(val_str[0]);
11392 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11393 decc_filename_unix_report = 1;
11396 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11397 if ($VMS_STATUS_SUCCESS(status)) {
11398 val_str[0] = _toupper(val_str[0]);
11399 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11400 decc_filename_unix_only = 1;
11401 decc_filename_unix_report = 1;
11404 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11405 if ($VMS_STATUS_SUCCESS(status)) {
11406 val_str[0] = _toupper(val_str[0]);
11407 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11408 decc_filename_unix_no_version = 1;
11411 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11412 if ($VMS_STATUS_SUCCESS(status)) {
11413 val_str[0] = _toupper(val_str[0]);
11414 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11415 decc_readdir_dropdotnotype = 1;
11420 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11422 /* Report true case tolerance */
11423 /*----------------------------*/
11424 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11425 if (!$VMS_STATUS_SUCCESS(status))
11426 case_perm = PPROP$K_CASE_BLIND;
11427 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11428 if (!$VMS_STATUS_SUCCESS(status))
11429 case_image = PPROP$K_CASE_BLIND;
11430 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11431 (case_image == PPROP$K_CASE_SENSITIVE))
11432 vms_process_case_tolerant = 0;
11437 /* CRTL can be initialized past this point, but not before. */
11438 /* DECC$CRTL_INIT(); */
11444 /* DECC dependent attributes */
11445 #if __DECC_VER < 60560002
11447 #define not_executable
11449 #define relative ,rel
11450 #define not_executable ,noexe
11453 #pragma extern_model save
11454 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11456 const __align (LONGWORD) int spare[8] = {0};
11457 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11460 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11461 nowrt,noshr relative not_executable
11463 const long vms_cc_features = (const long)set_features;
11466 ** Force a reference to LIB$INITIALIZE to ensure it
11467 ** exists in the image.
11469 int lib$initialize(void);
11471 #pragma extern_model strict_refdef
11473 int lib_init_ref = (int) lib$initialize;
11476 #pragma extern_model restore