3 * VMS-specific routines for perl5
6 * August 2005 Convert VMS status code to UNIX status codes
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
44 #include <str$routines.h>
50 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
52 #define NO_EFN EFN$C_ENF
57 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
58 int decc$feature_get_index(const char *name);
59 char* decc$feature_get_name(int index);
60 int decc$feature_get_value(int index, int mode);
61 int decc$feature_set_value(int index, int mode, int value);
66 #pragma member_alignment save
67 #pragma nomember_alignment longword
72 unsigned short * retadr;
74 #pragma member_alignment restore
76 /* More specific prototype than in starlet_c.h makes programming errors
85 const struct dsc$descriptor_s * devnam,
86 const struct item_list_3 * itmlst,
88 void * (astadr)(unsigned long),
92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
94 static int set_feature_default(const char *name, int value)
99 index = decc$feature_get_index(name);
101 status = decc$feature_set_value(index, 1, value);
102 if (index == -1 || (status == -1)) {
106 status = decc$feature_get_value(index, 1);
107 if (status != value) {
115 /* Older versions of ssdef.h don't have these */
116 #ifndef SS$_INVFILFOROP
117 # define SS$_INVFILFOROP 3930
119 #ifndef SS$_NOSUCHOBJECT
120 # define SS$_NOSUCHOBJECT 2696
123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
124 #define PERLIO_NOT_STDIO 0
126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
127 * code below needs to get to the underlying CRTL routines. */
128 #define DONT_MASK_RTL_CALLS
132 /* Anticipating future expansion in lexical warnings . . . */
133 #ifndef WARN_INTERNAL
134 # define WARN_INTERNAL WARN_MISC
137 #ifdef VMS_LONGNAME_SUPPORT
138 #include <libfildef.h>
141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
142 # define RTL_USES_UTC 1
146 /* gcc's header files don't #define direct access macros
147 * corresponding to VAXC's variant structs */
149 # define uic$v_format uic$r_uic_form.uic$v_format
150 # define uic$v_group uic$r_uic_form.uic$v_group
151 # define uic$v_member uic$r_uic_form.uic$v_member
152 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
153 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
154 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
155 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
158 #if defined(NEED_AN_H_ERRNO)
163 #pragma message disable pragma
164 #pragma member_alignment save
165 #pragma nomember_alignment longword
167 #pragma message disable misalgndmem
170 unsigned short int buflen;
171 unsigned short int itmcode;
173 unsigned short int *retlen;
176 struct filescan_itmlst_2 {
177 unsigned short length;
178 unsigned short itmcode;
183 unsigned short length;
188 #pragma message restore
189 #pragma member_alignment restore
192 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
193 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
194 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
195 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
196 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
197 #define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
198 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
199 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
200 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
201 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
202 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
204 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
205 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
206 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
207 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
213 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
216 #define PERL_LNM_MAX_ITER 10
218 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
220 #define MAX_DCL_SYMBOL (8192)
221 #define MAX_DCL_LINE_LENGTH (4096 - 4)
223 #define MAX_DCL_SYMBOL (1024)
224 #define MAX_DCL_LINE_LENGTH (1024 - 4)
227 static char *__mystrtolower(char *str)
229 if (str) for (; *str; ++str) *str= tolower(*str);
233 static struct dsc$descriptor_s fildevdsc =
234 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
235 static struct dsc$descriptor_s crtlenvdsc =
236 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
239 static struct dsc$descriptor_s **env_tables = defenv;
240 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
242 /* True if we shouldn't treat barewords as logicals during directory */
244 static int no_translate_barewords;
247 static int tz_updated = 1;
250 /* DECC Features that may need to affect how Perl interprets
251 * displays filename information
253 static int decc_disable_to_vms_logname_translation = 1;
254 static int decc_disable_posix_root = 1;
255 int decc_efs_case_preserve = 0;
256 static int decc_efs_charset = 0;
257 static int decc_filename_unix_no_version = 0;
258 static int decc_filename_unix_only = 0;
259 int decc_filename_unix_report = 0;
260 int decc_posix_compliant_pathnames = 0;
261 int decc_readdir_dropdotnotype = 0;
262 static int vms_process_case_tolerant = 1;
264 /* bug workarounds if needed */
265 int decc_bug_readdir_efs1 = 0;
266 int decc_bug_devnull = 1;
267 int decc_bug_fgetname = 0;
268 int decc_dir_barename = 0;
270 static int vms_debug_on_exception = 0;
272 /* Is this a UNIX file specification?
273 * No longer a simple check with EFS file specs
274 * For now, not a full check, but need to
275 * handle POSIX ^UP^ specifications
276 * Fixing to handle ^/ cases would require
277 * changes to many other conversion routines.
280 static int is_unix_filespec(const char *path)
286 if (strncmp(path,"\"^UP^",5) != 0) {
287 pch1 = strchr(path, '/');
292 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
293 if (decc_filename_unix_report || decc_filename_unix_only) {
294 if (strcmp(path,".") == 0)
302 /* This handles the expansion of a '^' prefix to the proper character
303 * in a UNIX file specification.
305 * The output count variable contains the number of characters added
306 * to the output string.
308 * The return value is the number of characters read from the input
311 static int copy_expand_vms_filename_escape
312 (char *outspec, const char *inspec, int *output_cnt)
319 if (*inspec == '^') {
323 /* Non trailing dots should just be passed through */
328 case '_': /* space */
334 case 'U': /* Unicode */
337 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
340 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
341 outspec[0] == c1 & 0xff;
342 outspec[1] == c2 & 0xff;
349 /* Error - do best we can to continue */
359 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
363 scnt = sscanf(inspec, "%2x", &c1);
364 outspec[0] = c1 & 0xff;
387 (const struct dsc$descriptor_s * srcstr,
388 struct filescan_itmlst_2 * valuelist,
389 unsigned long * fldflags,
390 struct dsc$descriptor_s *auxout,
391 unsigned short * retlen);
393 /* vms_split_path - Verify that the input file specification is a
394 * VMS format file specification, and provide pointers to the components of
395 * it. With EFS format filenames, this is virtually the only way to
396 * parse a VMS path specification into components.
398 * If the sum of the components do not add up to the length of the
399 * string, then the passed file specification is probably a UNIX style
402 static int vms_split_path
403 (pTHX_ const char * path,
417 struct dsc$descriptor path_desc;
421 struct filescan_itmlst_2 item_list[9];
422 const int filespec = 0;
423 const int nodespec = 1;
424 const int devspec = 2;
425 const int rootspec = 3;
426 const int dirspec = 4;
427 const int namespec = 5;
428 const int typespec = 6;
429 const int verspec = 7;
431 /* Assume the worst for an easy exit */
446 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
447 path_desc.dsc$w_length = strlen(path);
448 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
449 path_desc.dsc$b_class = DSC$K_CLASS_S;
451 /* Get the total length, if it is shorter than the string passed
452 * then this was probably not a VMS formatted file specification
454 item_list[filespec].itmcode = FSCN$_FILESPEC;
455 item_list[filespec].length = 0;
456 item_list[filespec].component = NULL;
458 /* If the node is present, then it gets considered as part of the
459 * volume name to hopefully make things simple.
461 item_list[nodespec].itmcode = FSCN$_NODE;
462 item_list[nodespec].length = 0;
463 item_list[nodespec].component = NULL;
465 item_list[devspec].itmcode = FSCN$_DEVICE;
466 item_list[devspec].length = 0;
467 item_list[devspec].component = NULL;
469 /* root is a special case, adding it to either the directory or
470 * the device components will probalby complicate things for the
471 * callers of this routine, so leave it separate.
473 item_list[rootspec].itmcode = FSCN$_ROOT;
474 item_list[rootspec].length = 0;
475 item_list[rootspec].component = NULL;
477 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
478 item_list[dirspec].length = 0;
479 item_list[dirspec].component = NULL;
481 item_list[namespec].itmcode = FSCN$_NAME;
482 item_list[namespec].length = 0;
483 item_list[namespec].component = NULL;
485 item_list[typespec].itmcode = FSCN$_TYPE;
486 item_list[typespec].length = 0;
487 item_list[typespec].component = NULL;
489 item_list[verspec].itmcode = FSCN$_VERSION;
490 item_list[verspec].length = 0;
491 item_list[verspec].component = NULL;
493 item_list[8].itmcode = 0;
494 item_list[8].length = 0;
495 item_list[8].component = NULL;
497 status = SYS$FILESCAN
498 ((const struct dsc$descriptor_s *)&path_desc, item_list,
500 _ckvmssts(status); /* All failure status values indicate a coding error */
502 /* If we parsed it successfully these two lengths should be the same */
503 if (path_desc.dsc$w_length != item_list[filespec].length)
506 /* If we got here, then it is a VMS file specification */
509 /* set the volume name */
510 if (item_list[nodespec].length > 0) {
511 *volume = item_list[nodespec].component;
512 *vol_len = item_list[nodespec].length + item_list[devspec].length;
515 *volume = item_list[devspec].component;
516 *vol_len = item_list[devspec].length;
519 *root = item_list[rootspec].component;
520 *root_len = item_list[rootspec].length;
522 *dir = item_list[dirspec].component;
523 *dir_len = item_list[dirspec].length;
525 /* Now fun with versions and EFS file specifications
526 * The parser can not tell the difference when a "." is a version
527 * delimiter or a part of the file specification.
529 if ((decc_efs_charset) &&
530 (item_list[verspec].length > 0) &&
531 (item_list[verspec].component[0] == '.')) {
532 *name = item_list[namespec].component;
533 *name_len = item_list[namespec].length + item_list[typespec].length;
534 *ext = item_list[verspec].component;
535 *ext_len = item_list[verspec].length;
540 *name = item_list[namespec].component;
541 *name_len = item_list[namespec].length;
542 *ext = item_list[typespec].component;
543 *ext_len = item_list[typespec].length;
544 *version = item_list[verspec].component;
545 *ver_len = item_list[verspec].length;
552 * Routine to retrieve the maximum equivalence index for an input
553 * logical name. Some calls to this routine have no knowledge if
554 * the variable is a logical or not. So on error we return a max
557 /*{{{int my_maxidx(const char *lnm) */
559 my_maxidx(const char *lnm)
563 int attr = LNM$M_CASE_BLIND;
564 struct dsc$descriptor lnmdsc;
565 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
568 lnmdsc.dsc$w_length = strlen(lnm);
569 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
570 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
571 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
573 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
574 if ((status & 1) == 0)
581 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
583 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
584 struct dsc$descriptor_s **tabvec, unsigned long int flags)
587 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
588 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
589 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
591 unsigned char acmode;
592 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
593 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
594 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
595 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
597 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
598 #if defined(PERL_IMPLICIT_CONTEXT)
601 aTHX = PERL_GET_INTERP;
607 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
608 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
610 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
611 *cp2 = _toupper(*cp1);
612 if (cp1 - lnm > LNM$C_NAMLENGTH) {
613 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
617 lnmdsc.dsc$w_length = cp1 - lnm;
618 lnmdsc.dsc$a_pointer = uplnm;
619 uplnm[lnmdsc.dsc$w_length] = '\0';
620 secure = flags & PERL__TRNENV_SECURE;
621 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
622 if (!tabvec || !*tabvec) tabvec = env_tables;
624 for (curtab = 0; tabvec[curtab]; curtab++) {
625 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
626 if (!ivenv && !secure) {
631 Perl_warn(aTHX_ "Can't read CRTL environ\n");
634 retsts = SS$_NOLOGNAM;
635 for (i = 0; environ[i]; i++) {
636 if ((eq = strchr(environ[i],'=')) &&
637 lnmdsc.dsc$w_length == (eq - environ[i]) &&
638 !strncmp(environ[i],uplnm,eq - environ[i])) {
640 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
641 if (!eqvlen) continue;
646 if (retsts != SS$_NOLOGNAM) break;
649 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
650 !str$case_blind_compare(&tmpdsc,&clisym)) {
651 if (!ivsym && !secure) {
652 unsigned short int deflen = LNM$C_NAMLENGTH;
653 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
654 /* dynamic dsc to accomodate possible long value */
655 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
656 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
658 if (eqvlen > MAX_DCL_SYMBOL) {
659 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
660 eqvlen = MAX_DCL_SYMBOL;
661 /* Special hack--we might be called before the interpreter's */
662 /* fully initialized, in which case either thr or PL_curcop */
663 /* might be bogus. We have to check, since ckWARN needs them */
664 /* both to be valid if running threaded */
665 if (ckWARN(WARN_MISC)) {
666 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
669 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
671 _ckvmssts(lib$sfree1_dd(&eqvdsc));
672 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
673 if (retsts == LIB$_NOSUCHSYM) continue;
678 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
679 midx = my_maxidx(lnm);
680 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
681 lnmlst[1].bufadr = cp2;
683 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
684 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
685 if (retsts == SS$_NOLOGNAM) break;
686 /* PPFs have a prefix */
689 *((int *)uplnm) == *((int *)"SYS$") &&
691 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
692 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
693 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
694 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
695 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
696 memmove(eqv,eqv+4,eqvlen-4);
702 if ((retsts == SS$_IVLOGNAM) ||
703 (retsts == SS$_NOLOGNAM)) { continue; }
706 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
707 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
708 if (retsts == SS$_NOLOGNAM) continue;
711 eqvlen = strlen(eqv);
715 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
716 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
717 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
718 retsts == SS$_NOLOGNAM) {
719 set_errno(EINVAL); set_vaxc_errno(retsts);
721 else _ckvmssts(retsts);
723 } /* end of vmstrnenv */
726 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
727 /* Define as a function so we can access statics. */
728 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
730 return vmstrnenv(lnm,eqv,idx,fildev,
731 #ifdef SECURE_INTERNAL_GETENV
732 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
741 * Note: Uses Perl temp to store result so char * can be returned to
742 * caller; this pointer will be invalidated at next Perl statement
744 * We define this as a function rather than a macro in terms of my_getenv_len()
745 * so that it'll work when PL_curinterp is undefined (and we therefore can't
748 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
750 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
753 static char *__my_getenv_eqv = NULL;
754 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
755 unsigned long int idx = 0;
756 int trnsuccess, success, secure, saverr, savvmserr;
760 midx = my_maxidx(lnm) + 1;
762 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
763 /* Set up a temporary buffer for the return value; Perl will
764 * clean it up at the next statement transition */
765 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
766 if (!tmpsv) return NULL;
770 /* Assume no interpreter ==> single thread */
771 if (__my_getenv_eqv != NULL) {
772 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
775 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
777 eqv = __my_getenv_eqv;
780 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
781 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
783 getcwd(eqv,LNM$C_NAMLENGTH);
787 /* Get rid of "000000/ in rooted filespecs */
790 zeros = strstr(eqv, "/000000/");
793 mlen = len - (zeros - eqv) - 7;
794 memmove(zeros, &zeros[7], mlen);
802 /* Impose security constraints only if tainting */
804 /* Impose security constraints only if tainting */
805 secure = PL_curinterp ? PL_tainting : will_taint;
806 saverr = errno; savvmserr = vaxc$errno;
813 #ifdef SECURE_INTERNAL_GETENV
814 secure ? PERL__TRNENV_SECURE : 0
820 /* For the getenv interface we combine all the equivalence names
821 * of a search list logical into one value to acquire a maximum
822 * value length of 255*128 (assuming %ENV is using logicals).
824 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
826 /* If the name contains a semicolon-delimited index, parse it
827 * off and make sure we only retrieve the equivalence name for
829 if ((cp2 = strchr(lnm,';')) != NULL) {
831 uplnm[cp2-lnm] = '\0';
832 idx = strtoul(cp2+1,NULL,0);
834 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
837 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
839 /* Discard NOLOGNAM on internal calls since we're often looking
840 * for an optional name, and this "error" often shows up as the
841 * (bogus) exit status for a die() call later on. */
842 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
843 return success ? eqv : Nullch;
846 } /* end of my_getenv() */
850 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
852 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
856 unsigned long idx = 0;
858 static char *__my_getenv_len_eqv = NULL;
859 int secure, saverr, savvmserr;
862 midx = my_maxidx(lnm) + 1;
864 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
865 /* Set up a temporary buffer for the return value; Perl will
866 * clean it up at the next statement transition */
867 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
868 if (!tmpsv) return NULL;
872 /* Assume no interpreter ==> single thread */
873 if (__my_getenv_len_eqv != NULL) {
874 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
877 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
879 buf = __my_getenv_len_eqv;
882 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
883 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
886 getcwd(buf,LNM$C_NAMLENGTH);
889 /* Get rid of "000000/ in rooted filespecs */
891 zeros = strstr(buf, "/000000/");
894 mlen = *len - (zeros - buf) - 7;
895 memmove(zeros, &zeros[7], mlen);
904 /* Impose security constraints only if tainting */
905 secure = PL_curinterp ? PL_tainting : will_taint;
906 saverr = errno; savvmserr = vaxc$errno;
913 #ifdef SECURE_INTERNAL_GETENV
914 secure ? PERL__TRNENV_SECURE : 0
920 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
922 if ((cp2 = strchr(lnm,';')) != NULL) {
925 idx = strtoul(cp2+1,NULL,0);
927 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
930 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
932 /* Get rid of "000000/ in rooted filespecs */
935 zeros = strstr(buf, "/000000/");
938 mlen = *len - (zeros - buf) - 7;
939 memmove(zeros, &zeros[7], mlen);
945 /* Discard NOLOGNAM on internal calls since we're often looking
946 * for an optional name, and this "error" often shows up as the
947 * (bogus) exit status for a die() call later on. */
948 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
949 return *len ? buf : Nullch;
952 } /* end of my_getenv_len() */
955 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
957 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
959 /*{{{ void prime_env_iter() */
962 /* Fill the %ENV associative array with all logical names we can
963 * find, in preparation for iterating over it.
966 static int primed = 0;
967 HV *seenhv = NULL, *envhv;
969 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
970 unsigned short int chan;
971 #ifndef CLI$M_TRUSTED
972 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
974 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
975 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
977 bool have_sym = FALSE, have_lnm = FALSE;
978 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
979 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
980 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
981 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
982 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
983 #if defined(PERL_IMPLICIT_CONTEXT)
986 #if defined(USE_ITHREADS)
987 static perl_mutex primenv_mutex;
988 MUTEX_INIT(&primenv_mutex);
991 #if defined(PERL_IMPLICIT_CONTEXT)
992 /* We jump through these hoops because we can be called at */
993 /* platform-specific initialization time, which is before anything is */
994 /* set up--we can't even do a plain dTHX since that relies on the */
995 /* interpreter structure to be initialized */
997 aTHX = PERL_GET_INTERP;
1003 if (primed || !PL_envgv) return;
1004 MUTEX_LOCK(&primenv_mutex);
1005 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1006 envhv = GvHVn(PL_envgv);
1007 /* Perform a dummy fetch as an lval to insure that the hash table is
1008 * set up. Otherwise, the hv_store() will turn into a nullop. */
1009 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1011 for (i = 0; env_tables[i]; i++) {
1012 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1013 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1014 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1016 if (have_sym || have_lnm) {
1017 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1018 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1019 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1020 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1023 for (i--; i >= 0; i--) {
1024 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1027 for (j = 0; environ[j]; j++) {
1028 if (!(start = strchr(environ[j],'='))) {
1029 if (ckWARN(WARN_INTERNAL))
1030 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1034 sv = newSVpv(start,0);
1036 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1041 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1042 !str$case_blind_compare(&tmpdsc,&clisym)) {
1043 strcpy(cmd,"Show Symbol/Global *");
1044 cmddsc.dsc$w_length = 20;
1045 if (env_tables[i]->dsc$w_length == 12 &&
1046 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1047 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1048 flags = defflags | CLI$M_NOLOGNAM;
1051 strcpy(cmd,"Show Logical *");
1052 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1053 strcat(cmd," /Table=");
1054 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1055 cmddsc.dsc$w_length = strlen(cmd);
1057 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1058 flags = defflags | CLI$M_NOCLISYM;
1061 /* Create a new subprocess to execute each command, to exclude the
1062 * remote possibility that someone could subvert a mbx or file used
1063 * to write multiple commands to a single subprocess.
1066 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1067 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1068 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1069 defflags &= ~CLI$M_TRUSTED;
1070 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1072 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1073 if (seenhv) SvREFCNT_dec(seenhv);
1076 char *cp1, *cp2, *key;
1077 unsigned long int sts, iosb[2], retlen, keylen;
1080 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1081 if (sts & 1) sts = iosb[0] & 0xffff;
1082 if (sts == SS$_ENDOFFILE) {
1084 while (substs == 0) { sys$hiber(); wakect++;}
1085 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1090 retlen = iosb[0] >> 16;
1091 if (!retlen) continue; /* blank line */
1093 if (iosb[1] != subpid) {
1095 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1099 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1100 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1102 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1103 if (*cp1 == '(' || /* Logical name table name */
1104 *cp1 == '=' /* Next eqv of searchlist */) continue;
1105 if (*cp1 == '"') cp1++;
1106 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1107 key = cp1; keylen = cp2 - cp1;
1108 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1109 while (*cp2 && *cp2 != '=') cp2++;
1110 while (*cp2 && *cp2 == '=') cp2++;
1111 while (*cp2 && *cp2 == ' ') cp2++;
1112 if (*cp2 == '"') { /* String translation; may embed "" */
1113 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1114 cp2++; cp1--; /* Skip "" surrounding translation */
1116 else { /* Numeric translation */
1117 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1118 cp1--; /* stop on last non-space char */
1120 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1121 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1124 PERL_HASH(hash,key,keylen);
1126 if (cp1 == cp2 && *cp2 == '.') {
1127 /* A single dot usually means an unprintable character, such as a null
1128 * to indicate a zero-length value. Get the actual value to make sure.
1130 char lnm[LNM$C_NAMLENGTH+1];
1131 char eqv[MAX_DCL_SYMBOL+1];
1132 strncpy(lnm, key, keylen);
1133 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1134 sv = newSVpvn(eqv, strlen(eqv));
1137 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1141 hv_store(envhv,key,keylen,sv,hash);
1142 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1144 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1145 /* get the PPFs for this process, not the subprocess */
1146 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1147 char eqv[LNM$C_NAMLENGTH+1];
1149 for (i = 0; ppfs[i]; i++) {
1150 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1151 sv = newSVpv(eqv,trnlen);
1153 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1158 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1159 if (buf) Safefree(buf);
1160 if (seenhv) SvREFCNT_dec(seenhv);
1161 MUTEX_UNLOCK(&primenv_mutex);
1164 } /* end of prime_env_iter */
1168 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1169 /* Define or delete an element in the same "environment" as
1170 * vmstrnenv(). If an element is to be deleted, it's removed from
1171 * the first place it's found. If it's to be set, it's set in the
1172 * place designated by the first element of the table vector.
1173 * Like setenv() returns 0 for success, non-zero on error.
1176 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1179 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1180 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1182 unsigned long int retsts, usermode = PSL$C_USER;
1183 struct itmlst_3 *ile, *ilist;
1184 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1185 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1186 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1187 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1188 $DESCRIPTOR(local,"_LOCAL");
1191 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1192 return SS$_IVLOGNAM;
1195 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1196 *cp2 = _toupper(*cp1);
1197 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1198 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1199 return SS$_IVLOGNAM;
1202 lnmdsc.dsc$w_length = cp1 - lnm;
1203 if (!tabvec || !*tabvec) tabvec = env_tables;
1205 if (!eqv) { /* we're deleting n element */
1206 for (curtab = 0; tabvec[curtab]; curtab++) {
1207 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1209 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1210 if ((cp1 = strchr(environ[i],'=')) &&
1211 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1212 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1214 return setenv(lnm,"",1) ? vaxc$errno : 0;
1217 ivenv = 1; retsts = SS$_NOLOGNAM;
1219 if (ckWARN(WARN_INTERNAL))
1220 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1221 ivenv = 1; retsts = SS$_NOSUCHPGM;
1227 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1228 !str$case_blind_compare(&tmpdsc,&clisym)) {
1229 unsigned int symtype;
1230 if (tabvec[curtab]->dsc$w_length == 12 &&
1231 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1232 !str$case_blind_compare(&tmpdsc,&local))
1233 symtype = LIB$K_CLI_LOCAL_SYM;
1234 else symtype = LIB$K_CLI_GLOBAL_SYM;
1235 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1236 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1237 if (retsts == LIB$_NOSUCHSYM) continue;
1241 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1242 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1243 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1244 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1245 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1249 else { /* we're defining a value */
1250 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1252 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1254 if (ckWARN(WARN_INTERNAL))
1255 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1256 retsts = SS$_NOSUCHPGM;
1260 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1261 eqvdsc.dsc$w_length = strlen(eqv);
1262 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1263 !str$case_blind_compare(&tmpdsc,&clisym)) {
1264 unsigned int symtype;
1265 if (tabvec[0]->dsc$w_length == 12 &&
1266 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1267 !str$case_blind_compare(&tmpdsc,&local))
1268 symtype = LIB$K_CLI_LOCAL_SYM;
1269 else symtype = LIB$K_CLI_GLOBAL_SYM;
1270 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1273 if (!*eqv) eqvdsc.dsc$w_length = 1;
1274 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1276 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1277 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1278 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1279 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1280 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1281 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1284 Newx(ilist,nseg+1,struct itmlst_3);
1287 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1290 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1292 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1293 ile->itmcode = LNM$_STRING;
1295 if ((j+1) == nseg) {
1296 ile->buflen = strlen(c);
1297 /* in case we are truncating one that's too long */
1298 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1301 ile->buflen = LNM$C_NAMLENGTH;
1305 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1309 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1314 if (!(retsts & 1)) {
1316 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1317 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1318 set_errno(EVMSERR); break;
1319 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1320 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1321 set_errno(EINVAL); break;
1323 set_errno(EACCES); break;
1328 set_vaxc_errno(retsts);
1329 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1332 /* We reset error values on success because Perl does an hv_fetch()
1333 * before each hv_store(), and if the thing we're setting didn't
1334 * previously exist, we've got a leftover error message. (Of course,
1335 * this fails in the face of
1336 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1337 * in that the error reported in $! isn't spurious,
1338 * but it's right more often than not.)
1340 set_errno(0); set_vaxc_errno(retsts);
1344 } /* end of vmssetenv() */
1347 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1348 /* This has to be a function since there's a prototype for it in proto.h */
1350 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1353 int len = strlen(lnm);
1357 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1358 if (!strcmp(uplnm,"DEFAULT")) {
1359 if (eqv && *eqv) my_chdir(eqv);
1363 #ifndef RTL_USES_UTC
1364 if (len == 6 || len == 2) {
1367 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1369 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1370 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1374 (void) vmssetenv(lnm,eqv,NULL);
1378 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1380 * sets a user-mode logical in the process logical name table
1381 * used for redirection of sys$error
1384 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1386 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1387 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1388 unsigned long int iss, attr = LNM$M_CONFINE;
1389 unsigned char acmode = PSL$C_USER;
1390 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1392 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1393 d_name.dsc$w_length = strlen(name);
1395 lnmlst[0].buflen = strlen(eqv);
1396 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1398 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1399 if (!(iss&1)) lib$signal(iss);
1404 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1405 /* my_crypt - VMS password hashing
1406 * my_crypt() provides an interface compatible with the Unix crypt()
1407 * C library function, and uses sys$hash_password() to perform VMS
1408 * password hashing. The quadword hashed password value is returned
1409 * as a NUL-terminated 8 character string. my_crypt() does not change
1410 * the case of its string arguments; in order to match the behavior
1411 * of LOGINOUT et al., alphabetic characters in both arguments must
1412 * be upcased by the caller.
1414 * - fix me to call ACM services when available
1417 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1419 # ifndef UAI$C_PREFERRED_ALGORITHM
1420 # define UAI$C_PREFERRED_ALGORITHM 127
1422 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1423 unsigned short int salt = 0;
1424 unsigned long int sts;
1426 unsigned short int dsc$w_length;
1427 unsigned char dsc$b_type;
1428 unsigned char dsc$b_class;
1429 const char * dsc$a_pointer;
1430 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1431 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1432 struct itmlst_3 uailst[3] = {
1433 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1434 { sizeof salt, UAI$_SALT, &salt, 0},
1435 { 0, 0, NULL, NULL}};
1436 static char hash[9];
1438 usrdsc.dsc$w_length = strlen(usrname);
1439 usrdsc.dsc$a_pointer = usrname;
1440 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1442 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1446 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1451 set_vaxc_errno(sts);
1452 if (sts != RMS$_RNF) return NULL;
1455 txtdsc.dsc$w_length = strlen(textpasswd);
1456 txtdsc.dsc$a_pointer = textpasswd;
1457 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1458 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1461 return (char *) hash;
1463 } /* end of my_crypt() */
1467 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1468 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1469 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1471 /* fixup barenames that are directories for internal use.
1472 * There have been problems with the consistent handling of UNIX
1473 * style directory names when routines are presented with a name that
1474 * has no directory delimitors at all. So this routine will eventually
1477 static char * fixup_bare_dirnames(const char * name)
1479 if (decc_disable_to_vms_logname_translation) {
1486 * A little hack to get around a bug in some implemenation of remove()
1487 * that do not know how to delete a directory
1489 * Delete any file to which user has control access, regardless of whether
1490 * delete access is explicitly allowed.
1491 * Limitations: User must have write access to parent directory.
1492 * Does not block signals or ASTs; if interrupted in midstream
1493 * may leave file with an altered ACL.
1496 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1498 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1500 char *vmsname, *rspec;
1502 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1503 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1504 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1506 unsigned char myace$b_length;
1507 unsigned char myace$b_type;
1508 unsigned short int myace$w_flags;
1509 unsigned long int myace$l_access;
1510 unsigned long int myace$l_ident;
1511 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1512 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1513 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1515 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1516 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1517 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1518 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1519 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1520 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1522 /* Expand the input spec using RMS, since the CRTL remove() and
1523 * system services won't do this by themselves, so we may miss
1524 * a file "hiding" behind a logical name or search list. */
1525 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1526 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1528 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1529 PerlMem_free(vmsname);
1533 if (decc_posix_compliant_pathnames) {
1534 /* In POSIX mode, we prefer to remove the UNIX name */
1536 remove_name = (char *)name;
1539 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1540 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1541 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1542 PerlMem_free(rspec);
1543 PerlMem_free(vmsname);
1546 PerlMem_free(vmsname);
1547 remove_name = rspec;
1550 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1552 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1553 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1554 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1556 do_pathify_dirspec(name, remove_name, 0);
1557 if (!rmdir(remove_name)) {
1559 PerlMem_free(remove_name);
1560 PerlMem_free(rspec);
1561 return 0; /* Can we just get rid of it? */
1565 if (!rmdir(remove_name)) {
1566 PerlMem_free(rspec);
1567 return 0; /* Can we just get rid of it? */
1573 if (!remove(remove_name)) {
1574 PerlMem_free(rspec);
1575 return 0; /* Can we just get rid of it? */
1578 /* If not, can changing protections help? */
1579 if (vaxc$errno != RMS$_PRV) {
1580 PerlMem_free(rspec);
1584 /* No, so we get our own UIC to use as a rights identifier,
1585 * and the insert an ACE at the head of the ACL which allows us
1586 * to delete the file.
1588 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1589 fildsc.dsc$w_length = strlen(rspec);
1590 fildsc.dsc$a_pointer = rspec;
1592 newace.myace$l_ident = oldace.myace$l_ident;
1593 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1595 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1596 set_errno(ENOENT); break;
1598 set_errno(ENOTDIR); break;
1600 set_errno(ENODEV); break;
1601 case RMS$_SYN: case SS$_INVFILFOROP:
1602 set_errno(EINVAL); break;
1604 set_errno(EACCES); break;
1608 set_vaxc_errno(aclsts);
1609 PerlMem_free(rspec);
1612 /* Grab any existing ACEs with this identifier in case we fail */
1613 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1614 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1615 || fndsts == SS$_NOMOREACE ) {
1616 /* Add the new ACE . . . */
1617 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1620 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1622 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1623 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1624 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1626 do_pathify_dirspec(name, remove_name, 0);
1627 rmsts = rmdir(remove_name);
1628 PerlMem_free(remove_name);
1631 rmsts = rmdir(remove_name);
1635 rmsts = remove(remove_name);
1637 /* We blew it - dir with files in it, no write priv for
1638 * parent directory, etc. Put things back the way they were. */
1639 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1642 addlst[0].bufadr = &oldace;
1643 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1650 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1651 /* We just deleted it, so of course it's not there. Some versions of
1652 * VMS seem to return success on the unlock operation anyhow (after all
1653 * the unlock is successful), but others don't.
1655 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1656 if (aclsts & 1) aclsts = fndsts;
1657 if (!(aclsts & 1)) {
1659 set_vaxc_errno(aclsts);
1660 PerlMem_free(rspec);
1664 PerlMem_free(rspec);
1667 } /* end of kill_file() */
1671 /*{{{int do_rmdir(char *name)*/
1673 Perl_do_rmdir(pTHX_ const char *name)
1675 char dirfile[NAM$C_MAXRSS+1];
1679 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1680 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1681 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1684 } /* end of do_rmdir */
1688 * Delete any file to which user has control access, regardless of whether
1689 * delete access is explicitly allowed.
1690 * Limitations: User must have write access to parent directory.
1691 * Does not block signals or ASTs; if interrupted in midstream
1692 * may leave file with an altered ACL.
1695 /*{{{int kill_file(char *name)*/
1697 Perl_kill_file(pTHX_ const char *name)
1699 char rspec[NAM$C_MAXRSS+1];
1701 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1702 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1703 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1705 unsigned char myace$b_length;
1706 unsigned char myace$b_type;
1707 unsigned short int myace$w_flags;
1708 unsigned long int myace$l_access;
1709 unsigned long int myace$l_ident;
1710 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1711 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1712 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1714 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1715 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1716 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1717 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1718 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1719 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1721 /* Expand the input spec using RMS, since the CRTL remove() and
1722 * system services won't do this by themselves, so we may miss
1723 * a file "hiding" behind a logical name or search list. */
1724 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS);
1725 if (tspec == NULL) return -1;
1726 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1727 /* If not, can changing protections help? */
1728 if (vaxc$errno != RMS$_PRV) return -1;
1730 /* No, so we get our own UIC to use as a rights identifier,
1731 * and the insert an ACE at the head of the ACL which allows us
1732 * to delete the file.
1734 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1735 fildsc.dsc$w_length = strlen(rspec);
1736 fildsc.dsc$a_pointer = rspec;
1738 newace.myace$l_ident = oldace.myace$l_ident;
1739 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1741 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1742 set_errno(ENOENT); break;
1744 set_errno(ENOTDIR); break;
1746 set_errno(ENODEV); break;
1747 case RMS$_SYN: case SS$_INVFILFOROP:
1748 set_errno(EINVAL); break;
1750 set_errno(EACCES); break;
1754 set_vaxc_errno(aclsts);
1757 /* Grab any existing ACEs with this identifier in case we fail */
1758 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1759 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1760 || fndsts == SS$_NOMOREACE ) {
1761 /* Add the new ACE . . . */
1762 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1764 if ((rmsts = remove(name))) {
1765 /* We blew it - dir with files in it, no write priv for
1766 * parent directory, etc. Put things back the way they were. */
1767 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1770 addlst[0].bufadr = &oldace;
1771 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1778 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1779 /* We just deleted it, so of course it's not there. Some versions of
1780 * VMS seem to return success on the unlock operation anyhow (after all
1781 * the unlock is successful), but others don't.
1783 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1784 if (aclsts & 1) aclsts = fndsts;
1785 if (!(aclsts & 1)) {
1787 set_vaxc_errno(aclsts);
1793 } /* end of kill_file() */
1797 /*{{{int my_mkdir(char *,Mode_t)*/
1799 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1801 STRLEN dirlen = strlen(dir);
1803 /* zero length string sometimes gives ACCVIO */
1804 if (dirlen == 0) return -1;
1806 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1807 * null file name/type. However, it's commonplace under Unix,
1808 * so we'll allow it for a gain in portability.
1810 if (dir[dirlen-1] == '/') {
1811 char *newdir = savepvn(dir,dirlen-1);
1812 int ret = mkdir(newdir,mode);
1816 else return mkdir(dir,mode);
1817 } /* end of my_mkdir */
1820 /*{{{int my_chdir(char *)*/
1822 Perl_my_chdir(pTHX_ const char *dir)
1824 STRLEN dirlen = strlen(dir);
1826 /* zero length string sometimes gives ACCVIO */
1827 if (dirlen == 0) return -1;
1830 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1831 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1832 * so that existing scripts do not need to be changed.
1835 while ((dirlen > 0) && (*dir1 == ' ')) {
1840 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1842 * null file name/type. However, it's commonplace under Unix,
1843 * so we'll allow it for a gain in portability.
1845 * - Preview- '/' will be valid soon on VMS
1847 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1848 char *newdir = savepvn(dir1,dirlen-1);
1849 int ret = chdir(newdir);
1853 else return chdir(dir1);
1854 } /* end of my_chdir */
1858 /*{{{FILE *my_tmpfile()*/
1865 if ((fp = tmpfile())) return fp;
1867 cp = PerlMem_malloc(L_tmpnam+24);
1868 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1870 if (decc_filename_unix_only == 0)
1871 strcpy(cp,"Sys$Scratch:");
1874 tmpnam(cp+strlen(cp));
1875 strcat(cp,".Perltmp");
1876 fp = fopen(cp,"w+","fop=dlt");
1883 #ifndef HOMEGROWN_POSIX_SIGNALS
1885 * The C RTL's sigaction fails to check for invalid signal numbers so we
1886 * help it out a bit. The docs are correct, but the actual routine doesn't
1887 * do what the docs say it will.
1889 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1891 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1892 struct sigaction* oact)
1894 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1895 SETERRNO(EINVAL, SS$_INVARG);
1898 return sigaction(sig, act, oact);
1903 #ifdef KILL_BY_SIGPRC
1904 #include <errnodef.h>
1906 /* We implement our own kill() using the undocumented system service
1907 sys$sigprc for one of two reasons:
1909 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1910 target process to do a sys$exit, which usually can't be handled
1911 gracefully...certainly not by Perl and the %SIG{} mechanism.
1913 2.) If the kill() in the CRTL can't be called from a signal
1914 handler without disappearing into the ether, i.e., the signal
1915 it purportedly sends is never trapped. Still true as of VMS 7.3.
1917 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1918 in the target process rather than calling sys$exit.
1920 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1921 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1922 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1923 with condition codes C$_SIG0+nsig*8, catching the exception on the
1924 target process and resignaling with appropriate arguments.
1926 But we don't have that VMS 7.0+ exception handler, so if you
1927 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1929 Also note that SIGTERM is listed in the docs as being "unimplemented",
1930 yet always seems to be signaled with a VMS condition code of 4 (and
1931 correctly handled for that code). So we hardwire it in.
1933 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1934 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1935 than signalling with an unrecognized (and unhandled by CRTL) code.
1938 #define _MY_SIG_MAX 17
1941 Perl_sig_to_vmscondition_int(int sig)
1943 static unsigned int sig_code[_MY_SIG_MAX+1] =
1946 SS$_HANGUP, /* 1 SIGHUP */
1947 SS$_CONTROLC, /* 2 SIGINT */
1948 SS$_CONTROLY, /* 3 SIGQUIT */
1949 SS$_RADRMOD, /* 4 SIGILL */
1950 SS$_BREAK, /* 5 SIGTRAP */
1951 SS$_OPCCUS, /* 6 SIGABRT */
1952 SS$_COMPAT, /* 7 SIGEMT */
1954 SS$_FLTOVF, /* 8 SIGFPE VAX */
1956 SS$_HPARITH, /* 8 SIGFPE AXP */
1958 SS$_ABORT, /* 9 SIGKILL */
1959 SS$_ACCVIO, /* 10 SIGBUS */
1960 SS$_ACCVIO, /* 11 SIGSEGV */
1961 SS$_BADPARAM, /* 12 SIGSYS */
1962 SS$_NOMBX, /* 13 SIGPIPE */
1963 SS$_ASTFLT, /* 14 SIGALRM */
1969 #if __VMS_VER >= 60200000
1970 static int initted = 0;
1973 sig_code[16] = C$_SIGUSR1;
1974 sig_code[17] = C$_SIGUSR2;
1978 if (sig < _SIG_MIN) return 0;
1979 if (sig > _MY_SIG_MAX) return 0;
1980 return sig_code[sig];
1984 Perl_sig_to_vmscondition(int sig)
1987 if (vms_debug_on_exception != 0)
1988 lib$signal(SS$_DEBUG);
1990 return Perl_sig_to_vmscondition_int(sig);
1995 Perl_my_kill(int pid, int sig)
2000 int sys$sigprc(unsigned int *pidadr,
2001 struct dsc$descriptor_s *prcname,
2004 /* sig 0 means validate the PID */
2005 /*------------------------------*/
2007 const unsigned long int jpicode = JPI$_PID;
2010 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2011 if ($VMS_STATUS_SUCCESS(status))
2014 case SS$_NOSUCHNODE:
2015 case SS$_UNREACHABLE:
2029 code = Perl_sig_to_vmscondition_int(sig);
2032 SETERRNO(EINVAL, SS$_BADPARAM);
2036 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2037 * signals are to be sent to multiple processes.
2038 * pid = 0 - all processes in group except ones that the system exempts
2039 * pid = -1 - all processes except ones that the system exempts
2040 * pid = -n - all processes in group (abs(n)) except ...
2041 * For now, just report as not supported.
2045 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2049 iss = sys$sigprc((unsigned int *)&pid,0,code);
2050 if (iss&1) return 0;
2054 set_errno(EPERM); break;
2056 case SS$_NOSUCHNODE:
2057 case SS$_UNREACHABLE:
2058 set_errno(ESRCH); break;
2060 set_errno(ENOMEM); break;
2065 set_vaxc_errno(iss);
2071 /* Routine to convert a VMS status code to a UNIX status code.
2072 ** More tricky than it appears because of conflicting conventions with
2075 ** VMS status codes are a bit mask, with the least significant bit set for
2078 ** Special UNIX status of EVMSERR indicates that no translation is currently
2079 ** available, and programs should check the VMS status code.
2081 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2085 #ifndef C_FACILITY_NO
2086 #define C_FACILITY_NO 0x350000
2089 #define DCL_IVVERB 0x38090
2092 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2100 /* Assume the best or the worst */
2101 if (vms_status & STS$M_SUCCESS)
2104 unix_status = EVMSERR;
2106 msg_status = vms_status & ~STS$M_CONTROL;
2108 facility = vms_status & STS$M_FAC_NO;
2109 fac_sp = vms_status & STS$M_FAC_SP;
2110 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2112 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2118 unix_status = EFAULT;
2120 case SS$_DEVOFFLINE:
2121 unix_status = EBUSY;
2124 unix_status = ENOTCONN;
2132 case SS$_INVFILFOROP:
2136 unix_status = EINVAL;
2138 case SS$_UNSUPPORTED:
2139 unix_status = ENOTSUP;
2144 unix_status = EACCES;
2146 case SS$_DEVICEFULL:
2147 unix_status = ENOSPC;
2150 unix_status = ENODEV;
2152 case SS$_NOSUCHFILE:
2153 case SS$_NOSUCHOBJECT:
2154 unix_status = ENOENT;
2156 case SS$_ABORT: /* Fatal case */
2157 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2158 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2159 unix_status = EINTR;
2162 unix_status = E2BIG;
2165 unix_status = ENOMEM;
2168 unix_status = EPERM;
2170 case SS$_NOSUCHNODE:
2171 case SS$_UNREACHABLE:
2172 unix_status = ESRCH;
2175 unix_status = ECHILD;
2178 if ((facility == 0) && (msg_no < 8)) {
2179 /* These are not real VMS status codes so assume that they are
2180 ** already UNIX status codes
2182 unix_status = msg_no;
2188 /* Translate a POSIX exit code to a UNIX exit code */
2189 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2190 unix_status = (msg_no & 0x07F8) >> 3;
2194 /* Documented traditional behavior for handling VMS child exits */
2195 /*--------------------------------------------------------------*/
2196 if (child_flag != 0) {
2198 /* Success / Informational return 0 */
2199 /*----------------------------------*/
2200 if (msg_no & STS$K_SUCCESS)
2203 /* Warning returns 1 */
2204 /*-------------------*/
2205 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2208 /* Everything else pass through the severity bits */
2209 /*------------------------------------------------*/
2210 return (msg_no & STS$M_SEVERITY);
2213 /* Normal VMS status to ERRNO mapping attempt */
2214 /*--------------------------------------------*/
2215 switch(msg_status) {
2216 /* case RMS$_EOF: */ /* End of File */
2217 case RMS$_FNF: /* File Not Found */
2218 case RMS$_DNF: /* Dir Not Found */
2219 unix_status = ENOENT;
2221 case RMS$_RNF: /* Record Not Found */
2222 unix_status = ESRCH;
2225 unix_status = ENOTDIR;
2228 unix_status = ENODEV;
2233 unix_status = EBADF;
2236 unix_status = EEXIST;
2240 case LIB$_INVSTRDES:
2242 case LIB$_NOSUCHSYM:
2243 case LIB$_INVSYMNAM:
2245 unix_status = EINVAL;
2251 unix_status = E2BIG;
2253 case RMS$_PRV: /* No privilege */
2254 case RMS$_ACC: /* ACP file access failed */
2255 case RMS$_WLK: /* Device write locked */
2256 unix_status = EACCES;
2258 /* case RMS$_NMF: */ /* No more files */
2266 /* Try to guess at what VMS error status should go with a UNIX errno
2267 * value. This is hard to do as there could be many possible VMS
2268 * error statuses that caused the errno value to be set.
2271 int Perl_unix_status_to_vms(int unix_status)
2273 int test_unix_status;
2275 /* Trivial cases first */
2276 /*---------------------*/
2277 if (unix_status == EVMSERR)
2280 /* Is vaxc$errno sane? */
2281 /*---------------------*/
2282 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2283 if (test_unix_status == unix_status)
2286 /* If way out of range, must be VMS code already */
2287 /*-----------------------------------------------*/
2288 if (unix_status > EVMSERR)
2291 /* If out of range, punt */
2292 /*-----------------------*/
2293 if (unix_status > __ERRNO_MAX)
2297 /* Ok, now we have to do it the hard way. */
2298 /*----------------------------------------*/
2299 switch(unix_status) {
2300 case 0: return SS$_NORMAL;
2301 case EPERM: return SS$_NOPRIV;
2302 case ENOENT: return SS$_NOSUCHOBJECT;
2303 case ESRCH: return SS$_UNREACHABLE;
2304 case EINTR: return SS$_ABORT;
2307 case E2BIG: return SS$_BUFFEROVF;
2309 case EBADF: return RMS$_IFI;
2310 case ECHILD: return SS$_NONEXPR;
2312 case ENOMEM: return SS$_INSFMEM;
2313 case EACCES: return SS$_FILACCERR;
2314 case EFAULT: return SS$_ACCVIO;
2316 case EBUSY: return SS$_DEVOFFLINE;
2317 case EEXIST: return RMS$_FEX;
2319 case ENODEV: return SS$_NOSUCHDEV;
2320 case ENOTDIR: return RMS$_DIR;
2322 case EINVAL: return SS$_INVARG;
2328 case ENOSPC: return SS$_DEVICEFULL;
2329 case ESPIPE: return LIB$_INVARG;
2334 case ERANGE: return LIB$_INVARG;
2335 /* case EWOULDBLOCK */
2336 /* case EINPROGRESS */
2339 /* case EDESTADDRREQ */
2341 /* case EPROTOTYPE */
2342 /* case ENOPROTOOPT */
2343 /* case EPROTONOSUPPORT */
2344 /* case ESOCKTNOSUPPORT */
2345 /* case EOPNOTSUPP */
2346 /* case EPFNOSUPPORT */
2347 /* case EAFNOSUPPORT */
2348 /* case EADDRINUSE */
2349 /* case EADDRNOTAVAIL */
2351 /* case ENETUNREACH */
2352 /* case ENETRESET */
2353 /* case ECONNABORTED */
2354 /* case ECONNRESET */
2357 case ENOTCONN: return SS$_CLEARED;
2358 /* case ESHUTDOWN */
2359 /* case ETOOMANYREFS */
2360 /* case ETIMEDOUT */
2361 /* case ECONNREFUSED */
2363 /* case ENAMETOOLONG */
2364 /* case EHOSTDOWN */
2365 /* case EHOSTUNREACH */
2366 /* case ENOTEMPTY */
2378 /* case ECANCELED */
2382 return SS$_UNSUPPORTED;
2388 /* case EABANDONED */
2390 return SS$_ABORT; /* punt */
2393 return SS$_ABORT; /* Should not get here */
2397 /* default piping mailbox size */
2398 #define PERL_BUFSIZ 512
2402 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2404 unsigned long int mbxbufsiz;
2405 static unsigned long int syssize = 0;
2406 unsigned long int dviitm = DVI$_DEVNAM;
2407 char csize[LNM$C_NAMLENGTH+1];
2411 unsigned long syiitm = SYI$_MAXBUF;
2413 * Get the SYSGEN parameter MAXBUF
2415 * If the logical 'PERL_MBX_SIZE' is defined
2416 * use the value of the logical instead of PERL_BUFSIZ, but
2417 * keep the size between 128 and MAXBUF.
2420 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2423 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2424 mbxbufsiz = atoi(csize);
2426 mbxbufsiz = PERL_BUFSIZ;
2428 if (mbxbufsiz < 128) mbxbufsiz = 128;
2429 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2431 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2433 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2434 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2436 } /* end of create_mbx() */
2439 /*{{{ my_popen and my_pclose*/
2441 typedef struct _iosb IOSB;
2442 typedef struct _iosb* pIOSB;
2443 typedef struct _pipe Pipe;
2444 typedef struct _pipe* pPipe;
2445 typedef struct pipe_details Info;
2446 typedef struct pipe_details* pInfo;
2447 typedef struct _srqp RQE;
2448 typedef struct _srqp* pRQE;
2449 typedef struct _tochildbuf CBuf;
2450 typedef struct _tochildbuf* pCBuf;
2453 unsigned short status;
2454 unsigned short count;
2455 unsigned long dvispec;
2458 #pragma member_alignment save
2459 #pragma nomember_alignment quadword
2460 struct _srqp { /* VMS self-relative queue entry */
2461 unsigned long qptr[2];
2463 #pragma member_alignment restore
2464 static RQE RQE_ZERO = {0,0};
2466 struct _tochildbuf {
2469 unsigned short size;
2477 unsigned short chan_in;
2478 unsigned short chan_out;
2480 unsigned int bufsize;
2492 #if defined(PERL_IMPLICIT_CONTEXT)
2493 void *thx; /* Either a thread or an interpreter */
2494 /* pointer, depending on how we're built */
2502 PerlIO *fp; /* file pointer to pipe mailbox */
2503 int useFILE; /* using stdio, not perlio */
2504 int pid; /* PID of subprocess */
2505 int mode; /* == 'r' if pipe open for reading */
2506 int done; /* subprocess has completed */
2507 int waiting; /* waiting for completion/closure */
2508 int closing; /* my_pclose is closing this pipe */
2509 unsigned long completion; /* termination status of subprocess */
2510 pPipe in; /* pipe in to sub */
2511 pPipe out; /* pipe out of sub */
2512 pPipe err; /* pipe of sub's sys$error */
2513 int in_done; /* true when in pipe finished */
2518 struct exit_control_block
2520 struct exit_control_block *flink;
2521 unsigned long int (*exit_routine)();
2522 unsigned long int arg_count;
2523 unsigned long int *status_address;
2524 unsigned long int exit_status;
2527 typedef struct _closed_pipes Xpipe;
2528 typedef struct _closed_pipes* pXpipe;
2530 struct _closed_pipes {
2531 int pid; /* PID of subprocess */
2532 unsigned long completion; /* termination status of subprocess */
2534 #define NKEEPCLOSED 50
2535 static Xpipe closed_list[NKEEPCLOSED];
2536 static int closed_index = 0;
2537 static int closed_num = 0;
2539 #define RETRY_DELAY "0 ::0.20"
2540 #define MAX_RETRY 50
2542 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2543 static unsigned long mypid;
2544 static unsigned long delaytime[2];
2546 static pInfo open_pipes = NULL;
2547 static $DESCRIPTOR(nl_desc, "NL:");
2549 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2553 static unsigned long int
2554 pipe_exit_routine(pTHX)
2557 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2558 int sts, did_stuff, need_eof, j;
2561 flush any pending i/o
2567 PerlIO_flush(info->fp); /* first, flush data */
2569 fflush((FILE *)info->fp);
2575 next we try sending an EOF...ignore if doesn't work, make sure we
2583 _ckvmssts_noperl(sys$setast(0));
2584 if (info->in && !info->in->shut_on_empty) {
2585 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2590 _ckvmssts_noperl(sys$setast(1));
2594 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2596 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2601 _ckvmssts_noperl(sys$setast(0));
2602 if (info->waiting && info->done)
2604 nwait += info->waiting;
2605 _ckvmssts_noperl(sys$setast(1));
2615 _ckvmssts_noperl(sys$setast(0));
2616 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2617 sts = sys$forcex(&info->pid,0,&abort);
2618 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2621 _ckvmssts_noperl(sys$setast(1));
2625 /* again, wait for effect */
2627 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2632 _ckvmssts_noperl(sys$setast(0));
2633 if (info->waiting && info->done)
2635 nwait += info->waiting;
2636 _ckvmssts_noperl(sys$setast(1));
2645 _ckvmssts_noperl(sys$setast(0));
2646 if (!info->done) { /* We tried to be nice . . . */
2647 sts = sys$delprc(&info->pid,0);
2648 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2650 _ckvmssts_noperl(sys$setast(1));
2655 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2656 else if (!(sts & 1)) retsts = sts;
2661 static struct exit_control_block pipe_exitblock =
2662 {(struct exit_control_block *) 0,
2663 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2665 static void pipe_mbxtofd_ast(pPipe p);
2666 static void pipe_tochild1_ast(pPipe p);
2667 static void pipe_tochild2_ast(pPipe p);
2670 popen_completion_ast(pInfo info)
2672 pInfo i = open_pipes;
2677 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2678 closed_list[closed_index].pid = info->pid;
2679 closed_list[closed_index].completion = info->completion;
2681 if (closed_index == NKEEPCLOSED)
2686 if (i == info) break;
2689 if (!i) return; /* unlinked, probably freed too */
2694 Writing to subprocess ...
2695 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2697 chan_out may be waiting for "done" flag, or hung waiting
2698 for i/o completion to child...cancel the i/o. This will
2699 put it into "snarf mode" (done but no EOF yet) that discards
2702 Output from subprocess (stdout, stderr) needs to be flushed and
2703 shut down. We try sending an EOF, but if the mbx is full the pipe
2704 routine should still catch the "shut_on_empty" flag, telling it to
2705 use immediate-style reads so that "mbx empty" -> EOF.
2709 if (info->in && !info->in_done) { /* only for mode=w */
2710 if (info->in->shut_on_empty && info->in->need_wake) {
2711 info->in->need_wake = FALSE;
2712 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2714 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2718 if (info->out && !info->out_done) { /* were we also piping output? */
2719 info->out->shut_on_empty = TRUE;
2720 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2721 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2722 _ckvmssts_noperl(iss);
2725 if (info->err && !info->err_done) { /* we were piping stderr */
2726 info->err->shut_on_empty = TRUE;
2727 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2728 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2729 _ckvmssts_noperl(iss);
2731 _ckvmssts_noperl(sys$setef(pipe_ef));
2735 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2736 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2739 we actually differ from vmstrnenv since we use this to
2740 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2741 are pointing to the same thing
2744 static unsigned short
2745 popen_translate(pTHX_ char *logical, char *result)
2748 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2749 $DESCRIPTOR(d_log,"");
2751 unsigned short length;
2752 unsigned short code;
2754 unsigned short *retlenaddr;
2756 unsigned short l, ifi;
2758 d_log.dsc$a_pointer = logical;
2759 d_log.dsc$w_length = strlen(logical);
2761 itmlst[0].code = LNM$_STRING;
2762 itmlst[0].length = 255;
2763 itmlst[0].buffer_addr = result;
2764 itmlst[0].retlenaddr = &l;
2767 itmlst[1].length = 0;
2768 itmlst[1].buffer_addr = 0;
2769 itmlst[1].retlenaddr = 0;
2771 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2772 if (iss == SS$_NOLOGNAM) {
2776 if (!(iss&1)) lib$signal(iss);
2779 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2780 strip it off and return the ifi, if any
2783 if (result[0] == 0x1b && result[1] == 0x00) {
2784 memmove(&ifi,result+2,2);
2785 strcpy(result,result+4);
2787 return ifi; /* this is the RMS internal file id */
2790 static void pipe_infromchild_ast(pPipe p);
2793 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2794 inside an AST routine without worrying about reentrancy and which Perl
2795 memory allocator is being used.
2797 We read data and queue up the buffers, then spit them out one at a
2798 time to the output mailbox when the output mailbox is ready for one.
2801 #define INITIAL_TOCHILDQUEUE 2
2804 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2808 char mbx1[64], mbx2[64];
2809 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2810 DSC$K_CLASS_S, mbx1},
2811 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2812 DSC$K_CLASS_S, mbx2};
2813 unsigned int dviitm = DVI$_DEVBUFSIZ;
2817 _ckvmssts(lib$get_vm(&n, &p));
2819 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2820 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2821 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2824 p->shut_on_empty = FALSE;
2825 p->need_wake = FALSE;
2828 p->iosb.status = SS$_NORMAL;
2829 p->iosb2.status = SS$_NORMAL;
2835 #ifdef PERL_IMPLICIT_CONTEXT
2839 n = sizeof(CBuf) + p->bufsize;
2841 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2842 _ckvmssts(lib$get_vm(&n, &b));
2843 b->buf = (char *) b + sizeof(CBuf);
2844 _ckvmssts(lib$insqhi(b, &p->free));
2847 pipe_tochild2_ast(p);
2848 pipe_tochild1_ast(p);
2854 /* reads the MBX Perl is writing, and queues */
2857 pipe_tochild1_ast(pPipe p)
2860 int iss = p->iosb.status;
2861 int eof = (iss == SS$_ENDOFFILE);
2863 #ifdef PERL_IMPLICIT_CONTEXT
2869 p->shut_on_empty = TRUE;
2871 _ckvmssts(sys$dassgn(p->chan_in));
2877 b->size = p->iosb.count;
2878 _ckvmssts(sts = lib$insqhi(b, &p->wait));
2880 p->need_wake = FALSE;
2881 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2884 p->retry = 1; /* initial call */
2887 if (eof) { /* flush the free queue, return when done */
2888 int n = sizeof(CBuf) + p->bufsize;
2890 iss = lib$remqti(&p->free, &b);
2891 if (iss == LIB$_QUEWASEMP) return;
2893 _ckvmssts(lib$free_vm(&n, &b));
2897 iss = lib$remqti(&p->free, &b);
2898 if (iss == LIB$_QUEWASEMP) {
2899 int n = sizeof(CBuf) + p->bufsize;
2900 _ckvmssts(lib$get_vm(&n, &b));
2901 b->buf = (char *) b + sizeof(CBuf);
2907 iss = sys$qio(0,p->chan_in,
2908 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2910 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2911 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2916 /* writes queued buffers to output, waits for each to complete before
2920 pipe_tochild2_ast(pPipe p)
2923 int iss = p->iosb2.status;
2924 int n = sizeof(CBuf) + p->bufsize;
2925 int done = (p->info && p->info->done) ||
2926 iss == SS$_CANCEL || iss == SS$_ABORT;
2927 #if defined(PERL_IMPLICIT_CONTEXT)
2932 if (p->type) { /* type=1 has old buffer, dispose */
2933 if (p->shut_on_empty) {
2934 _ckvmssts(lib$free_vm(&n, &b));
2936 _ckvmssts(lib$insqhi(b, &p->free));
2941 iss = lib$remqti(&p->wait, &b);
2942 if (iss == LIB$_QUEWASEMP) {
2943 if (p->shut_on_empty) {
2945 _ckvmssts(sys$dassgn(p->chan_out));
2946 *p->pipe_done = TRUE;
2947 _ckvmssts(sys$setef(pipe_ef));
2949 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2950 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2954 p->need_wake = TRUE;
2964 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2965 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2967 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2968 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2977 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2980 char mbx1[64], mbx2[64];
2981 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2982 DSC$K_CLASS_S, mbx1},
2983 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2984 DSC$K_CLASS_S, mbx2};
2985 unsigned int dviitm = DVI$_DEVBUFSIZ;
2987 int n = sizeof(Pipe);
2988 _ckvmssts(lib$get_vm(&n, &p));
2989 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2990 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2992 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2993 n = p->bufsize * sizeof(char);
2994 _ckvmssts(lib$get_vm(&n, &p->buf));
2995 p->shut_on_empty = FALSE;
2998 p->iosb.status = SS$_NORMAL;
2999 #if defined(PERL_IMPLICIT_CONTEXT)
3002 pipe_infromchild_ast(p);
3010 pipe_infromchild_ast(pPipe p)
3012 int iss = p->iosb.status;
3013 int eof = (iss == SS$_ENDOFFILE);
3014 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3015 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3016 #if defined(PERL_IMPLICIT_CONTEXT)
3020 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3021 _ckvmssts(sys$dassgn(p->chan_out));
3026 input shutdown if EOF from self (done or shut_on_empty)
3027 output shutdown if closing flag set (my_pclose)
3028 send data/eof from child or eof from self
3029 otherwise, re-read (snarf of data from child)
3034 if (myeof && p->chan_in) { /* input shutdown */
3035 _ckvmssts(sys$dassgn(p->chan_in));
3040 if (myeof || kideof) { /* pass EOF to parent */
3041 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3042 pipe_infromchild_ast, p,
3045 } else if (eof) { /* eat EOF --- fall through to read*/
3047 } else { /* transmit data */
3048 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3049 pipe_infromchild_ast,p,
3050 p->buf, p->iosb.count, 0, 0, 0, 0));
3056 /* everything shut? flag as done */
3058 if (!p->chan_in && !p->chan_out) {
3059 *p->pipe_done = TRUE;
3060 _ckvmssts(sys$setef(pipe_ef));
3064 /* write completed (or read, if snarfing from child)
3065 if still have input active,
3066 queue read...immediate mode if shut_on_empty so we get EOF if empty
3068 check if Perl reading, generate EOFs as needed
3074 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3075 pipe_infromchild_ast,p,
3076 p->buf, p->bufsize, 0, 0, 0, 0);
3077 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3079 } else { /* send EOFs for extra reads */
3080 p->iosb.status = SS$_ENDOFFILE;
3081 p->iosb.dvispec = 0;
3082 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3084 pipe_infromchild_ast, p, 0, 0, 0, 0));
3090 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3094 unsigned long dviitm = DVI$_DEVBUFSIZ;
3096 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3097 DSC$K_CLASS_S, mbx};
3098 int n = sizeof(Pipe);
3100 /* things like terminals and mbx's don't need this filter */
3101 if (fd && fstat(fd,&s) == 0) {
3102 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3104 unsigned short dev_len;
3105 struct dsc$descriptor_s d_dev;
3107 struct item_list_3 items[3];
3109 unsigned short dvi_iosb[4];
3111 cptr = getname(fd, out, 1);
3112 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3113 d_dev.dsc$a_pointer = out;
3114 d_dev.dsc$w_length = strlen(out);
3115 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3116 d_dev.dsc$b_class = DSC$K_CLASS_S;
3119 items[0].code = DVI$_DEVCHAR;
3120 items[0].bufadr = &devchar;
3121 items[0].retadr = NULL;
3123 items[1].code = DVI$_FULLDEVNAM;
3124 items[1].bufadr = device;
3125 items[1].retadr = &dev_len;
3129 status = sys$getdviw
3130 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3132 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3133 device[dev_len] = 0;
3135 if (!(devchar & DEV$M_DIR)) {
3136 strcpy(out, device);
3142 _ckvmssts(lib$get_vm(&n, &p));
3143 p->fd_out = dup(fd);
3144 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3145 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3146 n = (p->bufsize+1) * sizeof(char);
3147 _ckvmssts(lib$get_vm(&n, &p->buf));
3148 p->shut_on_empty = FALSE;
3153 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3154 pipe_mbxtofd_ast, p,
3155 p->buf, p->bufsize, 0, 0, 0, 0));
3161 pipe_mbxtofd_ast(pPipe p)
3163 int iss = p->iosb.status;
3164 int done = p->info->done;
3166 int eof = (iss == SS$_ENDOFFILE);
3167 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3168 int err = !(iss&1) && !eof;
3169 #if defined(PERL_IMPLICIT_CONTEXT)
3173 if (done && myeof) { /* end piping */
3175 sys$dassgn(p->chan_in);
3176 *p->pipe_done = TRUE;
3177 _ckvmssts(sys$setef(pipe_ef));
3181 if (!err && !eof) { /* good data to send to file */
3182 p->buf[p->iosb.count] = '\n';
3183 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3186 if (p->retry < MAX_RETRY) {
3187 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3197 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3198 pipe_mbxtofd_ast, p,
3199 p->buf, p->bufsize, 0, 0, 0, 0);
3200 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3205 typedef struct _pipeloc PLOC;
3206 typedef struct _pipeloc* pPLOC;
3210 char dir[NAM$C_MAXRSS+1];
3212 static pPLOC head_PLOC = 0;
3215 free_pipelocs(pTHX_ void *head)
3218 pPLOC *pHead = (pPLOC *)head;
3230 store_pipelocs(pTHX)
3239 char temp[NAM$C_MAXRSS+1];
3243 free_pipelocs(aTHX_ &head_PLOC);
3245 /* the . directory from @INC comes last */
3247 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3248 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3249 p->next = head_PLOC;
3251 strcpy(p->dir,"./");
3253 /* get the directory from $^X */
3255 unixdir = PerlMem_malloc(VMS_MAXRSS);
3256 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3258 #ifdef PERL_IMPLICIT_CONTEXT
3259 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3261 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3263 strcpy(temp, PL_origargv[0]);
3264 x = strrchr(temp,']');
3266 x = strrchr(temp,'>');
3268 /* It could be a UNIX path */
3269 x = strrchr(temp,'/');
3275 /* Got a bare name, so use default directory */
3280 if ((tounixpath(temp, unixdir)) != Nullch) {
3281 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3282 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3283 p->next = head_PLOC;
3285 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3286 p->dir[NAM$C_MAXRSS] = '\0';
3290 /* reverse order of @INC entries, skip "." since entered above */
3292 #ifdef PERL_IMPLICIT_CONTEXT
3295 if (PL_incgv) av = GvAVn(PL_incgv);
3297 for (i = 0; av && i <= AvFILL(av); i++) {
3298 dirsv = *av_fetch(av,i,TRUE);
3300 if (SvROK(dirsv)) continue;
3301 dir = SvPVx(dirsv,n_a);
3302 if (strcmp(dir,".") == 0) continue;
3303 if ((tounixpath(dir, unixdir)) == Nullch)
3306 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3307 p->next = head_PLOC;
3309 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3310 p->dir[NAM$C_MAXRSS] = '\0';
3313 /* most likely spot (ARCHLIB) put first in the list */
3316 if ((tounixpath(ARCHLIB_EXP, unixdir)) != Nullch) {
3317 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3318 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3319 p->next = head_PLOC;
3321 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3322 p->dir[NAM$C_MAXRSS] = '\0';
3325 PerlMem_free(unixdir);
3329 Perl_cando_by_name_int
3330 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3331 #if !defined(PERL_IMPLICIT_CONTEXT)
3332 #define cando_by_name_int Perl_cando_by_name_int
3334 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3340 static int vmspipe_file_status = 0;
3341 static char vmspipe_file[NAM$C_MAXRSS+1];
3343 /* already found? Check and use ... need read+execute permission */
3345 if (vmspipe_file_status == 1) {
3346 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3347 && cando_by_name_int
3348 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3349 return vmspipe_file;
3351 vmspipe_file_status = 0;
3354 /* scan through stored @INC, $^X */
3356 if (vmspipe_file_status == 0) {
3357 char file[NAM$C_MAXRSS+1];
3358 pPLOC p = head_PLOC;
3363 strcpy(file, p->dir);
3364 dirlen = strlen(file);
3365 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3366 file[NAM$C_MAXRSS] = '\0';
3369 exp_res = do_rmsexpand
3370 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS);
3371 if (!exp_res) continue;
3373 if (cando_by_name_int
3374 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3375 && cando_by_name_int
3376 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3377 vmspipe_file_status = 1;
3378 return vmspipe_file;
3381 vmspipe_file_status = -1; /* failed, use tempfiles */
3388 vmspipe_tempfile(pTHX)
3390 char file[NAM$C_MAXRSS+1];
3392 static int index = 0;
3396 /* create a tempfile */
3398 /* we can't go from W, shr=get to R, shr=get without
3399 an intermediate vulnerable state, so don't bother trying...
3401 and lib$spawn doesn't shr=put, so have to close the write
3403 So... match up the creation date/time and the FID to
3404 make sure we're dealing with the same file
3409 if (!decc_filename_unix_only) {
3410 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3411 fp = fopen(file,"w");
3413 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3414 fp = fopen(file,"w");
3416 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3417 fp = fopen(file,"w");
3422 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3423 fp = fopen(file,"w");
3425 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3426 fp = fopen(file,"w");
3428 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3429 fp = fopen(file,"w");
3433 if (!fp) return 0; /* we're hosed */
3435 fprintf(fp,"$! 'f$verify(0)'\n");
3436 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3437 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3438 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3439 fprintf(fp,"$ perl_on = \"set noon\"\n");
3440 fprintf(fp,"$ perl_exit = \"exit\"\n");
3441 fprintf(fp,"$ perl_del = \"delete\"\n");
3442 fprintf(fp,"$ pif = \"if\"\n");
3443 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3444 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3445 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3446 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3447 fprintf(fp,"$! --- build command line to get max possible length\n");
3448 fprintf(fp,"$c=perl_popen_cmd0\n");
3449 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3450 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3451 fprintf(fp,"$x=perl_popen_cmd3\n");
3452 fprintf(fp,"$c=c+x\n");
3453 fprintf(fp,"$ perl_on\n");
3454 fprintf(fp,"$ 'c'\n");
3455 fprintf(fp,"$ perl_status = $STATUS\n");
3456 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3457 fprintf(fp,"$ perl_exit 'perl_status'\n");
3460 fgetname(fp, file, 1);
3461 fstat(fileno(fp), (struct stat *)&s0);
3464 if (decc_filename_unix_only)
3465 do_tounixspec(file, file, 0);
3466 fp = fopen(file,"r","shr=get");
3468 fstat(fileno(fp), (struct stat *)&s1);
3470 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3471 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3482 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3484 static int handler_set_up = FALSE;
3485 unsigned long int sts, flags = CLI$M_NOWAIT;
3486 /* The use of a GLOBAL table (as was done previously) rendered
3487 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3488 * environment. Hence we've switched to LOCAL symbol table.
3490 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3492 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3493 char *in, *out, *err, mbx[512];
3495 char tfilebuf[NAM$C_MAXRSS+1];
3497 char cmd_sym_name[20];
3498 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3499 DSC$K_CLASS_S, symbol};
3500 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3502 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3503 DSC$K_CLASS_S, cmd_sym_name};
3504 struct dsc$descriptor_s *vmscmd;
3505 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3506 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3507 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3509 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3511 /* once-per-program initialization...
3512 note that the SETAST calls and the dual test of pipe_ef
3513 makes sure that only the FIRST thread through here does
3514 the initialization...all other threads wait until it's
3517 Yeah, uglier than a pthread call, it's got all the stuff inline
3518 rather than in a separate routine.
3522 _ckvmssts(sys$setast(0));
3524 unsigned long int pidcode = JPI$_PID;
3525 $DESCRIPTOR(d_delay, RETRY_DELAY);
3526 _ckvmssts(lib$get_ef(&pipe_ef));
3527 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3528 _ckvmssts(sys$bintim(&d_delay, delaytime));
3530 if (!handler_set_up) {
3531 _ckvmssts(sys$dclexh(&pipe_exitblock));
3532 handler_set_up = TRUE;
3534 _ckvmssts(sys$setast(1));
3537 /* see if we can find a VMSPIPE.COM */
3540 vmspipe = find_vmspipe(aTHX);
3542 strcpy(tfilebuf+1,vmspipe);
3543 } else { /* uh, oh...we're in tempfile hell */
3544 tpipe = vmspipe_tempfile(aTHX);
3545 if (!tpipe) { /* a fish popular in Boston */
3546 if (ckWARN(WARN_PIPE)) {
3547 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3551 fgetname(tpipe,tfilebuf+1,1);
3553 vmspipedsc.dsc$a_pointer = tfilebuf;
3554 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3556 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3559 case RMS$_FNF: case RMS$_DNF:
3560 set_errno(ENOENT); break;
3562 set_errno(ENOTDIR); break;
3564 set_errno(ENODEV); break;
3566 set_errno(EACCES); break;
3568 set_errno(EINVAL); break;
3569 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3570 set_errno(E2BIG); break;
3571 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3572 _ckvmssts(sts); /* fall through */
3573 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3576 set_vaxc_errno(sts);
3577 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3578 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3584 _ckvmssts(lib$get_vm(&n, &info));
3586 strcpy(mode,in_mode);
3589 info->completion = 0;
3590 info->closing = FALSE;
3597 info->in_done = TRUE;
3598 info->out_done = TRUE;
3599 info->err_done = TRUE;
3601 in = PerlMem_malloc(VMS_MAXRSS);
3602 if (in == NULL) _ckvmssts(SS$_INSFMEM);
3603 out = PerlMem_malloc(VMS_MAXRSS);
3604 if (out == NULL) _ckvmssts(SS$_INSFMEM);
3605 err = PerlMem_malloc(VMS_MAXRSS);
3606 if (err == NULL) _ckvmssts(SS$_INSFMEM);
3608 in[0] = out[0] = err[0] = '\0';
3610 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3614 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3619 if (*mode == 'r') { /* piping from subroutine */
3621 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3623 info->out->pipe_done = &info->out_done;
3624 info->out_done = FALSE;
3625 info->out->info = info;
3627 if (!info->useFILE) {
3628 info->fp = PerlIO_open(mbx, mode);
3630 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3631 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3634 if (!info->fp && info->out) {
3635 sys$cancel(info->out->chan_out);
3637 while (!info->out_done) {
3639 _ckvmssts(sys$setast(0));
3640 done = info->out_done;
3641 if (!done) _ckvmssts(sys$clref(pipe_ef));
3642 _ckvmssts(sys$setast(1));
3643 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3646 if (info->out->buf) {
3647 n = info->out->bufsize * sizeof(char);
3648 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3651 _ckvmssts(lib$free_vm(&n, &info->out));
3653 _ckvmssts(lib$free_vm(&n, &info));
3658 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3660 info->err->pipe_done = &info->err_done;
3661 info->err_done = FALSE;
3662 info->err->info = info;
3665 } else if (*mode == 'w') { /* piping to subroutine */
3667 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3669 info->out->pipe_done = &info->out_done;
3670 info->out_done = FALSE;
3671 info->out->info = info;
3674 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3676 info->err->pipe_done = &info->err_done;
3677 info->err_done = FALSE;
3678 info->err->info = info;
3681 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3682 if (!info->useFILE) {
3683 info->fp = PerlIO_open(mbx, mode);
3685 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3686 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3690 info->in->pipe_done = &info->in_done;
3691 info->in_done = FALSE;
3692 info->in->info = info;
3696 if (!info->fp && info->in) {
3698 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3699 0, 0, 0, 0, 0, 0, 0, 0));
3701 while (!info->in_done) {
3703 _ckvmssts(sys$setast(0));
3704 done = info->in_done;
3705 if (!done) _ckvmssts(sys$clref(pipe_ef));
3706 _ckvmssts(sys$setast(1));
3707 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3710 if (info->in->buf) {
3711 n = info->in->bufsize * sizeof(char);
3712 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3715 _ckvmssts(lib$free_vm(&n, &info->in));
3717 _ckvmssts(lib$free_vm(&n, &info));
3723 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3724 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3726 info->out->pipe_done = &info->out_done;
3727 info->out_done = FALSE;
3728 info->out->info = info;
3731 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3733 info->err->pipe_done = &info->err_done;
3734 info->err_done = FALSE;
3735 info->err->info = info;
3739 symbol[MAX_DCL_SYMBOL] = '\0';
3741 strncpy(symbol, in, MAX_DCL_SYMBOL);
3742 d_symbol.dsc$w_length = strlen(symbol);
3743 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3745 strncpy(symbol, err, MAX_DCL_SYMBOL);
3746 d_symbol.dsc$w_length = strlen(symbol);
3747 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3749 strncpy(symbol, out, MAX_DCL_SYMBOL);
3750 d_symbol.dsc$w_length = strlen(symbol);
3751 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3753 /* Done with the names for the pipes */
3758 p = vmscmd->dsc$a_pointer;
3759 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3760 if (*p == '$') p++; /* remove leading $ */
3761 while (*p == ' ' || *p == '\t') p++;
3763 for (j = 0; j < 4; j++) {
3764 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3765 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3767 strncpy(symbol, p, MAX_DCL_SYMBOL);
3768 d_symbol.dsc$w_length = strlen(symbol);
3769 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3771 if (strlen(p) > MAX_DCL_SYMBOL) {
3772 p += MAX_DCL_SYMBOL;
3777 _ckvmssts(sys$setast(0));
3778 info->next=open_pipes; /* prepend to list */
3780 _ckvmssts(sys$setast(1));
3781 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3782 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3783 * have SYS$COMMAND if we need it.
3785 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3786 0, &info->pid, &info->completion,
3787 0, popen_completion_ast,info,0,0,0));
3789 /* if we were using a tempfile, close it now */
3791 if (tpipe) fclose(tpipe);
3793 /* once the subprocess is spawned, it has copied the symbols and
3794 we can get rid of ours */
3796 for (j = 0; j < 4; j++) {
3797 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3798 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3799 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3801 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3802 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3803 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3804 vms_execfree(vmscmd);
3806 #ifdef PERL_IMPLICIT_CONTEXT
3809 PL_forkprocess = info->pid;
3814 _ckvmssts(sys$setast(0));
3816 if (!done) _ckvmssts(sys$clref(pipe_ef));
3817 _ckvmssts(sys$setast(1));
3818 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3820 *psts = info->completion;
3821 /* Caller thinks it is open and tries to close it. */
3822 /* This causes some problems, as it changes the error status */
3823 /* my_pclose(info->fp); */
3828 } /* end of safe_popen */
3831 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3833 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3837 TAINT_PROPER("popen");
3838 PERL_FLUSHALL_FOR_CHILD;
3839 return safe_popen(aTHX_ cmd,mode,&sts);
3844 /*{{{ I32 my_pclose(PerlIO *fp)*/
3845 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3847 pInfo info, last = NULL;
3848 unsigned long int retsts;
3851 for (info = open_pipes; info != NULL; last = info, info = info->next)
3852 if (info->fp == fp) break;
3854 if (info == NULL) { /* no such pipe open */
3855 set_errno(ECHILD); /* quoth POSIX */
3856 set_vaxc_errno(SS$_NONEXPR);
3860 /* If we were writing to a subprocess, insure that someone reading from
3861 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
3862 * produce an EOF record in the mailbox.
3864 * well, at least sometimes it *does*, so we have to watch out for
3865 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3869 PerlIO_flush(info->fp); /* first, flush data */
3871 fflush((FILE *)info->fp);
3874 _ckvmssts(sys$setast(0));
3875 info->closing = TRUE;
3876 done = info->done && info->in_done && info->out_done && info->err_done;
3877 /* hanging on write to Perl's input? cancel it */
3878 if (info->mode == 'r' && info->out && !info->out_done) {
3879 if (info->out->chan_out) {
3880 _ckvmssts(sys$cancel(info->out->chan_out));
3881 if (!info->out->chan_in) { /* EOF generation, need AST */
3882 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3886 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3887 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3889 _ckvmssts(sys$setast(1));
3892 PerlIO_close(info->fp);
3894 fclose((FILE *)info->fp);
3897 we have to wait until subprocess completes, but ALSO wait until all
3898 the i/o completes...otherwise we'll be freeing the "info" structure
3899 that the i/o ASTs could still be using...
3903 _ckvmssts(sys$setast(0));
3904 done = info->done && info->in_done && info->out_done && info->err_done;
3905 if (!done) _ckvmssts(sys$clref(pipe_ef));
3906 _ckvmssts(sys$setast(1));
3907 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3909 retsts = info->completion;
3911 /* remove from list of open pipes */
3912 _ckvmssts(sys$setast(0));
3913 if (last) last->next = info->next;
3914 else open_pipes = info->next;
3915 _ckvmssts(sys$setast(1));
3917 /* free buffers and structures */
3920 if (info->in->buf) {
3921 n = info->in->bufsize * sizeof(char);
3922 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3925 _ckvmssts(lib$free_vm(&n, &info->in));
3928 if (info->out->buf) {
3929 n = info->out->bufsize * sizeof(char);
3930 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3933 _ckvmssts(lib$free_vm(&n, &info->out));
3936 if (info->err->buf) {
3937 n = info->err->bufsize * sizeof(char);
3938 _ckvmssts(lib$free_vm(&n, &info->err->buf));
3941 _ckvmssts(lib$free_vm(&n, &info->err));
3944 _ckvmssts(lib$free_vm(&n, &info));
3948 } /* end of my_pclose() */
3950 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3951 /* Roll our own prototype because we want this regardless of whether
3952 * _VMS_WAIT is defined.
3954 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3956 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3957 created with popen(); otherwise partially emulate waitpid() unless
3958 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3959 Also check processes not considered by the CRTL waitpid().
3961 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3963 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3970 if (statusp) *statusp = 0;
3972 for (info = open_pipes; info != NULL; info = info->next)
3973 if (info->pid == pid) break;
3975 if (info != NULL) { /* we know about this child */
3976 while (!info->done) {
3977 _ckvmssts(sys$setast(0));
3979 if (!done) _ckvmssts(sys$clref(pipe_ef));
3980 _ckvmssts(sys$setast(1));
3981 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3984 if (statusp) *statusp = info->completion;
3988 /* child that already terminated? */
3990 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3991 if (closed_list[j].pid == pid) {
3992 if (statusp) *statusp = closed_list[j].completion;
3997 /* fall through if this child is not one of our own pipe children */
3999 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4001 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4002 * in 7.2 did we get a version that fills in the VMS completion
4003 * status as Perl has always tried to do.
4006 sts = __vms_waitpid( pid, statusp, flags );
4008 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4011 /* If the real waitpid tells us the child does not exist, we
4012 * fall through here to implement waiting for a child that
4013 * was created by some means other than exec() (say, spawned
4014 * from DCL) or to wait for a process that is not a subprocess
4015 * of the current process.
4018 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4021 $DESCRIPTOR(intdsc,"0 00:00:01");
4022 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4023 unsigned long int pidcode = JPI$_PID, mypid;
4024 unsigned long int interval[2];
4025 unsigned int jpi_iosb[2];
4026 struct itmlst_3 jpilist[2] = {
4027 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4032 /* Sorry folks, we don't presently implement rooting around for
4033 the first child we can find, and we definitely don't want to
4034 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4040 /* Get the owner of the child so I can warn if it's not mine. If the
4041 * process doesn't exist or I don't have the privs to look at it,
4042 * I can go home early.
4044 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4045 if (sts & 1) sts = jpi_iosb[0];
4057 set_vaxc_errno(sts);
4061 if (ckWARN(WARN_EXEC)) {
4062 /* remind folks they are asking for non-standard waitpid behavior */
4063 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4064 if (ownerpid != mypid)
4065 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4066 "waitpid: process %x is not a child of process %x",
4070 /* simply check on it once a second until it's not there anymore. */
4072 _ckvmssts(sys$bintim(&intdsc,interval));
4073 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4074 _ckvmssts(sys$schdwk(0,0,interval,0));
4075 _ckvmssts(sys$hiber());
4077 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4082 } /* end of waitpid() */
4087 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4089 my_gconvert(double val, int ndig, int trail, char *buf)
4091 static char __gcvtbuf[DBL_DIG+1];
4094 loc = buf ? buf : __gcvtbuf;
4096 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4098 sprintf(loc,"%.*g",ndig,val);
4104 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4105 return gcvt(val,ndig,loc);
4108 loc[0] = '0'; loc[1] = '\0';
4115 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4116 static int rms_free_search_context(struct FAB * fab)
4120 nam = fab->fab$l_nam;
4121 nam->nam$b_nop |= NAM$M_SYNCHK;
4122 nam->nam$l_rlf = NULL;
4124 return sys$parse(fab, NULL, NULL);
4127 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4128 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4129 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4130 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4131 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4132 #define rms_nam_esll(nam) nam.nam$b_esl
4133 #define rms_nam_esl(nam) nam.nam$b_esl
4134 #define rms_nam_name(nam) nam.nam$l_name
4135 #define rms_nam_namel(nam) nam.nam$l_name
4136 #define rms_nam_type(nam) nam.nam$l_type
4137 #define rms_nam_typel(nam) nam.nam$l_type
4138 #define rms_nam_ver(nam) nam.nam$l_ver
4139 #define rms_nam_verl(nam) nam.nam$l_ver
4140 #define rms_nam_rsll(nam) nam.nam$b_rsl
4141 #define rms_nam_rsl(nam) nam.nam$b_rsl
4142 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4143 #define rms_set_fna(fab, nam, name, size) \
4144 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4145 #define rms_get_fna(fab, nam) fab.fab$l_fna
4146 #define rms_set_dna(fab, nam, name, size) \
4147 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4148 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4149 #define rms_set_esa(fab, nam, name, size) \
4150 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4151 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4152 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4153 #define rms_set_rsa(nam, name, size) \
4154 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4155 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4156 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4157 #define rms_nam_name_type_l_size(nam) \
4158 (nam.nam$b_name + nam.nam$b_type)
4160 static int rms_free_search_context(struct FAB * fab)
4164 nam = fab->fab$l_naml;
4165 nam->naml$b_nop |= NAM$M_SYNCHK;
4166 nam->naml$l_rlf = NULL;
4167 nam->naml$l_long_defname_size = 0;
4170 return sys$parse(fab, NULL, NULL);
4173 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4174 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4175 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4176 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4177 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4178 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4179 #define rms_nam_esl(nam) nam.naml$b_esl
4180 #define rms_nam_name(nam) nam.naml$l_name
4181 #define rms_nam_namel(nam) nam.naml$l_long_name
4182 #define rms_nam_type(nam) nam.naml$l_type
4183 #define rms_nam_typel(nam) nam.naml$l_long_type
4184 #define rms_nam_ver(nam) nam.naml$l_ver
4185 #define rms_nam_verl(nam) nam.naml$l_long_ver
4186 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4187 #define rms_nam_rsl(nam) nam.naml$b_rsl
4188 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4189 #define rms_set_fna(fab, nam, name, size) \
4190 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4191 nam.naml$l_long_filename_size = size; \
4192 nam.naml$l_long_filename = name;}
4193 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4194 #define rms_set_dna(fab, nam, name, size) \
4195 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4196 nam.naml$l_long_defname_size = size; \
4197 nam.naml$l_long_defname = name; }
4198 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4199 #define rms_set_esa(fab, nam, name, size) \
4200 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4201 nam.naml$l_long_expand_alloc = size; \
4202 nam.naml$l_long_expand = name; }
4203 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4204 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4205 nam.naml$l_long_expand = l_name; \
4206 nam.naml$l_long_expand_alloc = l_size; }
4207 #define rms_set_rsa(nam, name, size) \
4208 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4209 nam.naml$l_long_result = name; \
4210 nam.naml$l_long_result_alloc = size; }
4211 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4212 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4213 nam.naml$l_long_result = l_name; \
4214 nam.naml$l_long_result_alloc = l_size; }
4215 #define rms_nam_name_type_l_size(nam) \
4216 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4220 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4221 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4222 * to expand file specification. Allows for a single default file
4223 * specification and a simple mask of options. If outbuf is non-NULL,
4224 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4225 * the resultant file specification is placed. If outbuf is NULL, the
4226 * resultant file specification is placed into a static buffer.
4227 * The third argument, if non-NULL, is taken to be a default file
4228 * specification string. The fourth argument is unused at present.
4229 * rmesexpand() returns the address of the resultant string if
4230 * successful, and NULL on error.
4232 * New functionality for previously unused opts value:
4233 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4234 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4235 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4237 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4240 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4242 static char __rmsexpand_retbuf[VMS_MAXRSS];
4243 char * vmsfspec, *tmpfspec;
4244 char * esa, *cp, *out = NULL;
4248 struct FAB myfab = cc$rms_fab;
4249 rms_setup_nam(mynam);
4251 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4254 if (!filespec || !*filespec) {
4255 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4259 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4260 else outbuf = __rmsexpand_retbuf;
4268 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4269 isunix = is_unix_filespec(filespec);
4271 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4272 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4273 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4274 PerlMem_free(vmsfspec);
4279 filespec = vmsfspec;
4281 /* Unless we are forcing to VMS format, a UNIX input means
4282 * UNIX output, and that requires long names to be used
4284 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4285 opts |= PERL_RMSEXPAND_M_LONG;
4292 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4293 rms_bind_fab_nam(myfab, mynam);
4295 if (defspec && *defspec) {
4297 t_isunix = is_unix_filespec(defspec);
4299 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4300 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4301 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4302 PerlMem_free(tmpfspec);
4303 if (vmsfspec != NULL)
4304 PerlMem_free(vmsfspec);
4311 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4314 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4315 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4316 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4317 esal = PerlMem_malloc(VMS_MAXRSS);
4318 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4320 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4322 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4323 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4326 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4327 outbufl = PerlMem_malloc(VMS_MAXRSS);
4328 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4329 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4331 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4335 #ifdef NAM$M_NO_SHORT_UPCASE
4336 if (decc_efs_case_preserve)
4337 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4340 /* First attempt to parse as an existing file */
4341 retsts = sys$parse(&myfab,0,0);
4342 if (!(retsts & STS$K_SUCCESS)) {
4344 /* Could not find the file, try as syntax only if error is not fatal */
4345 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4346 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4347 retsts = sys$parse(&myfab,0,0);
4348 if (retsts & STS$K_SUCCESS) goto expanded;
4351 /* Still could not parse the file specification */
4352 /*----------------------------------------------*/
4353 sts = rms_free_search_context(&myfab); /* Free search context */
4354 if (out) Safefree(out);
4355 if (tmpfspec != NULL)
4356 PerlMem_free(tmpfspec);
4357 if (vmsfspec != NULL)
4358 PerlMem_free(vmsfspec);
4359 if (outbufl != NULL)
4360 PerlMem_free(outbufl);
4363 set_vaxc_errno(retsts);
4364 if (retsts == RMS$_PRV) set_errno(EACCES);
4365 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4366 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4367 else set_errno(EVMSERR);
4370 retsts = sys$search(&myfab,0,0);
4371 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4372 sts = rms_free_search_context(&myfab); /* Free search context */
4373 if (out) Safefree(out);
4374 if (tmpfspec != NULL)
4375 PerlMem_free(tmpfspec);
4376 if (vmsfspec != NULL)
4377 PerlMem_free(vmsfspec);
4378 if (outbufl != NULL)
4379 PerlMem_free(outbufl);
4382 set_vaxc_errno(retsts);
4383 if (retsts == RMS$_PRV) set_errno(EACCES);
4384 else set_errno(EVMSERR);
4388 /* If the input filespec contained any lowercase characters,
4389 * downcase the result for compatibility with Unix-minded code. */
4391 if (!decc_efs_case_preserve) {
4392 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4393 if (islower(*tbuf)) { haslower = 1; break; }
4396 /* Is a long or a short name expected */
4397 /*------------------------------------*/
4398 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4399 if (rms_nam_rsll(mynam)) {
4401 speclen = rms_nam_rsll(mynam);
4404 tbuf = esal; /* Not esa */
4405 speclen = rms_nam_esll(mynam);
4409 if (rms_nam_rsl(mynam)) {
4411 speclen = rms_nam_rsl(mynam);
4414 tbuf = esa; /* Not esal */
4415 speclen = rms_nam_esl(mynam);
4418 tbuf[speclen] = '\0';
4420 /* Trim off null fields added by $PARSE
4421 * If type > 1 char, must have been specified in original or default spec
4422 * (not true for version; $SEARCH may have added version of existing file).
4424 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4425 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4426 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4427 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4430 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4431 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4433 if (trimver || trimtype) {
4434 if (defspec && *defspec) {
4435 char *defesal = NULL;
4436 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4437 if (defesal != NULL) {
4438 struct FAB deffab = cc$rms_fab;
4439 rms_setup_nam(defnam);
4441 rms_bind_fab_nam(deffab, defnam);
4445 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4447 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4449 rms_clear_nam_nop(defnam);
4450 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4451 #ifdef NAM$M_NO_SHORT_UPCASE
4452 if (decc_efs_case_preserve)
4453 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4455 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4457 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4460 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4463 PerlMem_free(defesal);
4467 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4468 if (*(rms_nam_verl(mynam)) != '\"')
4469 speclen = rms_nam_verl(mynam) - tbuf;
4472 if (*(rms_nam_ver(mynam)) != '\"')
4473 speclen = rms_nam_ver(mynam) - tbuf;
4477 /* If we didn't already trim version, copy down */
4478 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4479 if (speclen > rms_nam_verl(mynam) - tbuf)
4481 (rms_nam_typel(mynam),
4482 rms_nam_verl(mynam),
4483 speclen - (rms_nam_verl(mynam) - tbuf));
4484 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4487 if (speclen > rms_nam_ver(mynam) - tbuf)
4489 (rms_nam_type(mynam),
4491 speclen - (rms_nam_ver(mynam) - tbuf));
4492 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4497 /* Done with these copies of the input files */
4498 /*-------------------------------------------*/
4499 if (vmsfspec != NULL)
4500 PerlMem_free(vmsfspec);
4501 if (tmpfspec != NULL)
4502 PerlMem_free(tmpfspec);
4504 /* If we just had a directory spec on input, $PARSE "helpfully"
4505 * adds an empty name and type for us */
4506 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4507 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4508 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4509 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4510 speclen = rms_nam_namel(mynam) - tbuf;
4513 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4514 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4515 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4516 speclen = rms_nam_name(mynam) - tbuf;
4519 /* Posix format specifications must have matching quotes */
4520 if (speclen < (VMS_MAXRSS - 1)) {
4521 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4522 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4523 tbuf[speclen] = '\"';
4528 tbuf[speclen] = '\0';
4529 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4531 /* Have we been working with an expanded, but not resultant, spec? */
4532 /* Also, convert back to Unix syntax if necessary. */
4534 if (!rms_nam_rsll(mynam)) {
4536 if (do_tounixspec(esa,outbuf,0) == NULL) {
4537 if (out) Safefree(out);
4540 if (outbufl != NULL)
4541 PerlMem_free(outbufl);
4545 else strcpy(outbuf,esa);
4548 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4549 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4550 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4551 if (out) Safefree(out);
4554 PerlMem_free(tmpfspec);
4555 if (outbufl != NULL)
4556 PerlMem_free(outbufl);
4559 strcpy(outbuf,tmpfspec);
4560 PerlMem_free(tmpfspec);
4563 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4564 sts = rms_free_search_context(&myfab); /* Free search context */
4567 if (outbufl != NULL)
4568 PerlMem_free(outbufl);
4572 /* External entry points */
4573 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4574 { return do_rmsexpand(spec,buf,0,def,opt); }
4575 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4576 { return do_rmsexpand(spec,buf,1,def,opt); }
4580 ** The following routines are provided to make life easier when
4581 ** converting among VMS-style and Unix-style directory specifications.
4582 ** All will take input specifications in either VMS or Unix syntax. On
4583 ** failure, all return NULL. If successful, the routines listed below
4584 ** return a pointer to a buffer containing the appropriately
4585 ** reformatted spec (and, therefore, subsequent calls to that routine
4586 ** will clobber the result), while the routines of the same names with
4587 ** a _ts suffix appended will return a pointer to a mallocd string
4588 ** containing the appropriately reformatted spec.
4589 ** In all cases, only explicit syntax is altered; no check is made that
4590 ** the resulting string is valid or that the directory in question
4593 ** fileify_dirspec() - convert a directory spec into the name of the
4594 ** directory file (i.e. what you can stat() to see if it's a dir).
4595 ** The style (VMS or Unix) of the result is the same as the style
4596 ** of the parameter passed in.
4597 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4598 ** what you prepend to a filename to indicate what directory it's in).
4599 ** The style (VMS or Unix) of the result is the same as the style
4600 ** of the parameter passed in.
4601 ** tounixpath() - convert a directory spec into a Unix-style path.
4602 ** tovmspath() - convert a directory spec into a VMS-style path.
4603 ** tounixspec() - convert any file spec into a Unix-style file spec.
4604 ** tovmsspec() - convert any file spec into a VMS-style spec.
4606 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4607 ** Permission is given to distribute this code as part of the Perl
4608 ** standard distribution under the terms of the GNU General Public
4609 ** License or the Perl Artistic License. Copies of each may be
4610 ** found in the Perl standard distribution.
4613 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4614 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4616 static char __fileify_retbuf[VMS_MAXRSS];
4617 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4618 char *retspec, *cp1, *cp2, *lastdir;
4619 char *trndir, *vmsdir;
4620 unsigned short int trnlnm_iter_count;
4623 if (!dir || !*dir) {
4624 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4626 dirlen = strlen(dir);
4627 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4628 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4629 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4636 if (dirlen > (VMS_MAXRSS - 1)) {
4637 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4640 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4641 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4642 if (!strpbrk(dir+1,"/]>:") &&
4643 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4644 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4645 trnlnm_iter_count = 0;
4646 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4647 trnlnm_iter_count++;
4648 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4650 dirlen = strlen(trndir);
4653 strncpy(trndir,dir,dirlen);
4654 trndir[dirlen] = '\0';
4657 /* At this point we are done with *dir and use *trndir which is a
4658 * copy that can be modified. *dir must not be modified.
4661 /* If we were handed a rooted logical name or spec, treat it like a
4662 * simple directory, so that
4663 * $ Define myroot dev:[dir.]
4664 * ... do_fileify_dirspec("myroot",buf,1) ...
4665 * does something useful.
4667 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4668 trndir[--dirlen] = '\0';
4669 trndir[dirlen-1] = ']';
4671 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4672 trndir[--dirlen] = '\0';
4673 trndir[dirlen-1] = '>';
4676 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4677 /* If we've got an explicit filename, we can just shuffle the string. */
4678 if (*(cp1+1)) hasfilename = 1;
4679 /* Similarly, we can just back up a level if we've got multiple levels
4680 of explicit directories in a VMS spec which ends with directories. */
4682 for (cp2 = cp1; cp2 > trndir; cp2--) {
4684 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4685 /* fix-me, can not scan EFS file specs backward like this */
4686 *cp2 = *cp1; *cp1 = '\0';
4691 if (*cp2 == '[' || *cp2 == '<') break;
4696 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4697 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4698 cp1 = strpbrk(trndir,"]:>");
4699 if (hasfilename || !cp1) { /* Unix-style path or filename */
4700 if (trndir[0] == '.') {
4701 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4702 PerlMem_free(trndir);
4703 PerlMem_free(vmsdir);
4704 return do_fileify_dirspec("[]",buf,ts);
4706 else if (trndir[1] == '.' &&
4707 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4708 PerlMem_free(trndir);
4709 PerlMem_free(vmsdir);
4710 return do_fileify_dirspec("[-]",buf,ts);
4713 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4714 dirlen -= 1; /* to last element */
4715 lastdir = strrchr(trndir,'/');
4717 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4718 /* If we have "/." or "/..", VMSify it and let the VMS code
4719 * below expand it, rather than repeating the code to handle
4720 * relative components of a filespec here */
4722 if (*(cp1+2) == '.') cp1++;
4723 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4725 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4726 PerlMem_free(trndir);
4727 PerlMem_free(vmsdir);
4730 if (strchr(vmsdir,'/') != NULL) {
4731 /* If do_tovmsspec() returned it, it must have VMS syntax
4732 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4733 * the time to check this here only so we avoid a recursion
4734 * loop; otherwise, gigo.
4736 PerlMem_free(trndir);
4737 PerlMem_free(vmsdir);
4738 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4741 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4742 PerlMem_free(trndir);
4743 PerlMem_free(vmsdir);
4746 ret_chr = do_tounixspec(trndir,buf,ts);
4747 PerlMem_free(trndir);
4748 PerlMem_free(vmsdir);
4752 } while ((cp1 = strstr(cp1,"/.")) != NULL);
4753 lastdir = strrchr(trndir,'/');
4755 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4757 /* Ditto for specs that end in an MFD -- let the VMS code
4758 * figure out whether it's a real device or a rooted logical. */
4760 /* This should not happen any more. Allowing the fake /000000
4761 * in a UNIX pathname causes all sorts of problems when trying
4762 * to run in UNIX emulation. So the VMS to UNIX conversions
4763 * now remove the fake /000000 directories.
4766 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4767 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4768 PerlMem_free(trndir);
4769 PerlMem_free(vmsdir);
4772 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4773 PerlMem_free(trndir);
4774 PerlMem_free(vmsdir);
4777 ret_chr = do_tounixspec(trndir,buf,ts);
4778 PerlMem_free(trndir);
4779 PerlMem_free(vmsdir);
4784 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4785 !(lastdir = cp1 = strrchr(trndir,']')) &&
4786 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4787 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
4790 /* For EFS or ODS-5 look for the last dot */
4791 if (decc_efs_charset) {
4792 cp2 = strrchr(cp1,'.');
4794 if (vms_process_case_tolerant) {
4795 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4796 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4797 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4798 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4799 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4800 (ver || *cp3)))))) {
4801 PerlMem_free(trndir);
4802 PerlMem_free(vmsdir);
4804 set_vaxc_errno(RMS$_DIR);
4809 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4810 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4811 !*(cp2+3) || *(cp2+3) != 'R' ||
4812 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4813 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4814 (ver || *cp3)))))) {
4815 PerlMem_free(trndir);
4816 PerlMem_free(vmsdir);
4818 set_vaxc_errno(RMS$_DIR);
4822 dirlen = cp2 - trndir;
4826 retlen = dirlen + 6;
4827 if (buf) retspec = buf;
4828 else if (ts) Newx(retspec,retlen+1,char);
4829 else retspec = __fileify_retbuf;
4830 memcpy(retspec,trndir,dirlen);
4831 retspec[dirlen] = '\0';
4833 /* We've picked up everything up to the directory file name.
4834 Now just add the type and version, and we're set. */
4835 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4836 strcat(retspec,".dir;1");
4838 strcat(retspec,".DIR;1");
4839 PerlMem_free(trndir);
4840 PerlMem_free(vmsdir);
4843 else { /* VMS-style directory spec */
4845 char *esa, term, *cp;
4846 unsigned long int sts, cmplen, haslower = 0;
4847 unsigned int nam_fnb;
4849 struct FAB dirfab = cc$rms_fab;
4850 rms_setup_nam(savnam);
4851 rms_setup_nam(dirnam);
4853 esa = PerlMem_malloc(VMS_MAXRSS + 1);
4854 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4855 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4856 rms_bind_fab_nam(dirfab, dirnam);
4857 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4858 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4859 #ifdef NAM$M_NO_SHORT_UPCASE
4860 if (decc_efs_case_preserve)
4861 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4864 for (cp = trndir; *cp; cp++)
4865 if (islower(*cp)) { haslower = 1; break; }
4866 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4867 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4868 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4869 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4873 PerlMem_free(trndir);
4874 PerlMem_free(vmsdir);
4876 set_vaxc_errno(dirfab.fab$l_sts);
4882 /* Does the file really exist? */
4883 if (sys$search(&dirfab)& STS$K_SUCCESS) {
4884 /* Yes; fake the fnb bits so we'll check type below */
4885 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4887 else { /* No; just work with potential name */
4888 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4891 fab_sts = dirfab.fab$l_sts;
4892 sts = rms_free_search_context(&dirfab);
4894 PerlMem_free(trndir);
4895 PerlMem_free(vmsdir);
4896 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
4901 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
4902 cp1 = strchr(esa,']');
4903 if (!cp1) cp1 = strchr(esa,'>');
4904 if (cp1) { /* Should always be true */
4905 rms_nam_esll(dirnam) -= cp1 - esa - 1;
4906 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
4909 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
4910 /* Yep; check version while we're at it, if it's there. */
4911 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
4912 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
4913 /* Something other than .DIR[;1]. Bzzt. */
4914 sts = rms_free_search_context(&dirfab);
4916 PerlMem_free(trndir);
4917 PerlMem_free(vmsdir);
4919 set_vaxc_errno(RMS$_DIR);
4923 esa[rms_nam_esll(dirnam)] = '\0';
4924 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
4925 /* They provided at least the name; we added the type, if necessary, */
4926 if (buf) retspec = buf; /* in sys$parse() */
4927 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
4928 else retspec = __fileify_retbuf;
4929 strcpy(retspec,esa);
4930 sts = rms_free_search_context(&dirfab);
4931 PerlMem_free(trndir);
4933 PerlMem_free(vmsdir);
4936 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
4937 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
4939 rms_nam_esll(dirnam) -= 9;
4941 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
4942 if (cp1 == NULL) { /* should never happen */
4943 sts = rms_free_search_context(&dirfab);
4944 PerlMem_free(trndir);
4946 PerlMem_free(vmsdir);
4951 retlen = strlen(esa);
4952 cp1 = strrchr(esa,'.');
4953 /* ODS-5 directory specifications can have extra "." in them. */
4954 /* Fix-me, can not scan EFS file specifications backwards */
4955 while (cp1 != NULL) {
4956 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
4960 while ((cp1 > esa) && (*cp1 != '.'))
4967 if ((cp1) != NULL) {
4968 /* There's more than one directory in the path. Just roll back. */
4970 if (buf) retspec = buf;
4971 else if (ts) Newx(retspec,retlen+7,char);
4972 else retspec = __fileify_retbuf;
4973 strcpy(retspec,esa);
4976 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
4977 /* Go back and expand rooted logical name */
4978 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
4979 #ifdef NAM$M_NO_SHORT_UPCASE
4980 if (decc_efs_case_preserve)
4981 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4983 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
4984 sts = rms_free_search_context(&dirfab);
4986 PerlMem_free(trndir);
4987 PerlMem_free(vmsdir);
4989 set_vaxc_errno(dirfab.fab$l_sts);
4992 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
4993 if (buf) retspec = buf;
4994 else if (ts) Newx(retspec,retlen+16,char);
4995 else retspec = __fileify_retbuf;
4996 cp1 = strstr(esa,"][");
4997 if (!cp1) cp1 = strstr(esa,"]<");
4999 memcpy(retspec,esa,dirlen);
5000 if (!strncmp(cp1+2,"000000]",7)) {
5001 retspec[dirlen-1] = '\0';
5002 /* fix-me Not full ODS-5, just extra dots in directories for now */
5003 cp1 = retspec + dirlen - 1;
5004 while (cp1 > retspec)
5009 if (*(cp1-1) != '^')
5014 if (*cp1 == '.') *cp1 = ']';
5016 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5017 memmove(cp1+1,"000000]",7);
5021 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5022 retspec[retlen] = '\0';
5023 /* Convert last '.' to ']' */
5024 cp1 = retspec+retlen-1;
5025 while (*cp != '[') {
5028 /* Do not trip on extra dots in ODS-5 directories */
5029 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5033 if (*cp1 == '.') *cp1 = ']';
5035 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5036 memmove(cp1+1,"000000]",7);
5040 else { /* This is a top-level dir. Add the MFD to the path. */
5041 if (buf) retspec = buf;
5042 else if (ts) Newx(retspec,retlen+16,char);
5043 else retspec = __fileify_retbuf;
5046 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5047 strcpy(cp2,":[000000]");
5052 sts = rms_free_search_context(&dirfab);
5053 /* We've set up the string up through the filename. Add the
5054 type and version, and we're done. */
5055 strcat(retspec,".DIR;1");
5057 /* $PARSE may have upcased filespec, so convert output to lower
5058 * case if input contained any lowercase characters. */
5059 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5060 PerlMem_free(trndir);
5062 PerlMem_free(vmsdir);
5065 } /* end of do_fileify_dirspec() */
5067 /* External entry points */
5068 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5069 { return do_fileify_dirspec(dir,buf,0); }
5070 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5071 { return do_fileify_dirspec(dir,buf,1); }
5073 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5074 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5076 static char __pathify_retbuf[VMS_MAXRSS];
5077 unsigned long int retlen;
5078 char *retpath, *cp1, *cp2, *trndir;
5079 unsigned short int trnlnm_iter_count;
5083 if (!dir || !*dir) {
5084 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5087 trndir = PerlMem_malloc(VMS_MAXRSS);
5088 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5089 if (*dir) strcpy(trndir,dir);
5090 else getcwd(trndir,VMS_MAXRSS - 1);
5092 trnlnm_iter_count = 0;
5093 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5094 && my_trnlnm(trndir,trndir,0)) {
5095 trnlnm_iter_count++;
5096 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5097 trnlen = strlen(trndir);
5099 /* Trap simple rooted lnms, and return lnm:[000000] */
5100 if (!strcmp(trndir+trnlen-2,".]")) {
5101 if (buf) retpath = buf;
5102 else if (ts) Newx(retpath,strlen(dir)+10,char);
5103 else retpath = __pathify_retbuf;
5104 strcpy(retpath,dir);
5105 strcat(retpath,":[000000]");
5106 PerlMem_free(trndir);
5111 /* At this point we do not work with *dir, but the copy in
5112 * *trndir that is modifiable.
5115 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5116 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5117 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5118 retlen = 2 + (*(trndir+1) != '\0');
5120 if ( !(cp1 = strrchr(trndir,'/')) &&
5121 !(cp1 = strrchr(trndir,']')) &&
5122 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5123 if ((cp2 = strchr(cp1,'.')) != NULL &&
5124 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5125 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5126 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5127 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5130 /* For EFS or ODS-5 look for the last dot */
5131 if (decc_efs_charset) {
5132 cp2 = strrchr(cp1,'.');
5134 if (vms_process_case_tolerant) {
5135 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5136 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5137 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5138 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5139 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5140 (ver || *cp3)))))) {
5141 PerlMem_free(trndir);
5143 set_vaxc_errno(RMS$_DIR);
5148 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5149 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5150 !*(cp2+3) || *(cp2+3) != 'R' ||
5151 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5152 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5153 (ver || *cp3)))))) {
5154 PerlMem_free(trndir);
5156 set_vaxc_errno(RMS$_DIR);
5160 retlen = cp2 - trndir + 1;
5162 else { /* No file type present. Treat the filename as a directory. */
5163 retlen = strlen(trndir) + 1;
5166 if (buf) retpath = buf;
5167 else if (ts) Newx(retpath,retlen+1,char);
5168 else retpath = __pathify_retbuf;
5169 strncpy(retpath, trndir, retlen-1);
5170 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5171 retpath[retlen-1] = '/'; /* with '/', add it. */
5172 retpath[retlen] = '\0';
5174 else retpath[retlen-1] = '\0';
5176 else { /* VMS-style directory spec */
5178 unsigned long int sts, cmplen, haslower;
5179 struct FAB dirfab = cc$rms_fab;
5181 rms_setup_nam(savnam);
5182 rms_setup_nam(dirnam);
5184 /* If we've got an explicit filename, we can just shuffle the string. */
5185 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5186 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5187 if ((cp2 = strchr(cp1,'.')) != NULL) {
5189 if (vms_process_case_tolerant) {
5190 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5191 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5192 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5193 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5194 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5195 (ver || *cp3)))))) {
5196 PerlMem_free(trndir);
5198 set_vaxc_errno(RMS$_DIR);
5203 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5204 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5205 !*(cp2+3) || *(cp2+3) != 'R' ||
5206 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5207 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5208 (ver || *cp3)))))) {
5209 PerlMem_free(trndir);
5211 set_vaxc_errno(RMS$_DIR);
5216 else { /* No file type, so just draw name into directory part */
5217 for (cp2 = cp1; *cp2; cp2++) ;
5220 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5222 /* We've now got a VMS 'path'; fall through */
5225 dirlen = strlen(trndir);
5226 if (trndir[dirlen-1] == ']' ||
5227 trndir[dirlen-1] == '>' ||
5228 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5229 if (buf) retpath = buf;
5230 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5231 else retpath = __pathify_retbuf;
5232 strcpy(retpath,trndir);
5233 PerlMem_free(trndir);
5236 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5237 esa = PerlMem_malloc(VMS_MAXRSS);
5238 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5239 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5240 rms_bind_fab_nam(dirfab, dirnam);
5241 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5242 #ifdef NAM$M_NO_SHORT_UPCASE
5243 if (decc_efs_case_preserve)
5244 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5247 for (cp = trndir; *cp; cp++)
5248 if (islower(*cp)) { haslower = 1; break; }
5250 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5251 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5252 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5253 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5256 PerlMem_free(trndir);
5259 set_vaxc_errno(dirfab.fab$l_sts);
5265 /* Does the file really exist? */
5266 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5267 if (dirfab.fab$l_sts != RMS$_FNF) {
5269 sts1 = rms_free_search_context(&dirfab);
5270 PerlMem_free(trndir);
5273 set_vaxc_errno(dirfab.fab$l_sts);
5276 dirnam = savnam; /* No; just work with potential name */
5279 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5280 /* Yep; check version while we're at it, if it's there. */
5281 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5282 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5284 /* Something other than .DIR[;1]. Bzzt. */
5285 sts2 = rms_free_search_context(&dirfab);
5286 PerlMem_free(trndir);
5289 set_vaxc_errno(RMS$_DIR);
5293 /* OK, the type was fine. Now pull any file name into the
5295 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5297 cp1 = strrchr(esa,'>');
5298 *(rms_nam_typel(dirnam)) = '>';
5301 *(rms_nam_typel(dirnam) + 1) = '\0';
5302 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5303 if (buf) retpath = buf;
5304 else if (ts) Newx(retpath,retlen,char);
5305 else retpath = __pathify_retbuf;
5306 strcpy(retpath,esa);
5308 sts = rms_free_search_context(&dirfab);
5309 /* $PARSE may have upcased filespec, so convert output to lower
5310 * case if input contained any lowercase characters. */
5311 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5314 PerlMem_free(trndir);
5316 } /* end of do_pathify_dirspec() */
5318 /* External entry points */
5319 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5320 { return do_pathify_dirspec(dir,buf,0); }
5321 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5322 { return do_pathify_dirspec(dir,buf,1); }
5324 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5325 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5327 static char __tounixspec_retbuf[VMS_MAXRSS];
5328 char *dirend, *rslt, *cp1, *cp3, *tmp;
5330 int devlen, dirlen, retlen = VMS_MAXRSS;
5331 int expand = 1; /* guarantee room for leading and trailing slashes */
5332 unsigned short int trnlnm_iter_count;
5335 if (spec == NULL) return NULL;
5336 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5337 if (buf) rslt = buf;
5339 Newx(rslt, VMS_MAXRSS, char);
5341 else rslt = __tounixspec_retbuf;
5343 /* New VMS specific format needs translation
5344 * glob passes filenames with trailing '\n' and expects this preserved.
5346 if (decc_posix_compliant_pathnames) {
5347 if (strncmp(spec, "\"^UP^", 5) == 0) {
5353 tunix = PerlMem_malloc(VMS_MAXRSS);
5354 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5355 strcpy(tunix, spec);
5356 tunix_len = strlen(tunix);
5358 if (tunix[tunix_len - 1] == '\n') {
5359 tunix[tunix_len - 1] = '\"';
5360 tunix[tunix_len] = '\0';
5364 uspec = decc$translate_vms(tunix);
5365 PerlMem_free(tunix);
5366 if ((int)uspec > 0) {
5372 /* If we can not translate it, makemaker wants as-is */
5380 cmp_rslt = 0; /* Presume VMS */
5381 cp1 = strchr(spec, '/');
5385 /* Look for EFS ^/ */
5386 if (decc_efs_charset) {
5387 while (cp1 != NULL) {
5390 /* Found illegal VMS, assume UNIX */
5395 cp1 = strchr(cp1, '/');
5399 /* Look for "." and ".." */
5400 if (decc_filename_unix_report) {
5401 if (spec[0] == '.') {
5402 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5406 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5412 /* This is already UNIX or at least nothing VMS understands */
5420 dirend = strrchr(spec,']');
5421 if (dirend == NULL) dirend = strrchr(spec,'>');
5422 if (dirend == NULL) dirend = strchr(spec,':');
5423 if (dirend == NULL) {
5428 /* Special case 1 - sys$posix_root = / */
5429 #if __CRTL_VER >= 70000000
5430 if (!decc_disable_posix_root) {
5431 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5439 /* Special case 2 - Convert NLA0: to /dev/null */
5440 #if __CRTL_VER < 70000000
5441 cmp_rslt = strncmp(spec,"NLA0:", 5);
5443 cmp_rslt = strncmp(spec,"nla0:", 5);
5445 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5447 if (cmp_rslt == 0) {
5448 strcpy(rslt, "/dev/null");
5451 if (spec[6] != '\0') {
5458 /* Also handle special case "SYS$SCRATCH:" */
5459 #if __CRTL_VER < 70000000
5460 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5462 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5464 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5466 tmp = PerlMem_malloc(VMS_MAXRSS);
5467 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5468 if (cmp_rslt == 0) {
5471 islnm = my_trnlnm(tmp, "TMP", 0);
5473 strcpy(rslt, "/tmp");
5476 if (spec[12] != '\0') {
5484 if (*cp2 != '[' && *cp2 != '<') {
5487 else { /* the VMS spec begins with directories */
5489 if (*cp2 == ']' || *cp2 == '>') {
5490 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5494 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5495 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5496 if (ts) Safefree(rslt);
5500 trnlnm_iter_count = 0;
5503 while (*cp3 != ':' && *cp3) cp3++;
5505 if (strchr(cp3,']') != NULL) break;
5506 trnlnm_iter_count++;
5507 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5508 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5510 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5511 retlen = devlen + dirlen;
5512 Renew(rslt,retlen+1+2*expand,char);
5518 *(cp1++) = *(cp3++);
5519 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5521 return NULL; /* No room */
5526 if ((*cp2 == '^')) {
5527 /* EFS file escape, pass the next character as is */
5528 /* Fix me: HEX encoding for UNICODE not implemented */
5531 else if ( *cp2 == '.') {
5532 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5533 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5540 for (; cp2 <= dirend; cp2++) {
5541 if ((*cp2 == '^')) {
5542 /* EFS file escape, pass the next character as is */
5543 /* Fix me: HEX encoding for UNICODE not implemented */
5549 if (*(cp2+1) == '[') cp2++;
5551 else if (*cp2 == ']' || *cp2 == '>') {
5552 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5554 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5556 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5557 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5558 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5559 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5560 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5562 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5563 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5567 else if (*cp2 == '-') {
5568 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5569 while (*cp2 == '-') {
5571 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5573 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5574 if (ts) Safefree(rslt); /* filespecs like */
5575 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5579 else *(cp1++) = *cp2;
5581 else *(cp1++) = *cp2;
5583 while (*cp2) *(cp1++) = *(cp2++);
5586 /* This still leaves /000000/ when working with a
5587 * VMS device root or concealed root.
5593 ulen = strlen(rslt);
5595 /* Get rid of "000000/ in rooted filespecs */
5597 zeros = strstr(rslt, "/000000/");
5598 if (zeros != NULL) {
5600 mlen = ulen - (zeros - rslt) - 7;
5601 memmove(zeros, &zeros[7], mlen);
5610 } /* end of do_tounixspec() */
5612 /* External entry points */
5613 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5614 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5616 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5618 static int posix_to_vmsspec
5619 (char *vmspath, int vmspath_len, const char *unixpath) {
5621 struct FAB myfab = cc$rms_fab;
5622 struct NAML mynam = cc$rms_naml;
5623 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5624 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5630 /* If not a posix spec already, convert it */
5632 unixlen = strlen(unixpath);
5637 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5638 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5641 /* This is already a VMS specification, no conversion */
5643 strncpy(vmspath,unixpath, vmspath_len);
5645 vmspath[vmspath_len] = 0;
5646 if (unixpath[unixlen - 1] == '/')
5648 esa = PerlMem_malloc(VMS_MAXRSS);
5649 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5650 myfab.fab$l_fna = vmspath;
5651 myfab.fab$b_fns = strlen(vmspath);
5652 myfab.fab$l_naml = &mynam;
5653 mynam.naml$l_esa = NULL;
5654 mynam.naml$b_ess = 0;
5655 mynam.naml$l_long_expand = esa;
5656 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5657 mynam.naml$l_rsa = NULL;
5658 mynam.naml$b_rss = 0;
5659 if (decc_efs_case_preserve)
5660 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5661 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5663 /* Set up the remaining naml fields */
5664 sts = sys$parse(&myfab);
5666 /* It failed! Try again as a UNIX filespec */
5672 /* get the Device ID and the FID */
5673 sts = sys$search(&myfab);
5674 /* on any failure, returned the POSIX ^UP^ filespec */
5679 specdsc.dsc$a_pointer = vmspath;
5680 specdsc.dsc$w_length = vmspath_len;
5682 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5683 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5684 sts = lib$fid_to_name
5685 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5687 /* on any failure, returned the POSIX ^UP^ filespec */
5689 /* This can happen if user does not have permission to read directories */
5690 if (strncmp(unixpath,"\"^UP^",5) != 0)
5691 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5693 strcpy(vmspath, unixpath);
5696 vmspath[specdsc.dsc$w_length] = 0;
5698 /* Are we expecting a directory? */
5699 if (dir_flag != 0) {
5705 i = specdsc.dsc$w_length - 1;
5709 /* Version must be '1' */
5710 if (vmspath[i--] != '1')
5712 /* Version delimiter is one of ".;" */
5713 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5716 if (vmspath[i--] != 'R')
5718 if (vmspath[i--] != 'I')
5720 if (vmspath[i--] != 'D')
5722 if (vmspath[i--] != '.')
5724 eptr = &vmspath[i+1];
5726 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5727 if (vmspath[i-1] != '^') {
5735 /* Get rid of 6 imaginary zero directory filename */
5736 vmspath[i+1] = '\0';
5740 if (vmspath[i] == '0')
5754 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5755 static int posix_to_vmsspec_hardway
5756 (char *vmspath, int vmspath_len, const char *unixpath) {
5759 const char *unixptr;
5761 const char *lastslash;
5762 const char *lastdot;
5773 /* Ignore leading "/" characters */
5774 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5777 unixlen = strlen(unixptr);
5779 /* Do nothing with blank paths */
5785 lastslash = strrchr(unixptr,'/');
5786 lastdot = strrchr(unixptr,'.');
5789 /* last dot is last dot or past end of string */
5790 if (lastdot == NULL)
5791 lastdot = unixptr + unixlen;
5793 /* if no directories, set last slash to beginning of string */
5794 if (lastslash == NULL) {
5795 lastslash = unixptr;
5798 /* Watch out for trailing "." after last slash, still a directory */
5799 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5800 lastslash = unixptr + unixlen;
5803 /* Watch out for traiing ".." after last slash, still a directory */
5804 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5805 lastslash = unixptr + unixlen;
5808 /* dots in directories are aways escaped */
5809 if (lastdot < lastslash)
5810 lastdot = unixptr + unixlen;
5813 /* if (unixptr < lastslash) then we are in a directory */
5821 /* This could have a "^UP^ on the front */
5822 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5827 /* Start with the UNIX path */
5828 if (*unixptr != '/') {
5829 /* relative paths */
5830 if (lastslash > unixptr) {
5833 /* skip leading ./ */
5835 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5841 /* Are we still in a directory? */
5842 if (unixptr <= lastslash) {
5847 /* if not backing up, then it is relative forward. */
5848 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5849 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5857 /* Perl wants an empty directory here to tell the difference
5858 * between a DCL commmand and a filename
5867 /* Handle two special files . and .. */
5868 if (unixptr[0] == '.') {
5869 if (unixptr[1] == '\0') {
5876 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5887 else { /* Absolute PATH handling */
5891 /* Need to find out where root is */
5893 /* In theory, this procedure should never get an absolute POSIX pathname
5894 * that can not be found on the POSIX root.
5895 * In practice, that can not be relied on, and things will show up
5896 * here that are a VMS device name or concealed logical name instead.
5897 * So to make things work, this procedure must be tolerant.
5899 esa = PerlMem_malloc(vmspath_len);
5900 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5903 nextslash = strchr(&unixptr[1],'/');
5905 if (nextslash != NULL) {
5906 seg_len = nextslash - &unixptr[1];
5907 strncpy(vmspath, unixptr, seg_len + 1);
5908 vmspath[seg_len+1] = 0;
5909 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
5913 /* This is verified to be a real path */
5915 sts = posix_to_vmsspec(esa, vmspath_len, "/");
5916 strcpy(vmspath, esa);
5917 vmslen = strlen(vmspath);
5918 vmsptr = vmspath + vmslen;
5920 if (unixptr < lastslash) {
5929 cmp = strcmp(rptr,"000000.");
5934 } /* removing 6 zeros */
5935 } /* vmslen < 7, no 6 zeros possible */
5936 } /* Not in a directory */
5937 } /* end of verified real path handling */
5942 /* Ok, we have a device or a concealed root that is not in POSIX
5943 * or we have garbage. Make the best of it.
5946 /* Posix to VMS destroyed this, so copy it again */
5947 strncpy(vmspath, &unixptr[1], seg_len);
5948 vmspath[seg_len] = 0;
5950 vmsptr = &vmsptr[vmslen];
5953 /* Now do we need to add the fake 6 zero directory to it? */
5955 if ((*lastslash == '/') && (nextslash < lastslash)) {
5956 /* No there is another directory */
5962 /* now we have foo:bar or foo:[000000]bar to decide from */
5963 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
5964 trnend = islnm ? islnm - 1 : 0;
5966 /* if this was a logical name, ']' or '>' must be present */
5967 /* if not a logical name, then assume a device and hope. */
5968 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
5970 /* if log name and trailing '.' then rooted - treat as device */
5971 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
5973 /* Fix me, if not a logical name, a device lookup should be
5974 * done to see if the device is file structured. If the device
5975 * is not file structured, the 6 zeros should not be put on.
5977 * As it is, perl is occasionally looking for dev:[000000]tty.
5978 * which looks a little strange.
5981 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
5982 /* No real directory present */
5987 /* Put the device delimiter on */
5990 unixptr = nextslash;
5993 /* Start directory if needed */
5994 if (!islnm || add_6zero) {
6000 /* add fake 000000] if needed */
6013 } /* non-POSIX translation */
6015 } /* End of relative/absolute path handling */
6017 while ((*unixptr) && (vmslen < vmspath_len)){
6022 if (dir_start != 0) {
6024 /* First characters in a directory are handled special */
6025 while ((*unixptr == '/') ||
6026 ((*unixptr == '.') &&
6027 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6032 /* Skip redundant / in specification */
6033 while ((*unixptr == '/') && (dir_start != 0)) {
6036 if (unixptr == lastslash)
6039 if (unixptr == lastslash)
6042 /* Skip redundant ./ characters */
6043 while ((*unixptr == '.') &&
6044 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6047 if (unixptr == lastslash)
6049 if (*unixptr == '/')
6052 if (unixptr == lastslash)
6055 /* Skip redundant ../ characters */
6056 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6057 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6058 /* Set the backing up flag */
6064 unixptr++; /* first . */
6065 unixptr++; /* second . */
6066 if (unixptr == lastslash)
6068 if (*unixptr == '/') /* The slash */
6071 if (unixptr == lastslash)
6074 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6075 /* Not needed when VMS is pretending to be UNIX. */
6077 /* Is this loop stuck because of too many dots? */
6078 if (loop_flag == 0) {
6079 /* Exit the loop and pass the rest through */
6084 /* Are we done with directories yet? */
6085 if (unixptr >= lastslash) {
6087 /* Watch out for trailing dots */
6096 if (*unixptr == '/')
6100 /* Have we stopped backing up? */
6105 /* dir_start continues to be = 1 */
6107 if (*unixptr == '-') {
6109 *vmsptr++ = *unixptr++;
6113 /* Now are we done with directories yet? */
6114 if (unixptr >= lastslash) {
6116 /* Watch out for trailing dots */
6132 if (*unixptr == '\0')
6135 /* Normal characters - More EFS work probably needed */
6141 /* remove multiple / */
6142 while (unixptr[1] == '/') {
6145 if (unixptr == lastslash) {
6146 /* Watch out for trailing dots */
6158 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6159 /* Not needed when VMS is pretending to be UNIX. */
6163 if (*unixptr != '\0')
6179 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6185 /* trailing dot ==> '^..' on VMS */
6186 if (*unixptr == '\0') {
6190 *vmsptr++ = *unixptr++;
6193 if (quoted && (unixptr[1] == '\0')) {
6198 *vmsptr++ = *unixptr++;
6205 *vmsptr++ = *unixptr++;
6209 if (*unixptr != '\0') {
6210 *vmsptr++ = *unixptr++;
6217 /* Make sure directory is closed */
6218 if (unixptr == lastslash) {
6220 vmsptr2 = vmsptr - 1;
6222 if (*vmsptr2 != ']') {
6225 /* directories do not end in a dot bracket */
6226 if (*vmsptr2 == '.') {
6230 if (*vmsptr2 != '^') {
6231 vmsptr--; /* back up over the dot */
6239 /* Add a trailing dot if a file with no extension */
6240 vmsptr2 = vmsptr - 1;
6241 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6242 (*lastdot != '.')) {
6253 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6254 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6255 static char __tovmsspec_retbuf[VMS_MAXRSS];
6256 char *rslt, *dirend;
6261 unsigned long int infront = 0, hasdir = 1;
6265 if (path == NULL) return NULL;
6266 rslt_len = VMS_MAXRSS-1;
6267 if (buf) rslt = buf;
6268 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6269 else rslt = __tovmsspec_retbuf;
6270 if (strpbrk(path,"]:>") ||
6271 (dirend = strrchr(path,'/')) == NULL) {
6272 if (path[0] == '.') {
6273 if (path[1] == '\0') strcpy(rslt,"[]");
6274 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6275 else strcpy(rslt,path); /* probably garbage */
6277 else strcpy(rslt,path);
6281 /* Posix specifications are now a native VMS format */
6282 /*--------------------------------------------------*/
6283 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6284 if (decc_posix_compliant_pathnames) {
6285 if (strncmp(path,"\"^UP^",5) == 0) {
6286 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6292 vms_delim = strpbrk(path,"]:>");
6294 if ((vms_delim != NULL) ||
6295 ((dirend = strrchr(path,'/')) == NULL)) {
6297 /* VMS special characters found! */
6299 if (path[0] == '.') {
6300 if (path[1] == '\0') strcpy(rslt,"[]");
6301 else if (path[1] == '.' && path[2] == '\0')
6304 /* Dot preceeding a device or directory ? */
6306 /* If not in POSIX mode, pass it through and hope it works */
6307 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6308 if (!decc_posix_compliant_pathnames)
6309 strcpy(rslt,path); /* probably garbage */
6311 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6313 strcpy(rslt,path); /* probably garbage */
6319 /* If no VMS characters and in POSIX mode, convert it!
6320 * This is the easiest way to get directory specifications
6321 * handled correctly in POSIX mode
6323 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6324 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6325 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6327 /* No unix path separators - presume VMS already */
6331 strcpy(rslt,path); /* probably garbage */
6337 /* If POSIX mode active, handle the conversion */
6338 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6339 if (decc_posix_compliant_pathnames) {
6340 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6345 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
6346 if (!*(dirend+2)) dirend +=2;
6347 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6348 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6353 lastdot = strrchr(cp2,'.');
6359 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6361 if (decc_disable_posix_root) {
6362 strcpy(rslt,"sys$disk:[000000]");
6365 strcpy(rslt,"sys$posix_root:[000000]");
6369 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6371 trndev = PerlMem_malloc(VMS_MAXRSS);
6372 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
6373 islnm = my_trnlnm(rslt,trndev,0);
6375 /* DECC special handling */
6377 if (strcmp(rslt,"bin") == 0) {
6378 strcpy(rslt,"sys$system");
6381 islnm = my_trnlnm(rslt,trndev,0);
6383 else if (strcmp(rslt,"tmp") == 0) {
6384 strcpy(rslt,"sys$scratch");
6387 islnm = my_trnlnm(rslt,trndev,0);
6389 else if (!decc_disable_posix_root) {
6390 strcpy(rslt, "sys$posix_root");
6394 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6395 islnm = my_trnlnm(rslt,trndev,0);
6397 else if (strcmp(rslt,"dev") == 0) {
6398 if (strncmp(cp2,"/null", 5) == 0) {
6399 if ((cp2[5] == 0) || (cp2[5] == '/')) {
6400 strcpy(rslt,"NLA0");
6404 islnm = my_trnlnm(rslt,trndev,0);
6410 trnend = islnm ? strlen(trndev) - 1 : 0;
6411 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6412 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6413 /* If the first element of the path is a logical name, determine
6414 * whether it has to be translated so we can add more directories. */
6415 if (!islnm || rooted) {
6418 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6422 if (cp2 != dirend) {
6423 strcpy(rslt,trndev);
6424 cp1 = rslt + trnend;
6431 if (decc_disable_posix_root) {
6437 PerlMem_free(trndev);
6442 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6443 cp2 += 2; /* skip over "./" - it's redundant */
6444 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
6446 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6447 *(cp1++) = '-'; /* "../" --> "-" */
6450 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6451 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6452 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6453 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6456 else if ((cp2 != lastdot) || (lastdot < dirend)) {
6457 /* Escape the extra dots in EFS file specifications */
6460 if (cp2 > dirend) cp2 = dirend;
6462 else *(cp1++) = '.';
6464 for (; cp2 < dirend; cp2++) {
6466 if (*(cp2-1) == '/') continue;
6467 if (*(cp1-1) != '.') *(cp1++) = '.';
6470 else if (!infront && *cp2 == '.') {
6471 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6472 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
6473 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6474 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6475 else if (*(cp1-2) == '[') *(cp1-1) = '-';
6476 else { /* back up over previous directory name */
6478 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6479 if (*(cp1-1) == '[') {
6480 memcpy(cp1,"000000.",7);
6485 if (cp2 == dirend) break;
6487 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6488 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6489 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6490 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6492 *(cp1++) = '.'; /* Simulate trailing '/' */
6493 cp2 += 2; /* for loop will incr this to == dirend */
6495 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
6498 if (decc_efs_charset == 0)
6499 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
6501 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
6507 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
6509 if (decc_efs_charset == 0)
6516 else *(cp1++) = *cp2;
6520 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6521 if (hasdir) *(cp1++) = ']';
6522 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
6523 /* fixme for ODS5 */
6538 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6539 decc_readdir_dropdotnotype) {
6544 /* trailing dot ==> '^..' on VMS */
6551 *(cp1++) = *(cp2++);
6579 *(cp1++) = *(cp2++);
6582 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6583 * which is wrong. UNIX notation should be ".dir." unless
6584 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6585 * changing this behavior could break more things at this time.
6586 * efs character set effectively does not allow "." to be a version
6587 * delimiter as a further complication about changing this.
6589 if (decc_filename_unix_report != 0) {
6592 *(cp1++) = *(cp2++);
6595 *(cp1++) = *(cp2++);
6598 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6602 /* Fix me for "^]", but that requires making sure that you do
6603 * not back up past the start of the filename
6605 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6612 } /* end of do_tovmsspec() */
6614 /* External entry points */
6615 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6616 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6618 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6619 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6620 static char __tovmspath_retbuf[VMS_MAXRSS];
6622 char *pathified, *vmsified, *cp;
6624 if (path == NULL) return NULL;
6625 pathified = PerlMem_malloc(VMS_MAXRSS);
6626 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6627 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6628 PerlMem_free(pathified);
6634 Newx(vmsified, VMS_MAXRSS, char);
6635 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) {
6636 PerlMem_free(pathified);
6637 if (vmsified) Safefree(vmsified);
6640 PerlMem_free(pathified);
6645 vmslen = strlen(vmsified);
6646 Newx(cp,vmslen+1,char);
6647 memcpy(cp,vmsified,vmslen);
6653 strcpy(__tovmspath_retbuf,vmsified);
6655 return __tovmspath_retbuf;
6658 } /* end of do_tovmspath() */
6660 /* External entry points */
6661 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6662 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6665 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6666 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6667 static char __tounixpath_retbuf[VMS_MAXRSS];
6669 char *pathified, *unixified, *cp;
6671 if (path == NULL) return NULL;
6672 pathified = PerlMem_malloc(VMS_MAXRSS);
6673 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6674 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6675 PerlMem_free(pathified);
6681 Newx(unixified, VMS_MAXRSS, char);
6683 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6684 PerlMem_free(pathified);
6685 if (unixified) Safefree(unixified);
6688 PerlMem_free(pathified);
6693 unixlen = strlen(unixified);
6694 Newx(cp,unixlen+1,char);
6695 memcpy(cp,unixified,unixlen);
6697 Safefree(unixified);
6701 strcpy(__tounixpath_retbuf,unixified);
6702 Safefree(unixified);
6703 return __tounixpath_retbuf;
6706 } /* end of do_tounixpath() */
6708 /* External entry points */
6709 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6710 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6713 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
6715 *****************************************************************************
6717 * Copyright (C) 1989-1994 by *
6718 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
6720 * Permission is hereby granted for the reproduction of this software, *
6721 * on condition that this copyright notice is included in the reproduction, *
6722 * and that such reproduction is not for purposes of profit or material *
6725 * 27-Aug-1994 Modified for inclusion in perl5 *
6726 * by Charles Bailey bailey@newman.upenn.edu *
6727 *****************************************************************************
6731 * getredirection() is intended to aid in porting C programs
6732 * to VMS (Vax-11 C). The native VMS environment does not support
6733 * '>' and '<' I/O redirection, or command line wild card expansion,
6734 * or a command line pipe mechanism using the '|' AND background
6735 * command execution '&'. All of these capabilities are provided to any
6736 * C program which calls this procedure as the first thing in the
6738 * The piping mechanism will probably work with almost any 'filter' type
6739 * of program. With suitable modification, it may useful for other
6740 * portability problems as well.
6742 * Author: Mark Pizzolato mark@infocomm.com
6746 struct list_item *next;
6750 static void add_item(struct list_item **head,
6751 struct list_item **tail,
6755 static void mp_expand_wild_cards(pTHX_ char *item,
6756 struct list_item **head,
6757 struct list_item **tail,
6760 static int background_process(pTHX_ int argc, char **argv);
6762 static void pipe_and_fork(pTHX_ char **cmargv);
6764 /*{{{ void getredirection(int *ac, char ***av)*/
6766 mp_getredirection(pTHX_ int *ac, char ***av)
6768 * Process vms redirection arg's. Exit if any error is seen.
6769 * If getredirection() processes an argument, it is erased
6770 * from the vector. getredirection() returns a new argc and argv value.
6771 * In the event that a background command is requested (by a trailing "&"),
6772 * this routine creates a background subprocess, and simply exits the program.
6774 * Warning: do not try to simplify the code for vms. The code
6775 * presupposes that getredirection() is called before any data is
6776 * read from stdin or written to stdout.
6778 * Normal usage is as follows:
6784 * getredirection(&argc, &argv);
6788 int argc = *ac; /* Argument Count */
6789 char **argv = *av; /* Argument Vector */
6790 char *ap; /* Argument pointer */
6791 int j; /* argv[] index */
6792 int item_count = 0; /* Count of Items in List */
6793 struct list_item *list_head = 0; /* First Item in List */
6794 struct list_item *list_tail; /* Last Item in List */
6795 char *in = NULL; /* Input File Name */
6796 char *out = NULL; /* Output File Name */
6797 char *outmode = "w"; /* Mode to Open Output File */
6798 char *err = NULL; /* Error File Name */
6799 char *errmode = "w"; /* Mode to Open Error File */
6800 int cmargc = 0; /* Piped Command Arg Count */
6801 char **cmargv = NULL;/* Piped Command Arg Vector */
6804 * First handle the case where the last thing on the line ends with
6805 * a '&'. This indicates the desire for the command to be run in a
6806 * subprocess, so we satisfy that desire.
6809 if (0 == strcmp("&", ap))
6810 exit(background_process(aTHX_ --argc, argv));
6811 if (*ap && '&' == ap[strlen(ap)-1])
6813 ap[strlen(ap)-1] = '\0';
6814 exit(background_process(aTHX_ argc, argv));
6817 * Now we handle the general redirection cases that involve '>', '>>',
6818 * '<', and pipes '|'.
6820 for (j = 0; j < argc; ++j)
6822 if (0 == strcmp("<", argv[j]))
6826 fprintf(stderr,"No input file after < on command line");
6827 exit(LIB$_WRONUMARG);
6832 if ('<' == *(ap = argv[j]))
6837 if (0 == strcmp(">", ap))
6841 fprintf(stderr,"No output file after > on command line");
6842 exit(LIB$_WRONUMARG);
6861 fprintf(stderr,"No output file after > or >> on command line");
6862 exit(LIB$_WRONUMARG);
6866 if (('2' == *ap) && ('>' == ap[1]))
6883 fprintf(stderr,"No output file after 2> or 2>> on command line");
6884 exit(LIB$_WRONUMARG);
6888 if (0 == strcmp("|", argv[j]))
6892 fprintf(stderr,"No command into which to pipe on command line");
6893 exit(LIB$_WRONUMARG);
6895 cmargc = argc-(j+1);
6896 cmargv = &argv[j+1];
6900 if ('|' == *(ap = argv[j]))
6908 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
6911 * Allocate and fill in the new argument vector, Some Unix's terminate
6912 * the list with an extra null pointer.
6914 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
6915 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6917 for (j = 0; j < item_count; ++j, list_head = list_head->next)
6918 argv[j] = list_head->value;
6924 fprintf(stderr,"'|' and '>' may not both be specified on command line");
6925 exit(LIB$_INVARGORD);
6927 pipe_and_fork(aTHX_ cmargv);
6930 /* Check for input from a pipe (mailbox) */
6932 if (in == NULL && 1 == isapipe(0))
6934 char mbxname[L_tmpnam];
6936 long int dvi_item = DVI$_DEVBUFSIZ;
6937 $DESCRIPTOR(mbxnam, "");
6938 $DESCRIPTOR(mbxdevnam, "");
6940 /* Input from a pipe, reopen it in binary mode to disable */
6941 /* carriage control processing. */
6943 fgetname(stdin, mbxname);
6944 mbxnam.dsc$a_pointer = mbxname;
6945 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
6946 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
6947 mbxdevnam.dsc$a_pointer = mbxname;
6948 mbxdevnam.dsc$w_length = sizeof(mbxname);
6949 dvi_item = DVI$_DEVNAM;
6950 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
6951 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
6954 freopen(mbxname, "rb", stdin);
6957 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
6961 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
6963 fprintf(stderr,"Can't open input file %s as stdin",in);
6966 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
6968 fprintf(stderr,"Can't open output file %s as stdout",out);
6971 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
6974 if (strcmp(err,"&1") == 0) {
6975 dup2(fileno(stdout), fileno(stderr));
6976 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
6979 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
6981 fprintf(stderr,"Can't open error file %s as stderr",err);
6985 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
6989 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
6992 #ifdef ARGPROC_DEBUG
6993 PerlIO_printf(Perl_debug_log, "Arglist:\n");
6994 for (j = 0; j < *ac; ++j)
6995 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
6997 /* Clear errors we may have hit expanding wildcards, so they don't
6998 show up in Perl's $! later */
6999 set_errno(0); set_vaxc_errno(1);
7000 } /* end of getredirection() */
7003 static void add_item(struct list_item **head,
7004 struct list_item **tail,
7010 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7011 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7015 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7016 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7017 *tail = (*tail)->next;
7019 (*tail)->value = value;
7023 static void mp_expand_wild_cards(pTHX_ char *item,
7024 struct list_item **head,
7025 struct list_item **tail,
7029 unsigned long int context = 0;
7037 $DESCRIPTOR(filespec, "");
7038 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7039 $DESCRIPTOR(resultspec, "");
7040 unsigned long int lff_flags = 0;
7044 #ifdef VMS_LONGNAME_SUPPORT
7045 lff_flags = LIB$M_FIL_LONG_NAMES;
7048 for (cp = item; *cp; cp++) {
7049 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7050 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7052 if (!*cp || isspace(*cp))
7054 add_item(head, tail, item, count);
7059 /* "double quoted" wild card expressions pass as is */
7060 /* From DCL that means using e.g.: */
7061 /* perl program """perl.*""" */
7062 item_len = strlen(item);
7063 if ( '"' == *item && '"' == item[item_len-1] )
7066 item[item_len-2] = '\0';
7067 add_item(head, tail, item, count);
7071 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7072 resultspec.dsc$b_class = DSC$K_CLASS_D;
7073 resultspec.dsc$a_pointer = NULL;
7074 vmsspec = PerlMem_malloc(VMS_MAXRSS);
7075 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7076 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7077 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7078 if (!isunix || !filespec.dsc$a_pointer)
7079 filespec.dsc$a_pointer = item;
7080 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7082 * Only return version specs, if the caller specified a version
7084 had_version = strchr(item, ';');
7086 * Only return device and directory specs, if the caller specifed either.
7088 had_device = strchr(item, ':');
7089 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7091 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7092 (&filespec, &resultspec, &context,
7093 &defaultspec, 0, &rms_sts, &lff_flags)))
7098 string = PerlMem_malloc(resultspec.dsc$w_length+1);
7099 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7100 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7101 string[resultspec.dsc$w_length] = '\0';
7102 if (NULL == had_version)
7103 *(strrchr(string, ';')) = '\0';
7104 if ((!had_directory) && (had_device == NULL))
7106 if (NULL == (devdir = strrchr(string, ']')))
7107 devdir = strrchr(string, '>');
7108 strcpy(string, devdir + 1);
7111 * Be consistent with what the C RTL has already done to the rest of
7112 * the argv items and lowercase all of these names.
7114 if (!decc_efs_case_preserve) {
7115 for (c = string; *c; ++c)
7119 if (isunix) trim_unixpath(string,item,1);
7120 add_item(head, tail, string, count);
7123 PerlMem_free(vmsspec);
7124 if (sts != RMS$_NMF)
7126 set_vaxc_errno(sts);
7129 case RMS$_FNF: case RMS$_DNF:
7130 set_errno(ENOENT); break;
7132 set_errno(ENOTDIR); break;
7134 set_errno(ENODEV); break;
7135 case RMS$_FNM: case RMS$_SYN:
7136 set_errno(EINVAL); break;
7138 set_errno(EACCES); break;
7140 _ckvmssts_noperl(sts);
7144 add_item(head, tail, item, count);
7145 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7146 _ckvmssts_noperl(lib$find_file_end(&context));
7149 static int child_st[2];/* Event Flag set when child process completes */
7151 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
7153 static unsigned long int exit_handler(int *status)
7157 if (0 == child_st[0])
7159 #ifdef ARGPROC_DEBUG
7160 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7162 fflush(stdout); /* Have to flush pipe for binary data to */
7163 /* terminate properly -- <tp@mccall.com> */
7164 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7165 sys$dassgn(child_chan);
7167 sys$synch(0, child_st);
7172 static void sig_child(int chan)
7174 #ifdef ARGPROC_DEBUG
7175 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7177 if (child_st[0] == 0)
7181 static struct exit_control_block exit_block =
7186 &exit_block.exit_status,
7191 pipe_and_fork(pTHX_ char **cmargv)
7194 struct dsc$descriptor_s *vmscmd;
7195 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7196 int sts, j, l, ismcr, quote, tquote = 0;
7198 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
7199 vms_execfree(vmscmd);
7204 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7205 && toupper(*(q+2)) == 'R' && !*(q+3);
7207 while (q && l < MAX_DCL_LINE_LENGTH) {
7209 if (j > 0 && quote) {
7215 if (ismcr && j > 1) quote = 1;
7216 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7219 if (quote || tquote) {
7225 if ((quote||tquote) && *q == '"') {
7235 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7237 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7241 static int background_process(pTHX_ int argc, char **argv)
7243 char command[MAX_DCL_SYMBOL + 1] = "$";
7244 $DESCRIPTOR(value, "");
7245 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7246 static $DESCRIPTOR(null, "NLA0:");
7247 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7249 $DESCRIPTOR(pidstr, "");
7251 unsigned long int flags = 17, one = 1, retsts;
7254 strcat(command, argv[0]);
7255 len = strlen(command);
7256 while (--argc && (len < MAX_DCL_SYMBOL))
7258 strcat(command, " \"");
7259 strcat(command, *(++argv));
7260 strcat(command, "\"");
7261 len = strlen(command);
7263 value.dsc$a_pointer = command;
7264 value.dsc$w_length = strlen(value.dsc$a_pointer);
7265 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7266 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7267 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7268 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7271 _ckvmssts_noperl(retsts);
7273 #ifdef ARGPROC_DEBUG
7274 PerlIO_printf(Perl_debug_log, "%s\n", command);
7276 sprintf(pidstring, "%08X", pid);
7277 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7278 pidstr.dsc$a_pointer = pidstring;
7279 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7280 lib$set_symbol(&pidsymbol, &pidstr);
7284 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7287 /* OS-specific initialization at image activation (not thread startup) */
7288 /* Older VAXC header files lack these constants */
7289 #ifndef JPI$_RIGHTS_SIZE
7290 # define JPI$_RIGHTS_SIZE 817
7292 #ifndef KGB$M_SUBSYSTEM
7293 # define KGB$M_SUBSYSTEM 0x8
7296 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7298 /*{{{void vms_image_init(int *, char ***)*/
7300 vms_image_init(int *argcp, char ***argvp)
7302 char eqv[LNM$C_NAMLENGTH+1] = "";
7303 unsigned int len, tabct = 8, tabidx = 0;
7304 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7305 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7306 unsigned short int dummy, rlen;
7307 struct dsc$descriptor_s **tabvec;
7308 #if defined(PERL_IMPLICIT_CONTEXT)
7311 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
7312 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
7313 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7316 #ifdef KILL_BY_SIGPRC
7317 Perl_csighandler_init();
7320 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7321 _ckvmssts_noperl(iosb[0]);
7322 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7323 if (iprv[i]) { /* Running image installed with privs? */
7324 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
7329 /* Rights identifiers might trigger tainting as well. */
7330 if (!will_taint && (rlen || rsz)) {
7331 while (rlen < rsz) {
7332 /* We didn't get all the identifiers on the first pass. Allocate a
7333 * buffer much larger than $GETJPI wants (rsz is size in bytes that
7334 * were needed to hold all identifiers at time of last call; we'll
7335 * allocate that many unsigned long ints), and go back and get 'em.
7336 * If it gave us less than it wanted to despite ample buffer space,
7337 * something's broken. Is your system missing a system identifier?
7339 if (rsz <= jpilist[1].buflen) {
7340 /* Perl_croak accvios when used this early in startup. */
7341 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7342 rsz, (unsigned long) jpilist[1].buflen,
7343 "Check your rights database for corruption.\n");
7346 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7347 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7348 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7349 jpilist[1].buflen = rsz * sizeof(unsigned long int);
7350 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7351 _ckvmssts_noperl(iosb[0]);
7353 mask = jpilist[1].bufadr;
7354 /* Check attribute flags for each identifier (2nd longword); protected
7355 * subsystem identifiers trigger tainting.
7357 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7358 if (mask[i] & KGB$M_SUBSYSTEM) {
7363 if (mask != rlst) PerlMem_free(mask);
7366 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7367 * logical, some versions of the CRTL will add a phanthom /000000/
7368 * directory. This needs to be removed.
7370 if (decc_filename_unix_report) {
7373 ulen = strlen(argvp[0][0]);
7375 zeros = strstr(argvp[0][0], "/000000/");
7376 if (zeros != NULL) {
7378 mlen = ulen - (zeros - argvp[0][0]) - 7;
7379 memmove(zeros, &zeros[7], mlen);
7381 argvp[0][0][ulen] = '\0';
7384 /* It also may have a trailing dot that needs to be removed otherwise
7385 * it will be converted to VMS mode incorrectly.
7388 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7389 argvp[0][0][ulen] = '\0';
7392 /* We need to use this hack to tell Perl it should run with tainting,
7393 * since its tainting flag may be part of the PL_curinterp struct, which
7394 * hasn't been allocated when vms_image_init() is called.
7397 char **newargv, **oldargv;
7399 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7400 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7401 newargv[0] = oldargv[0];
7402 newargv[1] = PerlMem_malloc(3 * sizeof(char));
7403 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7404 strcpy(newargv[1], "-T");
7405 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7407 newargv[*argcp] = NULL;
7408 /* We orphan the old argv, since we don't know where it's come from,
7409 * so we don't know how to free it.
7413 else { /* Did user explicitly request tainting? */
7415 char *cp, **av = *argvp;
7416 for (i = 1; i < *argcp; i++) {
7417 if (*av[i] != '-') break;
7418 for (cp = av[i]+1; *cp; cp++) {
7419 if (*cp == 'T') { will_taint = 1; break; }
7420 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7421 strchr("DFIiMmx",*cp)) break;
7423 if (will_taint) break;
7428 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7431 tabvec = (struct dsc$descriptor_s **)
7432 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7433 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7435 else if (tabidx >= tabct) {
7437 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7438 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7440 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7441 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7442 tabvec[tabidx]->dsc$w_length = 0;
7443 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
7444 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
7445 tabvec[tabidx]->dsc$a_pointer = NULL;
7446 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7448 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7450 getredirection(argcp,argvp);
7451 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7453 # include <reentrancy.h>
7454 decc$set_reentrancy(C$C_MULTITHREAD);
7463 * Trim Unix-style prefix off filespec, so it looks like what a shell
7464 * glob expansion would return (i.e. from specified prefix on, not
7465 * full path). Note that returned filespec is Unix-style, regardless
7466 * of whether input filespec was VMS-style or Unix-style.
7468 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7469 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
7470 * vector of options; at present, only bit 0 is used, and if set tells
7471 * trim unixpath to try the current default directory as a prefix when
7472 * presented with a possibly ambiguous ... wildcard.
7474 * Returns !=0 on success, with trimmed filespec replacing contents of
7475 * fspec, and 0 on failure, with contents of fpsec unchanged.
7477 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7479 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7481 char *unixified, *unixwild,
7482 *template, *base, *end, *cp1, *cp2;
7483 register int tmplen, reslen = 0, dirs = 0;
7485 unixwild = PerlMem_malloc(VMS_MAXRSS);
7486 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
7487 if (!wildspec || !fspec) return 0;
7488 template = unixwild;
7489 if (strpbrk(wildspec,"]>:") != NULL) {
7490 if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7491 PerlMem_free(unixwild);
7496 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7497 unixwild[VMS_MAXRSS-1] = 0;
7499 unixified = PerlMem_malloc(VMS_MAXRSS);
7500 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
7501 if (strpbrk(fspec,"]>:") != NULL) {
7502 if (do_tounixspec(fspec,unixified,0) == NULL) {
7503 PerlMem_free(unixwild);
7504 PerlMem_free(unixified);
7507 else base = unixified;
7508 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7509 * check to see that final result fits into (isn't longer than) fspec */
7510 reslen = strlen(fspec);
7514 /* No prefix or absolute path on wildcard, so nothing to remove */
7515 if (!*template || *template == '/') {
7516 PerlMem_free(unixwild);
7517 if (base == fspec) {
7518 PerlMem_free(unixified);
7521 tmplen = strlen(unixified);
7522 if (tmplen > reslen) {
7523 PerlMem_free(unixified);
7524 return 0; /* not enough space */
7526 /* Copy unixified resultant, including trailing NUL */
7527 memmove(fspec,unixified,tmplen+1);
7528 PerlMem_free(unixified);
7532 for (end = base; *end; end++) ; /* Find end of resultant filespec */
7533 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7534 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7535 for (cp1 = end ;cp1 >= base; cp1--)
7536 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7538 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7539 PerlMem_free(unixified);
7540 PerlMem_free(unixwild);
7545 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7546 int ells = 1, totells, segdirs, match;
7547 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7548 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7550 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7552 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7553 tpl = PerlMem_malloc(VMS_MAXRSS);
7554 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
7555 if (ellipsis == template && opts & 1) {
7556 /* Template begins with an ellipsis. Since we can't tell how many
7557 * directory names at the front of the resultant to keep for an
7558 * arbitrary starting point, we arbitrarily choose the current
7559 * default directory as a starting point. If it's there as a prefix,
7560 * clip it off. If not, fall through and act as if the leading
7561 * ellipsis weren't there (i.e. return shortest possible path that
7562 * could match template).
7564 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7566 PerlMem_free(unixified);
7567 PerlMem_free(unixwild);
7570 if (!decc_efs_case_preserve) {
7571 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7572 if (_tolower(*cp1) != _tolower(*cp2)) break;
7574 segdirs = dirs - totells; /* Min # of dirs we must have left */
7575 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7576 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7577 memmove(fspec,cp2+1,end - cp2);
7579 PerlMem_free(unixified);
7580 PerlMem_free(unixwild);
7584 /* First off, back up over constant elements at end of path */
7586 for (front = end ; front >= base; front--)
7587 if (*front == '/' && !dirs--) { front++; break; }
7589 lcres = PerlMem_malloc(VMS_MAXRSS);
7590 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
7591 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7593 if (!decc_efs_case_preserve) {
7594 *cp2 = _tolower(*cp1); /* Make lc copy for match */
7602 PerlMem_free(unixified);
7603 PerlMem_free(unixwild);
7604 PerlMem_free(lcres);
7605 return 0; /* Path too long. */
7608 *cp2 = '\0'; /* Pick up with memcpy later */
7609 lcfront = lcres + (front - base);
7610 /* Now skip over each ellipsis and try to match the path in front of it. */
7612 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7613 if (*(cp1) == '.' && *(cp1+1) == '.' &&
7614 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
7615 if (cp1 < template) break; /* template started with an ellipsis */
7616 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7617 ellipsis = cp1; continue;
7619 wilddsc.dsc$a_pointer = tpl;
7620 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7622 for (segdirs = 0, cp2 = tpl;
7623 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7625 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7627 if (!decc_efs_case_preserve) {
7628 *cp2 = _tolower(*cp1); /* else lowercase for match */
7631 *cp2 = *cp1; /* else preserve case for match */
7634 if (*cp2 == '/') segdirs++;
7636 if (cp1 != ellipsis - 1) {
7638 PerlMem_free(unixified);
7639 PerlMem_free(unixwild);
7640 PerlMem_free(lcres);
7641 return 0; /* Path too long */
7643 /* Back up at least as many dirs as in template before matching */
7644 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7645 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7646 for (match = 0; cp1 > lcres;) {
7647 resdsc.dsc$a_pointer = cp1;
7648 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7650 if (match == 1) lcfront = cp1;
7652 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7656 PerlMem_free(unixified);
7657 PerlMem_free(unixwild);
7658 PerlMem_free(lcres);
7659 return 0; /* Can't find prefix ??? */
7661 if (match > 1 && opts & 1) {
7662 /* This ... wildcard could cover more than one set of dirs (i.e.
7663 * a set of similar dir names is repeated). If the template
7664 * contains more than 1 ..., upstream elements could resolve the
7665 * ambiguity, but it's not worth a full backtracking setup here.
7666 * As a quick heuristic, clip off the current default directory
7667 * if it's present to find the trimmed spec, else use the
7668 * shortest string that this ... could cover.
7670 char def[NAM$C_MAXRSS+1], *st;
7672 if (getcwd(def, sizeof def,0) == NULL) {
7673 Safefree(unixified);
7679 if (!decc_efs_case_preserve) {
7680 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7681 if (_tolower(*cp1) != _tolower(*cp2)) break;
7683 segdirs = dirs - totells; /* Min # of dirs we must have left */
7684 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7685 if (*cp1 == '\0' && *cp2 == '/') {
7686 memmove(fspec,cp2+1,end - cp2);
7688 PerlMem_free(unixified);
7689 PerlMem_free(unixwild);
7690 PerlMem_free(lcres);
7693 /* Nope -- stick with lcfront from above and keep going. */
7696 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7698 PerlMem_free(unixified);
7699 PerlMem_free(unixwild);
7700 PerlMem_free(lcres);
7705 } /* end of trim_unixpath() */
7710 * VMS readdir() routines.
7711 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7713 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
7714 * Minor modifications to original routines.
7717 /* readdir may have been redefined by reentr.h, so make sure we get
7718 * the local version for what we do here.
7723 #if !defined(PERL_IMPLICIT_CONTEXT)
7724 # define readdir Perl_readdir
7726 # define readdir(a) Perl_readdir(aTHX_ a)
7729 /* Number of elements in vms_versions array */
7730 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
7733 * Open a directory, return a handle for later use.
7735 /*{{{ DIR *opendir(char*name) */
7737 Perl_opendir(pTHX_ const char *name)
7745 if (decc_efs_charset) {
7746 unix_flag = is_unix_filespec(name);
7749 Newx(dir, VMS_MAXRSS, char);
7750 if (do_tovmspath(name,dir,0) == NULL) {
7754 /* Check access before stat; otherwise stat does not
7755 * accurately report whether it's a directory.
7757 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
7758 /* cando_by_name has already set errno */
7762 if (flex_stat(dir,&sb) == -1) return NULL;
7763 if (!S_ISDIR(sb.st_mode)) {
7765 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
7768 /* Get memory for the handle, and the pattern. */
7770 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7772 /* Fill in the fields; mainly playing with the descriptor. */
7773 sprintf(dd->pattern, "%s*.*",dir);
7779 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7780 dd->pat.dsc$a_pointer = dd->pattern;
7781 dd->pat.dsc$w_length = strlen(dd->pattern);
7782 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7783 dd->pat.dsc$b_class = DSC$K_CLASS_S;
7784 #if defined(USE_ITHREADS)
7785 Newx(dd->mutex,1,perl_mutex);
7786 MUTEX_INIT( (perl_mutex *) dd->mutex );
7792 } /* end of opendir() */
7796 * Set the flag to indicate we want versions or not.
7798 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7800 vmsreaddirversions(DIR *dd, int flag)
7803 dd->flags |= PERL_VMSDIR_M_VERSIONS;
7805 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7810 * Free up an opened directory.
7812 /*{{{ void closedir(DIR *dd)*/
7814 Perl_closedir(DIR *dd)
7818 sts = lib$find_file_end(&dd->context);
7819 Safefree(dd->pattern);
7820 #if defined(USE_ITHREADS)
7821 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7822 Safefree(dd->mutex);
7829 * Collect all the version numbers for the current file.
7832 collectversions(pTHX_ DIR *dd)
7834 struct dsc$descriptor_s pat;
7835 struct dsc$descriptor_s res;
7837 char *p, *text, *buff;
7839 unsigned long context, tmpsts;
7841 /* Convenient shorthand. */
7844 /* Add the version wildcard, ignoring the "*.*" put on before */
7845 i = strlen(dd->pattern);
7846 Newx(text,i + e->d_namlen + 3,char);
7847 strcpy(text, dd->pattern);
7848 sprintf(&text[i - 3], "%s;*", e->d_name);
7850 /* Set up the pattern descriptor. */
7851 pat.dsc$a_pointer = text;
7852 pat.dsc$w_length = i + e->d_namlen - 1;
7853 pat.dsc$b_dtype = DSC$K_DTYPE_T;
7854 pat.dsc$b_class = DSC$K_CLASS_S;
7856 /* Set up result descriptor. */
7857 Newx(buff, VMS_MAXRSS, char);
7858 res.dsc$a_pointer = buff;
7859 res.dsc$w_length = VMS_MAXRSS - 1;
7860 res.dsc$b_dtype = DSC$K_DTYPE_T;
7861 res.dsc$b_class = DSC$K_CLASS_S;
7863 /* Read files, collecting versions. */
7864 for (context = 0, e->vms_verscount = 0;
7865 e->vms_verscount < VERSIZE(e);
7866 e->vms_verscount++) {
7868 unsigned long flags = 0;
7870 #ifdef VMS_LONGNAME_SUPPORT
7871 flags = LIB$M_FIL_LONG_NAMES;
7873 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
7874 if (tmpsts == RMS$_NMF || context == 0) break;
7876 buff[VMS_MAXRSS - 1] = '\0';
7877 if ((p = strchr(buff, ';')))
7878 e->vms_versions[e->vms_verscount] = atoi(p + 1);
7880 e->vms_versions[e->vms_verscount] = -1;
7883 _ckvmssts(lib$find_file_end(&context));
7887 } /* end of collectversions() */
7890 * Read the next entry from the directory.
7892 /*{{{ struct dirent *readdir(DIR *dd)*/
7894 Perl_readdir(pTHX_ DIR *dd)
7896 struct dsc$descriptor_s res;
7898 unsigned long int tmpsts;
7900 unsigned long flags = 0;
7901 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7902 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7904 /* Set up result descriptor, and get next file. */
7905 Newx(buff, VMS_MAXRSS, char);
7906 res.dsc$a_pointer = buff;
7907 res.dsc$w_length = VMS_MAXRSS - 1;
7908 res.dsc$b_dtype = DSC$K_DTYPE_T;
7909 res.dsc$b_class = DSC$K_CLASS_S;
7911 #ifdef VMS_LONGNAME_SUPPORT
7912 flags = LIB$M_FIL_LONG_NAMES;
7915 tmpsts = lib$find_file
7916 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
7917 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
7918 if (!(tmpsts & 1)) {
7919 set_vaxc_errno(tmpsts);
7922 set_errno(EACCES); break;
7924 set_errno(ENODEV); break;
7926 set_errno(ENOTDIR); break;
7927 case RMS$_FNF: case RMS$_DNF:
7928 set_errno(ENOENT); break;
7936 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
7937 if (!decc_efs_case_preserve) {
7938 buff[VMS_MAXRSS - 1] = '\0';
7939 for (p = buff; *p; p++) *p = _tolower(*p);
7942 /* we don't want to force to lowercase, just null terminate */
7943 buff[res.dsc$w_length] = '\0';
7945 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
7948 /* Skip any directory component and just copy the name. */
7949 sts = vms_split_path
7964 /* Drop NULL extensions on UNIX file specification */
7965 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
7966 (e_len == 1) && decc_readdir_dropdotnotype)) {
7971 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
7972 dd->entry.d_name[n_len + e_len] = '\0';
7973 dd->entry.d_namlen = strlen(dd->entry.d_name);
7975 /* Convert the filename to UNIX format if needed */
7976 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
7978 /* Translate the encoded characters. */
7979 /* Fixme: unicode handling could result in embedded 0 characters */
7980 if (strchr(dd->entry.d_name, '^') != NULL) {
7984 p = dd->entry.d_name;
7988 x = copy_expand_vms_filename_escape(q, p, &y);
7992 /* if y > 1, then this is a wide file specification */
7993 /* Wide file specifications need to be passed in Perl */
7994 /* counted strings apparently with a unicode flag */
7997 strcpy(dd->entry.d_name, new_name);
8001 dd->entry.vms_verscount = 0;
8002 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8006 } /* end of readdir() */
8010 * Read the next entry from the directory -- thread-safe version.
8012 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8014 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8018 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8020 entry = readdir(dd);
8022 retval = ( *result == NULL ? errno : 0 );
8024 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8028 } /* end of readdir_r() */
8032 * Return something that can be used in a seekdir later.
8034 /*{{{ long telldir(DIR *dd)*/
8036 Perl_telldir(DIR *dd)
8043 * Return to a spot where we used to be. Brute force.
8045 /*{{{ void seekdir(DIR *dd,long count)*/
8047 Perl_seekdir(pTHX_ DIR *dd, long count)
8051 /* If we haven't done anything yet... */
8055 /* Remember some state, and clear it. */
8056 old_flags = dd->flags;
8057 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8058 _ckvmssts(lib$find_file_end(&dd->context));
8061 /* The increment is in readdir(). */
8062 for (dd->count = 0; dd->count < count; )
8065 dd->flags = old_flags;
8067 } /* end of seekdir() */
8070 /* VMS subprocess management
8072 * my_vfork() - just a vfork(), after setting a flag to record that
8073 * the current script is trying a Unix-style fork/exec.
8075 * vms_do_aexec() and vms_do_exec() are called in response to the
8076 * perl 'exec' function. If this follows a vfork call, then they
8077 * call out the regular perl routines in doio.c which do an
8078 * execvp (for those who really want to try this under VMS).
8079 * Otherwise, they do exactly what the perl docs say exec should
8080 * do - terminate the current script and invoke a new command
8081 * (See below for notes on command syntax.)
8083 * do_aspawn() and do_spawn() implement the VMS side of the perl
8084 * 'system' function.
8086 * Note on command arguments to perl 'exec' and 'system': When handled
8087 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8088 * are concatenated to form a DCL command string. If the first arg
8089 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8090 * the command string is handed off to DCL directly. Otherwise,
8091 * the first token of the command is taken as the filespec of an image
8092 * to run. The filespec is expanded using a default type of '.EXE' and
8093 * the process defaults for device, directory, etc., and if found, the resultant
8094 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8095 * the command string as parameters. This is perhaps a bit complicated,
8096 * but I hope it will form a happy medium between what VMS folks expect
8097 * from lib$spawn and what Unix folks expect from exec.
8100 static int vfork_called;
8102 /*{{{int my_vfork()*/
8113 vms_execfree(struct dsc$descriptor_s *vmscmd)
8116 if (vmscmd->dsc$a_pointer) {
8117 PerlMem_free(vmscmd->dsc$a_pointer);
8119 PerlMem_free(vmscmd);
8124 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8126 char *junk, *tmps = Nullch;
8127 register size_t cmdlen = 0;
8134 tmps = SvPV(really,rlen);
8141 for (idx++; idx <= sp; idx++) {
8143 junk = SvPVx(*idx,rlen);
8144 cmdlen += rlen ? rlen + 1 : 0;
8147 Newx(PL_Cmd, cmdlen+1, char);
8149 if (tmps && *tmps) {
8150 strcpy(PL_Cmd,tmps);
8153 else *PL_Cmd = '\0';
8154 while (++mark <= sp) {
8156 char *s = SvPVx(*mark,n_a);
8158 if (*PL_Cmd) strcat(PL_Cmd," ");
8164 } /* end of setup_argstr() */
8167 static unsigned long int
8168 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8169 struct dsc$descriptor_s **pvmscmd)
8171 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8172 char image_name[NAM$C_MAXRSS+1];
8173 char image_argv[NAM$C_MAXRSS+1];
8174 $DESCRIPTOR(defdsc,".EXE");
8175 $DESCRIPTOR(defdsc2,".");
8176 $DESCRIPTOR(resdsc,resspec);
8177 struct dsc$descriptor_s *vmscmd;
8178 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8179 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8180 register char *s, *rest, *cp, *wordbreak;
8185 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8186 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8188 /* Make a copy for modification */
8189 cmdlen = strlen(incmd);
8190 cmd = PerlMem_malloc(cmdlen+1);
8191 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8192 strncpy(cmd, incmd, cmdlen);
8197 vmscmd->dsc$a_pointer = NULL;
8198 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8199 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8200 vmscmd->dsc$w_length = 0;
8201 if (pvmscmd) *pvmscmd = vmscmd;
8203 if (suggest_quote) *suggest_quote = 0;
8205 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8207 return CLI$_BUFOVF; /* continuation lines currently unsupported */
8212 while (*s && isspace(*s)) s++;
8214 if (*s == '@' || *s == '$') {
8215 vmsspec[0] = *s; rest = s + 1;
8216 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8218 else { cp = vmsspec; rest = s; }
8219 if (*rest == '.' || *rest == '/') {
8222 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8223 rest++, cp2++) *cp2 = *rest;
8225 if (do_tovmsspec(resspec,cp,0)) {
8228 for (cp2 = vmsspec + strlen(vmsspec);
8229 *rest && cp2 - vmsspec < sizeof vmsspec;
8230 rest++, cp2++) *cp2 = *rest;
8235 /* Intuit whether verb (first word of cmd) is a DCL command:
8236 * - if first nonspace char is '@', it's a DCL indirection
8238 * - if verb contains a filespec separator, it's not a DCL command
8239 * - if it doesn't, caller tells us whether to default to a DCL
8240 * command, or to a local image unless told it's DCL (by leading '$')
8244 if (suggest_quote) *suggest_quote = 1;
8246 register char *filespec = strpbrk(s,":<[.;");
8247 rest = wordbreak = strpbrk(s," \"\t/");
8248 if (!wordbreak) wordbreak = s + strlen(s);
8249 if (*s == '$') check_img = 0;
8250 if (filespec && (filespec < wordbreak)) isdcl = 0;
8251 else isdcl = !check_img;
8256 imgdsc.dsc$a_pointer = s;
8257 imgdsc.dsc$w_length = wordbreak - s;
8258 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8260 _ckvmssts(lib$find_file_end(&cxt));
8261 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8262 if (!(retsts & 1) && *s == '$') {
8263 _ckvmssts(lib$find_file_end(&cxt));
8264 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8265 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8267 _ckvmssts(lib$find_file_end(&cxt));
8268 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8272 _ckvmssts(lib$find_file_end(&cxt));
8277 while (*s && !isspace(*s)) s++;
8280 /* check that it's really not DCL with no file extension */
8281 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8283 char b[256] = {0,0,0,0};
8284 read(fileno(fp), b, 256);
8285 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8289 /* Check for script */
8291 if ((b[0] == '#') && (b[1] == '!'))
8293 #ifdef ALTERNATE_SHEBANG
8295 shebang_len = strlen(ALTERNATE_SHEBANG);
8296 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8298 perlstr = strstr("perl",b);
8299 if (perlstr == NULL)
8307 if (shebang_len > 0) {
8310 char tmpspec[NAM$C_MAXRSS + 1];
8313 /* Image is following after white space */
8314 /*--------------------------------------*/
8315 while (isprint(b[i]) && isspace(b[i]))
8319 while (isprint(b[i]) && !isspace(b[i])) {
8320 tmpspec[j++] = b[i++];
8321 if (j >= NAM$C_MAXRSS)
8326 /* There may be some default parameters to the image */
8327 /*---------------------------------------------------*/
8329 while (isprint(b[i])) {
8330 image_argv[j++] = b[i++];
8331 if (j >= NAM$C_MAXRSS)
8334 while ((j > 0) && !isprint(image_argv[j-1]))
8338 /* It will need to be converted to VMS format and validated */
8339 if (tmpspec[0] != '\0') {
8342 /* Try to find the exact program requested to be run */
8343 /*---------------------------------------------------*/
8344 iname = do_rmsexpand
8345 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8346 if (iname != NULL) {
8347 if (cando_by_name_int
8348 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
8349 /* MCR prefix needed */
8353 /* Try again with a null type */
8354 /*----------------------------*/
8355 iname = do_rmsexpand
8356 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8357 if (iname != NULL) {
8358 if (cando_by_name_int
8359 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
8360 /* MCR prefix needed */
8366 /* Did we find the image to run the script? */
8367 /*------------------------------------------*/
8371 /* Assume DCL or foreign command exists */
8372 /*--------------------------------------*/
8373 tchr = strrchr(tmpspec, '/');
8380 strcpy(image_name, tchr);
8388 if (check_img && isdcl) return RMS$_FNF;
8390 if (cando_by_name(S_IXUSR,0,resspec)) {
8391 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
8392 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8394 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8395 if (image_name[0] != 0) {
8396 strcat(vmscmd->dsc$a_pointer, image_name);
8397 strcat(vmscmd->dsc$a_pointer, " ");
8399 } else if (image_name[0] != 0) {
8400 strcpy(vmscmd->dsc$a_pointer, image_name);
8401 strcat(vmscmd->dsc$a_pointer, " ");
8403 strcpy(vmscmd->dsc$a_pointer,"@");
8405 if (suggest_quote) *suggest_quote = 1;
8407 /* If there is an image name, use original command */
8408 if (image_name[0] == 0)
8409 strcat(vmscmd->dsc$a_pointer,resspec);
8412 while (*rest && isspace(*rest)) rest++;
8415 if (image_argv[0] != 0) {
8416 strcat(vmscmd->dsc$a_pointer,image_argv);
8417 strcat(vmscmd->dsc$a_pointer, " ");
8423 rest_len = strlen(rest);
8424 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8425 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8426 strcat(vmscmd->dsc$a_pointer,rest);
8428 retsts = CLI$_BUFOVF;
8430 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8432 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8438 /* It's either a DCL command or we couldn't find a suitable image */
8439 vmscmd->dsc$w_length = strlen(cmd);
8441 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
8442 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
8443 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
8447 /* check if it's a symbol (for quoting purposes) */
8448 if (suggest_quote && !*suggest_quote) {
8450 char equiv[LNM$C_NAMLENGTH];
8451 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8452 eqvdsc.dsc$a_pointer = equiv;
8454 iss = lib$get_symbol(vmscmd,&eqvdsc);
8455 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8457 if (!(retsts & 1)) {
8458 /* just hand off status values likely to be due to user error */
8459 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8460 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8461 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8462 else { _ckvmssts(retsts); }
8465 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8467 } /* end of setup_cmddsc() */
8470 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8472 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8478 if (vfork_called) { /* this follows a vfork - act Unixish */
8480 if (vfork_called < 0) {
8481 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8484 else return do_aexec(really,mark,sp);
8486 /* no vfork - act VMSish */
8487 cmd = setup_argstr(aTHX_ really,mark,sp);
8488 exec_sts = vms_do_exec(cmd);
8489 Safefree(cmd); /* Clean up from setup_argstr() */
8494 } /* end of vms_do_aexec() */
8497 /* {{{bool vms_do_exec(char *cmd) */
8499 Perl_vms_do_exec(pTHX_ const char *cmd)
8501 struct dsc$descriptor_s *vmscmd;
8503 if (vfork_called) { /* this follows a vfork - act Unixish */
8505 if (vfork_called < 0) {
8506 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8509 else return do_exec(cmd);
8512 { /* no vfork - act VMSish */
8513 unsigned long int retsts;
8516 TAINT_PROPER("exec");
8517 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8518 retsts = lib$do_command(vmscmd);
8521 case RMS$_FNF: case RMS$_DNF:
8522 set_errno(ENOENT); break;
8524 set_errno(ENOTDIR); break;
8526 set_errno(ENODEV); break;
8528 set_errno(EACCES); break;
8530 set_errno(EINVAL); break;
8531 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8532 set_errno(E2BIG); break;
8533 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8534 _ckvmssts(retsts); /* fall through */
8535 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8538 set_vaxc_errno(retsts);
8539 if (ckWARN(WARN_EXEC)) {
8540 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8541 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8543 vms_execfree(vmscmd);
8548 } /* end of vms_do_exec() */
8551 unsigned long int Perl_do_spawn(pTHX_ const char *);
8553 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8555 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8557 unsigned long int sts;
8561 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
8562 sts = do_spawn(cmd);
8563 /* pp_sys will clean up cmd */
8567 } /* end of do_aspawn() */
8570 /* {{{unsigned long int do_spawn(char *cmd) */
8572 Perl_do_spawn(pTHX_ const char *cmd)
8574 unsigned long int sts, substs;
8576 /* The caller of this routine expects to Safefree(PL_Cmd) */
8577 Newx(PL_Cmd,10,char);
8580 TAINT_PROPER("spawn");
8581 if (!cmd || !*cmd) {
8582 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8585 case RMS$_FNF: case RMS$_DNF:
8586 set_errno(ENOENT); break;
8588 set_errno(ENOTDIR); break;
8590 set_errno(ENODEV); break;
8592 set_errno(EACCES); break;
8594 set_errno(EINVAL); break;
8595 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8596 set_errno(E2BIG); break;
8597 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8598 _ckvmssts(sts); /* fall through */
8599 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8602 set_vaxc_errno(sts);
8603 if (ckWARN(WARN_EXEC)) {
8604 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8612 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8617 } /* end of do_spawn() */
8621 static unsigned int *sockflags, sockflagsize;
8624 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8625 * routines found in some versions of the CRTL can't deal with sockets.
8626 * We don't shim the other file open routines since a socket isn't
8627 * likely to be opened by a name.
8629 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8630 FILE *my_fdopen(int fd, const char *mode)
8632 FILE *fp = fdopen(fd, mode);
8635 unsigned int fdoff = fd / sizeof(unsigned int);
8636 Stat_t sbuf; /* native stat; we don't need flex_stat */
8637 if (!sockflagsize || fdoff > sockflagsize) {
8638 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
8639 else Newx (sockflags,fdoff+2,unsigned int);
8640 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8641 sockflagsize = fdoff + 2;
8643 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8644 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8653 * Clear the corresponding bit when the (possibly) socket stream is closed.
8654 * There still a small hole: we miss an implicit close which might occur
8655 * via freopen(). >> Todo
8657 /*{{{ int my_fclose(FILE *fp)*/
8658 int my_fclose(FILE *fp) {
8660 unsigned int fd = fileno(fp);
8661 unsigned int fdoff = fd / sizeof(unsigned int);
8663 if (sockflagsize && fdoff <= sockflagsize)
8664 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8672 * A simple fwrite replacement which outputs itmsz*nitm chars without
8673 * introducing record boundaries every itmsz chars.
8674 * We are using fputs, which depends on a terminating null. We may
8675 * well be writing binary data, so we need to accommodate not only
8676 * data with nulls sprinkled in the middle but also data with no null
8679 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8681 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8683 register char *cp, *end, *cpd, *data;
8684 register unsigned int fd = fileno(dest);
8685 register unsigned int fdoff = fd / sizeof(unsigned int);
8687 int bufsize = itmsz * nitm + 1;
8689 if (fdoff < sockflagsize &&
8690 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8691 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8695 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8696 memcpy( data, src, itmsz*nitm );
8697 data[itmsz*nitm] = '\0';
8699 end = data + itmsz * nitm;
8700 retval = (int) nitm; /* on success return # items written */
8703 while (cpd <= end) {
8704 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8705 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8707 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8711 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8714 } /* end of my_fwrite() */
8717 /*{{{ int my_flush(FILE *fp)*/
8719 Perl_my_flush(pTHX_ FILE *fp)
8722 if ((res = fflush(fp)) == 0 && fp) {
8723 #ifdef VMS_DO_SOCKETS
8725 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8727 res = fsync(fileno(fp));
8730 * If the flush succeeded but set end-of-file, we need to clear
8731 * the error because our caller may check ferror(). BTW, this
8732 * probably means we just flushed an empty file.
8734 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8741 * Here are replacements for the following Unix routines in the VMS environment:
8742 * getpwuid Get information for a particular UIC or UID
8743 * getpwnam Get information for a named user
8744 * getpwent Get information for each user in the rights database
8745 * setpwent Reset search to the start of the rights database
8746 * endpwent Finish searching for users in the rights database
8748 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8749 * (defined in pwd.h), which contains the following fields:-
8751 * char *pw_name; Username (in lower case)
8752 * char *pw_passwd; Hashed password
8753 * unsigned int pw_uid; UIC
8754 * unsigned int pw_gid; UIC group number
8755 * char *pw_unixdir; Default device/directory (VMS-style)
8756 * char *pw_gecos; Owner name
8757 * char *pw_dir; Default device/directory (Unix-style)
8758 * char *pw_shell; Default CLI name (eg. DCL)
8760 * If the specified user does not exist, getpwuid and getpwnam return NULL.
8762 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8763 * not the UIC member number (eg. what's returned by getuid()),
8764 * getpwuid() can accept either as input (if uid is specified, the caller's
8765 * UIC group is used), though it won't recognise gid=0.
8767 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8768 * information about other users in your group or in other groups, respectively.
8769 * If the required privilege is not available, then these routines fill only
8770 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8773 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8776 /* sizes of various UAF record fields */
8777 #define UAI$S_USERNAME 12
8778 #define UAI$S_IDENT 31
8779 #define UAI$S_OWNER 31
8780 #define UAI$S_DEFDEV 31
8781 #define UAI$S_DEFDIR 63
8782 #define UAI$S_DEFCLI 31
8785 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
8786 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8787 (uic).uic$v_group != UIC$K_WILD_GROUP)
8789 static char __empty[]= "";
8790 static struct passwd __passwd_empty=
8791 {(char *) __empty, (char *) __empty, 0, 0,
8792 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8793 static int contxt= 0;
8794 static struct passwd __pwdcache;
8795 static char __pw_namecache[UAI$S_IDENT+1];
8798 * This routine does most of the work extracting the user information.
8800 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8803 unsigned char length;
8804 char pw_gecos[UAI$S_OWNER+1];
8806 static union uicdef uic;
8808 unsigned char length;
8809 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8812 unsigned char length;
8813 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8816 unsigned char length;
8817 char pw_shell[UAI$S_DEFCLI+1];
8819 static char pw_passwd[UAI$S_PWD+1];
8821 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8822 struct dsc$descriptor_s name_desc;
8823 unsigned long int sts;
8825 static struct itmlst_3 itmlst[]= {
8826 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
8827 {sizeof(uic), UAI$_UIC, &uic, &luic},
8828 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
8829 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
8830 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
8831 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
8832 {0, 0, NULL, NULL}};
8834 name_desc.dsc$w_length= strlen(name);
8835 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8836 name_desc.dsc$b_class= DSC$K_CLASS_S;
8837 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8839 /* Note that sys$getuai returns many fields as counted strings. */
8840 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8841 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8842 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8844 else { _ckvmssts(sts); }
8845 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
8847 if ((int) owner.length < lowner) lowner= (int) owner.length;
8848 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8849 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8850 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8851 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8852 owner.pw_gecos[lowner]= '\0';
8853 defdev.pw_dir[ldefdev+ldefdir]= '\0';
8854 defcli.pw_shell[ldefcli]= '\0';
8855 if (valid_uic(uic)) {
8856 pwd->pw_uid= uic.uic$l_uic;
8857 pwd->pw_gid= uic.uic$v_group;
8860 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8861 pwd->pw_passwd= pw_passwd;
8862 pwd->pw_gecos= owner.pw_gecos;
8863 pwd->pw_dir= defdev.pw_dir;
8864 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8865 pwd->pw_shell= defcli.pw_shell;
8866 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8868 ldir= strlen(pwd->pw_unixdir) - 1;
8869 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8872 strcpy(pwd->pw_unixdir, pwd->pw_dir);
8873 if (!decc_efs_case_preserve)
8874 __mystrtolower(pwd->pw_unixdir);
8879 * Get information for a named user.
8881 /*{{{struct passwd *getpwnam(char *name)*/
8882 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8884 struct dsc$descriptor_s name_desc;
8886 unsigned long int status, sts;
8888 __pwdcache = __passwd_empty;
8889 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8890 /* We still may be able to determine pw_uid and pw_gid */
8891 name_desc.dsc$w_length= strlen(name);
8892 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8893 name_desc.dsc$b_class= DSC$K_CLASS_S;
8894 name_desc.dsc$a_pointer= (char *) name;
8895 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
8896 __pwdcache.pw_uid= uic.uic$l_uic;
8897 __pwdcache.pw_gid= uic.uic$v_group;
8900 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
8901 set_vaxc_errno(sts);
8902 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
8905 else { _ckvmssts(sts); }
8908 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
8909 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
8910 __pwdcache.pw_name= __pw_namecache;
8912 } /* end of my_getpwnam() */
8916 * Get information for a particular UIC or UID.
8917 * Called by my_getpwent with uid=-1 to list all users.
8919 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
8920 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
8922 const $DESCRIPTOR(name_desc,__pw_namecache);
8923 unsigned short lname;
8925 unsigned long int status;
8927 if (uid == (unsigned int) -1) {
8929 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
8930 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
8931 set_vaxc_errno(status);
8932 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8936 else { _ckvmssts(status); }
8937 } while (!valid_uic (uic));
8941 if (!uic.uic$v_group)
8942 uic.uic$v_group= PerlProc_getgid();
8944 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
8945 else status = SS$_IVIDENT;
8946 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
8947 status == RMS$_PRV) {
8948 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
8951 else { _ckvmssts(status); }
8953 __pw_namecache[lname]= '\0';
8954 __mystrtolower(__pw_namecache);
8956 __pwdcache = __passwd_empty;
8957 __pwdcache.pw_name = __pw_namecache;
8959 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
8960 The identifier's value is usually the UIC, but it doesn't have to be,
8961 so if we can, we let fillpasswd update this. */
8962 __pwdcache.pw_uid = uic.uic$l_uic;
8963 __pwdcache.pw_gid = uic.uic$v_group;
8965 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
8968 } /* end of my_getpwuid() */
8972 * Get information for next user.
8974 /*{{{struct passwd *my_getpwent()*/
8975 struct passwd *Perl_my_getpwent(pTHX)
8977 return (my_getpwuid((unsigned int) -1));
8982 * Finish searching rights database for users.
8984 /*{{{void my_endpwent()*/
8985 void Perl_my_endpwent(pTHX)
8988 _ckvmssts(sys$finish_rdb(&contxt));
8994 #ifdef HOMEGROWN_POSIX_SIGNALS
8995 /* Signal handling routines, pulled into the core from POSIX.xs.
8997 * We need these for threads, so they've been rolled into the core,
8998 * rather than left in POSIX.xs.
9000 * (DRS, Oct 23, 1997)
9003 /* sigset_t is atomic under VMS, so these routines are easy */
9004 /*{{{int my_sigemptyset(sigset_t *) */
9005 int my_sigemptyset(sigset_t *set) {
9006 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9012 /*{{{int my_sigfillset(sigset_t *)*/
9013 int my_sigfillset(sigset_t *set) {
9015 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9016 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9022 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9023 int my_sigaddset(sigset_t *set, int sig) {
9024 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9025 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9026 *set |= (1 << (sig - 1));
9032 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9033 int my_sigdelset(sigset_t *set, int sig) {
9034 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9035 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9036 *set &= ~(1 << (sig - 1));
9042 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9043 int my_sigismember(sigset_t *set, int sig) {
9044 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9045 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9046 return *set & (1 << (sig - 1));
9051 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9052 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9055 /* If set and oset are both null, then things are badly wrong. Bail out. */
9056 if ((oset == NULL) && (set == NULL)) {
9057 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9061 /* If set's null, then we're just handling a fetch. */
9063 tempmask = sigblock(0);
9068 tempmask = sigsetmask(*set);
9071 tempmask = sigblock(*set);
9074 tempmask = sigblock(0);
9075 sigsetmask(*oset & ~tempmask);
9078 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9083 /* Did they pass us an oset? If so, stick our holding mask into it */
9090 #endif /* HOMEGROWN_POSIX_SIGNALS */
9093 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9094 * my_utime(), and flex_stat(), all of which operate on UTC unless
9095 * VMSISH_TIMES is true.
9097 /* method used to handle UTC conversions:
9098 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
9100 static int gmtime_emulation_type;
9101 /* number of secs to add to UTC POSIX-style time to get local time */
9102 static long int utc_offset_secs;
9104 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9105 * in vmsish.h. #undef them here so we can call the CRTL routines
9114 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9115 * qualifier with the extern prefix pragma. This provisional
9116 * hack circumvents this prefix pragma problem in previous
9119 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9120 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9121 # pragma __extern_prefix save
9122 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
9123 # define gmtime decc$__utctz_gmtime
9124 # define localtime decc$__utctz_localtime
9125 # define time decc$__utc_time
9126 # pragma __extern_prefix restore
9128 struct tm *gmtime(), *localtime();
9134 static time_t toutc_dst(time_t loc) {
9137 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9138 loc -= utc_offset_secs;
9139 if (rsltmp->tm_isdst) loc -= 3600;
9142 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9143 ((gmtime_emulation_type || my_time(NULL)), \
9144 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9145 ((secs) - utc_offset_secs))))
9147 static time_t toloc_dst(time_t utc) {
9150 utc += utc_offset_secs;
9151 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9152 if (rsltmp->tm_isdst) utc += 3600;
9155 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9156 ((gmtime_emulation_type || my_time(NULL)), \
9157 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9158 ((secs) + utc_offset_secs))))
9160 #ifndef RTL_USES_UTC
9163 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9164 DST starts on 1st sun of april at 02:00 std time
9165 ends on last sun of october at 02:00 dst time
9166 see the UCX management command reference, SET CONFIG TIMEZONE
9167 for formatting info.
9169 No, it's not as general as it should be, but then again, NOTHING
9170 will handle UK times in a sensible way.
9175 parse the DST start/end info:
9176 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9180 tz_parse_startend(char *s, struct tm *w, int *past)
9182 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9183 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9188 if (!past) return 0;
9191 if (w->tm_year % 4 == 0) ly = 1;
9192 if (w->tm_year % 100 == 0) ly = 0;
9193 if (w->tm_year+1900 % 400 == 0) ly = 1;
9196 dozjd = isdigit(*s);
9197 if (*s == 'J' || *s == 'j' || dozjd) {
9198 if (!dozjd && !isdigit(*++s)) return 0;
9201 d = d*10 + *s++ - '0';
9203 d = d*10 + *s++ - '0';
9206 if (d == 0) return 0;
9207 if (d > 366) return 0;
9209 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9212 } else if (*s == 'M' || *s == 'm') {
9213 if (!isdigit(*++s)) return 0;
9215 if (isdigit(*s)) m = 10*m + *s++ - '0';
9216 if (*s != '.') return 0;
9217 if (!isdigit(*++s)) return 0;
9219 if (n < 1 || n > 5) return 0;
9220 if (*s != '.') return 0;
9221 if (!isdigit(*++s)) return 0;
9223 if (d > 6) return 0;
9227 if (!isdigit(*++s)) return 0;
9229 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9231 if (!isdigit(*++s)) return 0;
9233 if (isdigit(*s)) min = 10*min + *s++ - '0';
9235 if (!isdigit(*++s)) return 0;
9237 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9247 if (w->tm_yday < d) goto before;
9248 if (w->tm_yday > d) goto after;
9250 if (w->tm_mon+1 < m) goto before;
9251 if (w->tm_mon+1 > m) goto after;
9253 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9254 k = d - j; /* mday of first d */
9256 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9257 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9258 if (w->tm_mday < k) goto before;
9259 if (w->tm_mday > k) goto after;
9262 if (w->tm_hour < hour) goto before;
9263 if (w->tm_hour > hour) goto after;
9264 if (w->tm_min < min) goto before;
9265 if (w->tm_min > min) goto after;
9266 if (w->tm_sec < sec) goto before;
9280 /* parse the offset: (+|-)hh[:mm[:ss]] */
9283 tz_parse_offset(char *s, int *offset)
9285 int hour = 0, min = 0, sec = 0;
9288 if (!offset) return 0;
9290 if (*s == '-') {neg++; s++;}
9292 if (!isdigit(*s)) return 0;
9294 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9295 if (hour > 24) return 0;
9297 if (!isdigit(*++s)) return 0;
9299 if (isdigit(*s)) min = min*10 + (*s++ - '0');
9300 if (min > 59) return 0;
9302 if (!isdigit(*++s)) return 0;
9304 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9305 if (sec > 59) return 0;
9309 *offset = (hour*60+min)*60 + sec;
9310 if (neg) *offset = -*offset;
9315 input time is w, whatever type of time the CRTL localtime() uses.
9316 sets dst, the zone, and the gmtoff (seconds)
9318 caches the value of TZ and UCX$TZ env variables; note that
9319 my_setenv looks for these and sets a flag if they're changed
9322 We have to watch out for the "australian" case (dst starts in
9323 october, ends in april)...flagged by "reverse" and checked by
9324 scanning through the months of the previous year.
9329 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9334 char *dstzone, *tz, *s_start, *s_end;
9335 int std_off, dst_off, isdst;
9336 int y, dststart, dstend;
9337 static char envtz[1025]; /* longer than any logical, symbol, ... */
9338 static char ucxtz[1025];
9339 static char reversed = 0;
9345 reversed = -1; /* flag need to check */
9346 envtz[0] = ucxtz[0] = '\0';
9347 tz = my_getenv("TZ",0);
9348 if (tz) strcpy(envtz, tz);
9349 tz = my_getenv("UCX$TZ",0);
9350 if (tz) strcpy(ucxtz, tz);
9351 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
9354 if (!*tz) tz = ucxtz;
9357 while (isalpha(*s)) s++;
9358 s = tz_parse_offset(s, &std_off);
9360 if (!*s) { /* no DST, hurray we're done! */
9366 while (isalpha(*s)) s++;
9367 s2 = tz_parse_offset(s, &dst_off);
9371 dst_off = std_off - 3600;
9374 if (!*s) { /* default dst start/end?? */
9375 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
9376 s = strchr(ucxtz,',');
9378 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
9380 if (*s != ',') return 0;
9383 when = _toutc(when); /* convert to utc */
9384 when = when - std_off; /* convert to pseudolocal time*/
9386 w2 = localtime(&when);
9389 s = tz_parse_startend(s_start,w2,&dststart);
9391 if (*s != ',') return 0;
9394 when = _toutc(when); /* convert to utc */
9395 when = when - dst_off; /* convert to pseudolocal time*/
9396 w2 = localtime(&when);
9397 if (w2->tm_year != y) { /* spans a year, just check one time */
9398 when += dst_off - std_off;
9399 w2 = localtime(&when);
9402 s = tz_parse_startend(s_end,w2,&dstend);
9405 if (reversed == -1) { /* need to check if start later than end */
9409 if (when < 2*365*86400) {
9410 when += 2*365*86400;
9414 w2 =localtime(&when);
9415 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
9417 for (j = 0; j < 12; j++) {
9418 w2 =localtime(&when);
9419 tz_parse_startend(s_start,w2,&ds);
9420 tz_parse_startend(s_end,w2,&de);
9421 if (ds != de) break;
9425 if (de && !ds) reversed = 1;
9428 isdst = dststart && !dstend;
9429 if (reversed) isdst = dststart || !dstend;
9432 if (dst) *dst = isdst;
9433 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9434 if (isdst) tz = dstzone;
9436 while(isalpha(*tz)) *zone++ = *tz++;
9442 #endif /* !RTL_USES_UTC */
9444 /* my_time(), my_localtime(), my_gmtime()
9445 * By default traffic in UTC time values, using CRTL gmtime() or
9446 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9447 * Note: We need to use these functions even when the CRTL has working
9448 * UTC support, since they also handle C<use vmsish qw(times);>
9450 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
9451 * Modified by Charles Bailey <bailey@newman.upenn.edu>
9454 /*{{{time_t my_time(time_t *timep)*/
9455 time_t Perl_my_time(pTHX_ time_t *timep)
9460 if (gmtime_emulation_type == 0) {
9462 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
9463 /* results of calls to gmtime() and localtime() */
9464 /* for same &base */
9466 gmtime_emulation_type++;
9467 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9468 char off[LNM$C_NAMLENGTH+1];;
9470 gmtime_emulation_type++;
9471 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9472 gmtime_emulation_type++;
9473 utc_offset_secs = 0;
9474 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9476 else { utc_offset_secs = atol(off); }
9478 else { /* We've got a working gmtime() */
9479 struct tm gmt, local;
9482 tm_p = localtime(&base);
9484 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
9485 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9486 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
9487 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
9493 # ifdef RTL_USES_UTC
9494 if (VMSISH_TIME) when = _toloc(when);
9496 if (!VMSISH_TIME) when = _toutc(when);
9499 if (timep != NULL) *timep = when;
9502 } /* end of my_time() */
9506 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9508 Perl_my_gmtime(pTHX_ const time_t *timep)
9514 if (timep == NULL) {
9515 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9518 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9522 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9524 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
9525 return gmtime(&when);
9527 /* CRTL localtime() wants local time as input, so does no tz correction */
9528 rsltmp = localtime(&when);
9529 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
9532 } /* end of my_gmtime() */
9536 /*{{{struct tm *my_localtime(const time_t *timep)*/
9538 Perl_my_localtime(pTHX_ const time_t *timep)
9540 time_t when, whenutc;
9544 if (timep == NULL) {
9545 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9548 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9549 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9552 # ifdef RTL_USES_UTC
9554 if (VMSISH_TIME) when = _toutc(when);
9556 /* CRTL localtime() wants UTC as input, does tz correction itself */
9557 return localtime(&when);
9559 # else /* !RTL_USES_UTC */
9562 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
9563 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
9566 #ifndef RTL_USES_UTC
9567 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
9568 when = whenutc - offset; /* pseudolocal time*/
9571 /* CRTL localtime() wants local time as input, so does no tz correction */
9572 rsltmp = localtime(&when);
9573 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9577 } /* end of my_localtime() */
9580 /* Reset definitions for later calls */
9581 #define gmtime(t) my_gmtime(t)
9582 #define localtime(t) my_localtime(t)
9583 #define time(t) my_time(t)
9586 /* my_utime - update modification/access time of a file
9588 * VMS 7.3 and later implementation
9589 * Only the UTC translation is home-grown. The rest is handled by the
9590 * CRTL utime(), which will take into account the relevant feature
9591 * logicals and ODS-5 volume characteristics for true access times.
9593 * pre VMS 7.3 implementation:
9594 * The calling sequence is identical to POSIX utime(), but under
9595 * VMS with ODS-2, only the modification time is changed; ODS-2 does
9596 * not maintain access times. Restrictions differ from the POSIX
9597 * definition in that the time can be changed as long as the
9598 * caller has permission to execute the necessary IO$_MODIFY $QIO;
9599 * no separate checks are made to insure that the caller is the
9600 * owner of the file or has special privs enabled.
9601 * Code here is based on Joe Meadows' FILE utility.
9605 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9606 * to VMS epoch (01-JAN-1858 00:00:00.00)
9607 * in 100 ns intervals.
9609 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9611 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9612 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9614 #if __CRTL_VER >= 70300000
9615 struct utimbuf utc_utimes, *utc_utimesp;
9617 if (utimes != NULL) {
9618 utc_utimes.actime = utimes->actime;
9619 utc_utimes.modtime = utimes->modtime;
9621 /* If input was local; convert to UTC for sys svc */
9623 utc_utimes.actime = _toutc(utimes->actime);
9624 utc_utimes.modtime = _toutc(utimes->modtime);
9627 utc_utimesp = &utc_utimes;
9633 return utime(file, utc_utimesp);
9635 #else /* __CRTL_VER < 70300000 */
9639 long int bintime[2], len = 2, lowbit, unixtime,
9640 secscale = 10000000; /* seconds --> 100 ns intervals */
9641 unsigned long int chan, iosb[2], retsts;
9642 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9643 struct FAB myfab = cc$rms_fab;
9644 struct NAM mynam = cc$rms_nam;
9645 #if defined (__DECC) && defined (__VAX)
9646 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9647 * at least through VMS V6.1, which causes a type-conversion warning.
9649 # pragma message save
9650 # pragma message disable cvtdiftypes
9652 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9653 struct fibdef myfib;
9654 #if defined (__DECC) && defined (__VAX)
9655 /* This should be right after the declaration of myatr, but due
9656 * to a bug in VAX DEC C, this takes effect a statement early.
9658 # pragma message restore
9660 /* cast ok for read only parameter */
9661 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9662 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9663 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9665 if (file == NULL || *file == '\0') {
9666 SETERRNO(ENOENT, LIB$_INVARG);
9670 /* Convert to VMS format ensuring that it will fit in 255 characters */
9671 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
9672 SETERRNO(ENOENT, LIB$_INVARG);
9675 if (utimes != NULL) {
9676 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
9677 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9678 * Since time_t is unsigned long int, and lib$emul takes a signed long int
9679 * as input, we force the sign bit to be clear by shifting unixtime right
9680 * one bit, then multiplying by an extra factor of 2 in lib$emul().
9682 lowbit = (utimes->modtime & 1) ? secscale : 0;
9683 unixtime = (long int) utimes->modtime;
9685 /* If input was UTC; convert to local for sys svc */
9686 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9688 unixtime >>= 1; secscale <<= 1;
9689 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9690 if (!(retsts & 1)) {
9691 SETERRNO(EVMSERR, retsts);
9694 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9695 if (!(retsts & 1)) {
9696 SETERRNO(EVMSERR, retsts);
9701 /* Just get the current time in VMS format directly */
9702 retsts = sys$gettim(bintime);
9703 if (!(retsts & 1)) {
9704 SETERRNO(EVMSERR, retsts);
9709 myfab.fab$l_fna = vmsspec;
9710 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9711 myfab.fab$l_nam = &mynam;
9712 mynam.nam$l_esa = esa;
9713 mynam.nam$b_ess = (unsigned char) sizeof esa;
9714 mynam.nam$l_rsa = rsa;
9715 mynam.nam$b_rss = (unsigned char) sizeof rsa;
9716 if (decc_efs_case_preserve)
9717 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9719 /* Look for the file to be affected, letting RMS parse the file
9720 * specification for us as well. I have set errno using only
9721 * values documented in the utime() man page for VMS POSIX.
9723 retsts = sys$parse(&myfab,0,0);
9724 if (!(retsts & 1)) {
9725 set_vaxc_errno(retsts);
9726 if (retsts == RMS$_PRV) set_errno(EACCES);
9727 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9728 else set_errno(EVMSERR);
9731 retsts = sys$search(&myfab,0,0);
9732 if (!(retsts & 1)) {
9733 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9734 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9735 set_vaxc_errno(retsts);
9736 if (retsts == RMS$_PRV) set_errno(EACCES);
9737 else if (retsts == RMS$_FNF) set_errno(ENOENT);
9738 else set_errno(EVMSERR);
9742 devdsc.dsc$w_length = mynam.nam$b_dev;
9743 /* cast ok for read only parameter */
9744 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9746 retsts = sys$assign(&devdsc,&chan,0,0);
9747 if (!(retsts & 1)) {
9748 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9749 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9750 set_vaxc_errno(retsts);
9751 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
9752 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
9753 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
9754 else set_errno(EVMSERR);
9758 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9759 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9761 memset((void *) &myfib, 0, sizeof myfib);
9762 #if defined(__DECC) || defined(__DECCXX)
9763 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9764 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9765 /* This prevents the revision time of the file being reset to the current
9766 * time as a result of our IO$_MODIFY $QIO. */
9767 myfib.fib$l_acctl = FIB$M_NORECORD;
9769 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9770 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9771 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9773 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9774 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9775 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9776 _ckvmssts(sys$dassgn(chan));
9777 if (retsts & 1) retsts = iosb[0];
9778 if (!(retsts & 1)) {
9779 set_vaxc_errno(retsts);
9780 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9781 else set_errno(EVMSERR);
9787 #endif /* #if __CRTL_VER >= 70300000 */
9789 } /* end of my_utime() */
9793 * flex_stat, flex_lstat, flex_fstat
9794 * basic stat, but gets it right when asked to stat
9795 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9798 #ifndef _USE_STD_STAT
9799 /* encode_dev packs a VMS device name string into an integer to allow
9800 * simple comparisons. This can be used, for example, to check whether two
9801 * files are located on the same device, by comparing their encoded device
9802 * names. Even a string comparison would not do, because stat() reuses the
9803 * device name buffer for each call; so without encode_dev, it would be
9804 * necessary to save the buffer and use strcmp (this would mean a number of
9805 * changes to the standard Perl code, to say nothing of what a Perl script
9808 * The device lock id, if it exists, should be unique (unless perhaps compared
9809 * with lock ids transferred from other nodes). We have a lock id if the disk is
9810 * mounted cluster-wide, which is when we tend to get long (host-qualified)
9811 * device names. Thus we use the lock id in preference, and only if that isn't
9812 * available, do we try to pack the device name into an integer (flagged by
9813 * the sign bit (LOCKID_MASK) being set).
9815 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9816 * name and its encoded form, but it seems very unlikely that we will find
9817 * two files on different disks that share the same encoded device names,
9818 * and even more remote that they will share the same file id (if the test
9819 * is to check for the same file).
9821 * A better method might be to use sys$device_scan on the first call, and to
9822 * search for the device, returning an index into the cached array.
9823 * The number returned would be more intelligable.
9824 * This is probably not worth it, and anyway would take quite a bit longer
9825 * on the first call.
9827 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
9828 static mydev_t encode_dev (pTHX_ const char *dev)
9831 unsigned long int f;
9836 if (!dev || !dev[0]) return 0;
9840 struct dsc$descriptor_s dev_desc;
9841 unsigned long int status, lockid, item = DVI$_LOCKID;
9843 /* For cluster-mounted disks, the disk lock identifier is unique, so we
9844 can try that first. */
9845 dev_desc.dsc$w_length = strlen (dev);
9846 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
9847 dev_desc.dsc$b_class = DSC$K_CLASS_S;
9848 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
9849 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9850 if (lockid) return (lockid & ~LOCKID_MASK);
9854 /* Otherwise we try to encode the device name */
9858 for (q = dev + strlen(dev); q--; q >= dev) {
9863 else if (isalpha (toupper (*q)))
9864 c= toupper (*q) - 'A' + (char)10;
9866 continue; /* Skip '$'s */
9868 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
9870 enc += f * (unsigned long int) c;
9872 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
9874 } /* end of encode_dev() */
9875 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
9876 device_no = encode_dev(aTHX_ devname)
9878 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
9879 device_no = new_dev_no
9883 is_null_device(name)
9886 if (decc_bug_devnull != 0) {
9887 if (strncmp("/dev/null", name, 9) == 0)
9890 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9891 The underscore prefix, controller letter, and unit number are
9892 independently optional; for our purposes, the colon punctuation
9893 is not. The colon can be trailed by optional directory and/or
9894 filename, but two consecutive colons indicates a nodename rather
9895 than a device. [pr] */
9896 if (*name == '_') ++name;
9897 if (tolower(*name++) != 'n') return 0;
9898 if (tolower(*name++) != 'l') return 0;
9899 if (tolower(*name) == 'a') ++name;
9900 if (*name == '0') ++name;
9901 return (*name++ == ':') && (*name != ':');
9906 Perl_cando_by_name_int
9907 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
9909 static char usrname[L_cuserid];
9910 static struct dsc$descriptor_s usrdsc =
9911 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
9912 char vmsname[NAM$C_MAXRSS+1];
9914 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
9915 unsigned short int retlen, trnlnm_iter_count;
9916 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9917 union prvdef curprv;
9918 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
9919 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
9920 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
9921 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
9922 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
9924 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
9926 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9928 if (!fname || !*fname) return FALSE;
9929 /* Make sure we expand logical names, since sys$check_access doesn't */
9932 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
9933 fileified = PerlMem_malloc(VMS_MAXRSS);
9934 if (!strpbrk(fname,"/]>:")) {
9935 strcpy(fileified,fname);
9936 trnlnm_iter_count = 0;
9937 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
9938 trnlnm_iter_count++;
9939 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
9943 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) {
9944 PerlMem_free(fileified);
9947 retlen = namdsc.dsc$w_length = strlen(vmsname);
9948 namdsc.dsc$a_pointer = vmsname;
9949 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
9950 vmsname[retlen-1] == ':') {
9951 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
9952 namdsc.dsc$w_length = strlen(fileified);
9953 namdsc.dsc$a_pointer = fileified;
9957 retlen = namdsc.dsc$w_length = strlen(fname);
9958 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
9962 case S_IXUSR: case S_IXGRP: case S_IXOTH:
9963 access = ARM$M_EXECUTE;
9966 case S_IRUSR: case S_IRGRP: case S_IROTH:
9967 access = ARM$M_READ;
9968 flags = CHP$M_READ | CHP$M_USEREADALL;
9970 case S_IWUSR: case S_IWGRP: case S_IWOTH:
9971 access = ARM$M_WRITE;
9972 flags = CHP$M_READ | CHP$M_WRITE;
9974 case S_IDUSR: case S_IDGRP: case S_IDOTH:
9975 access = ARM$M_DELETE;
9976 flags = CHP$M_READ | CHP$M_WRITE;
9979 if (fileified != NULL)
9980 PerlMem_free(fileified);
9984 /* Before we call $check_access, create a user profile with the current
9985 * process privs since otherwise it just uses the default privs from the
9986 * UAF and might give false positives or negatives. This only works on
9987 * VMS versions v6.0 and later since that's when sys$create_user_profile
9991 /* get current process privs and username */
9992 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
9995 #if defined(__VMS_VER) && __VMS_VER >= 60000000
9997 /* find out the space required for the profile */
9998 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
9999 &usrprodsc.dsc$w_length,0));
10001 /* allocate space for the profile and get it filled in */
10002 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10003 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10004 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10005 &usrprodsc.dsc$w_length,0));
10007 /* use the profile to check access to the file; free profile & analyze results */
10008 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10009 PerlMem_free(usrprodsc.dsc$a_pointer);
10010 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10014 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10018 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
10019 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10020 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10021 set_vaxc_errno(retsts);
10022 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10023 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10024 else set_errno(ENOENT);
10025 if (fileified != NULL)
10026 PerlMem_free(fileified);
10029 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10030 if (fileified != NULL)
10031 PerlMem_free(fileified);
10036 if (fileified != NULL)
10037 PerlMem_free(fileified);
10038 return FALSE; /* Should never get here */
10042 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
10043 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10044 * subset of the applicable information.
10047 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10049 return cando_by_name_int
10050 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10051 } /* end of cando() */
10055 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10057 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10059 return cando_by_name_int(bit, effective, fname, 0);
10061 } /* end of cando_by_name() */
10065 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10067 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10069 if (!fstat(fd,(stat_t *) statbufp)) {
10071 char *vms_filename;
10072 vms_filename = PerlMem_malloc(VMS_MAXRSS);
10073 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10075 /* Save name for cando by name in VMS format */
10076 cptr = getname(fd, vms_filename, 1);
10078 /* This should not happen, but just in case */
10079 if (cptr == NULL) {
10080 statbufp->st_devnam[0] = 0;
10083 /* Make sure that the saved name fits in 255 characters */
10084 cptr = do_rmsexpand
10086 statbufp->st_devnam,
10089 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN);
10091 statbufp->st_devnam[0] = 0;
10093 PerlMem_free(vms_filename);
10095 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10097 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10099 # ifdef RTL_USES_UTC
10100 # ifdef VMSISH_TIME
10102 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10103 statbufp->st_atime = _toloc(statbufp->st_atime);
10104 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10108 # ifdef VMSISH_TIME
10109 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10113 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10114 statbufp->st_atime = _toutc(statbufp->st_atime);
10115 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10122 } /* end of flex_fstat() */
10125 #if !defined(__VAX) && __CRTL_VER >= 80200000
10133 #define lstat(_x, _y) stat(_x, _y)
10136 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10139 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10141 char fileified[VMS_MAXRSS];
10142 char temp_fspec[VMS_MAXRSS];
10145 int saved_errno, saved_vaxc_errno;
10147 if (!fspec) return retval;
10148 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10149 strcpy(temp_fspec, fspec);
10151 if (decc_bug_devnull != 0) {
10152 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10153 memset(statbufp,0,sizeof *statbufp);
10154 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10155 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10156 statbufp->st_uid = 0x00010001;
10157 statbufp->st_gid = 0x0001;
10158 time((time_t *)&statbufp->st_mtime);
10159 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10164 /* Try for a directory name first. If fspec contains a filename without
10165 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10166 * and sea:[wine.dark]water. exist, we prefer the directory here.
10167 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10168 * not sea:[wine.dark]., if the latter exists. If the intended target is
10169 * the file with null type, specify this by calling flex_stat() with
10170 * a '.' at the end of fspec.
10172 * If we are in Posix filespec mode, accept the filename as is.
10174 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10175 if (decc_posix_compliant_pathnames == 0) {
10177 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10178 if (lstat_flag == 0)
10179 retval = stat(fileified,(stat_t *) statbufp);
10181 retval = lstat(fileified,(stat_t *) statbufp);
10182 save_spec = fileified;
10185 if (lstat_flag == 0)
10186 retval = stat(temp_fspec,(stat_t *) statbufp);
10188 retval = lstat(temp_fspec,(stat_t *) statbufp);
10189 save_spec = temp_fspec;
10191 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10193 if (lstat_flag == 0)
10194 retval = stat(temp_fspec,(stat_t *) statbufp);
10196 retval = lstat(temp_fspec,(stat_t *) statbufp);
10197 save_spec = temp_fspec;
10202 cptr = do_rmsexpand
10203 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS);
10205 statbufp->st_devnam[0] = 0;
10207 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10209 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10210 # ifdef RTL_USES_UTC
10211 # ifdef VMSISH_TIME
10213 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10214 statbufp->st_atime = _toloc(statbufp->st_atime);
10215 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10219 # ifdef VMSISH_TIME
10220 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10224 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10225 statbufp->st_atime = _toutc(statbufp->st_atime);
10226 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10230 /* If we were successful, leave errno where we found it */
10231 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10234 } /* end of flex_stat_int() */
10237 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10239 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10241 return flex_stat_int(fspec, statbufp, 0);
10245 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10247 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10249 return flex_stat_int(fspec, statbufp, 1);
10254 /*{{{char *my_getlogin()*/
10255 /* VMS cuserid == Unix getlogin, except calling sequence */
10259 static char user[L_cuserid];
10260 return cuserid(user);
10265 /* rmscopy - copy a file using VMS RMS routines
10267 * Copies contents and attributes of spec_in to spec_out, except owner
10268 * and protection information. Name and type of spec_in are used as
10269 * defaults for spec_out. The third parameter specifies whether rmscopy()
10270 * should try to propagate timestamps from the input file to the output file.
10271 * If it is less than 0, no timestamps are preserved. If it is 0, then
10272 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
10273 * propagated to the output file at creation iff the output file specification
10274 * did not contain an explicit name or type, and the revision date is always
10275 * updated at the end of the copy operation. If it is greater than 0, then
10276 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10277 * other than the revision date should be propagated, and bit 1 indicates
10278 * that the revision date should be propagated.
10280 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10282 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10283 * Incorporates, with permission, some code from EZCOPY by Tim Adye
10284 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
10285 * as part of the Perl standard distribution under the terms of the
10286 * GNU General Public License or the Perl Artistic License. Copies
10287 * of each may be found in the Perl standard distribution.
10289 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10291 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10293 char *vmsin, * vmsout, *esa, *esa_out,
10295 unsigned long int i, sts, sts2;
10297 struct FAB fab_in, fab_out;
10298 struct RAB rab_in, rab_out;
10299 rms_setup_nam(nam);
10300 rms_setup_nam(nam_out);
10301 struct XABDAT xabdat;
10302 struct XABFHC xabfhc;
10303 struct XABRDT xabrdt;
10304 struct XABSUM xabsum;
10306 vmsin = PerlMem_malloc(VMS_MAXRSS);
10307 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
10308 vmsout = PerlMem_malloc(VMS_MAXRSS);
10309 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
10310 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10311 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10312 PerlMem_free(vmsin);
10313 PerlMem_free(vmsout);
10314 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10318 esa = PerlMem_malloc(VMS_MAXRSS);
10319 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
10320 fab_in = cc$rms_fab;
10321 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
10322 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10323 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10324 fab_in.fab$l_fop = FAB$M_SQO;
10325 rms_bind_fab_nam(fab_in, nam);
10326 fab_in.fab$l_xab = (void *) &xabdat;
10328 rsa = PerlMem_malloc(VMS_MAXRSS);
10329 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
10330 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
10331 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
10332 rms_nam_esl(nam) = 0;
10333 rms_nam_rsl(nam) = 0;
10334 rms_nam_esll(nam) = 0;
10335 rms_nam_rsll(nam) = 0;
10336 #ifdef NAM$M_NO_SHORT_UPCASE
10337 if (decc_efs_case_preserve)
10338 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
10341 xabdat = cc$rms_xabdat; /* To get creation date */
10342 xabdat.xab$l_nxt = (void *) &xabfhc;
10344 xabfhc = cc$rms_xabfhc; /* To get record length */
10345 xabfhc.xab$l_nxt = (void *) &xabsum;
10347 xabsum = cc$rms_xabsum; /* To get key and area information */
10349 if (!((sts = sys$open(&fab_in)) & 1)) {
10350 PerlMem_free(vmsin);
10351 PerlMem_free(vmsout);
10354 set_vaxc_errno(sts);
10356 case RMS$_FNF: case RMS$_DNF:
10357 set_errno(ENOENT); break;
10359 set_errno(ENOTDIR); break;
10361 set_errno(ENODEV); break;
10363 set_errno(EINVAL); break;
10365 set_errno(EACCES); break;
10367 set_errno(EVMSERR);
10374 fab_out.fab$w_ifi = 0;
10375 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10376 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10377 fab_out.fab$l_fop = FAB$M_SQO;
10378 rms_bind_fab_nam(fab_out, nam_out);
10379 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
10380 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
10381 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
10382 esa_out = PerlMem_malloc(VMS_MAXRSS);
10383 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
10384 rms_set_rsa(nam_out, NULL, 0);
10385 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
10387 if (preserve_dates == 0) { /* Act like DCL COPY */
10388 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
10389 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10390 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
10391 PerlMem_free(vmsin);
10392 PerlMem_free(vmsout);
10395 PerlMem_free(esa_out);
10396 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10397 set_vaxc_errno(sts);
10400 fab_out.fab$l_xab = (void *) &xabdat;
10401 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
10402 preserve_dates = 1;
10404 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10405 preserve_dates =0; /* bitmask from this point forward */
10407 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10408 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
10409 PerlMem_free(vmsin);
10410 PerlMem_free(vmsout);
10413 PerlMem_free(esa_out);
10414 set_vaxc_errno(sts);
10417 set_errno(ENOENT); break;
10419 set_errno(ENOTDIR); break;
10421 set_errno(ENODEV); break;
10423 set_errno(EINVAL); break;
10425 set_errno(EACCES); break;
10427 set_errno(EVMSERR);
10431 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10432 if (preserve_dates & 2) {
10433 /* sys$close() will process xabrdt, not xabdat */
10434 xabrdt = cc$rms_xabrdt;
10436 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10438 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10439 * is unsigned long[2], while DECC & VAXC use a struct */
10440 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10442 fab_out.fab$l_xab = (void *) &xabrdt;
10445 ubf = PerlMem_malloc(32256);
10446 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
10447 rab_in = cc$rms_rab;
10448 rab_in.rab$l_fab = &fab_in;
10449 rab_in.rab$l_rop = RAB$M_BIO;
10450 rab_in.rab$l_ubf = ubf;
10451 rab_in.rab$w_usz = 32256;
10452 if (!((sts = sys$connect(&rab_in)) & 1)) {
10453 sys$close(&fab_in); sys$close(&fab_out);
10454 PerlMem_free(vmsin);
10455 PerlMem_free(vmsout);
10459 PerlMem_free(esa_out);
10460 set_errno(EVMSERR); set_vaxc_errno(sts);
10464 rab_out = cc$rms_rab;
10465 rab_out.rab$l_fab = &fab_out;
10466 rab_out.rab$l_rbf = ubf;
10467 if (!((sts = sys$connect(&rab_out)) & 1)) {
10468 sys$close(&fab_in); sys$close(&fab_out);
10469 PerlMem_free(vmsin);
10470 PerlMem_free(vmsout);
10474 PerlMem_free(esa_out);
10475 set_errno(EVMSERR); set_vaxc_errno(sts);
10479 while ((sts = sys$read(&rab_in))) { /* always true */
10480 if (sts == RMS$_EOF) break;
10481 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10482 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10483 sys$close(&fab_in); sys$close(&fab_out);
10484 PerlMem_free(vmsin);
10485 PerlMem_free(vmsout);
10489 PerlMem_free(esa_out);
10490 set_errno(EVMSERR); set_vaxc_errno(sts);
10496 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10497 sys$close(&fab_in); sys$close(&fab_out);
10498 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10500 PerlMem_free(vmsin);
10501 PerlMem_free(vmsout);
10505 PerlMem_free(esa_out);
10506 set_errno(EVMSERR); set_vaxc_errno(sts);
10510 PerlMem_free(vmsin);
10511 PerlMem_free(vmsout);
10515 PerlMem_free(esa_out);
10518 } /* end of rmscopy() */
10522 /*** The following glue provides 'hooks' to make some of the routines
10523 * from this file available from Perl. These routines are sufficiently
10524 * basic, and are required sufficiently early in the build process,
10525 * that's it's nice to have them available to miniperl as well as the
10526 * full Perl, so they're set up here instead of in an extension. The
10527 * Perl code which handles importation of these names into a given
10528 * package lives in [.VMS]Filespec.pm in @INC.
10532 rmsexpand_fromperl(pTHX_ CV *cv)
10535 char *fspec, *defspec = NULL, *rslt;
10538 if (!items || items > 2)
10539 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10540 fspec = SvPV(ST(0),n_a);
10541 if (!fspec || !*fspec) XSRETURN_UNDEF;
10542 if (items == 2) defspec = SvPV(ST(1),n_a);
10544 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10545 ST(0) = sv_newmortal();
10546 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10551 vmsify_fromperl(pTHX_ CV *cv)
10557 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10558 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10559 ST(0) = sv_newmortal();
10560 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10565 unixify_fromperl(pTHX_ CV *cv)
10571 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10572 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10573 ST(0) = sv_newmortal();
10574 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10579 fileify_fromperl(pTHX_ CV *cv)
10585 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10586 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10587 ST(0) = sv_newmortal();
10588 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10593 pathify_fromperl(pTHX_ CV *cv)
10599 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10600 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10601 ST(0) = sv_newmortal();
10602 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10607 vmspath_fromperl(pTHX_ CV *cv)
10613 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10614 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10615 ST(0) = sv_newmortal();
10616 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10621 unixpath_fromperl(pTHX_ CV *cv)
10627 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10628 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10629 ST(0) = sv_newmortal();
10630 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10635 candelete_fromperl(pTHX_ CV *cv)
10643 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10645 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10646 Newx(fspec, VMS_MAXRSS, char);
10647 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
10648 if (SvTYPE(mysv) == SVt_PVGV) {
10649 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10650 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10658 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10659 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10666 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10672 rmscopy_fromperl(pTHX_ CV *cv)
10675 char *inspec, *outspec, *inp, *outp;
10677 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10678 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10679 unsigned long int sts;
10684 if (items < 2 || items > 3)
10685 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10687 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10688 Newx(inspec, VMS_MAXRSS, char);
10689 if (SvTYPE(mysv) == SVt_PVGV) {
10690 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10691 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10699 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10700 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10706 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10707 Newx(outspec, VMS_MAXRSS, char);
10708 if (SvTYPE(mysv) == SVt_PVGV) {
10709 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10710 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10719 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10720 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10727 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
10729 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
10735 /* The mod2fname is limited to shorter filenames by design, so it should
10736 * not be modified to support longer EFS pathnames
10739 mod2fname(pTHX_ CV *cv)
10742 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
10743 workbuff[NAM$C_MAXRSS*1 + 1];
10744 int total_namelen = 3, counter, num_entries;
10745 /* ODS-5 ups this, but we want to be consistent, so... */
10746 int max_name_len = 39;
10747 AV *in_array = (AV *)SvRV(ST(0));
10749 num_entries = av_len(in_array);
10751 /* All the names start with PL_. */
10752 strcpy(ultimate_name, "PL_");
10754 /* Clean up our working buffer */
10755 Zero(work_name, sizeof(work_name), char);
10757 /* Run through the entries and build up a working name */
10758 for(counter = 0; counter <= num_entries; counter++) {
10759 /* If it's not the first name then tack on a __ */
10761 strcat(work_name, "__");
10763 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
10767 /* Check to see if we actually have to bother...*/
10768 if (strlen(work_name) + 3 <= max_name_len) {
10769 strcat(ultimate_name, work_name);
10771 /* It's too darned big, so we need to go strip. We use the same */
10772 /* algorithm as xsubpp does. First, strip out doubled __ */
10773 char *source, *dest, last;
10776 for (source = work_name; *source; source++) {
10777 if (last == *source && last == '_') {
10783 /* Go put it back */
10784 strcpy(work_name, workbuff);
10785 /* Is it still too big? */
10786 if (strlen(work_name) + 3 > max_name_len) {
10787 /* Strip duplicate letters */
10790 for (source = work_name; *source; source++) {
10791 if (last == toupper(*source)) {
10795 last = toupper(*source);
10797 strcpy(work_name, workbuff);
10800 /* Is it *still* too big? */
10801 if (strlen(work_name) + 3 > max_name_len) {
10802 /* Too bad, we truncate */
10803 work_name[max_name_len - 2] = 0;
10805 strcat(ultimate_name, work_name);
10808 /* Okay, return it */
10809 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
10814 hushexit_fromperl(pTHX_ CV *cv)
10819 VMSISH_HUSHED = SvTRUE(ST(0));
10821 ST(0) = boolSV(VMSISH_HUSHED);
10827 Perl_vms_start_glob
10828 (pTHX_ SV *tmpglob,
10832 struct vs_str_st *rslt;
10836 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
10839 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10840 struct dsc$descriptor_vs rsdsc;
10841 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
10842 unsigned long hasver = 0, isunix = 0;
10843 unsigned long int lff_flags = 0;
10846 #ifdef VMS_LONGNAME_SUPPORT
10847 lff_flags = LIB$M_FIL_LONG_NAMES;
10849 /* The Newx macro will not allow me to assign a smaller array
10850 * to the rslt pointer, so we will assign it to the begin char pointer
10851 * and then copy the value into the rslt pointer.
10853 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
10854 rslt = (struct vs_str_st *)begin;
10856 rstr = &rslt->str[0];
10857 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
10858 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
10859 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
10860 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
10862 Newx(vmsspec, VMS_MAXRSS, char);
10864 /* We could find out if there's an explicit dev/dir or version
10865 by peeking into lib$find_file's internal context at
10866 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
10867 but that's unsupported, so I don't want to do it now and
10868 have it bite someone in the future. */
10869 /* Fix-me: vms_split_path() is the only way to do this, the
10870 existing method will fail with many legal EFS or UNIX specifications
10873 cp = SvPV(tmpglob,i);
10876 if (cp[i] == ';') hasver = 1;
10877 if (cp[i] == '.') {
10878 if (sts) hasver = 1;
10881 if (cp[i] == '/') {
10882 hasdir = isunix = 1;
10885 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
10890 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
10893 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
10894 if (!stat_sts && S_ISDIR(st.st_mode)) {
10895 wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec);
10896 ok = (wilddsc.dsc$a_pointer != NULL);
10899 wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
10900 ok = (wilddsc.dsc$a_pointer != NULL);
10903 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
10905 /* If not extended character set, replace ? with % */
10906 /* With extended character set, ? is a wildcard single character */
10907 if (!decc_efs_case_preserve) {
10908 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
10909 if (*cp == '?') *cp = '%';
10912 while (ok && $VMS_STATUS_SUCCESS(sts)) {
10913 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10914 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10916 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
10917 &dfltdsc,NULL,&rms_sts,&lff_flags);
10918 if (!$VMS_STATUS_SUCCESS(sts))
10921 /* with varying string, 1st word of buffer contains result length */
10922 rstr[rslt->length] = '\0';
10924 /* Find where all the components are */
10925 v_sts = vms_split_path
10940 /* If no version on input, truncate the version on output */
10941 if (!hasver && (vs_len > 0)) {
10945 /* No version & a null extension on UNIX handling */
10946 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
10952 if (!decc_efs_case_preserve) {
10953 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
10957 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
10961 /* Start with the name */
10964 strcat(begin,"\n");
10965 ok = (PerlIO_puts(tmpfp,begin) != EOF);
10967 if (cxt) (void)lib$find_file_end(&cxt);
10968 if (ok && sts != RMS$_NMF &&
10969 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
10972 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
10974 PerlIO_close(tmpfp);
10978 PerlIO_rewind(tmpfp);
10979 IoTYPE(io) = IoTYPE_RDONLY;
10980 IoIFP(io) = fp = tmpfp;
10981 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
10991 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
10994 vms_realpath_fromperl(pTHX_ CV *cv)
10997 char *fspec, *rslt_spec, *rslt;
11000 if (!items || items != 1)
11001 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11003 fspec = SvPV(ST(0),n_a);
11004 if (!fspec || !*fspec) XSRETURN_UNDEF;
11006 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11007 rslt = do_vms_realpath(fspec, rslt_spec);
11008 ST(0) = sv_newmortal();
11010 sv_usepvn(ST(0),rslt,strlen(rslt));
11012 Safefree(rslt_spec);
11017 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11018 int do_vms_case_tolerant(void);
11021 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11024 ST(0) = boolSV(do_vms_case_tolerant());
11030 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11031 struct interp_intern *dst)
11033 memcpy(dst,src,sizeof(struct interp_intern));
11037 Perl_sys_intern_clear(pTHX)
11042 Perl_sys_intern_init(pTHX)
11044 unsigned int ix = RAND_MAX;
11049 /* fix me later to track running under GNV */
11050 /* this allows some limited testing */
11051 MY_POSIX_EXIT = decc_filename_unix_report;
11054 MY_INV_RAND_MAX = 1./x;
11058 init_os_extras(void)
11061 char* file = __FILE__;
11062 if (decc_disable_to_vms_logname_translation) {
11063 no_translate_barewords = TRUE;
11065 no_translate_barewords = FALSE;
11068 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11069 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11070 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11071 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11072 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11073 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11074 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11075 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11076 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11077 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11078 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11080 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11082 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11083 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11086 store_pipelocs(aTHX); /* will redo any earlier attempts */
11093 #if __CRTL_VER == 80200000
11094 /* This missed getting in to the DECC SDK for 8.2 */
11095 char *realpath(const char *file_name, char * resolved_name, ...);
11098 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11099 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11100 * The perl fallback routine to provide realpath() is not as efficient
11104 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11106 return realpath(filespec, outbuf);
11110 /* External entry points */
11111 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11112 { return do_vms_realpath(filespec, outbuf); }
11114 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11119 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11120 /* case_tolerant */
11122 /*{{{int do_vms_case_tolerant(void)*/
11123 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11124 * controlled by a process setting.
11126 int do_vms_case_tolerant(void)
11128 return vms_process_case_tolerant;
11131 /* External entry points */
11132 int Perl_vms_case_tolerant(void)
11133 { return do_vms_case_tolerant(); }
11135 int Perl_vms_case_tolerant(void)
11136 { return vms_process_case_tolerant; }
11140 /* Start of DECC RTL Feature handling */
11142 static int sys_trnlnm
11143 (const char * logname,
11147 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11148 const unsigned long attr = LNM$M_CASE_BLIND;
11149 struct dsc$descriptor_s name_dsc;
11151 unsigned short result;
11152 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11155 name_dsc.dsc$w_length = strlen(logname);
11156 name_dsc.dsc$a_pointer = (char *)logname;
11157 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11158 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11160 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11162 if ($VMS_STATUS_SUCCESS(status)) {
11164 /* Null terminate and return the string */
11165 /*--------------------------------------*/
11172 static int sys_crelnm
11173 (const char * logname,
11174 const char * value)
11177 const char * proc_table = "LNM$PROCESS_TABLE";
11178 struct dsc$descriptor_s proc_table_dsc;
11179 struct dsc$descriptor_s logname_dsc;
11180 struct itmlst_3 item_list[2];
11182 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11183 proc_table_dsc.dsc$w_length = strlen(proc_table);
11184 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11185 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11187 logname_dsc.dsc$a_pointer = (char *) logname;
11188 logname_dsc.dsc$w_length = strlen(logname);
11189 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11190 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11192 item_list[0].buflen = strlen(value);
11193 item_list[0].itmcode = LNM$_STRING;
11194 item_list[0].bufadr = (char *)value;
11195 item_list[0].retlen = NULL;
11197 item_list[1].buflen = 0;
11198 item_list[1].itmcode = 0;
11200 ret_val = sys$crelnm
11202 (const struct dsc$descriptor_s *)&proc_table_dsc,
11203 (const struct dsc$descriptor_s *)&logname_dsc,
11205 (const struct item_list_3 *) item_list);
11211 /* C RTL Feature settings */
11213 static int set_features
11214 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
11215 int (* cli_routine)(void), /* Not documented */
11216 void *image_info) /* Not documented */
11223 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11224 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11225 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11226 unsigned long case_perm;
11227 unsigned long case_image;
11230 /* Allow an exception to bring Perl into the VMS debugger */
11231 vms_debug_on_exception = 0;
11232 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11233 if ($VMS_STATUS_SUCCESS(status)) {
11234 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11235 vms_debug_on_exception = 1;
11237 vms_debug_on_exception = 0;
11241 /* hacks to see if known bugs are still present for testing */
11243 /* Readdir is returning filenames in VMS syntax always */
11244 decc_bug_readdir_efs1 = 1;
11245 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11246 if ($VMS_STATUS_SUCCESS(status)) {
11247 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11248 decc_bug_readdir_efs1 = 1;
11250 decc_bug_readdir_efs1 = 0;
11253 /* PCP mode requires creating /dev/null special device file */
11254 decc_bug_devnull = 0;
11255 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11256 if ($VMS_STATUS_SUCCESS(status)) {
11257 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11258 decc_bug_devnull = 1;
11260 decc_bug_devnull = 0;
11263 /* fgetname returning a VMS name in UNIX mode */
11264 decc_bug_fgetname = 1;
11265 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11266 if ($VMS_STATUS_SUCCESS(status)) {
11267 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11268 decc_bug_fgetname = 1;
11270 decc_bug_fgetname = 0;
11273 /* UNIX directory names with no paths are broken in a lot of places */
11274 decc_dir_barename = 1;
11275 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11276 if ($VMS_STATUS_SUCCESS(status)) {
11277 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11278 decc_dir_barename = 1;
11280 decc_dir_barename = 0;
11283 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11284 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11286 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11287 if (decc_disable_to_vms_logname_translation < 0)
11288 decc_disable_to_vms_logname_translation = 0;
11291 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11293 decc_efs_case_preserve = decc$feature_get_value(s, 1);
11294 if (decc_efs_case_preserve < 0)
11295 decc_efs_case_preserve = 0;
11298 s = decc$feature_get_index("DECC$EFS_CHARSET");
11300 decc_efs_charset = decc$feature_get_value(s, 1);
11301 if (decc_efs_charset < 0)
11302 decc_efs_charset = 0;
11305 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11307 decc_filename_unix_report = decc$feature_get_value(s, 1);
11308 if (decc_filename_unix_report > 0)
11309 decc_filename_unix_report = 1;
11311 decc_filename_unix_report = 0;
11314 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11316 decc_filename_unix_only = decc$feature_get_value(s, 1);
11317 if (decc_filename_unix_only > 0) {
11318 decc_filename_unix_only = 1;
11321 decc_filename_unix_only = 0;
11325 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11327 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11328 if (decc_filename_unix_no_version < 0)
11329 decc_filename_unix_no_version = 0;
11332 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11334 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11335 if (decc_readdir_dropdotnotype < 0)
11336 decc_readdir_dropdotnotype = 0;
11339 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11340 if ($VMS_STATUS_SUCCESS(status)) {
11341 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11343 dflt = decc$feature_get_value(s, 4);
11345 decc_disable_posix_root = decc$feature_get_value(s, 1);
11346 if (decc_disable_posix_root <= 0) {
11347 decc$feature_set_value(s, 1, 1);
11348 decc_disable_posix_root = 1;
11352 /* Traditionally Perl assumes this is off */
11353 decc_disable_posix_root = 1;
11354 decc$feature_set_value(s, 1, 1);
11359 #if __CRTL_VER >= 80200000
11360 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11362 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11363 if (decc_posix_compliant_pathnames < 0)
11364 decc_posix_compliant_pathnames = 0;
11365 if (decc_posix_compliant_pathnames > 4)
11366 decc_posix_compliant_pathnames = 0;
11371 status = sys_trnlnm
11372 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11373 if ($VMS_STATUS_SUCCESS(status)) {
11374 val_str[0] = _toupper(val_str[0]);
11375 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11376 decc_disable_to_vms_logname_translation = 1;
11381 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11382 if ($VMS_STATUS_SUCCESS(status)) {
11383 val_str[0] = _toupper(val_str[0]);
11384 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11385 decc_efs_case_preserve = 1;
11390 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11391 if ($VMS_STATUS_SUCCESS(status)) {
11392 val_str[0] = _toupper(val_str[0]);
11393 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11394 decc_filename_unix_report = 1;
11397 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11398 if ($VMS_STATUS_SUCCESS(status)) {
11399 val_str[0] = _toupper(val_str[0]);
11400 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11401 decc_filename_unix_only = 1;
11402 decc_filename_unix_report = 1;
11405 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11406 if ($VMS_STATUS_SUCCESS(status)) {
11407 val_str[0] = _toupper(val_str[0]);
11408 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11409 decc_filename_unix_no_version = 1;
11412 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11413 if ($VMS_STATUS_SUCCESS(status)) {
11414 val_str[0] = _toupper(val_str[0]);
11415 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11416 decc_readdir_dropdotnotype = 1;
11421 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11423 /* Report true case tolerance */
11424 /*----------------------------*/
11425 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11426 if (!$VMS_STATUS_SUCCESS(status))
11427 case_perm = PPROP$K_CASE_BLIND;
11428 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11429 if (!$VMS_STATUS_SUCCESS(status))
11430 case_image = PPROP$K_CASE_BLIND;
11431 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11432 (case_image == PPROP$K_CASE_SENSITIVE))
11433 vms_process_case_tolerant = 0;
11438 /* CRTL can be initialized past this point, but not before. */
11439 /* DECC$CRTL_INIT(); */
11445 /* DECC dependent attributes */
11446 #if __DECC_VER < 60560002
11448 #define not_executable
11450 #define relative ,rel
11451 #define not_executable ,noexe
11454 #pragma extern_model save
11455 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11457 const __align (LONGWORD) int spare[8] = {0};
11458 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11461 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11462 nowrt,noshr relative not_executable
11464 const long vms_cc_features = (const long)set_features;
11467 ** Force a reference to LIB$INITIALIZE to ensure it
11468 ** exists in the image.
11470 int lib$initialize(void);
11472 #pragma extern_model strict_refdef
11474 int lib_init_ref = (int) lib$initialize;
11477 #pragma extern_model restore