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;
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);
3332 static int vmspipe_file_status = 0;
3333 static char vmspipe_file[NAM$C_MAXRSS+1];
3335 /* already found? Check and use ... need read+execute permission */
3337 if (vmspipe_file_status == 1) {
3338 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3339 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3340 return vmspipe_file;
3342 vmspipe_file_status = 0;
3345 /* scan through stored @INC, $^X */
3347 if (vmspipe_file_status == 0) {
3348 char file[NAM$C_MAXRSS+1];
3349 pPLOC p = head_PLOC;
3354 strcpy(file, p->dir);
3355 dirlen = strlen(file);
3356 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3357 file[NAM$C_MAXRSS] = '\0';
3360 exp_res = do_rmsexpand
3361 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS);
3362 if (!exp_res) continue;
3364 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3365 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3366 vmspipe_file_status = 1;
3367 return vmspipe_file;
3370 vmspipe_file_status = -1; /* failed, use tempfiles */
3377 vmspipe_tempfile(pTHX)
3379 char file[NAM$C_MAXRSS+1];
3381 static int index = 0;
3385 /* create a tempfile */
3387 /* we can't go from W, shr=get to R, shr=get without
3388 an intermediate vulnerable state, so don't bother trying...
3390 and lib$spawn doesn't shr=put, so have to close the write
3392 So... match up the creation date/time and the FID to
3393 make sure we're dealing with the same file
3398 if (!decc_filename_unix_only) {
3399 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3400 fp = fopen(file,"w");
3402 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3403 fp = fopen(file,"w");
3405 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3406 fp = fopen(file,"w");
3411 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3412 fp = fopen(file,"w");
3414 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3415 fp = fopen(file,"w");
3417 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3418 fp = fopen(file,"w");
3422 if (!fp) return 0; /* we're hosed */
3424 fprintf(fp,"$! 'f$verify(0)'\n");
3425 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3426 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3427 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3428 fprintf(fp,"$ perl_on = \"set noon\"\n");
3429 fprintf(fp,"$ perl_exit = \"exit\"\n");
3430 fprintf(fp,"$ perl_del = \"delete\"\n");
3431 fprintf(fp,"$ pif = \"if\"\n");
3432 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3433 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3434 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3435 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3436 fprintf(fp,"$! --- build command line to get max possible length\n");
3437 fprintf(fp,"$c=perl_popen_cmd0\n");
3438 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3439 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3440 fprintf(fp,"$x=perl_popen_cmd3\n");
3441 fprintf(fp,"$c=c+x\n");
3442 fprintf(fp,"$ perl_on\n");
3443 fprintf(fp,"$ 'c'\n");
3444 fprintf(fp,"$ perl_status = $STATUS\n");
3445 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3446 fprintf(fp,"$ perl_exit 'perl_status'\n");
3449 fgetname(fp, file, 1);
3450 fstat(fileno(fp), (struct stat *)&s0);
3453 if (decc_filename_unix_only)
3454 do_tounixspec(file, file, 0);
3455 fp = fopen(file,"r","shr=get");
3457 fstat(fileno(fp), (struct stat *)&s1);
3459 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3460 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3471 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3473 static int handler_set_up = FALSE;
3474 unsigned long int sts, flags = CLI$M_NOWAIT;
3475 /* The use of a GLOBAL table (as was done previously) rendered
3476 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3477 * environment. Hence we've switched to LOCAL symbol table.
3479 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3481 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3482 char *in, *out, *err, mbx[512];
3484 char tfilebuf[NAM$C_MAXRSS+1];
3486 char cmd_sym_name[20];
3487 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3488 DSC$K_CLASS_S, symbol};
3489 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3491 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3492 DSC$K_CLASS_S, cmd_sym_name};
3493 struct dsc$descriptor_s *vmscmd;
3494 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3495 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3496 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3498 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3500 /* once-per-program initialization...
3501 note that the SETAST calls and the dual test of pipe_ef
3502 makes sure that only the FIRST thread through here does
3503 the initialization...all other threads wait until it's
3506 Yeah, uglier than a pthread call, it's got all the stuff inline
3507 rather than in a separate routine.
3511 _ckvmssts(sys$setast(0));
3513 unsigned long int pidcode = JPI$_PID;
3514 $DESCRIPTOR(d_delay, RETRY_DELAY);
3515 _ckvmssts(lib$get_ef(&pipe_ef));
3516 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3517 _ckvmssts(sys$bintim(&d_delay, delaytime));
3519 if (!handler_set_up) {
3520 _ckvmssts(sys$dclexh(&pipe_exitblock));
3521 handler_set_up = TRUE;
3523 _ckvmssts(sys$setast(1));
3526 /* see if we can find a VMSPIPE.COM */
3529 vmspipe = find_vmspipe(aTHX);
3531 strcpy(tfilebuf+1,vmspipe);
3532 } else { /* uh, oh...we're in tempfile hell */
3533 tpipe = vmspipe_tempfile(aTHX);
3534 if (!tpipe) { /* a fish popular in Boston */
3535 if (ckWARN(WARN_PIPE)) {
3536 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3540 fgetname(tpipe,tfilebuf+1,1);
3542 vmspipedsc.dsc$a_pointer = tfilebuf;
3543 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3545 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3548 case RMS$_FNF: case RMS$_DNF:
3549 set_errno(ENOENT); break;
3551 set_errno(ENOTDIR); break;
3553 set_errno(ENODEV); break;
3555 set_errno(EACCES); break;
3557 set_errno(EINVAL); break;
3558 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3559 set_errno(E2BIG); break;
3560 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3561 _ckvmssts(sts); /* fall through */
3562 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3565 set_vaxc_errno(sts);
3566 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3567 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3573 _ckvmssts(lib$get_vm(&n, &info));
3575 strcpy(mode,in_mode);
3578 info->completion = 0;
3579 info->closing = FALSE;
3586 info->in_done = TRUE;
3587 info->out_done = TRUE;
3588 info->err_done = TRUE;
3590 in = PerlMem_malloc(VMS_MAXRSS);
3591 if (in == NULL) _ckvmssts(SS$_INSFMEM);
3592 out = PerlMem_malloc(VMS_MAXRSS);
3593 if (out == NULL) _ckvmssts(SS$_INSFMEM);
3594 err = PerlMem_malloc(VMS_MAXRSS);
3595 if (err == NULL) _ckvmssts(SS$_INSFMEM);
3597 in[0] = out[0] = err[0] = '\0';
3599 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3603 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3608 if (*mode == 'r') { /* piping from subroutine */
3610 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3612 info->out->pipe_done = &info->out_done;
3613 info->out_done = FALSE;
3614 info->out->info = info;
3616 if (!info->useFILE) {
3617 info->fp = PerlIO_open(mbx, mode);
3619 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3620 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3623 if (!info->fp && info->out) {
3624 sys$cancel(info->out->chan_out);
3626 while (!info->out_done) {
3628 _ckvmssts(sys$setast(0));
3629 done = info->out_done;
3630 if (!done) _ckvmssts(sys$clref(pipe_ef));
3631 _ckvmssts(sys$setast(1));
3632 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3635 if (info->out->buf) {
3636 n = info->out->bufsize * sizeof(char);
3637 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3640 _ckvmssts(lib$free_vm(&n, &info->out));
3642 _ckvmssts(lib$free_vm(&n, &info));
3647 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3649 info->err->pipe_done = &info->err_done;
3650 info->err_done = FALSE;
3651 info->err->info = info;
3654 } else if (*mode == 'w') { /* piping to subroutine */
3656 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3658 info->out->pipe_done = &info->out_done;
3659 info->out_done = FALSE;
3660 info->out->info = info;
3663 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3665 info->err->pipe_done = &info->err_done;
3666 info->err_done = FALSE;
3667 info->err->info = info;
3670 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3671 if (!info->useFILE) {
3672 info->fp = PerlIO_open(mbx, mode);
3674 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3675 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3679 info->in->pipe_done = &info->in_done;
3680 info->in_done = FALSE;
3681 info->in->info = info;
3685 if (!info->fp && info->in) {
3687 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3688 0, 0, 0, 0, 0, 0, 0, 0));
3690 while (!info->in_done) {
3692 _ckvmssts(sys$setast(0));
3693 done = info->in_done;
3694 if (!done) _ckvmssts(sys$clref(pipe_ef));
3695 _ckvmssts(sys$setast(1));
3696 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3699 if (info->in->buf) {
3700 n = info->in->bufsize * sizeof(char);
3701 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3704 _ckvmssts(lib$free_vm(&n, &info->in));
3706 _ckvmssts(lib$free_vm(&n, &info));
3712 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3713 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3715 info->out->pipe_done = &info->out_done;
3716 info->out_done = FALSE;
3717 info->out->info = info;
3720 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3722 info->err->pipe_done = &info->err_done;
3723 info->err_done = FALSE;
3724 info->err->info = info;
3728 symbol[MAX_DCL_SYMBOL] = '\0';
3730 strncpy(symbol, in, MAX_DCL_SYMBOL);
3731 d_symbol.dsc$w_length = strlen(symbol);
3732 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3734 strncpy(symbol, err, MAX_DCL_SYMBOL);
3735 d_symbol.dsc$w_length = strlen(symbol);
3736 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3738 strncpy(symbol, out, MAX_DCL_SYMBOL);
3739 d_symbol.dsc$w_length = strlen(symbol);
3740 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3742 /* Done with the names for the pipes */
3747 p = vmscmd->dsc$a_pointer;
3748 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3749 if (*p == '$') p++; /* remove leading $ */
3750 while (*p == ' ' || *p == '\t') p++;
3752 for (j = 0; j < 4; j++) {
3753 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3754 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3756 strncpy(symbol, p, MAX_DCL_SYMBOL);
3757 d_symbol.dsc$w_length = strlen(symbol);
3758 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3760 if (strlen(p) > MAX_DCL_SYMBOL) {
3761 p += MAX_DCL_SYMBOL;
3766 _ckvmssts(sys$setast(0));
3767 info->next=open_pipes; /* prepend to list */
3769 _ckvmssts(sys$setast(1));
3770 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3771 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3772 * have SYS$COMMAND if we need it.
3774 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3775 0, &info->pid, &info->completion,
3776 0, popen_completion_ast,info,0,0,0));
3778 /* if we were using a tempfile, close it now */
3780 if (tpipe) fclose(tpipe);
3782 /* once the subprocess is spawned, it has copied the symbols and
3783 we can get rid of ours */
3785 for (j = 0; j < 4; j++) {
3786 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3787 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3788 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3790 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3791 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3792 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3793 vms_execfree(vmscmd);
3795 #ifdef PERL_IMPLICIT_CONTEXT
3798 PL_forkprocess = info->pid;
3803 _ckvmssts(sys$setast(0));
3805 if (!done) _ckvmssts(sys$clref(pipe_ef));
3806 _ckvmssts(sys$setast(1));
3807 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3809 *psts = info->completion;
3810 /* Caller thinks it is open and tries to close it. */
3811 /* This causes some problems, as it changes the error status */
3812 /* my_pclose(info->fp); */
3817 } /* end of safe_popen */
3820 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3822 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3826 TAINT_PROPER("popen");
3827 PERL_FLUSHALL_FOR_CHILD;
3828 return safe_popen(aTHX_ cmd,mode,&sts);
3833 /*{{{ I32 my_pclose(PerlIO *fp)*/
3834 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3836 pInfo info, last = NULL;
3837 unsigned long int retsts;
3840 for (info = open_pipes; info != NULL; last = info, info = info->next)
3841 if (info->fp == fp) break;
3843 if (info == NULL) { /* no such pipe open */
3844 set_errno(ECHILD); /* quoth POSIX */
3845 set_vaxc_errno(SS$_NONEXPR);
3849 /* If we were writing to a subprocess, insure that someone reading from
3850 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
3851 * produce an EOF record in the mailbox.
3853 * well, at least sometimes it *does*, so we have to watch out for
3854 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3858 PerlIO_flush(info->fp); /* first, flush data */
3860 fflush((FILE *)info->fp);
3863 _ckvmssts(sys$setast(0));
3864 info->closing = TRUE;
3865 done = info->done && info->in_done && info->out_done && info->err_done;
3866 /* hanging on write to Perl's input? cancel it */
3867 if (info->mode == 'r' && info->out && !info->out_done) {
3868 if (info->out->chan_out) {
3869 _ckvmssts(sys$cancel(info->out->chan_out));
3870 if (!info->out->chan_in) { /* EOF generation, need AST */
3871 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3875 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3876 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3878 _ckvmssts(sys$setast(1));
3881 PerlIO_close(info->fp);
3883 fclose((FILE *)info->fp);
3886 we have to wait until subprocess completes, but ALSO wait until all
3887 the i/o completes...otherwise we'll be freeing the "info" structure
3888 that the i/o ASTs could still be using...
3892 _ckvmssts(sys$setast(0));
3893 done = info->done && info->in_done && info->out_done && info->err_done;
3894 if (!done) _ckvmssts(sys$clref(pipe_ef));
3895 _ckvmssts(sys$setast(1));
3896 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3898 retsts = info->completion;
3900 /* remove from list of open pipes */
3901 _ckvmssts(sys$setast(0));
3902 if (last) last->next = info->next;
3903 else open_pipes = info->next;
3904 _ckvmssts(sys$setast(1));
3906 /* free buffers and structures */
3909 if (info->in->buf) {
3910 n = info->in->bufsize * sizeof(char);
3911 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3914 _ckvmssts(lib$free_vm(&n, &info->in));
3917 if (info->out->buf) {
3918 n = info->out->bufsize * sizeof(char);
3919 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3922 _ckvmssts(lib$free_vm(&n, &info->out));
3925 if (info->err->buf) {
3926 n = info->err->bufsize * sizeof(char);
3927 _ckvmssts(lib$free_vm(&n, &info->err->buf));
3930 _ckvmssts(lib$free_vm(&n, &info->err));
3933 _ckvmssts(lib$free_vm(&n, &info));
3937 } /* end of my_pclose() */
3939 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3940 /* Roll our own prototype because we want this regardless of whether
3941 * _VMS_WAIT is defined.
3943 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3945 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3946 created with popen(); otherwise partially emulate waitpid() unless
3947 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3948 Also check processes not considered by the CRTL waitpid().
3950 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3952 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3959 if (statusp) *statusp = 0;
3961 for (info = open_pipes; info != NULL; info = info->next)
3962 if (info->pid == pid) break;
3964 if (info != NULL) { /* we know about this child */
3965 while (!info->done) {
3966 _ckvmssts(sys$setast(0));
3968 if (!done) _ckvmssts(sys$clref(pipe_ef));
3969 _ckvmssts(sys$setast(1));
3970 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3973 if (statusp) *statusp = info->completion;
3977 /* child that already terminated? */
3979 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3980 if (closed_list[j].pid == pid) {
3981 if (statusp) *statusp = closed_list[j].completion;
3986 /* fall through if this child is not one of our own pipe children */
3988 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3990 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3991 * in 7.2 did we get a version that fills in the VMS completion
3992 * status as Perl has always tried to do.
3995 sts = __vms_waitpid( pid, statusp, flags );
3997 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4000 /* If the real waitpid tells us the child does not exist, we
4001 * fall through here to implement waiting for a child that
4002 * was created by some means other than exec() (say, spawned
4003 * from DCL) or to wait for a process that is not a subprocess
4004 * of the current process.
4007 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4010 $DESCRIPTOR(intdsc,"0 00:00:01");
4011 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4012 unsigned long int pidcode = JPI$_PID, mypid;
4013 unsigned long int interval[2];
4014 unsigned int jpi_iosb[2];
4015 struct itmlst_3 jpilist[2] = {
4016 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4021 /* Sorry folks, we don't presently implement rooting around for
4022 the first child we can find, and we definitely don't want to
4023 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4029 /* Get the owner of the child so I can warn if it's not mine. If the
4030 * process doesn't exist or I don't have the privs to look at it,
4031 * I can go home early.
4033 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4034 if (sts & 1) sts = jpi_iosb[0];
4046 set_vaxc_errno(sts);
4050 if (ckWARN(WARN_EXEC)) {
4051 /* remind folks they are asking for non-standard waitpid behavior */
4052 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4053 if (ownerpid != mypid)
4054 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4055 "waitpid: process %x is not a child of process %x",
4059 /* simply check on it once a second until it's not there anymore. */
4061 _ckvmssts(sys$bintim(&intdsc,interval));
4062 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4063 _ckvmssts(sys$schdwk(0,0,interval,0));
4064 _ckvmssts(sys$hiber());
4066 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4071 } /* end of waitpid() */
4076 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4078 my_gconvert(double val, int ndig, int trail, char *buf)
4080 static char __gcvtbuf[DBL_DIG+1];
4083 loc = buf ? buf : __gcvtbuf;
4085 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4087 sprintf(loc,"%.*g",ndig,val);
4093 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4094 return gcvt(val,ndig,loc);
4097 loc[0] = '0'; loc[1] = '\0';
4104 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4105 static int rms_free_search_context(struct FAB * fab)
4109 nam = fab->fab$l_nam;
4110 nam->nam$b_nop |= NAM$M_SYNCHK;
4111 nam->nam$l_rlf = NULL;
4113 return sys$parse(fab, NULL, NULL);
4116 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4117 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4118 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4119 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4120 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4121 #define rms_nam_esll(nam) nam.nam$b_esl
4122 #define rms_nam_esl(nam) nam.nam$b_esl
4123 #define rms_nam_name(nam) nam.nam$l_name
4124 #define rms_nam_namel(nam) nam.nam$l_name
4125 #define rms_nam_type(nam) nam.nam$l_type
4126 #define rms_nam_typel(nam) nam.nam$l_type
4127 #define rms_nam_ver(nam) nam.nam$l_ver
4128 #define rms_nam_verl(nam) nam.nam$l_ver
4129 #define rms_nam_rsll(nam) nam.nam$b_rsl
4130 #define rms_nam_rsl(nam) nam.nam$b_rsl
4131 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4132 #define rms_set_fna(fab, nam, name, size) \
4133 fab.fab$b_fns = size; fab.fab$l_fna = name;
4134 #define rms_get_fna(fab, nam) fab.fab$l_fna
4135 #define rms_set_dna(fab, nam, name, size) \
4136 fab.fab$b_dns = size; fab.fab$l_dna = name;
4137 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
4138 #define rms_set_esa(fab, nam, name, size) \
4139 nam.nam$b_ess = size; nam.nam$l_esa = name;
4140 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4141 nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
4142 #define rms_set_rsa(nam, name, size) \
4143 nam.nam$l_rsa = name; nam.nam$b_rss = size;
4144 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4145 nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
4148 static int rms_free_search_context(struct FAB * fab)
4152 nam = fab->fab$l_naml;
4153 nam->naml$b_nop |= NAM$M_SYNCHK;
4154 nam->naml$l_rlf = NULL;
4155 nam->naml$l_long_defname_size = 0;
4158 return sys$parse(fab, NULL, NULL);
4161 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4162 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4163 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4164 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4165 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4166 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4167 #define rms_nam_esl(nam) nam.naml$b_esl
4168 #define rms_nam_name(nam) nam.naml$l_name
4169 #define rms_nam_namel(nam) nam.naml$l_long_name
4170 #define rms_nam_type(nam) nam.naml$l_type
4171 #define rms_nam_typel(nam) nam.naml$l_long_type
4172 #define rms_nam_ver(nam) nam.naml$l_ver
4173 #define rms_nam_verl(nam) nam.naml$l_long_ver
4174 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4175 #define rms_nam_rsl(nam) nam.naml$b_rsl
4176 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4177 #define rms_set_fna(fab, nam, name, size) \
4178 fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4179 nam.naml$l_long_filename_size = size; \
4180 nam.naml$l_long_filename = name
4181 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4182 #define rms_set_dna(fab, nam, name, size) \
4183 fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4184 nam.naml$l_long_defname_size = size; \
4185 nam.naml$l_long_defname = name
4186 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4187 #define rms_set_esa(fab, nam, name, size) \
4188 nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4189 nam.naml$l_long_expand_alloc = size; \
4190 nam.naml$l_long_expand = name
4191 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4192 nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4193 nam.naml$l_long_expand = l_name; \
4194 nam.naml$l_long_expand_alloc = l_size;
4195 #define rms_set_rsa(nam, name, size) \
4196 nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4197 nam.naml$l_long_result = name; \
4198 nam.naml$l_long_result_alloc = size;
4199 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4200 nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4201 nam.naml$l_long_result = l_name; \
4202 nam.naml$l_long_result_alloc = l_size;
4207 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4208 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4209 * to expand file specification. Allows for a single default file
4210 * specification and a simple mask of options. If outbuf is non-NULL,
4211 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4212 * the resultant file specification is placed. If outbuf is NULL, the
4213 * resultant file specification is placed into a static buffer.
4214 * The third argument, if non-NULL, is taken to be a default file
4215 * specification string. The fourth argument is unused at present.
4216 * rmesexpand() returns the address of the resultant string if
4217 * successful, and NULL on error.
4219 * New functionality for previously unused opts value:
4220 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4222 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4224 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4225 /* ODS-2 only version */
4227 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4229 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
4230 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
4231 char esa[NAM$C_MAXRSS+1], *cp, *out = NULL;
4232 struct FAB myfab = cc$rms_fab;
4233 struct NAM mynam = cc$rms_nam;
4235 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4238 if (!filespec || !*filespec) {
4239 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4243 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
4244 else outbuf = __rmsexpand_retbuf;
4246 isunix = is_unix_filespec(filespec);
4248 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4253 filespec = vmsfspec;
4256 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
4257 myfab.fab$b_fns = strlen(filespec);
4258 myfab.fab$l_nam = &mynam;
4260 if (defspec && *defspec) {
4261 if (strchr(defspec,'/') != NULL) {
4262 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4269 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
4270 myfab.fab$b_dns = strlen(defspec);
4273 mynam.nam$l_esa = esa;
4274 mynam.nam$b_ess = NAM$C_MAXRSS;
4275 mynam.nam$l_rsa = outbuf;
4276 mynam.nam$b_rss = NAM$C_MAXRSS;
4278 #ifdef NAM$M_NO_SHORT_UPCASE
4279 if (decc_efs_case_preserve)
4280 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4283 retsts = sys$parse(&myfab,0,0);
4284 if (!(retsts & 1)) {
4285 mynam.nam$b_nop |= NAM$M_SYNCHK;
4286 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4287 retsts = sys$parse(&myfab,0,0);
4288 if (retsts & 1) goto expanded;
4290 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
4291 sts = sys$parse(&myfab,0,0); /* Free search context */
4292 if (out) Safefree(out);
4293 set_vaxc_errno(retsts);
4294 if (retsts == RMS$_PRV) set_errno(EACCES);
4295 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4296 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4297 else set_errno(EVMSERR);
4300 retsts = sys$search(&myfab,0,0);
4301 if (!(retsts & 1) && retsts != RMS$_FNF) {
4302 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4303 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4304 if (out) Safefree(out);
4305 set_vaxc_errno(retsts);
4306 if (retsts == RMS$_PRV) set_errno(EACCES);
4307 else set_errno(EVMSERR);
4311 /* If the input filespec contained any lowercase characters,
4312 * downcase the result for compatibility with Unix-minded code. */
4314 if (!decc_efs_case_preserve) {
4315 for (out = myfab.fab$l_fna; *out; out++)
4316 if (islower(*out)) { haslower = 1; break; }
4318 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
4319 else { out = esa; speclen = mynam.nam$b_esl; }
4321 /* Trim off null fields added by $PARSE
4322 * If type > 1 char, must have been specified in original or default spec
4323 * (not true for version; $SEARCH may have added version of existing file).
4325 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
4326 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
4327 (mynam.nam$l_ver - mynam.nam$l_type == 1);
4328 if (trimver || trimtype) {
4329 if (defspec && *defspec) {
4330 char defesa[NAM$C_MAXRSS];
4331 struct FAB deffab = cc$rms_fab;
4332 struct NAM defnam = cc$rms_nam;
4334 deffab.fab$l_nam = &defnam;
4335 /* cast below ok for read only pointer */
4336 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
4337 defnam.nam$l_esa = defesa; defnam.nam$b_ess = NAM$C_MAXRSS;
4338 defnam.nam$b_nop = NAM$M_SYNCHK;
4339 #ifdef NAM$M_NO_SHORT_UPCASE
4340 if (decc_efs_case_preserve)
4341 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4343 if (sys$parse(&deffab,0,0) & 1) {
4344 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4345 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4349 if (*mynam.nam$l_ver != '\"')
4350 speclen = mynam.nam$l_ver - out;
4353 /* If we didn't already trim version, copy down */
4354 if (speclen > mynam.nam$l_ver - out)
4355 memmove(mynam.nam$l_type, mynam.nam$l_ver,
4356 speclen - (mynam.nam$l_ver - out));
4357 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4360 /* If we just had a directory spec on input, $PARSE "helpfully"
4361 * adds an empty name and type for us */
4362 if (mynam.nam$l_name == mynam.nam$l_type &&
4363 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
4364 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4365 speclen = mynam.nam$l_name - out;
4367 /* Posix format specifications must have matching quotes */
4368 if (speclen < NAM$C_MAXRSS) {
4369 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4370 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4371 out[speclen] = '\"';
4377 out[speclen] = '\0';
4378 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4380 /* Have we been working with an expanded, but not resultant, spec? */
4381 /* Also, convert back to Unix syntax if necessary. */
4382 if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4385 if (!mynam.nam$b_rsl) {
4387 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4389 else strcpy(outbuf,esa);
4392 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4393 strcpy(outbuf,tmpfspec);
4395 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4396 mynam.nam$l_rsa = NULL;
4397 mynam.nam$b_rss = 0;
4398 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4402 /* ODS-5 supporting routine */
4404 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4406 static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4407 char * vmsfspec, *tmpfspec;
4408 char * esa, *cp, *out = NULL;
4412 struct FAB myfab = cc$rms_fab;
4413 rms_setup_nam(mynam);
4415 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4418 if (!filespec || !*filespec) {
4419 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4423 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4424 else outbuf = __rmsexpand_retbuf;
4430 isunix = is_unix_filespec(filespec);
4432 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4433 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4434 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4435 PerlMem_free(vmsfspec);
4440 filespec = vmsfspec;
4442 /* Unless we are forcing to VMS format, a UNIX input means
4443 * UNIX output, and that requires long names to be used
4445 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4446 opts |= PERL_RMSEXPAND_M_LONG;
4452 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4453 rms_bind_fab_nam(myfab, mynam);
4455 if (defspec && *defspec) {
4457 t_isunix = is_unix_filespec(defspec);
4459 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4460 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4461 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4462 PerlMem_free(tmpfspec);
4463 if (vmsfspec != NULL)
4464 PerlMem_free(vmsfspec);
4471 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4474 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4475 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4476 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4477 esal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4478 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4480 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4482 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4483 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4486 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4487 outbufl = PerlMem_malloc(VMS_MAXRSS);
4488 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4489 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4491 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4495 #ifdef NAM$M_NO_SHORT_UPCASE
4496 if (decc_efs_case_preserve)
4497 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4500 /* First attempt to parse as an existing file */
4501 retsts = sys$parse(&myfab,0,0);
4502 if (!(retsts & STS$K_SUCCESS)) {
4504 /* Could not find the file, try as syntax only if error is not fatal */
4505 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4506 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4507 retsts = sys$parse(&myfab,0,0);
4508 if (retsts & STS$K_SUCCESS) goto expanded;
4511 /* Still could not parse the file specification */
4512 /*----------------------------------------------*/
4513 sts = rms_free_search_context(&myfab); /* Free search context */
4514 if (out) Safefree(out);
4515 if (tmpfspec != NULL)
4516 PerlMem_free(tmpfspec);
4517 if (vmsfspec != NULL)
4518 PerlMem_free(vmsfspec);
4519 if (outbufl != NULL)
4520 PerlMem_free(outbufl);
4523 set_vaxc_errno(retsts);
4524 if (retsts == RMS$_PRV) set_errno(EACCES);
4525 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4526 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4527 else set_errno(EVMSERR);
4530 retsts = sys$search(&myfab,0,0);
4531 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4532 sts = rms_free_search_context(&myfab); /* Free search context */
4533 if (out) Safefree(out);
4534 if (tmpfspec != NULL)
4535 PerlMem_free(tmpfspec);
4536 if (vmsfspec != NULL)
4537 PerlMem_free(vmsfspec);
4538 if (outbufl != NULL)
4539 PerlMem_free(outbufl);
4542 set_vaxc_errno(retsts);
4543 if (retsts == RMS$_PRV) set_errno(EACCES);
4544 else set_errno(EVMSERR);
4548 /* If the input filespec contained any lowercase characters,
4549 * downcase the result for compatibility with Unix-minded code. */
4551 if (!decc_efs_case_preserve) {
4552 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4553 if (islower(*tbuf)) { haslower = 1; break; }
4556 /* Is a long or a short name expected */
4557 /*------------------------------------*/
4558 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4559 if (rms_nam_rsll(mynam)) {
4561 speclen = rms_nam_rsll(mynam);
4564 tbuf = esal; /* Not esa */
4565 speclen = rms_nam_esll(mynam);
4569 if (rms_nam_rsl(mynam)) {
4571 speclen = rms_nam_rsl(mynam);
4574 tbuf = esa; /* Not esal */
4575 speclen = rms_nam_esl(mynam);
4578 tbuf[speclen] = '\0';
4580 /* Trim off null fields added by $PARSE
4581 * If type > 1 char, must have been specified in original or default spec
4582 * (not true for version; $SEARCH may have added version of existing file).
4584 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4585 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4586 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4587 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4590 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4591 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4593 if (trimver || trimtype) {
4594 if (defspec && *defspec) {
4595 char *defesal = NULL;
4596 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4597 if (defesal != NULL) {
4598 struct FAB deffab = cc$rms_fab;
4599 rms_setup_nam(defnam);
4601 rms_bind_fab_nam(deffab, defnam);
4605 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4607 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4609 rms_clear_nam_nop(defnam);
4610 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4611 #ifdef NAM$M_NO_SHORT_UPCASE
4612 if (decc_efs_case_preserve)
4613 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4615 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4617 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4620 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4623 PerlMem_free(defesal);
4627 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4628 if (*(rms_nam_verl(mynam)) != '\"')
4629 speclen = rms_nam_verl(mynam) - tbuf;
4632 if (*(rms_nam_ver(mynam)) != '\"')
4633 speclen = rms_nam_ver(mynam) - tbuf;
4637 /* If we didn't already trim version, copy down */
4638 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4639 if (speclen > rms_nam_verl(mynam) - tbuf)
4641 (rms_nam_typel(mynam),
4642 rms_nam_verl(mynam),
4643 speclen - (rms_nam_verl(mynam) - tbuf));
4644 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4647 if (speclen > rms_nam_ver(mynam) - tbuf)
4649 (rms_nam_type(mynam),
4651 speclen - (rms_nam_ver(mynam) - tbuf));
4652 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4657 /* Done with these copies of the input files */
4658 /*-------------------------------------------*/
4659 if (vmsfspec != NULL)
4660 PerlMem_free(vmsfspec);
4661 if (tmpfspec != NULL)
4662 PerlMem_free(tmpfspec);
4664 /* If we just had a directory spec on input, $PARSE "helpfully"
4665 * adds an empty name and type for us */
4666 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4667 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4668 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4669 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4670 speclen = rms_nam_namel(mynam) - tbuf;
4673 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4674 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4675 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4676 speclen = rms_nam_name(mynam) - tbuf;
4679 /* Posix format specifications must have matching quotes */
4680 if (speclen < (VMS_MAXRSS - 1)) {
4681 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4682 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4683 tbuf[speclen] = '\"';
4688 tbuf[speclen] = '\0';
4689 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4691 /* Have we been working with an expanded, but not resultant, spec? */
4692 /* Also, convert back to Unix syntax if necessary. */
4694 if (!rms_nam_rsll(mynam)) {
4696 if (do_tounixspec(esa,outbuf,0) == NULL) {
4697 if (out) Safefree(out);
4700 if (outbufl != NULL)
4701 PerlMem_free(outbufl);
4705 else strcpy(outbuf,esa);
4708 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4709 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4710 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4711 if (out) Safefree(out);
4714 PerlMem_free(tmpfspec);
4715 if (outbufl != NULL)
4716 PerlMem_free(outbufl);
4719 strcpy(outbuf,tmpfspec);
4720 PerlMem_free(tmpfspec);
4723 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4724 sts = rms_free_search_context(&myfab); /* Free search context */
4727 if (outbufl != NULL)
4728 PerlMem_free(outbufl);
4733 /* External entry points */
4734 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4735 { return do_rmsexpand(spec,buf,0,def,opt); }
4736 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4737 { return do_rmsexpand(spec,buf,1,def,opt); }
4741 ** The following routines are provided to make life easier when
4742 ** converting among VMS-style and Unix-style directory specifications.
4743 ** All will take input specifications in either VMS or Unix syntax. On
4744 ** failure, all return NULL. If successful, the routines listed below
4745 ** return a pointer to a buffer containing the appropriately
4746 ** reformatted spec (and, therefore, subsequent calls to that routine
4747 ** will clobber the result), while the routines of the same names with
4748 ** a _ts suffix appended will return a pointer to a mallocd string
4749 ** containing the appropriately reformatted spec.
4750 ** In all cases, only explicit syntax is altered; no check is made that
4751 ** the resulting string is valid or that the directory in question
4754 ** fileify_dirspec() - convert a directory spec into the name of the
4755 ** directory file (i.e. what you can stat() to see if it's a dir).
4756 ** The style (VMS or Unix) of the result is the same as the style
4757 ** of the parameter passed in.
4758 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4759 ** what you prepend to a filename to indicate what directory it's in).
4760 ** The style (VMS or Unix) of the result is the same as the style
4761 ** of the parameter passed in.
4762 ** tounixpath() - convert a directory spec into a Unix-style path.
4763 ** tovmspath() - convert a directory spec into a VMS-style path.
4764 ** tounixspec() - convert any file spec into a Unix-style file spec.
4765 ** tovmsspec() - convert any file spec into a VMS-style spec.
4767 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4768 ** Permission is given to distribute this code as part of the Perl
4769 ** standard distribution under the terms of the GNU General Public
4770 ** License or the Perl Artistic License. Copies of each may be
4771 ** found in the Perl standard distribution.
4774 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4775 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4777 static char __fileify_retbuf[VMS_MAXRSS];
4778 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4779 char *retspec, *cp1, *cp2, *lastdir;
4780 char *trndir, *vmsdir;
4781 unsigned short int trnlnm_iter_count;
4784 if (!dir || !*dir) {
4785 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4787 dirlen = strlen(dir);
4788 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4789 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4790 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4797 if (dirlen > (VMS_MAXRSS - 1)) {
4798 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4801 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4802 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4803 if (!strpbrk(dir+1,"/]>:") &&
4804 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4805 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4806 trnlnm_iter_count = 0;
4807 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4808 trnlnm_iter_count++;
4809 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4811 dirlen = strlen(trndir);
4814 strncpy(trndir,dir,dirlen);
4815 trndir[dirlen] = '\0';
4818 /* At this point we are done with *dir and use *trndir which is a
4819 * copy that can be modified. *dir must not be modified.
4822 /* If we were handed a rooted logical name or spec, treat it like a
4823 * simple directory, so that
4824 * $ Define myroot dev:[dir.]
4825 * ... do_fileify_dirspec("myroot",buf,1) ...
4826 * does something useful.
4828 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4829 trndir[--dirlen] = '\0';
4830 trndir[dirlen-1] = ']';
4832 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4833 trndir[--dirlen] = '\0';
4834 trndir[dirlen-1] = '>';
4837 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4838 /* If we've got an explicit filename, we can just shuffle the string. */
4839 if (*(cp1+1)) hasfilename = 1;
4840 /* Similarly, we can just back up a level if we've got multiple levels
4841 of explicit directories in a VMS spec which ends with directories. */
4843 for (cp2 = cp1; cp2 > trndir; cp2--) {
4845 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4846 /* fix-me, can not scan EFS file specs backward like this */
4847 *cp2 = *cp1; *cp1 = '\0';
4852 if (*cp2 == '[' || *cp2 == '<') break;
4857 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4858 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4859 cp1 = strpbrk(trndir,"]:>");
4860 if (hasfilename || !cp1) { /* Unix-style path or filename */
4861 if (trndir[0] == '.') {
4862 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4863 PerlMem_free(trndir);
4864 PerlMem_free(vmsdir);
4865 return do_fileify_dirspec("[]",buf,ts);
4867 else if (trndir[1] == '.' &&
4868 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4869 PerlMem_free(trndir);
4870 PerlMem_free(vmsdir);
4871 return do_fileify_dirspec("[-]",buf,ts);
4874 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4875 dirlen -= 1; /* to last element */
4876 lastdir = strrchr(trndir,'/');
4878 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4879 /* If we have "/." or "/..", VMSify it and let the VMS code
4880 * below expand it, rather than repeating the code to handle
4881 * relative components of a filespec here */
4883 if (*(cp1+2) == '.') cp1++;
4884 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4886 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4887 PerlMem_free(trndir);
4888 PerlMem_free(vmsdir);
4891 if (strchr(vmsdir,'/') != NULL) {
4892 /* If do_tovmsspec() returned it, it must have VMS syntax
4893 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4894 * the time to check this here only so we avoid a recursion
4895 * loop; otherwise, gigo.
4897 PerlMem_free(trndir);
4898 PerlMem_free(vmsdir);
4899 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4902 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4903 PerlMem_free(trndir);
4904 PerlMem_free(vmsdir);
4907 ret_chr = do_tounixspec(trndir,buf,ts);
4908 PerlMem_free(trndir);
4909 PerlMem_free(vmsdir);
4913 } while ((cp1 = strstr(cp1,"/.")) != NULL);
4914 lastdir = strrchr(trndir,'/');
4916 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4918 /* Ditto for specs that end in an MFD -- let the VMS code
4919 * figure out whether it's a real device or a rooted logical. */
4921 /* This should not happen any more. Allowing the fake /000000
4922 * in a UNIX pathname causes all sorts of problems when trying
4923 * to run in UNIX emulation. So the VMS to UNIX conversions
4924 * now remove the fake /000000 directories.
4927 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4928 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4929 PerlMem_free(trndir);
4930 PerlMem_free(vmsdir);
4933 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4934 PerlMem_free(trndir);
4935 PerlMem_free(vmsdir);
4938 ret_chr = do_tounixspec(trndir,buf,ts);
4939 PerlMem_free(trndir);
4940 PerlMem_free(vmsdir);
4945 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4946 !(lastdir = cp1 = strrchr(trndir,']')) &&
4947 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4948 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
4951 /* For EFS or ODS-5 look for the last dot */
4952 if (decc_efs_charset) {
4953 cp2 = strrchr(cp1,'.');
4955 if (vms_process_case_tolerant) {
4956 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4957 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4958 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4959 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4960 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4961 (ver || *cp3)))))) {
4962 PerlMem_free(trndir);
4963 PerlMem_free(vmsdir);
4965 set_vaxc_errno(RMS$_DIR);
4970 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4971 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4972 !*(cp2+3) || *(cp2+3) != 'R' ||
4973 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4974 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4975 (ver || *cp3)))))) {
4976 PerlMem_free(trndir);
4977 PerlMem_free(vmsdir);
4979 set_vaxc_errno(RMS$_DIR);
4983 dirlen = cp2 - trndir;
4987 retlen = dirlen + 6;
4988 if (buf) retspec = buf;
4989 else if (ts) Newx(retspec,retlen+1,char);
4990 else retspec = __fileify_retbuf;
4991 memcpy(retspec,trndir,dirlen);
4992 retspec[dirlen] = '\0';
4994 /* We've picked up everything up to the directory file name.
4995 Now just add the type and version, and we're set. */
4996 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4997 strcat(retspec,".dir;1");
4999 strcat(retspec,".DIR;1");
5000 PerlMem_free(trndir);
5001 PerlMem_free(vmsdir);
5004 else { /* VMS-style directory spec */
5006 char *esa, term, *cp;
5007 unsigned long int sts, cmplen, haslower = 0;
5008 unsigned int nam_fnb;
5010 struct FAB dirfab = cc$rms_fab;
5011 rms_setup_nam(savnam);
5012 rms_setup_nam(dirnam);
5014 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5015 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5016 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5017 rms_bind_fab_nam(dirfab, dirnam);
5018 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5019 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5020 #ifdef NAM$M_NO_SHORT_UPCASE
5021 if (decc_efs_case_preserve)
5022 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5025 for (cp = trndir; *cp; cp++)
5026 if (islower(*cp)) { haslower = 1; break; }
5027 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5028 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5029 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5030 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5034 PerlMem_free(trndir);
5035 PerlMem_free(vmsdir);
5037 set_vaxc_errno(dirfab.fab$l_sts);
5043 /* Does the file really exist? */
5044 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5045 /* Yes; fake the fnb bits so we'll check type below */
5046 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5048 else { /* No; just work with potential name */
5049 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5052 fab_sts = dirfab.fab$l_sts;
5053 sts = rms_free_search_context(&dirfab);
5055 PerlMem_free(trndir);
5056 PerlMem_free(vmsdir);
5057 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5062 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5063 cp1 = strchr(esa,']');
5064 if (!cp1) cp1 = strchr(esa,'>');
5065 if (cp1) { /* Should always be true */
5066 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5067 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5070 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5071 /* Yep; check version while we're at it, if it's there. */
5072 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5073 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5074 /* Something other than .DIR[;1]. Bzzt. */
5075 sts = rms_free_search_context(&dirfab);
5077 PerlMem_free(trndir);
5078 PerlMem_free(vmsdir);
5080 set_vaxc_errno(RMS$_DIR);
5084 esa[rms_nam_esll(dirnam)] = '\0';
5085 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5086 /* They provided at least the name; we added the type, if necessary, */
5087 if (buf) retspec = buf; /* in sys$parse() */
5088 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5089 else retspec = __fileify_retbuf;
5090 strcpy(retspec,esa);
5091 sts = rms_free_search_context(&dirfab);
5092 PerlMem_free(trndir);
5094 PerlMem_free(vmsdir);
5097 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5098 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5100 rms_nam_esll(dirnam) -= 9;
5102 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5103 if (cp1 == NULL) { /* should never happen */
5104 sts = rms_free_search_context(&dirfab);
5105 PerlMem_free(trndir);
5107 PerlMem_free(vmsdir);
5112 retlen = strlen(esa);
5113 cp1 = strrchr(esa,'.');
5114 /* ODS-5 directory specifications can have extra "." in them. */
5115 /* Fix-me, can not scan EFS file specifications backwards */
5116 while (cp1 != NULL) {
5117 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5121 while ((cp1 > esa) && (*cp1 != '.'))
5128 if ((cp1) != NULL) {
5129 /* There's more than one directory in the path. Just roll back. */
5131 if (buf) retspec = buf;
5132 else if (ts) Newx(retspec,retlen+7,char);
5133 else retspec = __fileify_retbuf;
5134 strcpy(retspec,esa);
5137 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5138 /* Go back and expand rooted logical name */
5139 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5140 #ifdef NAM$M_NO_SHORT_UPCASE
5141 if (decc_efs_case_preserve)
5142 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5144 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5145 sts = rms_free_search_context(&dirfab);
5147 PerlMem_free(trndir);
5148 PerlMem_free(vmsdir);
5150 set_vaxc_errno(dirfab.fab$l_sts);
5153 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5154 if (buf) retspec = buf;
5155 else if (ts) Newx(retspec,retlen+16,char);
5156 else retspec = __fileify_retbuf;
5157 cp1 = strstr(esa,"][");
5158 if (!cp1) cp1 = strstr(esa,"]<");
5160 memcpy(retspec,esa,dirlen);
5161 if (!strncmp(cp1+2,"000000]",7)) {
5162 retspec[dirlen-1] = '\0';
5163 /* fix-me Not full ODS-5, just extra dots in directories for now */
5164 cp1 = retspec + dirlen - 1;
5165 while (cp1 > retspec)
5170 if (*(cp1-1) != '^')
5175 if (*cp1 == '.') *cp1 = ']';
5177 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5178 memmove(cp1+1,"000000]",7);
5182 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5183 retspec[retlen] = '\0';
5184 /* Convert last '.' to ']' */
5185 cp1 = retspec+retlen-1;
5186 while (*cp != '[') {
5189 /* Do not trip on extra dots in ODS-5 directories */
5190 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5194 if (*cp1 == '.') *cp1 = ']';
5196 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5197 memmove(cp1+1,"000000]",7);
5201 else { /* This is a top-level dir. Add the MFD to the path. */
5202 if (buf) retspec = buf;
5203 else if (ts) Newx(retspec,retlen+16,char);
5204 else retspec = __fileify_retbuf;
5207 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5208 strcpy(cp2,":[000000]");
5213 sts = rms_free_search_context(&dirfab);
5214 /* We've set up the string up through the filename. Add the
5215 type and version, and we're done. */
5216 strcat(retspec,".DIR;1");
5218 /* $PARSE may have upcased filespec, so convert output to lower
5219 * case if input contained any lowercase characters. */
5220 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5221 PerlMem_free(trndir);
5223 PerlMem_free(vmsdir);
5226 } /* end of do_fileify_dirspec() */
5228 /* External entry points */
5229 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5230 { return do_fileify_dirspec(dir,buf,0); }
5231 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5232 { return do_fileify_dirspec(dir,buf,1); }
5234 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5235 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5237 static char __pathify_retbuf[VMS_MAXRSS];
5238 unsigned long int retlen;
5239 char *retpath, *cp1, *cp2, *trndir;
5240 unsigned short int trnlnm_iter_count;
5244 if (!dir || !*dir) {
5245 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5248 trndir = PerlMem_malloc(VMS_MAXRSS);
5249 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5250 if (*dir) strcpy(trndir,dir);
5251 else getcwd(trndir,VMS_MAXRSS - 1);
5253 trnlnm_iter_count = 0;
5254 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5255 && my_trnlnm(trndir,trndir,0)) {
5256 trnlnm_iter_count++;
5257 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5258 trnlen = strlen(trndir);
5260 /* Trap simple rooted lnms, and return lnm:[000000] */
5261 if (!strcmp(trndir+trnlen-2,".]")) {
5262 if (buf) retpath = buf;
5263 else if (ts) Newx(retpath,strlen(dir)+10,char);
5264 else retpath = __pathify_retbuf;
5265 strcpy(retpath,dir);
5266 strcat(retpath,":[000000]");
5267 PerlMem_free(trndir);
5272 /* At this point we do not work with *dir, but the copy in
5273 * *trndir that is modifiable.
5276 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5277 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5278 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5279 retlen = 2 + (*(trndir+1) != '\0');
5281 if ( !(cp1 = strrchr(trndir,'/')) &&
5282 !(cp1 = strrchr(trndir,']')) &&
5283 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5284 if ((cp2 = strchr(cp1,'.')) != NULL &&
5285 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5286 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5287 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5288 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5291 /* For EFS or ODS-5 look for the last dot */
5292 if (decc_efs_charset) {
5293 cp2 = strrchr(cp1,'.');
5295 if (vms_process_case_tolerant) {
5296 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5297 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5298 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5299 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5300 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5301 (ver || *cp3)))))) {
5302 PerlMem_free(trndir);
5304 set_vaxc_errno(RMS$_DIR);
5309 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5310 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5311 !*(cp2+3) || *(cp2+3) != 'R' ||
5312 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5313 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5314 (ver || *cp3)))))) {
5315 PerlMem_free(trndir);
5317 set_vaxc_errno(RMS$_DIR);
5321 retlen = cp2 - trndir + 1;
5323 else { /* No file type present. Treat the filename as a directory. */
5324 retlen = strlen(trndir) + 1;
5327 if (buf) retpath = buf;
5328 else if (ts) Newx(retpath,retlen+1,char);
5329 else retpath = __pathify_retbuf;
5330 strncpy(retpath, trndir, retlen-1);
5331 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5332 retpath[retlen-1] = '/'; /* with '/', add it. */
5333 retpath[retlen] = '\0';
5335 else retpath[retlen-1] = '\0';
5337 else { /* VMS-style directory spec */
5339 unsigned long int sts, cmplen, haslower;
5340 struct FAB dirfab = cc$rms_fab;
5342 rms_setup_nam(savnam);
5343 rms_setup_nam(dirnam);
5345 /* If we've got an explicit filename, we can just shuffle the string. */
5346 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5347 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5348 if ((cp2 = strchr(cp1,'.')) != NULL) {
5350 if (vms_process_case_tolerant) {
5351 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5352 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5353 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5354 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5355 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5356 (ver || *cp3)))))) {
5357 PerlMem_free(trndir);
5359 set_vaxc_errno(RMS$_DIR);
5364 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5365 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5366 !*(cp2+3) || *(cp2+3) != 'R' ||
5367 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5368 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5369 (ver || *cp3)))))) {
5370 PerlMem_free(trndir);
5372 set_vaxc_errno(RMS$_DIR);
5377 else { /* No file type, so just draw name into directory part */
5378 for (cp2 = cp1; *cp2; cp2++) ;
5381 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5383 /* We've now got a VMS 'path'; fall through */
5386 dirlen = strlen(trndir);
5387 if (trndir[dirlen-1] == ']' ||
5388 trndir[dirlen-1] == '>' ||
5389 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5390 if (buf) retpath = buf;
5391 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5392 else retpath = __pathify_retbuf;
5393 strcpy(retpath,trndir);
5394 PerlMem_free(trndir);
5397 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5398 esa = PerlMem_malloc(VMS_MAXRSS);
5399 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5400 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5401 rms_bind_fab_nam(dirfab, dirnam);
5402 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5403 #ifdef NAM$M_NO_SHORT_UPCASE
5404 if (decc_efs_case_preserve)
5405 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5408 for (cp = trndir; *cp; cp++)
5409 if (islower(*cp)) { haslower = 1; break; }
5411 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5412 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5413 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5414 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5417 PerlMem_free(trndir);
5420 set_vaxc_errno(dirfab.fab$l_sts);
5426 /* Does the file really exist? */
5427 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5428 if (dirfab.fab$l_sts != RMS$_FNF) {
5430 sts1 = rms_free_search_context(&dirfab);
5431 PerlMem_free(trndir);
5434 set_vaxc_errno(dirfab.fab$l_sts);
5437 dirnam = savnam; /* No; just work with potential name */
5440 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5441 /* Yep; check version while we're at it, if it's there. */
5442 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5443 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5445 /* Something other than .DIR[;1]. Bzzt. */
5446 sts2 = rms_free_search_context(&dirfab);
5447 PerlMem_free(trndir);
5450 set_vaxc_errno(RMS$_DIR);
5454 /* OK, the type was fine. Now pull any file name into the
5456 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5458 cp1 = strrchr(esa,'>');
5459 *(rms_nam_typel(dirnam)) = '>';
5462 *(rms_nam_typel(dirnam) + 1) = '\0';
5463 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5464 if (buf) retpath = buf;
5465 else if (ts) Newx(retpath,retlen,char);
5466 else retpath = __pathify_retbuf;
5467 strcpy(retpath,esa);
5469 sts = rms_free_search_context(&dirfab);
5470 /* $PARSE may have upcased filespec, so convert output to lower
5471 * case if input contained any lowercase characters. */
5472 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5475 PerlMem_free(trndir);
5477 } /* end of do_pathify_dirspec() */
5479 /* External entry points */
5480 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5481 { return do_pathify_dirspec(dir,buf,0); }
5482 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5483 { return do_pathify_dirspec(dir,buf,1); }
5485 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5486 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5488 static char __tounixspec_retbuf[VMS_MAXRSS];
5489 char *dirend, *rslt, *cp1, *cp3, *tmp;
5491 int devlen, dirlen, retlen = VMS_MAXRSS;
5492 int expand = 1; /* guarantee room for leading and trailing slashes */
5493 unsigned short int trnlnm_iter_count;
5496 if (spec == NULL) return NULL;
5497 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5498 if (buf) rslt = buf;
5500 Newx(rslt, VMS_MAXRSS, char);
5502 else rslt = __tounixspec_retbuf;
5504 /* New VMS specific format needs translation
5505 * glob passes filenames with trailing '\n' and expects this preserved.
5507 if (decc_posix_compliant_pathnames) {
5508 if (strncmp(spec, "\"^UP^", 5) == 0) {
5514 tunix = PerlMem_malloc(VMS_MAXRSS);
5515 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5516 strcpy(tunix, spec);
5517 tunix_len = strlen(tunix);
5519 if (tunix[tunix_len - 1] == '\n') {
5520 tunix[tunix_len - 1] = '\"';
5521 tunix[tunix_len] = '\0';
5525 uspec = decc$translate_vms(tunix);
5526 PerlMem_free(tunix);
5527 if ((int)uspec > 0) {
5533 /* If we can not translate it, makemaker wants as-is */
5541 cmp_rslt = 0; /* Presume VMS */
5542 cp1 = strchr(spec, '/');
5546 /* Look for EFS ^/ */
5547 if (decc_efs_charset) {
5548 while (cp1 != NULL) {
5551 /* Found illegal VMS, assume UNIX */
5556 cp1 = strchr(cp1, '/');
5560 /* Look for "." and ".." */
5561 if (decc_filename_unix_report) {
5562 if (spec[0] == '.') {
5563 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5567 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5573 /* This is already UNIX or at least nothing VMS understands */
5581 dirend = strrchr(spec,']');
5582 if (dirend == NULL) dirend = strrchr(spec,'>');
5583 if (dirend == NULL) dirend = strchr(spec,':');
5584 if (dirend == NULL) {
5589 /* Special case 1 - sys$posix_root = / */
5590 #if __CRTL_VER >= 70000000
5591 if (!decc_disable_posix_root) {
5592 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5600 /* Special case 2 - Convert NLA0: to /dev/null */
5601 #if __CRTL_VER < 70000000
5602 cmp_rslt = strncmp(spec,"NLA0:", 5);
5604 cmp_rslt = strncmp(spec,"nla0:", 5);
5606 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5608 if (cmp_rslt == 0) {
5609 strcpy(rslt, "/dev/null");
5612 if (spec[6] != '\0') {
5619 /* Also handle special case "SYS$SCRATCH:" */
5620 #if __CRTL_VER < 70000000
5621 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5623 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5625 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5627 tmp = PerlMem_malloc(VMS_MAXRSS);
5628 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5629 if (cmp_rslt == 0) {
5632 islnm = my_trnlnm(tmp, "TMP", 0);
5634 strcpy(rslt, "/tmp");
5637 if (spec[12] != '\0') {
5645 if (*cp2 != '[' && *cp2 != '<') {
5648 else { /* the VMS spec begins with directories */
5650 if (*cp2 == ']' || *cp2 == '>') {
5651 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5655 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5656 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5657 if (ts) Safefree(rslt);
5661 trnlnm_iter_count = 0;
5664 while (*cp3 != ':' && *cp3) cp3++;
5666 if (strchr(cp3,']') != NULL) break;
5667 trnlnm_iter_count++;
5668 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5669 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5671 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5672 retlen = devlen + dirlen;
5673 Renew(rslt,retlen+1+2*expand,char);
5679 *(cp1++) = *(cp3++);
5680 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5682 return NULL; /* No room */
5687 if ((*cp2 == '^')) {
5688 /* EFS file escape, pass the next character as is */
5689 /* Fix me: HEX encoding for UNICODE not implemented */
5692 else if ( *cp2 == '.') {
5693 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5694 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5701 for (; cp2 <= dirend; cp2++) {
5702 if ((*cp2 == '^')) {
5703 /* EFS file escape, pass the next character as is */
5704 /* Fix me: HEX encoding for UNICODE not implemented */
5710 if (*(cp2+1) == '[') cp2++;
5712 else if (*cp2 == ']' || *cp2 == '>') {
5713 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5715 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5717 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5718 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5719 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5720 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5721 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5723 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5724 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5728 else if (*cp2 == '-') {
5729 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5730 while (*cp2 == '-') {
5732 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5734 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5735 if (ts) Safefree(rslt); /* filespecs like */
5736 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5740 else *(cp1++) = *cp2;
5742 else *(cp1++) = *cp2;
5744 while (*cp2) *(cp1++) = *(cp2++);
5747 /* This still leaves /000000/ when working with a
5748 * VMS device root or concealed root.
5754 ulen = strlen(rslt);
5756 /* Get rid of "000000/ in rooted filespecs */
5758 zeros = strstr(rslt, "/000000/");
5759 if (zeros != NULL) {
5761 mlen = ulen - (zeros - rslt) - 7;
5762 memmove(zeros, &zeros[7], mlen);
5771 } /* end of do_tounixspec() */
5773 /* External entry points */
5774 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5775 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5777 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5779 static int posix_to_vmsspec
5780 (char *vmspath, int vmspath_len, const char *unixpath) {
5782 struct FAB myfab = cc$rms_fab;
5783 struct NAML mynam = cc$rms_naml;
5784 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5785 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5791 /* If not a posix spec already, convert it */
5793 unixlen = strlen(unixpath);
5798 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5799 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5802 /* This is already a VMS specification, no conversion */
5804 strncpy(vmspath,unixpath, vmspath_len);
5806 vmspath[vmspath_len] = 0;
5807 if (unixpath[unixlen - 1] == '/')
5809 esa = PerlMem_malloc(VMS_MAXRSS);
5810 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5811 myfab.fab$l_fna = vmspath;
5812 myfab.fab$b_fns = strlen(vmspath);
5813 myfab.fab$l_naml = &mynam;
5814 mynam.naml$l_esa = NULL;
5815 mynam.naml$b_ess = 0;
5816 mynam.naml$l_long_expand = esa;
5817 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5818 mynam.naml$l_rsa = NULL;
5819 mynam.naml$b_rss = 0;
5820 if (decc_efs_case_preserve)
5821 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5822 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5824 /* Set up the remaining naml fields */
5825 sts = sys$parse(&myfab);
5827 /* It failed! Try again as a UNIX filespec */
5833 /* get the Device ID and the FID */
5834 sts = sys$search(&myfab);
5835 /* on any failure, returned the POSIX ^UP^ filespec */
5840 specdsc.dsc$a_pointer = vmspath;
5841 specdsc.dsc$w_length = vmspath_len;
5843 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5844 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5845 sts = lib$fid_to_name
5846 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5848 /* on any failure, returned the POSIX ^UP^ filespec */
5850 /* This can happen if user does not have permission to read directories */
5851 if (strncmp(unixpath,"\"^UP^",5) != 0)
5852 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5854 strcpy(vmspath, unixpath);
5857 vmspath[specdsc.dsc$w_length] = 0;
5859 /* Are we expecting a directory? */
5860 if (dir_flag != 0) {
5866 i = specdsc.dsc$w_length - 1;
5870 /* Version must be '1' */
5871 if (vmspath[i--] != '1')
5873 /* Version delimiter is one of ".;" */
5874 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5877 if (vmspath[i--] != 'R')
5879 if (vmspath[i--] != 'I')
5881 if (vmspath[i--] != 'D')
5883 if (vmspath[i--] != '.')
5885 eptr = &vmspath[i+1];
5887 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5888 if (vmspath[i-1] != '^') {
5896 /* Get rid of 6 imaginary zero directory filename */
5897 vmspath[i+1] = '\0';
5901 if (vmspath[i] == '0')
5915 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5916 static int posix_to_vmsspec_hardway
5917 (char *vmspath, int vmspath_len, const char *unixpath) {
5920 const char *unixptr;
5922 const char *lastslash;
5923 const char *lastdot;
5934 /* Ignore leading "/" characters */
5935 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5938 unixlen = strlen(unixptr);
5940 /* Do nothing with blank paths */
5946 lastslash = strrchr(unixptr,'/');
5947 lastdot = strrchr(unixptr,'.');
5950 /* last dot is last dot or past end of string */
5951 if (lastdot == NULL)
5952 lastdot = unixptr + unixlen;
5954 /* if no directories, set last slash to beginning of string */
5955 if (lastslash == NULL) {
5956 lastslash = unixptr;
5959 /* Watch out for trailing "." after last slash, still a directory */
5960 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5961 lastslash = unixptr + unixlen;
5964 /* Watch out for traiing ".." after last slash, still a directory */
5965 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5966 lastslash = unixptr + unixlen;
5969 /* dots in directories are aways escaped */
5970 if (lastdot < lastslash)
5971 lastdot = unixptr + unixlen;
5974 /* if (unixptr < lastslash) then we are in a directory */
5982 /* This could have a "^UP^ on the front */
5983 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5988 /* Start with the UNIX path */
5989 if (*unixptr != '/') {
5990 /* relative paths */
5991 if (lastslash > unixptr) {
5994 /* skip leading ./ */
5996 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6002 /* Are we still in a directory? */
6003 if (unixptr <= lastslash) {
6008 /* if not backing up, then it is relative forward. */
6009 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6010 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
6018 /* Perl wants an empty directory here to tell the difference
6019 * between a DCL commmand and a filename
6028 /* Handle two special files . and .. */
6029 if (unixptr[0] == '.') {
6030 if (unixptr[1] == '\0') {
6037 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
6048 else { /* Absolute PATH handling */
6052 /* Need to find out where root is */
6054 /* In theory, this procedure should never get an absolute POSIX pathname
6055 * that can not be found on the POSIX root.
6056 * In practice, that can not be relied on, and things will show up
6057 * here that are a VMS device name or concealed logical name instead.
6058 * So to make things work, this procedure must be tolerant.
6060 esa = PerlMem_malloc(vmspath_len);
6061 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6064 nextslash = strchr(&unixptr[1],'/');
6066 if (nextslash != NULL) {
6067 seg_len = nextslash - &unixptr[1];
6068 strncpy(vmspath, unixptr, seg_len + 1);
6069 vmspath[seg_len+1] = 0;
6070 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
6074 /* This is verified to be a real path */
6076 sts = posix_to_vmsspec(esa, vmspath_len, "/");
6077 strcpy(vmspath, esa);
6078 vmslen = strlen(vmspath);
6079 vmsptr = vmspath + vmslen;
6081 if (unixptr < lastslash) {
6090 cmp = strcmp(rptr,"000000.");
6095 } /* removing 6 zeros */
6096 } /* vmslen < 7, no 6 zeros possible */
6097 } /* Not in a directory */
6098 } /* end of verified real path handling */
6103 /* Ok, we have a device or a concealed root that is not in POSIX
6104 * or we have garbage. Make the best of it.
6107 /* Posix to VMS destroyed this, so copy it again */
6108 strncpy(vmspath, &unixptr[1], seg_len);
6109 vmspath[seg_len] = 0;
6111 vmsptr = &vmsptr[vmslen];
6114 /* Now do we need to add the fake 6 zero directory to it? */
6116 if ((*lastslash == '/') && (nextslash < lastslash)) {
6117 /* No there is another directory */
6123 /* now we have foo:bar or foo:[000000]bar to decide from */
6124 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6125 trnend = islnm ? islnm - 1 : 0;
6127 /* if this was a logical name, ']' or '>' must be present */
6128 /* if not a logical name, then assume a device and hope. */
6129 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6131 /* if log name and trailing '.' then rooted - treat as device */
6132 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6134 /* Fix me, if not a logical name, a device lookup should be
6135 * done to see if the device is file structured. If the device
6136 * is not file structured, the 6 zeros should not be put on.
6138 * As it is, perl is occasionally looking for dev:[000000]tty.
6139 * which looks a little strange.
6142 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
6143 /* No real directory present */
6148 /* Put the device delimiter on */
6151 unixptr = nextslash;
6154 /* Start directory if needed */
6155 if (!islnm || add_6zero) {
6161 /* add fake 000000] if needed */
6174 } /* non-POSIX translation */
6176 } /* End of relative/absolute path handling */
6178 while ((*unixptr) && (vmslen < vmspath_len)){
6183 if (dir_start != 0) {
6185 /* First characters in a directory are handled special */
6186 while ((*unixptr == '/') ||
6187 ((*unixptr == '.') &&
6188 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6193 /* Skip redundant / in specification */
6194 while ((*unixptr == '/') && (dir_start != 0)) {
6197 if (unixptr == lastslash)
6200 if (unixptr == lastslash)
6203 /* Skip redundant ./ characters */
6204 while ((*unixptr == '.') &&
6205 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6208 if (unixptr == lastslash)
6210 if (*unixptr == '/')
6213 if (unixptr == lastslash)
6216 /* Skip redundant ../ characters */
6217 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6218 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6219 /* Set the backing up flag */
6225 unixptr++; /* first . */
6226 unixptr++; /* second . */
6227 if (unixptr == lastslash)
6229 if (*unixptr == '/') /* The slash */
6232 if (unixptr == lastslash)
6235 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6236 /* Not needed when VMS is pretending to be UNIX. */
6238 /* Is this loop stuck because of too many dots? */
6239 if (loop_flag == 0) {
6240 /* Exit the loop and pass the rest through */
6245 /* Are we done with directories yet? */
6246 if (unixptr >= lastslash) {
6248 /* Watch out for trailing dots */
6257 if (*unixptr == '/')
6261 /* Have we stopped backing up? */
6266 /* dir_start continues to be = 1 */
6268 if (*unixptr == '-') {
6270 *vmsptr++ = *unixptr++;
6274 /* Now are we done with directories yet? */
6275 if (unixptr >= lastslash) {
6277 /* Watch out for trailing dots */
6293 if (*unixptr == '\0')
6296 /* Normal characters - More EFS work probably needed */
6302 /* remove multiple / */
6303 while (unixptr[1] == '/') {
6306 if (unixptr == lastslash) {
6307 /* Watch out for trailing dots */
6319 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6320 /* Not needed when VMS is pretending to be UNIX. */
6324 if (*unixptr != '\0')
6340 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6346 /* trailing dot ==> '^..' on VMS */
6347 if (*unixptr == '\0') {
6351 *vmsptr++ = *unixptr++;
6354 if (quoted && (unixptr[1] == '\0')) {
6359 *vmsptr++ = *unixptr++;
6366 *vmsptr++ = *unixptr++;
6370 if (*unixptr != '\0') {
6371 *vmsptr++ = *unixptr++;
6378 /* Make sure directory is closed */
6379 if (unixptr == lastslash) {
6381 vmsptr2 = vmsptr - 1;
6383 if (*vmsptr2 != ']') {
6386 /* directories do not end in a dot bracket */
6387 if (*vmsptr2 == '.') {
6391 if (*vmsptr2 != '^') {
6392 vmsptr--; /* back up over the dot */
6400 /* Add a trailing dot if a file with no extension */
6401 vmsptr2 = vmsptr - 1;
6402 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6403 (*lastdot != '.')) {
6414 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6415 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6416 static char __tovmsspec_retbuf[VMS_MAXRSS];
6417 char *rslt, *dirend;
6422 unsigned long int infront = 0, hasdir = 1;
6426 if (path == NULL) return NULL;
6427 rslt_len = VMS_MAXRSS-1;
6428 if (buf) rslt = buf;
6429 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6430 else rslt = __tovmsspec_retbuf;
6431 if (strpbrk(path,"]:>") ||
6432 (dirend = strrchr(path,'/')) == NULL) {
6433 if (path[0] == '.') {
6434 if (path[1] == '\0') strcpy(rslt,"[]");
6435 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6436 else strcpy(rslt,path); /* probably garbage */
6438 else strcpy(rslt,path);
6442 /* Posix specifications are now a native VMS format */
6443 /*--------------------------------------------------*/
6444 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6445 if (decc_posix_compliant_pathnames) {
6446 if (strncmp(path,"\"^UP^",5) == 0) {
6447 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6453 vms_delim = strpbrk(path,"]:>");
6455 if ((vms_delim != NULL) ||
6456 ((dirend = strrchr(path,'/')) == NULL)) {
6458 /* VMS special characters found! */
6460 if (path[0] == '.') {
6461 if (path[1] == '\0') strcpy(rslt,"[]");
6462 else if (path[1] == '.' && path[2] == '\0')
6465 /* Dot preceeding a device or directory ? */
6467 /* If not in POSIX mode, pass it through and hope it works */
6468 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6469 if (!decc_posix_compliant_pathnames)
6470 strcpy(rslt,path); /* probably garbage */
6472 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6474 strcpy(rslt,path); /* probably garbage */
6480 /* If no VMS characters and in POSIX mode, convert it!
6481 * This is the easiest way to get directory specifications
6482 * handled correctly in POSIX mode
6484 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6485 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6486 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6488 /* No unix path separators - presume VMS already */
6492 strcpy(rslt,path); /* probably garbage */
6498 /* If POSIX mode active, handle the conversion */
6499 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6500 if (decc_posix_compliant_pathnames) {
6501 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6506 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
6507 if (!*(dirend+2)) dirend +=2;
6508 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6509 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6514 lastdot = strrchr(cp2,'.');
6520 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6522 if (decc_disable_posix_root) {
6523 strcpy(rslt,"sys$disk:[000000]");
6526 strcpy(rslt,"sys$posix_root:[000000]");
6530 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6532 trndev = PerlMem_malloc(VMS_MAXRSS);
6533 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
6534 islnm = my_trnlnm(rslt,trndev,0);
6536 /* DECC special handling */
6538 if (strcmp(rslt,"bin") == 0) {
6539 strcpy(rslt,"sys$system");
6542 islnm = my_trnlnm(rslt,trndev,0);
6544 else if (strcmp(rslt,"tmp") == 0) {
6545 strcpy(rslt,"sys$scratch");
6548 islnm = my_trnlnm(rslt,trndev,0);
6550 else if (!decc_disable_posix_root) {
6551 strcpy(rslt, "sys$posix_root");
6555 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6556 islnm = my_trnlnm(rslt,trndev,0);
6558 else if (strcmp(rslt,"dev") == 0) {
6559 if (strncmp(cp2,"/null", 5) == 0) {
6560 if ((cp2[5] == 0) || (cp2[5] == '/')) {
6561 strcpy(rslt,"NLA0");
6565 islnm = my_trnlnm(rslt,trndev,0);
6571 trnend = islnm ? strlen(trndev) - 1 : 0;
6572 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6573 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6574 /* If the first element of the path is a logical name, determine
6575 * whether it has to be translated so we can add more directories. */
6576 if (!islnm || rooted) {
6579 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6583 if (cp2 != dirend) {
6584 strcpy(rslt,trndev);
6585 cp1 = rslt + trnend;
6592 if (decc_disable_posix_root) {
6598 PerlMem_free(trndev);
6603 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6604 cp2 += 2; /* skip over "./" - it's redundant */
6605 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
6607 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6608 *(cp1++) = '-'; /* "../" --> "-" */
6611 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6612 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6613 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6614 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6617 else if ((cp2 != lastdot) || (lastdot < dirend)) {
6618 /* Escape the extra dots in EFS file specifications */
6621 if (cp2 > dirend) cp2 = dirend;
6623 else *(cp1++) = '.';
6625 for (; cp2 < dirend; cp2++) {
6627 if (*(cp2-1) == '/') continue;
6628 if (*(cp1-1) != '.') *(cp1++) = '.';
6631 else if (!infront && *cp2 == '.') {
6632 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6633 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
6634 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6635 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6636 else if (*(cp1-2) == '[') *(cp1-1) = '-';
6637 else { /* back up over previous directory name */
6639 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6640 if (*(cp1-1) == '[') {
6641 memcpy(cp1,"000000.",7);
6646 if (cp2 == dirend) break;
6648 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6649 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6650 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6651 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6653 *(cp1++) = '.'; /* Simulate trailing '/' */
6654 cp2 += 2; /* for loop will incr this to == dirend */
6656 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
6659 if (decc_efs_charset == 0)
6660 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
6662 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
6668 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
6670 if (decc_efs_charset == 0)
6677 else *(cp1++) = *cp2;
6681 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6682 if (hasdir) *(cp1++) = ']';
6683 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
6684 /* fixme for ODS5 */
6699 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6700 decc_readdir_dropdotnotype) {
6705 /* trailing dot ==> '^..' on VMS */
6712 *(cp1++) = *(cp2++);
6740 *(cp1++) = *(cp2++);
6743 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6744 * which is wrong. UNIX notation should be ".dir." unless
6745 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6746 * changing this behavior could break more things at this time.
6747 * efs character set effectively does not allow "." to be a version
6748 * delimiter as a further complication about changing this.
6750 if (decc_filename_unix_report != 0) {
6753 *(cp1++) = *(cp2++);
6756 *(cp1++) = *(cp2++);
6759 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6763 /* Fix me for "^]", but that requires making sure that you do
6764 * not back up past the start of the filename
6766 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6773 } /* end of do_tovmsspec() */
6775 /* External entry points */
6776 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6777 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6779 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6780 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6781 static char __tovmspath_retbuf[VMS_MAXRSS];
6783 char *pathified, *vmsified, *cp;
6785 if (path == NULL) return NULL;
6786 pathified = PerlMem_malloc(VMS_MAXRSS);
6787 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6788 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6789 PerlMem_free(pathified);
6795 Newx(vmsified, VMS_MAXRSS, char);
6796 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) {
6797 PerlMem_free(pathified);
6798 if (vmsified) Safefree(vmsified);
6801 PerlMem_free(pathified);
6806 vmslen = strlen(vmsified);
6807 Newx(cp,vmslen+1,char);
6808 memcpy(cp,vmsified,vmslen);
6814 strcpy(__tovmspath_retbuf,vmsified);
6816 return __tovmspath_retbuf;
6819 } /* end of do_tovmspath() */
6821 /* External entry points */
6822 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6823 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6826 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6827 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6828 static char __tounixpath_retbuf[VMS_MAXRSS];
6830 char *pathified, *unixified, *cp;
6832 if (path == NULL) return NULL;
6833 pathified = PerlMem_malloc(VMS_MAXRSS);
6834 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6835 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6836 PerlMem_free(pathified);
6842 Newx(unixified, VMS_MAXRSS, char);
6844 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6845 PerlMem_free(pathified);
6846 if (unixified) Safefree(unixified);
6849 PerlMem_free(pathified);
6854 unixlen = strlen(unixified);
6855 Newx(cp,unixlen+1,char);
6856 memcpy(cp,unixified,unixlen);
6858 Safefree(unixified);
6862 strcpy(__tounixpath_retbuf,unixified);
6863 Safefree(unixified);
6864 return __tounixpath_retbuf;
6867 } /* end of do_tounixpath() */
6869 /* External entry points */
6870 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6871 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6874 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
6876 *****************************************************************************
6878 * Copyright (C) 1989-1994 by *
6879 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
6881 * Permission is hereby granted for the reproduction of this software, *
6882 * on condition that this copyright notice is included in the reproduction, *
6883 * and that such reproduction is not for purposes of profit or material *
6886 * 27-Aug-1994 Modified for inclusion in perl5 *
6887 * by Charles Bailey bailey@newman.upenn.edu *
6888 *****************************************************************************
6892 * getredirection() is intended to aid in porting C programs
6893 * to VMS (Vax-11 C). The native VMS environment does not support
6894 * '>' and '<' I/O redirection, or command line wild card expansion,
6895 * or a command line pipe mechanism using the '|' AND background
6896 * command execution '&'. All of these capabilities are provided to any
6897 * C program which calls this procedure as the first thing in the
6899 * The piping mechanism will probably work with almost any 'filter' type
6900 * of program. With suitable modification, it may useful for other
6901 * portability problems as well.
6903 * Author: Mark Pizzolato mark@infocomm.com
6907 struct list_item *next;
6911 static void add_item(struct list_item **head,
6912 struct list_item **tail,
6916 static void mp_expand_wild_cards(pTHX_ char *item,
6917 struct list_item **head,
6918 struct list_item **tail,
6921 static int background_process(pTHX_ int argc, char **argv);
6923 static void pipe_and_fork(pTHX_ char **cmargv);
6925 /*{{{ void getredirection(int *ac, char ***av)*/
6927 mp_getredirection(pTHX_ int *ac, char ***av)
6929 * Process vms redirection arg's. Exit if any error is seen.
6930 * If getredirection() processes an argument, it is erased
6931 * from the vector. getredirection() returns a new argc and argv value.
6932 * In the event that a background command is requested (by a trailing "&"),
6933 * this routine creates a background subprocess, and simply exits the program.
6935 * Warning: do not try to simplify the code for vms. The code
6936 * presupposes that getredirection() is called before any data is
6937 * read from stdin or written to stdout.
6939 * Normal usage is as follows:
6945 * getredirection(&argc, &argv);
6949 int argc = *ac; /* Argument Count */
6950 char **argv = *av; /* Argument Vector */
6951 char *ap; /* Argument pointer */
6952 int j; /* argv[] index */
6953 int item_count = 0; /* Count of Items in List */
6954 struct list_item *list_head = 0; /* First Item in List */
6955 struct list_item *list_tail; /* Last Item in List */
6956 char *in = NULL; /* Input File Name */
6957 char *out = NULL; /* Output File Name */
6958 char *outmode = "w"; /* Mode to Open Output File */
6959 char *err = NULL; /* Error File Name */
6960 char *errmode = "w"; /* Mode to Open Error File */
6961 int cmargc = 0; /* Piped Command Arg Count */
6962 char **cmargv = NULL;/* Piped Command Arg Vector */
6965 * First handle the case where the last thing on the line ends with
6966 * a '&'. This indicates the desire for the command to be run in a
6967 * subprocess, so we satisfy that desire.
6970 if (0 == strcmp("&", ap))
6971 exit(background_process(aTHX_ --argc, argv));
6972 if (*ap && '&' == ap[strlen(ap)-1])
6974 ap[strlen(ap)-1] = '\0';
6975 exit(background_process(aTHX_ argc, argv));
6978 * Now we handle the general redirection cases that involve '>', '>>',
6979 * '<', and pipes '|'.
6981 for (j = 0; j < argc; ++j)
6983 if (0 == strcmp("<", argv[j]))
6987 fprintf(stderr,"No input file after < on command line");
6988 exit(LIB$_WRONUMARG);
6993 if ('<' == *(ap = argv[j]))
6998 if (0 == strcmp(">", ap))
7002 fprintf(stderr,"No output file after > on command line");
7003 exit(LIB$_WRONUMARG);
7022 fprintf(stderr,"No output file after > or >> on command line");
7023 exit(LIB$_WRONUMARG);
7027 if (('2' == *ap) && ('>' == ap[1]))
7044 fprintf(stderr,"No output file after 2> or 2>> on command line");
7045 exit(LIB$_WRONUMARG);
7049 if (0 == strcmp("|", argv[j]))
7053 fprintf(stderr,"No command into which to pipe on command line");
7054 exit(LIB$_WRONUMARG);
7056 cmargc = argc-(j+1);
7057 cmargv = &argv[j+1];
7061 if ('|' == *(ap = argv[j]))
7069 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7072 * Allocate and fill in the new argument vector, Some Unix's terminate
7073 * the list with an extra null pointer.
7075 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7076 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7078 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7079 argv[j] = list_head->value;
7085 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7086 exit(LIB$_INVARGORD);
7088 pipe_and_fork(aTHX_ cmargv);
7091 /* Check for input from a pipe (mailbox) */
7093 if (in == NULL && 1 == isapipe(0))
7095 char mbxname[L_tmpnam];
7097 long int dvi_item = DVI$_DEVBUFSIZ;
7098 $DESCRIPTOR(mbxnam, "");
7099 $DESCRIPTOR(mbxdevnam, "");
7101 /* Input from a pipe, reopen it in binary mode to disable */
7102 /* carriage control processing. */
7104 fgetname(stdin, mbxname);
7105 mbxnam.dsc$a_pointer = mbxname;
7106 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7107 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7108 mbxdevnam.dsc$a_pointer = mbxname;
7109 mbxdevnam.dsc$w_length = sizeof(mbxname);
7110 dvi_item = DVI$_DEVNAM;
7111 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7112 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7115 freopen(mbxname, "rb", stdin);
7118 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7122 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7124 fprintf(stderr,"Can't open input file %s as stdin",in);
7127 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7129 fprintf(stderr,"Can't open output file %s as stdout",out);
7132 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7135 if (strcmp(err,"&1") == 0) {
7136 dup2(fileno(stdout), fileno(stderr));
7137 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7140 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7142 fprintf(stderr,"Can't open error file %s as stderr",err);
7146 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7150 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7153 #ifdef ARGPROC_DEBUG
7154 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7155 for (j = 0; j < *ac; ++j)
7156 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7158 /* Clear errors we may have hit expanding wildcards, so they don't
7159 show up in Perl's $! later */
7160 set_errno(0); set_vaxc_errno(1);
7161 } /* end of getredirection() */
7164 static void add_item(struct list_item **head,
7165 struct list_item **tail,
7171 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7172 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7176 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7177 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7178 *tail = (*tail)->next;
7180 (*tail)->value = value;
7184 static void mp_expand_wild_cards(pTHX_ char *item,
7185 struct list_item **head,
7186 struct list_item **tail,
7190 unsigned long int context = 0;
7198 $DESCRIPTOR(filespec, "");
7199 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7200 $DESCRIPTOR(resultspec, "");
7201 unsigned long int lff_flags = 0;
7205 #ifdef VMS_LONGNAME_SUPPORT
7206 lff_flags = LIB$M_FIL_LONG_NAMES;
7209 for (cp = item; *cp; cp++) {
7210 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7211 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7213 if (!*cp || isspace(*cp))
7215 add_item(head, tail, item, count);
7220 /* "double quoted" wild card expressions pass as is */
7221 /* From DCL that means using e.g.: */
7222 /* perl program """perl.*""" */
7223 item_len = strlen(item);
7224 if ( '"' == *item && '"' == item[item_len-1] )
7227 item[item_len-2] = '\0';
7228 add_item(head, tail, item, count);
7232 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7233 resultspec.dsc$b_class = DSC$K_CLASS_D;
7234 resultspec.dsc$a_pointer = NULL;
7235 vmsspec = PerlMem_malloc(VMS_MAXRSS);
7236 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7237 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7238 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7239 if (!isunix || !filespec.dsc$a_pointer)
7240 filespec.dsc$a_pointer = item;
7241 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7243 * Only return version specs, if the caller specified a version
7245 had_version = strchr(item, ';');
7247 * Only return device and directory specs, if the caller specifed either.
7249 had_device = strchr(item, ':');
7250 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7252 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7253 (&filespec, &resultspec, &context,
7254 &defaultspec, 0, &rms_sts, &lff_flags)))
7259 string = PerlMem_malloc(resultspec.dsc$w_length+1);
7260 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7261 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7262 string[resultspec.dsc$w_length] = '\0';
7263 if (NULL == had_version)
7264 *(strrchr(string, ';')) = '\0';
7265 if ((!had_directory) && (had_device == NULL))
7267 if (NULL == (devdir = strrchr(string, ']')))
7268 devdir = strrchr(string, '>');
7269 strcpy(string, devdir + 1);
7272 * Be consistent with what the C RTL has already done to the rest of
7273 * the argv items and lowercase all of these names.
7275 if (!decc_efs_case_preserve) {
7276 for (c = string; *c; ++c)
7280 if (isunix) trim_unixpath(string,item,1);
7281 add_item(head, tail, string, count);
7284 PerlMem_free(vmsspec);
7285 if (sts != RMS$_NMF)
7287 set_vaxc_errno(sts);
7290 case RMS$_FNF: case RMS$_DNF:
7291 set_errno(ENOENT); break;
7293 set_errno(ENOTDIR); break;
7295 set_errno(ENODEV); break;
7296 case RMS$_FNM: case RMS$_SYN:
7297 set_errno(EINVAL); break;
7299 set_errno(EACCES); break;
7301 _ckvmssts_noperl(sts);
7305 add_item(head, tail, item, count);
7306 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7307 _ckvmssts_noperl(lib$find_file_end(&context));
7310 static int child_st[2];/* Event Flag set when child process completes */
7312 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
7314 static unsigned long int exit_handler(int *status)
7318 if (0 == child_st[0])
7320 #ifdef ARGPROC_DEBUG
7321 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7323 fflush(stdout); /* Have to flush pipe for binary data to */
7324 /* terminate properly -- <tp@mccall.com> */
7325 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7326 sys$dassgn(child_chan);
7328 sys$synch(0, child_st);
7333 static void sig_child(int chan)
7335 #ifdef ARGPROC_DEBUG
7336 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7338 if (child_st[0] == 0)
7342 static struct exit_control_block exit_block =
7347 &exit_block.exit_status,
7352 pipe_and_fork(pTHX_ char **cmargv)
7355 struct dsc$descriptor_s *vmscmd;
7356 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7357 int sts, j, l, ismcr, quote, tquote = 0;
7359 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
7360 vms_execfree(vmscmd);
7365 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7366 && toupper(*(q+2)) == 'R' && !*(q+3);
7368 while (q && l < MAX_DCL_LINE_LENGTH) {
7370 if (j > 0 && quote) {
7376 if (ismcr && j > 1) quote = 1;
7377 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7380 if (quote || tquote) {
7386 if ((quote||tquote) && *q == '"') {
7396 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7398 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7402 static int background_process(pTHX_ int argc, char **argv)
7404 char command[MAX_DCL_SYMBOL + 1] = "$";
7405 $DESCRIPTOR(value, "");
7406 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7407 static $DESCRIPTOR(null, "NLA0:");
7408 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7410 $DESCRIPTOR(pidstr, "");
7412 unsigned long int flags = 17, one = 1, retsts;
7415 strcat(command, argv[0]);
7416 len = strlen(command);
7417 while (--argc && (len < MAX_DCL_SYMBOL))
7419 strcat(command, " \"");
7420 strcat(command, *(++argv));
7421 strcat(command, "\"");
7422 len = strlen(command);
7424 value.dsc$a_pointer = command;
7425 value.dsc$w_length = strlen(value.dsc$a_pointer);
7426 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7427 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7428 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7429 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7432 _ckvmssts_noperl(retsts);
7434 #ifdef ARGPROC_DEBUG
7435 PerlIO_printf(Perl_debug_log, "%s\n", command);
7437 sprintf(pidstring, "%08X", pid);
7438 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7439 pidstr.dsc$a_pointer = pidstring;
7440 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7441 lib$set_symbol(&pidsymbol, &pidstr);
7445 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7448 /* OS-specific initialization at image activation (not thread startup) */
7449 /* Older VAXC header files lack these constants */
7450 #ifndef JPI$_RIGHTS_SIZE
7451 # define JPI$_RIGHTS_SIZE 817
7453 #ifndef KGB$M_SUBSYSTEM
7454 # define KGB$M_SUBSYSTEM 0x8
7457 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7459 /*{{{void vms_image_init(int *, char ***)*/
7461 vms_image_init(int *argcp, char ***argvp)
7463 char eqv[LNM$C_NAMLENGTH+1] = "";
7464 unsigned int len, tabct = 8, tabidx = 0;
7465 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7466 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7467 unsigned short int dummy, rlen;
7468 struct dsc$descriptor_s **tabvec;
7469 #if defined(PERL_IMPLICIT_CONTEXT)
7472 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
7473 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
7474 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7477 #ifdef KILL_BY_SIGPRC
7478 Perl_csighandler_init();
7481 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7482 _ckvmssts_noperl(iosb[0]);
7483 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7484 if (iprv[i]) { /* Running image installed with privs? */
7485 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
7490 /* Rights identifiers might trigger tainting as well. */
7491 if (!will_taint && (rlen || rsz)) {
7492 while (rlen < rsz) {
7493 /* We didn't get all the identifiers on the first pass. Allocate a
7494 * buffer much larger than $GETJPI wants (rsz is size in bytes that
7495 * were needed to hold all identifiers at time of last call; we'll
7496 * allocate that many unsigned long ints), and go back and get 'em.
7497 * If it gave us less than it wanted to despite ample buffer space,
7498 * something's broken. Is your system missing a system identifier?
7500 if (rsz <= jpilist[1].buflen) {
7501 /* Perl_croak accvios when used this early in startup. */
7502 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7503 rsz, (unsigned long) jpilist[1].buflen,
7504 "Check your rights database for corruption.\n");
7507 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7508 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7509 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7510 jpilist[1].buflen = rsz * sizeof(unsigned long int);
7511 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7512 _ckvmssts_noperl(iosb[0]);
7514 mask = jpilist[1].bufadr;
7515 /* Check attribute flags for each identifier (2nd longword); protected
7516 * subsystem identifiers trigger tainting.
7518 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7519 if (mask[i] & KGB$M_SUBSYSTEM) {
7524 if (mask != rlst) PerlMem_free(mask);
7527 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7528 * logical, some versions of the CRTL will add a phanthom /000000/
7529 * directory. This needs to be removed.
7531 if (decc_filename_unix_report) {
7534 ulen = strlen(argvp[0][0]);
7536 zeros = strstr(argvp[0][0], "/000000/");
7537 if (zeros != NULL) {
7539 mlen = ulen - (zeros - argvp[0][0]) - 7;
7540 memmove(zeros, &zeros[7], mlen);
7542 argvp[0][0][ulen] = '\0';
7545 /* It also may have a trailing dot that needs to be removed otherwise
7546 * it will be converted to VMS mode incorrectly.
7549 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7550 argvp[0][0][ulen] = '\0';
7553 /* We need to use this hack to tell Perl it should run with tainting,
7554 * since its tainting flag may be part of the PL_curinterp struct, which
7555 * hasn't been allocated when vms_image_init() is called.
7558 char **newargv, **oldargv;
7560 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7561 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7562 newargv[0] = oldargv[0];
7563 newargv[1] = PerlMem_malloc(3 * sizeof(char));
7564 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7565 strcpy(newargv[1], "-T");
7566 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7568 newargv[*argcp] = NULL;
7569 /* We orphan the old argv, since we don't know where it's come from,
7570 * so we don't know how to free it.
7574 else { /* Did user explicitly request tainting? */
7576 char *cp, **av = *argvp;
7577 for (i = 1; i < *argcp; i++) {
7578 if (*av[i] != '-') break;
7579 for (cp = av[i]+1; *cp; cp++) {
7580 if (*cp == 'T') { will_taint = 1; break; }
7581 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7582 strchr("DFIiMmx",*cp)) break;
7584 if (will_taint) break;
7589 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7592 tabvec = (struct dsc$descriptor_s **)
7593 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7594 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7596 else if (tabidx >= tabct) {
7598 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7599 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7601 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7602 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7603 tabvec[tabidx]->dsc$w_length = 0;
7604 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
7605 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
7606 tabvec[tabidx]->dsc$a_pointer = NULL;
7607 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7609 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7611 getredirection(argcp,argvp);
7612 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7614 # include <reentrancy.h>
7615 decc$set_reentrancy(C$C_MULTITHREAD);
7624 * Trim Unix-style prefix off filespec, so it looks like what a shell
7625 * glob expansion would return (i.e. from specified prefix on, not
7626 * full path). Note that returned filespec is Unix-style, regardless
7627 * of whether input filespec was VMS-style or Unix-style.
7629 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7630 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
7631 * vector of options; at present, only bit 0 is used, and if set tells
7632 * trim unixpath to try the current default directory as a prefix when
7633 * presented with a possibly ambiguous ... wildcard.
7635 * Returns !=0 on success, with trimmed filespec replacing contents of
7636 * fspec, and 0 on failure, with contents of fpsec unchanged.
7638 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7640 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7642 char *unixified, *unixwild,
7643 *template, *base, *end, *cp1, *cp2;
7644 register int tmplen, reslen = 0, dirs = 0;
7646 unixwild = PerlMem_malloc(VMS_MAXRSS);
7647 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
7648 if (!wildspec || !fspec) return 0;
7649 template = unixwild;
7650 if (strpbrk(wildspec,"]>:") != NULL) {
7651 if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7652 PerlMem_free(unixwild);
7657 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7658 unixwild[VMS_MAXRSS-1] = 0;
7660 unixified = PerlMem_malloc(VMS_MAXRSS);
7661 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
7662 if (strpbrk(fspec,"]>:") != NULL) {
7663 if (do_tounixspec(fspec,unixified,0) == NULL) {
7664 PerlMem_free(unixwild);
7665 PerlMem_free(unixified);
7668 else base = unixified;
7669 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7670 * check to see that final result fits into (isn't longer than) fspec */
7671 reslen = strlen(fspec);
7675 /* No prefix or absolute path on wildcard, so nothing to remove */
7676 if (!*template || *template == '/') {
7677 PerlMem_free(unixwild);
7678 if (base == fspec) {
7679 PerlMem_free(unixified);
7682 tmplen = strlen(unixified);
7683 if (tmplen > reslen) {
7684 PerlMem_free(unixified);
7685 return 0; /* not enough space */
7687 /* Copy unixified resultant, including trailing NUL */
7688 memmove(fspec,unixified,tmplen+1);
7689 PerlMem_free(unixified);
7693 for (end = base; *end; end++) ; /* Find end of resultant filespec */
7694 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7695 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7696 for (cp1 = end ;cp1 >= base; cp1--)
7697 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7699 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7700 PerlMem_free(unixified);
7701 PerlMem_free(unixwild);
7706 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7707 int ells = 1, totells, segdirs, match;
7708 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7709 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7711 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7713 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7714 tpl = PerlMem_malloc(VMS_MAXRSS);
7715 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
7716 if (ellipsis == template && opts & 1) {
7717 /* Template begins with an ellipsis. Since we can't tell how many
7718 * directory names at the front of the resultant to keep for an
7719 * arbitrary starting point, we arbitrarily choose the current
7720 * default directory as a starting point. If it's there as a prefix,
7721 * clip it off. If not, fall through and act as if the leading
7722 * ellipsis weren't there (i.e. return shortest possible path that
7723 * could match template).
7725 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7727 PerlMem_free(unixified);
7728 PerlMem_free(unixwild);
7731 if (!decc_efs_case_preserve) {
7732 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7733 if (_tolower(*cp1) != _tolower(*cp2)) break;
7735 segdirs = dirs - totells; /* Min # of dirs we must have left */
7736 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7737 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7738 memmove(fspec,cp2+1,end - cp2);
7740 PerlMem_free(unixified);
7741 PerlMem_free(unixwild);
7745 /* First off, back up over constant elements at end of path */
7747 for (front = end ; front >= base; front--)
7748 if (*front == '/' && !dirs--) { front++; break; }
7750 lcres = PerlMem_malloc(VMS_MAXRSS);
7751 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
7752 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7754 if (!decc_efs_case_preserve) {
7755 *cp2 = _tolower(*cp1); /* Make lc copy for match */
7763 PerlMem_free(unixified);
7764 PerlMem_free(unixwild);
7765 PerlMem_free(lcres);
7766 return 0; /* Path too long. */
7769 *cp2 = '\0'; /* Pick up with memcpy later */
7770 lcfront = lcres + (front - base);
7771 /* Now skip over each ellipsis and try to match the path in front of it. */
7773 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7774 if (*(cp1) == '.' && *(cp1+1) == '.' &&
7775 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
7776 if (cp1 < template) break; /* template started with an ellipsis */
7777 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7778 ellipsis = cp1; continue;
7780 wilddsc.dsc$a_pointer = tpl;
7781 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7783 for (segdirs = 0, cp2 = tpl;
7784 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7786 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7788 if (!decc_efs_case_preserve) {
7789 *cp2 = _tolower(*cp1); /* else lowercase for match */
7792 *cp2 = *cp1; /* else preserve case for match */
7795 if (*cp2 == '/') segdirs++;
7797 if (cp1 != ellipsis - 1) {
7799 PerlMem_free(unixified);
7800 PerlMem_free(unixwild);
7801 PerlMem_free(lcres);
7802 return 0; /* Path too long */
7804 /* Back up at least as many dirs as in template before matching */
7805 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7806 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7807 for (match = 0; cp1 > lcres;) {
7808 resdsc.dsc$a_pointer = cp1;
7809 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7811 if (match == 1) lcfront = cp1;
7813 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7817 PerlMem_free(unixified);
7818 PerlMem_free(unixwild);
7819 PerlMem_free(lcres);
7820 return 0; /* Can't find prefix ??? */
7822 if (match > 1 && opts & 1) {
7823 /* This ... wildcard could cover more than one set of dirs (i.e.
7824 * a set of similar dir names is repeated). If the template
7825 * contains more than 1 ..., upstream elements could resolve the
7826 * ambiguity, but it's not worth a full backtracking setup here.
7827 * As a quick heuristic, clip off the current default directory
7828 * if it's present to find the trimmed spec, else use the
7829 * shortest string that this ... could cover.
7831 char def[NAM$C_MAXRSS+1], *st;
7833 if (getcwd(def, sizeof def,0) == NULL) {
7834 Safefree(unixified);
7840 if (!decc_efs_case_preserve) {
7841 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7842 if (_tolower(*cp1) != _tolower(*cp2)) break;
7844 segdirs = dirs - totells; /* Min # of dirs we must have left */
7845 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7846 if (*cp1 == '\0' && *cp2 == '/') {
7847 memmove(fspec,cp2+1,end - cp2);
7849 PerlMem_free(unixified);
7850 PerlMem_free(unixwild);
7851 PerlMem_free(lcres);
7854 /* Nope -- stick with lcfront from above and keep going. */
7857 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7859 PerlMem_free(unixified);
7860 PerlMem_free(unixwild);
7861 PerlMem_free(lcres);
7866 } /* end of trim_unixpath() */
7871 * VMS readdir() routines.
7872 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7874 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
7875 * Minor modifications to original routines.
7878 /* readdir may have been redefined by reentr.h, so make sure we get
7879 * the local version for what we do here.
7884 #if !defined(PERL_IMPLICIT_CONTEXT)
7885 # define readdir Perl_readdir
7887 # define readdir(a) Perl_readdir(aTHX_ a)
7890 /* Number of elements in vms_versions array */
7891 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
7894 * Open a directory, return a handle for later use.
7896 /*{{{ DIR *opendir(char*name) */
7898 Perl_opendir(pTHX_ const char *name)
7906 if (decc_efs_charset) {
7907 unix_flag = is_unix_filespec(name);
7910 Newx(dir, VMS_MAXRSS, char);
7911 if (do_tovmspath(name,dir,0) == NULL) {
7915 /* Check access before stat; otherwise stat does not
7916 * accurately report whether it's a directory.
7918 if (!cando_by_name(S_IRUSR,0,dir)) {
7919 /* cando_by_name has already set errno */
7923 if (flex_stat(dir,&sb) == -1) return NULL;
7924 if (!S_ISDIR(sb.st_mode)) {
7926 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
7929 /* Get memory for the handle, and the pattern. */
7931 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7933 /* Fill in the fields; mainly playing with the descriptor. */
7934 sprintf(dd->pattern, "%s*.*",dir);
7940 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7941 dd->pat.dsc$a_pointer = dd->pattern;
7942 dd->pat.dsc$w_length = strlen(dd->pattern);
7943 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7944 dd->pat.dsc$b_class = DSC$K_CLASS_S;
7945 #if defined(USE_ITHREADS)
7946 Newx(dd->mutex,1,perl_mutex);
7947 MUTEX_INIT( (perl_mutex *) dd->mutex );
7953 } /* end of opendir() */
7957 * Set the flag to indicate we want versions or not.
7959 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7961 vmsreaddirversions(DIR *dd, int flag)
7964 dd->flags |= PERL_VMSDIR_M_VERSIONS;
7966 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7971 * Free up an opened directory.
7973 /*{{{ void closedir(DIR *dd)*/
7975 Perl_closedir(DIR *dd)
7979 sts = lib$find_file_end(&dd->context);
7980 Safefree(dd->pattern);
7981 #if defined(USE_ITHREADS)
7982 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7983 Safefree(dd->mutex);
7990 * Collect all the version numbers for the current file.
7993 collectversions(pTHX_ DIR *dd)
7995 struct dsc$descriptor_s pat;
7996 struct dsc$descriptor_s res;
7998 char *p, *text, *buff;
8000 unsigned long context, tmpsts;
8002 /* Convenient shorthand. */
8005 /* Add the version wildcard, ignoring the "*.*" put on before */
8006 i = strlen(dd->pattern);
8007 Newx(text,i + e->d_namlen + 3,char);
8008 strcpy(text, dd->pattern);
8009 sprintf(&text[i - 3], "%s;*", e->d_name);
8011 /* Set up the pattern descriptor. */
8012 pat.dsc$a_pointer = text;
8013 pat.dsc$w_length = i + e->d_namlen - 1;
8014 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8015 pat.dsc$b_class = DSC$K_CLASS_S;
8017 /* Set up result descriptor. */
8018 Newx(buff, VMS_MAXRSS, char);
8019 res.dsc$a_pointer = buff;
8020 res.dsc$w_length = VMS_MAXRSS - 1;
8021 res.dsc$b_dtype = DSC$K_DTYPE_T;
8022 res.dsc$b_class = DSC$K_CLASS_S;
8024 /* Read files, collecting versions. */
8025 for (context = 0, e->vms_verscount = 0;
8026 e->vms_verscount < VERSIZE(e);
8027 e->vms_verscount++) {
8029 unsigned long flags = 0;
8031 #ifdef VMS_LONGNAME_SUPPORT
8032 flags = LIB$M_FIL_LONG_NAMES;
8034 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8035 if (tmpsts == RMS$_NMF || context == 0) break;
8037 buff[VMS_MAXRSS - 1] = '\0';
8038 if ((p = strchr(buff, ';')))
8039 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8041 e->vms_versions[e->vms_verscount] = -1;
8044 _ckvmssts(lib$find_file_end(&context));
8048 } /* end of collectversions() */
8051 * Read the next entry from the directory.
8053 /*{{{ struct dirent *readdir(DIR *dd)*/
8055 Perl_readdir(pTHX_ DIR *dd)
8057 struct dsc$descriptor_s res;
8059 unsigned long int tmpsts;
8061 unsigned long flags = 0;
8062 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8063 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8065 /* Set up result descriptor, and get next file. */
8066 Newx(buff, VMS_MAXRSS, char);
8067 res.dsc$a_pointer = buff;
8068 res.dsc$w_length = VMS_MAXRSS - 1;
8069 res.dsc$b_dtype = DSC$K_DTYPE_T;
8070 res.dsc$b_class = DSC$K_CLASS_S;
8072 #ifdef VMS_LONGNAME_SUPPORT
8073 flags = LIB$M_FIL_LONG_NAMES;
8076 tmpsts = lib$find_file
8077 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8078 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8079 if (!(tmpsts & 1)) {
8080 set_vaxc_errno(tmpsts);
8083 set_errno(EACCES); break;
8085 set_errno(ENODEV); break;
8087 set_errno(ENOTDIR); break;
8088 case RMS$_FNF: case RMS$_DNF:
8089 set_errno(ENOENT); break;
8097 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8098 if (!decc_efs_case_preserve) {
8099 buff[VMS_MAXRSS - 1] = '\0';
8100 for (p = buff; *p; p++) *p = _tolower(*p);
8103 /* we don't want to force to lowercase, just null terminate */
8104 buff[res.dsc$w_length] = '\0';
8106 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8109 /* Skip any directory component and just copy the name. */
8110 sts = vms_split_path
8125 /* Drop NULL extensions on UNIX file specification */
8126 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8127 (e_len == 1) && decc_readdir_dropdotnotype)) {
8132 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8133 dd->entry.d_name[n_len + e_len] = '\0';
8134 dd->entry.d_namlen = strlen(dd->entry.d_name);
8136 /* Convert the filename to UNIX format if needed */
8137 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8139 /* Translate the encoded characters. */
8140 /* Fixme: unicode handling could result in embedded 0 characters */
8141 if (strchr(dd->entry.d_name, '^') != NULL) {
8145 p = dd->entry.d_name;
8149 x = copy_expand_vms_filename_escape(q, p, &y);
8153 /* if y > 1, then this is a wide file specification */
8154 /* Wide file specifications need to be passed in Perl */
8155 /* counted strings apparently with a unicode flag */
8158 strcpy(dd->entry.d_name, new_name);
8162 dd->entry.vms_verscount = 0;
8163 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8167 } /* end of readdir() */
8171 * Read the next entry from the directory -- thread-safe version.
8173 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8175 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8179 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8181 entry = readdir(dd);
8183 retval = ( *result == NULL ? errno : 0 );
8185 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8189 } /* end of readdir_r() */
8193 * Return something that can be used in a seekdir later.
8195 /*{{{ long telldir(DIR *dd)*/
8197 Perl_telldir(DIR *dd)
8204 * Return to a spot where we used to be. Brute force.
8206 /*{{{ void seekdir(DIR *dd,long count)*/
8208 Perl_seekdir(pTHX_ DIR *dd, long count)
8212 /* If we haven't done anything yet... */
8216 /* Remember some state, and clear it. */
8217 old_flags = dd->flags;
8218 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8219 _ckvmssts(lib$find_file_end(&dd->context));
8222 /* The increment is in readdir(). */
8223 for (dd->count = 0; dd->count < count; )
8226 dd->flags = old_flags;
8228 } /* end of seekdir() */
8231 /* VMS subprocess management
8233 * my_vfork() - just a vfork(), after setting a flag to record that
8234 * the current script is trying a Unix-style fork/exec.
8236 * vms_do_aexec() and vms_do_exec() are called in response to the
8237 * perl 'exec' function. If this follows a vfork call, then they
8238 * call out the regular perl routines in doio.c which do an
8239 * execvp (for those who really want to try this under VMS).
8240 * Otherwise, they do exactly what the perl docs say exec should
8241 * do - terminate the current script and invoke a new command
8242 * (See below for notes on command syntax.)
8244 * do_aspawn() and do_spawn() implement the VMS side of the perl
8245 * 'system' function.
8247 * Note on command arguments to perl 'exec' and 'system': When handled
8248 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8249 * are concatenated to form a DCL command string. If the first arg
8250 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8251 * the command string is handed off to DCL directly. Otherwise,
8252 * the first token of the command is taken as the filespec of an image
8253 * to run. The filespec is expanded using a default type of '.EXE' and
8254 * the process defaults for device, directory, etc., and if found, the resultant
8255 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8256 * the command string as parameters. This is perhaps a bit complicated,
8257 * but I hope it will form a happy medium between what VMS folks expect
8258 * from lib$spawn and what Unix folks expect from exec.
8261 static int vfork_called;
8263 /*{{{int my_vfork()*/
8274 vms_execfree(struct dsc$descriptor_s *vmscmd)
8277 if (vmscmd->dsc$a_pointer) {
8278 PerlMem_free(vmscmd->dsc$a_pointer);
8280 PerlMem_free(vmscmd);
8285 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8287 char *junk, *tmps = Nullch;
8288 register size_t cmdlen = 0;
8295 tmps = SvPV(really,rlen);
8302 for (idx++; idx <= sp; idx++) {
8304 junk = SvPVx(*idx,rlen);
8305 cmdlen += rlen ? rlen + 1 : 0;
8308 Newx(PL_Cmd, cmdlen+1, char);
8310 if (tmps && *tmps) {
8311 strcpy(PL_Cmd,tmps);
8314 else *PL_Cmd = '\0';
8315 while (++mark <= sp) {
8317 char *s = SvPVx(*mark,n_a);
8319 if (*PL_Cmd) strcat(PL_Cmd," ");
8325 } /* end of setup_argstr() */
8328 static unsigned long int
8329 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8330 struct dsc$descriptor_s **pvmscmd)
8332 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8333 char image_name[NAM$C_MAXRSS+1];
8334 char image_argv[NAM$C_MAXRSS+1];
8335 $DESCRIPTOR(defdsc,".EXE");
8336 $DESCRIPTOR(defdsc2,".");
8337 $DESCRIPTOR(resdsc,resspec);
8338 struct dsc$descriptor_s *vmscmd;
8339 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8340 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8341 register char *s, *rest, *cp, *wordbreak;
8346 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8347 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8349 /* Make a copy for modification */
8350 cmdlen = strlen(incmd);
8351 cmd = PerlMem_malloc(cmdlen+1);
8352 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8353 strncpy(cmd, incmd, cmdlen);
8358 vmscmd->dsc$a_pointer = NULL;
8359 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8360 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8361 vmscmd->dsc$w_length = 0;
8362 if (pvmscmd) *pvmscmd = vmscmd;
8364 if (suggest_quote) *suggest_quote = 0;
8366 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8368 return CLI$_BUFOVF; /* continuation lines currently unsupported */
8373 while (*s && isspace(*s)) s++;
8375 if (*s == '@' || *s == '$') {
8376 vmsspec[0] = *s; rest = s + 1;
8377 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8379 else { cp = vmsspec; rest = s; }
8380 if (*rest == '.' || *rest == '/') {
8383 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8384 rest++, cp2++) *cp2 = *rest;
8386 if (do_tovmsspec(resspec,cp,0)) {
8389 for (cp2 = vmsspec + strlen(vmsspec);
8390 *rest && cp2 - vmsspec < sizeof vmsspec;
8391 rest++, cp2++) *cp2 = *rest;
8396 /* Intuit whether verb (first word of cmd) is a DCL command:
8397 * - if first nonspace char is '@', it's a DCL indirection
8399 * - if verb contains a filespec separator, it's not a DCL command
8400 * - if it doesn't, caller tells us whether to default to a DCL
8401 * command, or to a local image unless told it's DCL (by leading '$')
8405 if (suggest_quote) *suggest_quote = 1;
8407 register char *filespec = strpbrk(s,":<[.;");
8408 rest = wordbreak = strpbrk(s," \"\t/");
8409 if (!wordbreak) wordbreak = s + strlen(s);
8410 if (*s == '$') check_img = 0;
8411 if (filespec && (filespec < wordbreak)) isdcl = 0;
8412 else isdcl = !check_img;
8417 imgdsc.dsc$a_pointer = s;
8418 imgdsc.dsc$w_length = wordbreak - s;
8419 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8421 _ckvmssts(lib$find_file_end(&cxt));
8422 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8423 if (!(retsts & 1) && *s == '$') {
8424 _ckvmssts(lib$find_file_end(&cxt));
8425 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8426 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8428 _ckvmssts(lib$find_file_end(&cxt));
8429 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8433 _ckvmssts(lib$find_file_end(&cxt));
8438 while (*s && !isspace(*s)) s++;
8441 /* check that it's really not DCL with no file extension */
8442 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8444 char b[256] = {0,0,0,0};
8445 read(fileno(fp), b, 256);
8446 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8450 /* Check for script */
8452 if ((b[0] == '#') && (b[1] == '!'))
8454 #ifdef ALTERNATE_SHEBANG
8456 shebang_len = strlen(ALTERNATE_SHEBANG);
8457 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8459 perlstr = strstr("perl",b);
8460 if (perlstr == NULL)
8468 if (shebang_len > 0) {
8471 char tmpspec[NAM$C_MAXRSS + 1];
8474 /* Image is following after white space */
8475 /*--------------------------------------*/
8476 while (isprint(b[i]) && isspace(b[i]))
8480 while (isprint(b[i]) && !isspace(b[i])) {
8481 tmpspec[j++] = b[i++];
8482 if (j >= NAM$C_MAXRSS)
8487 /* There may be some default parameters to the image */
8488 /*---------------------------------------------------*/
8490 while (isprint(b[i])) {
8491 image_argv[j++] = b[i++];
8492 if (j >= NAM$C_MAXRSS)
8495 while ((j > 0) && !isprint(image_argv[j-1]))
8499 /* It will need to be converted to VMS format and validated */
8500 if (tmpspec[0] != '\0') {
8503 /* Try to find the exact program requested to be run */
8504 /*---------------------------------------------------*/
8505 iname = do_rmsexpand
8506 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8507 if (iname != NULL) {
8508 if (cando_by_name(S_IXUSR,0,image_name)) {
8509 /* MCR prefix needed */
8513 /* Try again with a null type */
8514 /*----------------------------*/
8515 iname = do_rmsexpand
8516 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8517 if (iname != NULL) {
8518 if (cando_by_name(S_IXUSR,0,image_name)) {
8519 /* MCR prefix needed */
8525 /* Did we find the image to run the script? */
8526 /*------------------------------------------*/
8530 /* Assume DCL or foreign command exists */
8531 /*--------------------------------------*/
8532 tchr = strrchr(tmpspec, '/');
8539 strcpy(image_name, tchr);
8547 if (check_img && isdcl) return RMS$_FNF;
8549 if (cando_by_name(S_IXUSR,0,resspec)) {
8550 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
8551 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8553 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8554 if (image_name[0] != 0) {
8555 strcat(vmscmd->dsc$a_pointer, image_name);
8556 strcat(vmscmd->dsc$a_pointer, " ");
8558 } else if (image_name[0] != 0) {
8559 strcpy(vmscmd->dsc$a_pointer, image_name);
8560 strcat(vmscmd->dsc$a_pointer, " ");
8562 strcpy(vmscmd->dsc$a_pointer,"@");
8564 if (suggest_quote) *suggest_quote = 1;
8566 /* If there is an image name, use original command */
8567 if (image_name[0] == 0)
8568 strcat(vmscmd->dsc$a_pointer,resspec);
8571 while (*rest && isspace(*rest)) rest++;
8574 if (image_argv[0] != 0) {
8575 strcat(vmscmd->dsc$a_pointer,image_argv);
8576 strcat(vmscmd->dsc$a_pointer, " ");
8582 rest_len = strlen(rest);
8583 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8584 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8585 strcat(vmscmd->dsc$a_pointer,rest);
8587 retsts = CLI$_BUFOVF;
8589 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8591 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8597 /* It's either a DCL command or we couldn't find a suitable image */
8598 vmscmd->dsc$w_length = strlen(cmd);
8600 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
8601 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
8602 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
8606 /* check if it's a symbol (for quoting purposes) */
8607 if (suggest_quote && !*suggest_quote) {
8609 char equiv[LNM$C_NAMLENGTH];
8610 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8611 eqvdsc.dsc$a_pointer = equiv;
8613 iss = lib$get_symbol(vmscmd,&eqvdsc);
8614 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8616 if (!(retsts & 1)) {
8617 /* just hand off status values likely to be due to user error */
8618 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8619 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8620 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8621 else { _ckvmssts(retsts); }
8624 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8626 } /* end of setup_cmddsc() */
8629 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8631 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8637 if (vfork_called) { /* this follows a vfork - act Unixish */
8639 if (vfork_called < 0) {
8640 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8643 else return do_aexec(really,mark,sp);
8645 /* no vfork - act VMSish */
8646 cmd = setup_argstr(aTHX_ really,mark,sp);
8647 exec_sts = vms_do_exec(cmd);
8648 Safefree(cmd); /* Clean up from setup_argstr() */
8653 } /* end of vms_do_aexec() */
8656 /* {{{bool vms_do_exec(char *cmd) */
8658 Perl_vms_do_exec(pTHX_ const char *cmd)
8660 struct dsc$descriptor_s *vmscmd;
8662 if (vfork_called) { /* this follows a vfork - act Unixish */
8664 if (vfork_called < 0) {
8665 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8668 else return do_exec(cmd);
8671 { /* no vfork - act VMSish */
8672 unsigned long int retsts;
8675 TAINT_PROPER("exec");
8676 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8677 retsts = lib$do_command(vmscmd);
8680 case RMS$_FNF: case RMS$_DNF:
8681 set_errno(ENOENT); break;
8683 set_errno(ENOTDIR); break;
8685 set_errno(ENODEV); break;
8687 set_errno(EACCES); break;
8689 set_errno(EINVAL); break;
8690 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8691 set_errno(E2BIG); break;
8692 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8693 _ckvmssts(retsts); /* fall through */
8694 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8697 set_vaxc_errno(retsts);
8698 if (ckWARN(WARN_EXEC)) {
8699 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8700 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8702 vms_execfree(vmscmd);
8707 } /* end of vms_do_exec() */
8710 unsigned long int Perl_do_spawn(pTHX_ const char *);
8712 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8714 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8716 unsigned long int sts;
8720 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
8721 sts = do_spawn(cmd);
8722 /* pp_sys will clean up cmd */
8726 } /* end of do_aspawn() */
8729 /* {{{unsigned long int do_spawn(char *cmd) */
8731 Perl_do_spawn(pTHX_ const char *cmd)
8733 unsigned long int sts, substs;
8735 /* The caller of this routine expects to Safefree(PL_Cmd) */
8736 Newx(PL_Cmd,10,char);
8739 TAINT_PROPER("spawn");
8740 if (!cmd || !*cmd) {
8741 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8744 case RMS$_FNF: case RMS$_DNF:
8745 set_errno(ENOENT); break;
8747 set_errno(ENOTDIR); break;
8749 set_errno(ENODEV); break;
8751 set_errno(EACCES); break;
8753 set_errno(EINVAL); break;
8754 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8755 set_errno(E2BIG); break;
8756 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8757 _ckvmssts(sts); /* fall through */
8758 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8761 set_vaxc_errno(sts);
8762 if (ckWARN(WARN_EXEC)) {
8763 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8771 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8776 } /* end of do_spawn() */
8780 static unsigned int *sockflags, sockflagsize;
8783 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8784 * routines found in some versions of the CRTL can't deal with sockets.
8785 * We don't shim the other file open routines since a socket isn't
8786 * likely to be opened by a name.
8788 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8789 FILE *my_fdopen(int fd, const char *mode)
8791 FILE *fp = fdopen(fd, mode);
8794 unsigned int fdoff = fd / sizeof(unsigned int);
8795 Stat_t sbuf; /* native stat; we don't need flex_stat */
8796 if (!sockflagsize || fdoff > sockflagsize) {
8797 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
8798 else Newx (sockflags,fdoff+2,unsigned int);
8799 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8800 sockflagsize = fdoff + 2;
8802 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8803 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8812 * Clear the corresponding bit when the (possibly) socket stream is closed.
8813 * There still a small hole: we miss an implicit close which might occur
8814 * via freopen(). >> Todo
8816 /*{{{ int my_fclose(FILE *fp)*/
8817 int my_fclose(FILE *fp) {
8819 unsigned int fd = fileno(fp);
8820 unsigned int fdoff = fd / sizeof(unsigned int);
8822 if (sockflagsize && fdoff <= sockflagsize)
8823 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8831 * A simple fwrite replacement which outputs itmsz*nitm chars without
8832 * introducing record boundaries every itmsz chars.
8833 * We are using fputs, which depends on a terminating null. We may
8834 * well be writing binary data, so we need to accommodate not only
8835 * data with nulls sprinkled in the middle but also data with no null
8838 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8840 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8842 register char *cp, *end, *cpd, *data;
8843 register unsigned int fd = fileno(dest);
8844 register unsigned int fdoff = fd / sizeof(unsigned int);
8846 int bufsize = itmsz * nitm + 1;
8848 if (fdoff < sockflagsize &&
8849 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8850 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8854 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8855 memcpy( data, src, itmsz*nitm );
8856 data[itmsz*nitm] = '\0';
8858 end = data + itmsz * nitm;
8859 retval = (int) nitm; /* on success return # items written */
8862 while (cpd <= end) {
8863 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8864 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8866 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8870 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8873 } /* end of my_fwrite() */
8876 /*{{{ int my_flush(FILE *fp)*/
8878 Perl_my_flush(pTHX_ FILE *fp)
8881 if ((res = fflush(fp)) == 0 && fp) {
8882 #ifdef VMS_DO_SOCKETS
8884 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8886 res = fsync(fileno(fp));
8889 * If the flush succeeded but set end-of-file, we need to clear
8890 * the error because our caller may check ferror(). BTW, this
8891 * probably means we just flushed an empty file.
8893 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8900 * Here are replacements for the following Unix routines in the VMS environment:
8901 * getpwuid Get information for a particular UIC or UID
8902 * getpwnam Get information for a named user
8903 * getpwent Get information for each user in the rights database
8904 * setpwent Reset search to the start of the rights database
8905 * endpwent Finish searching for users in the rights database
8907 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8908 * (defined in pwd.h), which contains the following fields:-
8910 * char *pw_name; Username (in lower case)
8911 * char *pw_passwd; Hashed password
8912 * unsigned int pw_uid; UIC
8913 * unsigned int pw_gid; UIC group number
8914 * char *pw_unixdir; Default device/directory (VMS-style)
8915 * char *pw_gecos; Owner name
8916 * char *pw_dir; Default device/directory (Unix-style)
8917 * char *pw_shell; Default CLI name (eg. DCL)
8919 * If the specified user does not exist, getpwuid and getpwnam return NULL.
8921 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8922 * not the UIC member number (eg. what's returned by getuid()),
8923 * getpwuid() can accept either as input (if uid is specified, the caller's
8924 * UIC group is used), though it won't recognise gid=0.
8926 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8927 * information about other users in your group or in other groups, respectively.
8928 * If the required privilege is not available, then these routines fill only
8929 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8932 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8935 /* sizes of various UAF record fields */
8936 #define UAI$S_USERNAME 12
8937 #define UAI$S_IDENT 31
8938 #define UAI$S_OWNER 31
8939 #define UAI$S_DEFDEV 31
8940 #define UAI$S_DEFDIR 63
8941 #define UAI$S_DEFCLI 31
8944 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
8945 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8946 (uic).uic$v_group != UIC$K_WILD_GROUP)
8948 static char __empty[]= "";
8949 static struct passwd __passwd_empty=
8950 {(char *) __empty, (char *) __empty, 0, 0,
8951 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8952 static int contxt= 0;
8953 static struct passwd __pwdcache;
8954 static char __pw_namecache[UAI$S_IDENT+1];
8957 * This routine does most of the work extracting the user information.
8959 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8962 unsigned char length;
8963 char pw_gecos[UAI$S_OWNER+1];
8965 static union uicdef uic;
8967 unsigned char length;
8968 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8971 unsigned char length;
8972 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8975 unsigned char length;
8976 char pw_shell[UAI$S_DEFCLI+1];
8978 static char pw_passwd[UAI$S_PWD+1];
8980 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8981 struct dsc$descriptor_s name_desc;
8982 unsigned long int sts;
8984 static struct itmlst_3 itmlst[]= {
8985 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
8986 {sizeof(uic), UAI$_UIC, &uic, &luic},
8987 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
8988 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
8989 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
8990 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
8991 {0, 0, NULL, NULL}};
8993 name_desc.dsc$w_length= strlen(name);
8994 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8995 name_desc.dsc$b_class= DSC$K_CLASS_S;
8996 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8998 /* Note that sys$getuai returns many fields as counted strings. */
8999 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9000 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9001 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9003 else { _ckvmssts(sts); }
9004 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9006 if ((int) owner.length < lowner) lowner= (int) owner.length;
9007 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9008 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9009 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9010 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9011 owner.pw_gecos[lowner]= '\0';
9012 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9013 defcli.pw_shell[ldefcli]= '\0';
9014 if (valid_uic(uic)) {
9015 pwd->pw_uid= uic.uic$l_uic;
9016 pwd->pw_gid= uic.uic$v_group;
9019 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9020 pwd->pw_passwd= pw_passwd;
9021 pwd->pw_gecos= owner.pw_gecos;
9022 pwd->pw_dir= defdev.pw_dir;
9023 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
9024 pwd->pw_shell= defcli.pw_shell;
9025 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9027 ldir= strlen(pwd->pw_unixdir) - 1;
9028 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9031 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9032 if (!decc_efs_case_preserve)
9033 __mystrtolower(pwd->pw_unixdir);
9038 * Get information for a named user.
9040 /*{{{struct passwd *getpwnam(char *name)*/
9041 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9043 struct dsc$descriptor_s name_desc;
9045 unsigned long int status, sts;
9047 __pwdcache = __passwd_empty;
9048 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9049 /* We still may be able to determine pw_uid and pw_gid */
9050 name_desc.dsc$w_length= strlen(name);
9051 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9052 name_desc.dsc$b_class= DSC$K_CLASS_S;
9053 name_desc.dsc$a_pointer= (char *) name;
9054 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9055 __pwdcache.pw_uid= uic.uic$l_uic;
9056 __pwdcache.pw_gid= uic.uic$v_group;
9059 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9060 set_vaxc_errno(sts);
9061 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9064 else { _ckvmssts(sts); }
9067 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9068 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9069 __pwdcache.pw_name= __pw_namecache;
9071 } /* end of my_getpwnam() */
9075 * Get information for a particular UIC or UID.
9076 * Called by my_getpwent with uid=-1 to list all users.
9078 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9079 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9081 const $DESCRIPTOR(name_desc,__pw_namecache);
9082 unsigned short lname;
9084 unsigned long int status;
9086 if (uid == (unsigned int) -1) {
9088 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9089 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9090 set_vaxc_errno(status);
9091 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9095 else { _ckvmssts(status); }
9096 } while (!valid_uic (uic));
9100 if (!uic.uic$v_group)
9101 uic.uic$v_group= PerlProc_getgid();
9103 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9104 else status = SS$_IVIDENT;
9105 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9106 status == RMS$_PRV) {
9107 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9110 else { _ckvmssts(status); }
9112 __pw_namecache[lname]= '\0';
9113 __mystrtolower(__pw_namecache);
9115 __pwdcache = __passwd_empty;
9116 __pwdcache.pw_name = __pw_namecache;
9118 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9119 The identifier's value is usually the UIC, but it doesn't have to be,
9120 so if we can, we let fillpasswd update this. */
9121 __pwdcache.pw_uid = uic.uic$l_uic;
9122 __pwdcache.pw_gid = uic.uic$v_group;
9124 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9127 } /* end of my_getpwuid() */
9131 * Get information for next user.
9133 /*{{{struct passwd *my_getpwent()*/
9134 struct passwd *Perl_my_getpwent(pTHX)
9136 return (my_getpwuid((unsigned int) -1));
9141 * Finish searching rights database for users.
9143 /*{{{void my_endpwent()*/
9144 void Perl_my_endpwent(pTHX)
9147 _ckvmssts(sys$finish_rdb(&contxt));
9153 #ifdef HOMEGROWN_POSIX_SIGNALS
9154 /* Signal handling routines, pulled into the core from POSIX.xs.
9156 * We need these for threads, so they've been rolled into the core,
9157 * rather than left in POSIX.xs.
9159 * (DRS, Oct 23, 1997)
9162 /* sigset_t is atomic under VMS, so these routines are easy */
9163 /*{{{int my_sigemptyset(sigset_t *) */
9164 int my_sigemptyset(sigset_t *set) {
9165 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9171 /*{{{int my_sigfillset(sigset_t *)*/
9172 int my_sigfillset(sigset_t *set) {
9174 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9175 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9181 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9182 int my_sigaddset(sigset_t *set, int sig) {
9183 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9184 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9185 *set |= (1 << (sig - 1));
9191 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9192 int my_sigdelset(sigset_t *set, int sig) {
9193 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9194 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9195 *set &= ~(1 << (sig - 1));
9201 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9202 int my_sigismember(sigset_t *set, int sig) {
9203 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9204 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9205 return *set & (1 << (sig - 1));
9210 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9211 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9214 /* If set and oset are both null, then things are badly wrong. Bail out. */
9215 if ((oset == NULL) && (set == NULL)) {
9216 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9220 /* If set's null, then we're just handling a fetch. */
9222 tempmask = sigblock(0);
9227 tempmask = sigsetmask(*set);
9230 tempmask = sigblock(*set);
9233 tempmask = sigblock(0);
9234 sigsetmask(*oset & ~tempmask);
9237 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9242 /* Did they pass us an oset? If so, stick our holding mask into it */
9249 #endif /* HOMEGROWN_POSIX_SIGNALS */
9252 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9253 * my_utime(), and flex_stat(), all of which operate on UTC unless
9254 * VMSISH_TIMES is true.
9256 /* method used to handle UTC conversions:
9257 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
9259 static int gmtime_emulation_type;
9260 /* number of secs to add to UTC POSIX-style time to get local time */
9261 static long int utc_offset_secs;
9263 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9264 * in vmsish.h. #undef them here so we can call the CRTL routines
9273 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9274 * qualifier with the extern prefix pragma. This provisional
9275 * hack circumvents this prefix pragma problem in previous
9278 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9279 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9280 # pragma __extern_prefix save
9281 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
9282 # define gmtime decc$__utctz_gmtime
9283 # define localtime decc$__utctz_localtime
9284 # define time decc$__utc_time
9285 # pragma __extern_prefix restore
9287 struct tm *gmtime(), *localtime();
9293 static time_t toutc_dst(time_t loc) {
9296 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9297 loc -= utc_offset_secs;
9298 if (rsltmp->tm_isdst) loc -= 3600;
9301 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9302 ((gmtime_emulation_type || my_time(NULL)), \
9303 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9304 ((secs) - utc_offset_secs))))
9306 static time_t toloc_dst(time_t utc) {
9309 utc += utc_offset_secs;
9310 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9311 if (rsltmp->tm_isdst) utc += 3600;
9314 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9315 ((gmtime_emulation_type || my_time(NULL)), \
9316 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9317 ((secs) + utc_offset_secs))))
9319 #ifndef RTL_USES_UTC
9322 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9323 DST starts on 1st sun of april at 02:00 std time
9324 ends on last sun of october at 02:00 dst time
9325 see the UCX management command reference, SET CONFIG TIMEZONE
9326 for formatting info.
9328 No, it's not as general as it should be, but then again, NOTHING
9329 will handle UK times in a sensible way.
9334 parse the DST start/end info:
9335 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9339 tz_parse_startend(char *s, struct tm *w, int *past)
9341 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9342 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9347 if (!past) return 0;
9350 if (w->tm_year % 4 == 0) ly = 1;
9351 if (w->tm_year % 100 == 0) ly = 0;
9352 if (w->tm_year+1900 % 400 == 0) ly = 1;
9355 dozjd = isdigit(*s);
9356 if (*s == 'J' || *s == 'j' || dozjd) {
9357 if (!dozjd && !isdigit(*++s)) return 0;
9360 d = d*10 + *s++ - '0';
9362 d = d*10 + *s++ - '0';
9365 if (d == 0) return 0;
9366 if (d > 366) return 0;
9368 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9371 } else if (*s == 'M' || *s == 'm') {
9372 if (!isdigit(*++s)) return 0;
9374 if (isdigit(*s)) m = 10*m + *s++ - '0';
9375 if (*s != '.') return 0;
9376 if (!isdigit(*++s)) return 0;
9378 if (n < 1 || n > 5) return 0;
9379 if (*s != '.') return 0;
9380 if (!isdigit(*++s)) return 0;
9382 if (d > 6) return 0;
9386 if (!isdigit(*++s)) return 0;
9388 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9390 if (!isdigit(*++s)) return 0;
9392 if (isdigit(*s)) min = 10*min + *s++ - '0';
9394 if (!isdigit(*++s)) return 0;
9396 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9406 if (w->tm_yday < d) goto before;
9407 if (w->tm_yday > d) goto after;
9409 if (w->tm_mon+1 < m) goto before;
9410 if (w->tm_mon+1 > m) goto after;
9412 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9413 k = d - j; /* mday of first d */
9415 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9416 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9417 if (w->tm_mday < k) goto before;
9418 if (w->tm_mday > k) goto after;
9421 if (w->tm_hour < hour) goto before;
9422 if (w->tm_hour > hour) goto after;
9423 if (w->tm_min < min) goto before;
9424 if (w->tm_min > min) goto after;
9425 if (w->tm_sec < sec) goto before;
9439 /* parse the offset: (+|-)hh[:mm[:ss]] */
9442 tz_parse_offset(char *s, int *offset)
9444 int hour = 0, min = 0, sec = 0;
9447 if (!offset) return 0;
9449 if (*s == '-') {neg++; s++;}
9451 if (!isdigit(*s)) return 0;
9453 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9454 if (hour > 24) return 0;
9456 if (!isdigit(*++s)) return 0;
9458 if (isdigit(*s)) min = min*10 + (*s++ - '0');
9459 if (min > 59) return 0;
9461 if (!isdigit(*++s)) return 0;
9463 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9464 if (sec > 59) return 0;
9468 *offset = (hour*60+min)*60 + sec;
9469 if (neg) *offset = -*offset;
9474 input time is w, whatever type of time the CRTL localtime() uses.
9475 sets dst, the zone, and the gmtoff (seconds)
9477 caches the value of TZ and UCX$TZ env variables; note that
9478 my_setenv looks for these and sets a flag if they're changed
9481 We have to watch out for the "australian" case (dst starts in
9482 october, ends in april)...flagged by "reverse" and checked by
9483 scanning through the months of the previous year.
9488 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9493 char *dstzone, *tz, *s_start, *s_end;
9494 int std_off, dst_off, isdst;
9495 int y, dststart, dstend;
9496 static char envtz[1025]; /* longer than any logical, symbol, ... */
9497 static char ucxtz[1025];
9498 static char reversed = 0;
9504 reversed = -1; /* flag need to check */
9505 envtz[0] = ucxtz[0] = '\0';
9506 tz = my_getenv("TZ",0);
9507 if (tz) strcpy(envtz, tz);
9508 tz = my_getenv("UCX$TZ",0);
9509 if (tz) strcpy(ucxtz, tz);
9510 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
9513 if (!*tz) tz = ucxtz;
9516 while (isalpha(*s)) s++;
9517 s = tz_parse_offset(s, &std_off);
9519 if (!*s) { /* no DST, hurray we're done! */
9525 while (isalpha(*s)) s++;
9526 s2 = tz_parse_offset(s, &dst_off);
9530 dst_off = std_off - 3600;
9533 if (!*s) { /* default dst start/end?? */
9534 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
9535 s = strchr(ucxtz,',');
9537 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
9539 if (*s != ',') return 0;
9542 when = _toutc(when); /* convert to utc */
9543 when = when - std_off; /* convert to pseudolocal time*/
9545 w2 = localtime(&when);
9548 s = tz_parse_startend(s_start,w2,&dststart);
9550 if (*s != ',') return 0;
9553 when = _toutc(when); /* convert to utc */
9554 when = when - dst_off; /* convert to pseudolocal time*/
9555 w2 = localtime(&when);
9556 if (w2->tm_year != y) { /* spans a year, just check one time */
9557 when += dst_off - std_off;
9558 w2 = localtime(&when);
9561 s = tz_parse_startend(s_end,w2,&dstend);
9564 if (reversed == -1) { /* need to check if start later than end */
9568 if (when < 2*365*86400) {
9569 when += 2*365*86400;
9573 w2 =localtime(&when);
9574 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
9576 for (j = 0; j < 12; j++) {
9577 w2 =localtime(&when);
9578 tz_parse_startend(s_start,w2,&ds);
9579 tz_parse_startend(s_end,w2,&de);
9580 if (ds != de) break;
9584 if (de && !ds) reversed = 1;
9587 isdst = dststart && !dstend;
9588 if (reversed) isdst = dststart || !dstend;
9591 if (dst) *dst = isdst;
9592 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9593 if (isdst) tz = dstzone;
9595 while(isalpha(*tz)) *zone++ = *tz++;
9601 #endif /* !RTL_USES_UTC */
9603 /* my_time(), my_localtime(), my_gmtime()
9604 * By default traffic in UTC time values, using CRTL gmtime() or
9605 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9606 * Note: We need to use these functions even when the CRTL has working
9607 * UTC support, since they also handle C<use vmsish qw(times);>
9609 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
9610 * Modified by Charles Bailey <bailey@newman.upenn.edu>
9613 /*{{{time_t my_time(time_t *timep)*/
9614 time_t Perl_my_time(pTHX_ time_t *timep)
9619 if (gmtime_emulation_type == 0) {
9621 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
9622 /* results of calls to gmtime() and localtime() */
9623 /* for same &base */
9625 gmtime_emulation_type++;
9626 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9627 char off[LNM$C_NAMLENGTH+1];;
9629 gmtime_emulation_type++;
9630 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9631 gmtime_emulation_type++;
9632 utc_offset_secs = 0;
9633 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9635 else { utc_offset_secs = atol(off); }
9637 else { /* We've got a working gmtime() */
9638 struct tm gmt, local;
9641 tm_p = localtime(&base);
9643 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
9644 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9645 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
9646 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
9652 # ifdef RTL_USES_UTC
9653 if (VMSISH_TIME) when = _toloc(when);
9655 if (!VMSISH_TIME) when = _toutc(when);
9658 if (timep != NULL) *timep = when;
9661 } /* end of my_time() */
9665 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9667 Perl_my_gmtime(pTHX_ const time_t *timep)
9673 if (timep == NULL) {
9674 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9677 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9681 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9683 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
9684 return gmtime(&when);
9686 /* CRTL localtime() wants local time as input, so does no tz correction */
9687 rsltmp = localtime(&when);
9688 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
9691 } /* end of my_gmtime() */
9695 /*{{{struct tm *my_localtime(const time_t *timep)*/
9697 Perl_my_localtime(pTHX_ const time_t *timep)
9699 time_t when, whenutc;
9703 if (timep == NULL) {
9704 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9707 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9708 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9711 # ifdef RTL_USES_UTC
9713 if (VMSISH_TIME) when = _toutc(when);
9715 /* CRTL localtime() wants UTC as input, does tz correction itself */
9716 return localtime(&when);
9718 # else /* !RTL_USES_UTC */
9721 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
9722 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
9725 #ifndef RTL_USES_UTC
9726 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
9727 when = whenutc - offset; /* pseudolocal time*/
9730 /* CRTL localtime() wants local time as input, so does no tz correction */
9731 rsltmp = localtime(&when);
9732 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9736 } /* end of my_localtime() */
9739 /* Reset definitions for later calls */
9740 #define gmtime(t) my_gmtime(t)
9741 #define localtime(t) my_localtime(t)
9742 #define time(t) my_time(t)
9745 /* my_utime - update modification/access time of a file
9747 * VMS 7.3 and later implementation
9748 * Only the UTC translation is home-grown. The rest is handled by the
9749 * CRTL utime(), which will take into account the relevant feature
9750 * logicals and ODS-5 volume characteristics for true access times.
9752 * pre VMS 7.3 implementation:
9753 * The calling sequence is identical to POSIX utime(), but under
9754 * VMS with ODS-2, only the modification time is changed; ODS-2 does
9755 * not maintain access times. Restrictions differ from the POSIX
9756 * definition in that the time can be changed as long as the
9757 * caller has permission to execute the necessary IO$_MODIFY $QIO;
9758 * no separate checks are made to insure that the caller is the
9759 * owner of the file or has special privs enabled.
9760 * Code here is based on Joe Meadows' FILE utility.
9764 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9765 * to VMS epoch (01-JAN-1858 00:00:00.00)
9766 * in 100 ns intervals.
9768 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9770 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9771 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9773 #if __CRTL_VER >= 70300000
9774 struct utimbuf utc_utimes, *utc_utimesp;
9776 if (utimes != NULL) {
9777 utc_utimes.actime = utimes->actime;
9778 utc_utimes.modtime = utimes->modtime;
9780 /* If input was local; convert to UTC for sys svc */
9782 utc_utimes.actime = _toutc(utimes->actime);
9783 utc_utimes.modtime = _toutc(utimes->modtime);
9786 utc_utimesp = &utc_utimes;
9792 return utime(file, utc_utimesp);
9794 #else /* __CRTL_VER < 70300000 */
9798 long int bintime[2], len = 2, lowbit, unixtime,
9799 secscale = 10000000; /* seconds --> 100 ns intervals */
9800 unsigned long int chan, iosb[2], retsts;
9801 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9802 struct FAB myfab = cc$rms_fab;
9803 struct NAM mynam = cc$rms_nam;
9804 #if defined (__DECC) && defined (__VAX)
9805 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9806 * at least through VMS V6.1, which causes a type-conversion warning.
9808 # pragma message save
9809 # pragma message disable cvtdiftypes
9811 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9812 struct fibdef myfib;
9813 #if defined (__DECC) && defined (__VAX)
9814 /* This should be right after the declaration of myatr, but due
9815 * to a bug in VAX DEC C, this takes effect a statement early.
9817 # pragma message restore
9819 /* cast ok for read only parameter */
9820 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9821 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9822 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9824 if (file == NULL || *file == '\0') {
9825 SETERRNO(ENOENT, LIB$_INVARG);
9829 /* Convert to VMS format ensuring that it will fit in 255 characters */
9830 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
9831 SETERRNO(ENOENT, LIB$_INVARG);
9834 if (utimes != NULL) {
9835 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
9836 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9837 * Since time_t is unsigned long int, and lib$emul takes a signed long int
9838 * as input, we force the sign bit to be clear by shifting unixtime right
9839 * one bit, then multiplying by an extra factor of 2 in lib$emul().
9841 lowbit = (utimes->modtime & 1) ? secscale : 0;
9842 unixtime = (long int) utimes->modtime;
9844 /* If input was UTC; convert to local for sys svc */
9845 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9847 unixtime >>= 1; secscale <<= 1;
9848 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9849 if (!(retsts & 1)) {
9850 SETERRNO(EVMSERR, retsts);
9853 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9854 if (!(retsts & 1)) {
9855 SETERRNO(EVMSERR, retsts);
9860 /* Just get the current time in VMS format directly */
9861 retsts = sys$gettim(bintime);
9862 if (!(retsts & 1)) {
9863 SETERRNO(EVMSERR, retsts);
9868 myfab.fab$l_fna = vmsspec;
9869 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9870 myfab.fab$l_nam = &mynam;
9871 mynam.nam$l_esa = esa;
9872 mynam.nam$b_ess = (unsigned char) sizeof esa;
9873 mynam.nam$l_rsa = rsa;
9874 mynam.nam$b_rss = (unsigned char) sizeof rsa;
9875 if (decc_efs_case_preserve)
9876 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9878 /* Look for the file to be affected, letting RMS parse the file
9879 * specification for us as well. I have set errno using only
9880 * values documented in the utime() man page for VMS POSIX.
9882 retsts = sys$parse(&myfab,0,0);
9883 if (!(retsts & 1)) {
9884 set_vaxc_errno(retsts);
9885 if (retsts == RMS$_PRV) set_errno(EACCES);
9886 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9887 else set_errno(EVMSERR);
9890 retsts = sys$search(&myfab,0,0);
9891 if (!(retsts & 1)) {
9892 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9893 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9894 set_vaxc_errno(retsts);
9895 if (retsts == RMS$_PRV) set_errno(EACCES);
9896 else if (retsts == RMS$_FNF) set_errno(ENOENT);
9897 else set_errno(EVMSERR);
9901 devdsc.dsc$w_length = mynam.nam$b_dev;
9902 /* cast ok for read only parameter */
9903 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9905 retsts = sys$assign(&devdsc,&chan,0,0);
9906 if (!(retsts & 1)) {
9907 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9908 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9909 set_vaxc_errno(retsts);
9910 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
9911 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
9912 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
9913 else set_errno(EVMSERR);
9917 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9918 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9920 memset((void *) &myfib, 0, sizeof myfib);
9921 #if defined(__DECC) || defined(__DECCXX)
9922 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9923 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9924 /* This prevents the revision time of the file being reset to the current
9925 * time as a result of our IO$_MODIFY $QIO. */
9926 myfib.fib$l_acctl = FIB$M_NORECORD;
9928 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9929 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9930 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9932 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9933 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9934 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9935 _ckvmssts(sys$dassgn(chan));
9936 if (retsts & 1) retsts = iosb[0];
9937 if (!(retsts & 1)) {
9938 set_vaxc_errno(retsts);
9939 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9940 else set_errno(EVMSERR);
9946 #endif /* #if __CRTL_VER >= 70300000 */
9948 } /* end of my_utime() */
9952 * flex_stat, flex_lstat, flex_fstat
9953 * basic stat, but gets it right when asked to stat
9954 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9957 #ifndef _USE_STD_STAT
9958 /* encode_dev packs a VMS device name string into an integer to allow
9959 * simple comparisons. This can be used, for example, to check whether two
9960 * files are located on the same device, by comparing their encoded device
9961 * names. Even a string comparison would not do, because stat() reuses the
9962 * device name buffer for each call; so without encode_dev, it would be
9963 * necessary to save the buffer and use strcmp (this would mean a number of
9964 * changes to the standard Perl code, to say nothing of what a Perl script
9967 * The device lock id, if it exists, should be unique (unless perhaps compared
9968 * with lock ids transferred from other nodes). We have a lock id if the disk is
9969 * mounted cluster-wide, which is when we tend to get long (host-qualified)
9970 * device names. Thus we use the lock id in preference, and only if that isn't
9971 * available, do we try to pack the device name into an integer (flagged by
9972 * the sign bit (LOCKID_MASK) being set).
9974 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9975 * name and its encoded form, but it seems very unlikely that we will find
9976 * two files on different disks that share the same encoded device names,
9977 * and even more remote that they will share the same file id (if the test
9978 * is to check for the same file).
9980 * A better method might be to use sys$device_scan on the first call, and to
9981 * search for the device, returning an index into the cached array.
9982 * The number returned would be more intelligable.
9983 * This is probably not worth it, and anyway would take quite a bit longer
9984 * on the first call.
9986 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
9987 static mydev_t encode_dev (pTHX_ const char *dev)
9990 unsigned long int f;
9995 if (!dev || !dev[0]) return 0;
9999 struct dsc$descriptor_s dev_desc;
10000 unsigned long int status, lockid, item = DVI$_LOCKID;
10002 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10003 can try that first. */
10004 dev_desc.dsc$w_length = strlen (dev);
10005 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10006 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10007 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10008 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
10009 if (lockid) return (lockid & ~LOCKID_MASK);
10013 /* Otherwise we try to encode the device name */
10017 for (q = dev + strlen(dev); q--; q >= dev) {
10022 else if (isalpha (toupper (*q)))
10023 c= toupper (*q) - 'A' + (char)10;
10025 continue; /* Skip '$'s */
10027 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10029 enc += f * (unsigned long int) c;
10031 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10033 } /* end of encode_dev() */
10034 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10035 device_no = encode_dev(aTHX_ devname)
10037 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10038 device_no = new_dev_no
10042 is_null_device(name)
10045 if (decc_bug_devnull != 0) {
10046 if (strncmp("/dev/null", name, 9) == 0)
10049 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10050 The underscore prefix, controller letter, and unit number are
10051 independently optional; for our purposes, the colon punctuation
10052 is not. The colon can be trailed by optional directory and/or
10053 filename, but two consecutive colons indicates a nodename rather
10054 than a device. [pr] */
10055 if (*name == '_') ++name;
10056 if (tolower(*name++) != 'n') return 0;
10057 if (tolower(*name++) != 'l') return 0;
10058 if (tolower(*name) == 'a') ++name;
10059 if (*name == '0') ++name;
10060 return (*name++ == ':') && (*name != ':');
10063 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
10064 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10065 * subset of the applicable information.
10068 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10070 return cando_by_name(bit,effective, statbufp->st_devnam);
10071 } /* end of cando() */
10075 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10077 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10079 static char usrname[L_cuserid];
10080 static struct dsc$descriptor_s usrdsc =
10081 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10082 char vmsname[NAM$C_MAXRSS+1];
10084 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
10085 unsigned short int retlen, trnlnm_iter_count;
10086 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10087 union prvdef curprv;
10088 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10089 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
10090 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10091 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10093 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10095 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10097 if (!fname || !*fname) return FALSE;
10098 /* Make sure we expand logical names, since sys$check_access doesn't */
10099 fileified = PerlMem_malloc(VMS_MAXRSS);
10100 if (!strpbrk(fname,"/]>:")) {
10101 strcpy(fileified,fname);
10102 trnlnm_iter_count = 0;
10103 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10104 trnlnm_iter_count++;
10105 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10109 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) {
10110 PerlMem_free(fileified);
10113 retlen = namdsc.dsc$w_length = strlen(vmsname);
10114 namdsc.dsc$a_pointer = vmsname;
10115 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10116 vmsname[retlen-1] == ':') {
10117 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
10118 namdsc.dsc$w_length = strlen(fileified);
10119 namdsc.dsc$a_pointer = fileified;
10123 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10124 access = ARM$M_EXECUTE; break;
10125 case S_IRUSR: case S_IRGRP: case S_IROTH:
10126 access = ARM$M_READ; break;
10127 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10128 access = ARM$M_WRITE; break;
10129 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10130 access = ARM$M_DELETE; break;
10132 PerlMem_free(fileified);
10136 /* Before we call $check_access, create a user profile with the current
10137 * process privs since otherwise it just uses the default privs from the
10138 * UAF and might give false positives or negatives. This only works on
10139 * VMS versions v6.0 and later since that's when sys$create_user_profile
10140 * became available.
10143 /* get current process privs and username */
10144 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10145 _ckvmssts(iosb[0]);
10147 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10149 /* find out the space required for the profile */
10150 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10151 &usrprodsc.dsc$w_length,0));
10153 /* allocate space for the profile and get it filled in */
10154 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10155 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10156 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10157 &usrprodsc.dsc$w_length,0));
10159 /* use the profile to check access to the file; free profile & analyze results */
10160 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10161 PerlMem_free(usrprodsc.dsc$a_pointer);
10162 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10166 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10170 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
10171 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10172 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10173 set_vaxc_errno(retsts);
10174 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10175 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10176 else set_errno(ENOENT);
10177 PerlMem_free(fileified);
10180 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10181 PerlMem_free(fileified);
10186 PerlMem_free(fileified);
10187 return FALSE; /* Should never get here */
10189 } /* end of cando_by_name() */
10193 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10195 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10197 if (!fstat(fd,(stat_t *) statbufp)) {
10199 char *vms_filename;
10200 vms_filename = PerlMem_malloc(VMS_MAXRSS);
10201 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10203 /* Save name for cando by name in VMS format */
10204 cptr = getname(fd, vms_filename, 1);
10206 /* This should not happen, but just in case */
10207 if (cptr == NULL) {
10208 statbufp->st_devnam[0] = 0;
10211 /* Make sure that the saved name fits in 255 characters */
10212 cptr = do_rmsexpand
10214 statbufp->st_devnam,
10217 PERL_RMSEXPAND_M_VMS);
10219 statbufp->st_devnam[0] = 0;
10221 PerlMem_free(vms_filename);
10223 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10225 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10227 # ifdef RTL_USES_UTC
10228 # ifdef VMSISH_TIME
10230 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10231 statbufp->st_atime = _toloc(statbufp->st_atime);
10232 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10236 # ifdef VMSISH_TIME
10237 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10241 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10242 statbufp->st_atime = _toutc(statbufp->st_atime);
10243 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10250 } /* end of flex_fstat() */
10253 #if !defined(__VAX) && __CRTL_VER >= 80200000
10261 #define lstat(_x, _y) stat(_x, _y)
10264 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10267 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10269 char fileified[VMS_MAXRSS];
10270 char temp_fspec[VMS_MAXRSS];
10273 int saved_errno, saved_vaxc_errno;
10275 if (!fspec) return retval;
10276 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10277 strcpy(temp_fspec, fspec);
10279 if (decc_bug_devnull != 0) {
10280 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10281 memset(statbufp,0,sizeof *statbufp);
10282 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10283 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10284 statbufp->st_uid = 0x00010001;
10285 statbufp->st_gid = 0x0001;
10286 time((time_t *)&statbufp->st_mtime);
10287 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10292 /* Try for a directory name first. If fspec contains a filename without
10293 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10294 * and sea:[wine.dark]water. exist, we prefer the directory here.
10295 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10296 * not sea:[wine.dark]., if the latter exists. If the intended target is
10297 * the file with null type, specify this by calling flex_stat() with
10298 * a '.' at the end of fspec.
10300 * If we are in Posix filespec mode, accept the filename as is.
10302 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10303 if (decc_posix_compliant_pathnames == 0) {
10305 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10306 if (lstat_flag == 0)
10307 retval = stat(fileified,(stat_t *) statbufp);
10309 retval = lstat(fileified,(stat_t *) statbufp);
10310 save_spec = fileified;
10313 if (lstat_flag == 0)
10314 retval = stat(temp_fspec,(stat_t *) statbufp);
10316 retval = lstat(temp_fspec,(stat_t *) statbufp);
10317 save_spec = temp_fspec;
10319 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10321 if (lstat_flag == 0)
10322 retval = stat(temp_fspec,(stat_t *) statbufp);
10324 retval = lstat(temp_fspec,(stat_t *) statbufp);
10325 save_spec = temp_fspec;
10330 cptr = do_rmsexpand
10331 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS);
10333 statbufp->st_devnam[0] = 0;
10335 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10337 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10338 # ifdef RTL_USES_UTC
10339 # ifdef VMSISH_TIME
10341 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10342 statbufp->st_atime = _toloc(statbufp->st_atime);
10343 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10347 # ifdef VMSISH_TIME
10348 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10352 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10353 statbufp->st_atime = _toutc(statbufp->st_atime);
10354 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10358 /* If we were successful, leave errno where we found it */
10359 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10362 } /* end of flex_stat_int() */
10365 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10367 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10369 return flex_stat_int(fspec, statbufp, 0);
10373 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10375 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10377 return flex_stat_int(fspec, statbufp, 1);
10382 /*{{{char *my_getlogin()*/
10383 /* VMS cuserid == Unix getlogin, except calling sequence */
10387 static char user[L_cuserid];
10388 return cuserid(user);
10393 /* rmscopy - copy a file using VMS RMS routines
10395 * Copies contents and attributes of spec_in to spec_out, except owner
10396 * and protection information. Name and type of spec_in are used as
10397 * defaults for spec_out. The third parameter specifies whether rmscopy()
10398 * should try to propagate timestamps from the input file to the output file.
10399 * If it is less than 0, no timestamps are preserved. If it is 0, then
10400 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
10401 * propagated to the output file at creation iff the output file specification
10402 * did not contain an explicit name or type, and the revision date is always
10403 * updated at the end of the copy operation. If it is greater than 0, then
10404 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10405 * other than the revision date should be propagated, and bit 1 indicates
10406 * that the revision date should be propagated.
10408 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10410 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10411 * Incorporates, with permission, some code from EZCOPY by Tim Adye
10412 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
10413 * as part of the Perl standard distribution under the terms of the
10414 * GNU General Public License or the Perl Artistic License. Copies
10415 * of each may be found in the Perl standard distribution.
10417 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10418 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
10420 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10422 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
10423 rsa[NAM$C_MAXRSS], ubf[32256];
10424 unsigned long int i, sts, sts2;
10425 struct FAB fab_in, fab_out;
10426 struct RAB rab_in, rab_out;
10428 struct XABDAT xabdat;
10429 struct XABFHC xabfhc;
10430 struct XABRDT xabrdt;
10431 struct XABSUM xabsum;
10433 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10434 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10435 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10439 fab_in = cc$rms_fab;
10440 fab_in.fab$l_fna = vmsin;
10441 fab_in.fab$b_fns = strlen(vmsin);
10442 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10443 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10444 fab_in.fab$l_fop = FAB$M_SQO;
10445 fab_in.fab$l_nam = &nam;
10446 fab_in.fab$l_xab = (void *) &xabdat;
10449 nam.nam$l_rsa = rsa;
10450 nam.nam$b_rss = sizeof(rsa);
10451 nam.nam$l_esa = esa;
10452 nam.nam$b_ess = sizeof (esa);
10453 nam.nam$b_esl = nam.nam$b_rsl = 0;
10454 #ifdef NAM$M_NO_SHORT_UPCASE
10455 if (decc_efs_case_preserve)
10456 nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10459 xabdat = cc$rms_xabdat; /* To get creation date */
10460 xabdat.xab$l_nxt = (void *) &xabfhc;
10462 xabfhc = cc$rms_xabfhc; /* To get record length */
10463 xabfhc.xab$l_nxt = (void *) &xabsum;
10465 xabsum = cc$rms_xabsum; /* To get key and area information */
10467 if (!((sts = sys$open(&fab_in)) & 1)) {
10468 set_vaxc_errno(sts);
10470 case RMS$_FNF: case RMS$_DNF:
10471 set_errno(ENOENT); break;
10473 set_errno(ENOTDIR); break;
10475 set_errno(ENODEV); break;
10477 set_errno(EINVAL); break;
10479 set_errno(EACCES); break;
10481 set_errno(EVMSERR);
10487 fab_out.fab$w_ifi = 0;
10488 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10489 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10490 fab_out.fab$l_fop = FAB$M_SQO;
10491 fab_out.fab$l_fna = vmsout;
10492 fab_out.fab$b_fns = strlen(vmsout);
10493 fab_out.fab$l_dna = nam.nam$l_name;
10494 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10496 if (preserve_dates == 0) { /* Act like DCL COPY */
10497 nam.nam$b_nop |= NAM$M_SYNCHK;
10498 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10499 if (!((sts = sys$parse(&fab_out)) & 1)) {
10500 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10501 set_vaxc_errno(sts);
10504 fab_out.fab$l_xab = (void *) &xabdat;
10505 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10507 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
10508 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10509 preserve_dates =0; /* bitmask from this point forward */
10511 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10512 if (!((sts = sys$create(&fab_out)) & 1)) {
10513 set_vaxc_errno(sts);
10516 set_errno(ENOENT); break;
10518 set_errno(ENOTDIR); break;
10520 set_errno(ENODEV); break;
10522 set_errno(EINVAL); break;
10524 set_errno(EACCES); break;
10526 set_errno(EVMSERR);
10530 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10531 if (preserve_dates & 2) {
10532 /* sys$close() will process xabrdt, not xabdat */
10533 xabrdt = cc$rms_xabrdt;
10535 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10537 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10538 * is unsigned long[2], while DECC & VAXC use a struct */
10539 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10541 fab_out.fab$l_xab = (void *) &xabrdt;
10544 rab_in = cc$rms_rab;
10545 rab_in.rab$l_fab = &fab_in;
10546 rab_in.rab$l_rop = RAB$M_BIO;
10547 rab_in.rab$l_ubf = ubf;
10548 rab_in.rab$w_usz = sizeof ubf;
10549 if (!((sts = sys$connect(&rab_in)) & 1)) {
10550 sys$close(&fab_in); sys$close(&fab_out);
10551 set_errno(EVMSERR); set_vaxc_errno(sts);
10555 rab_out = cc$rms_rab;
10556 rab_out.rab$l_fab = &fab_out;
10557 rab_out.rab$l_rbf = ubf;
10558 if (!((sts = sys$connect(&rab_out)) & 1)) {
10559 sys$close(&fab_in); sys$close(&fab_out);
10560 set_errno(EVMSERR); set_vaxc_errno(sts);
10564 while ((sts = sys$read(&rab_in))) { /* always true */
10565 if (sts == RMS$_EOF) break;
10566 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10567 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10568 sys$close(&fab_in); sys$close(&fab_out);
10569 set_errno(EVMSERR); set_vaxc_errno(sts);
10574 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10575 sys$close(&fab_in); sys$close(&fab_out);
10576 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10578 set_errno(EVMSERR); set_vaxc_errno(sts);
10584 } /* end of rmscopy() */
10586 /* ODS-5 support version */
10588 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10590 char *vmsin, * vmsout, *esa, *esa_out,
10592 unsigned long int i, sts, sts2;
10593 struct FAB fab_in, fab_out;
10594 struct RAB rab_in, rab_out;
10596 struct NAML nam_out;
10597 struct XABDAT xabdat;
10598 struct XABFHC xabfhc;
10599 struct XABRDT xabrdt;
10600 struct XABSUM xabsum;
10602 vmsin = PerlMem_malloc(VMS_MAXRSS);
10603 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
10604 vmsout = PerlMem_malloc(VMS_MAXRSS);
10605 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
10606 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10607 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10608 PerlMem_free(vmsin);
10609 PerlMem_free(vmsout);
10610 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10614 esa = PerlMem_malloc(VMS_MAXRSS);
10615 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
10617 fab_in = cc$rms_fab;
10618 fab_in.fab$l_fna = (char *) -1;
10619 fab_in.fab$b_fns = 0;
10620 nam.naml$l_long_filename = vmsin;
10621 nam.naml$l_long_filename_size = strlen(vmsin);
10622 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10623 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10624 fab_in.fab$l_fop = FAB$M_SQO;
10625 fab_in.fab$l_naml = &nam;
10626 fab_in.fab$l_xab = (void *) &xabdat;
10628 rsa = PerlMem_malloc(VMS_MAXRSS);
10629 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
10630 nam.naml$l_rsa = NULL;
10631 nam.naml$b_rss = 0;
10632 nam.naml$l_long_result = rsa;
10633 nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10634 nam.naml$l_esa = NULL;
10635 nam.naml$b_ess = 0;
10636 nam.naml$l_long_expand = esa;
10637 nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10638 nam.naml$b_esl = nam.naml$b_rsl = 0;
10639 nam.naml$l_long_expand_size = 0;
10640 nam.naml$l_long_result_size = 0;
10641 #ifdef NAM$M_NO_SHORT_UPCASE
10642 if (decc_efs_case_preserve)
10643 nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10646 xabdat = cc$rms_xabdat; /* To get creation date */
10647 xabdat.xab$l_nxt = (void *) &xabfhc;
10649 xabfhc = cc$rms_xabfhc; /* To get record length */
10650 xabfhc.xab$l_nxt = (void *) &xabsum;
10652 xabsum = cc$rms_xabsum; /* To get key and area information */
10654 if (!((sts = sys$open(&fab_in)) & 1)) {
10655 PerlMem_free(vmsin);
10656 PerlMem_free(vmsout);
10659 set_vaxc_errno(sts);
10661 case RMS$_FNF: case RMS$_DNF:
10662 set_errno(ENOENT); break;
10664 set_errno(ENOTDIR); break;
10666 set_errno(ENODEV); break;
10668 set_errno(EINVAL); break;
10670 set_errno(EACCES); break;
10672 set_errno(EVMSERR);
10679 fab_out.fab$w_ifi = 0;
10680 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10681 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10682 fab_out.fab$l_fop = FAB$M_SQO;
10683 fab_out.fab$l_naml = &nam_out;
10684 fab_out.fab$l_fna = (char *) -1;
10685 fab_out.fab$b_fns = 0;
10686 nam_out.naml$l_long_filename = vmsout;
10687 nam_out.naml$l_long_filename_size = strlen(vmsout);
10688 fab_out.fab$l_dna = (char *) -1;
10689 fab_out.fab$b_dns = 0;
10690 nam_out.naml$l_long_defname = nam.naml$l_long_name;
10691 nam_out.naml$l_long_defname_size =
10692 nam.naml$l_long_name ?
10693 nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10695 esa_out = PerlMem_malloc(VMS_MAXRSS);
10696 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
10697 nam_out.naml$l_rsa = NULL;
10698 nam_out.naml$b_rss = 0;
10699 nam_out.naml$l_long_result = NULL;
10700 nam_out.naml$l_long_result_alloc = 0;
10701 nam_out.naml$l_esa = NULL;
10702 nam_out.naml$b_ess = 0;
10703 nam_out.naml$l_long_expand = esa_out;
10704 nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10706 if (preserve_dates == 0) { /* Act like DCL COPY */
10707 nam_out.naml$b_nop |= NAM$M_SYNCHK;
10708 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10709 if (!((sts = sys$parse(&fab_out)) & 1)) {
10710 PerlMem_free(vmsin);
10711 PerlMem_free(vmsout);
10714 PerlMem_free(esa_out);
10715 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10716 set_vaxc_errno(sts);
10719 fab_out.fab$l_xab = (void *) &xabdat;
10720 if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10722 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10723 preserve_dates =0; /* bitmask from this point forward */
10725 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10726 if (!((sts = sys$create(&fab_out)) & 1)) {
10727 PerlMem_free(vmsin);
10728 PerlMem_free(vmsout);
10731 PerlMem_free(esa_out);
10732 set_vaxc_errno(sts);
10735 set_errno(ENOENT); break;
10737 set_errno(ENOTDIR); break;
10739 set_errno(ENODEV); break;
10741 set_errno(EINVAL); break;
10743 set_errno(EACCES); break;
10745 set_errno(EVMSERR);
10749 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10750 if (preserve_dates & 2) {
10751 /* sys$close() will process xabrdt, not xabdat */
10752 xabrdt = cc$rms_xabrdt;
10754 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10756 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10757 * is unsigned long[2], while DECC & VAXC use a struct */
10758 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10760 fab_out.fab$l_xab = (void *) &xabrdt;
10763 ubf = PerlMem_malloc(32256);
10764 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
10765 rab_in = cc$rms_rab;
10766 rab_in.rab$l_fab = &fab_in;
10767 rab_in.rab$l_rop = RAB$M_BIO;
10768 rab_in.rab$l_ubf = ubf;
10769 rab_in.rab$w_usz = 32256;
10770 if (!((sts = sys$connect(&rab_in)) & 1)) {
10771 sys$close(&fab_in); sys$close(&fab_out);
10772 PerlMem_free(vmsin);
10773 PerlMem_free(vmsout);
10777 PerlMem_free(esa_out);
10778 set_errno(EVMSERR); set_vaxc_errno(sts);
10782 rab_out = cc$rms_rab;
10783 rab_out.rab$l_fab = &fab_out;
10784 rab_out.rab$l_rbf = ubf;
10785 if (!((sts = sys$connect(&rab_out)) & 1)) {
10786 sys$close(&fab_in); sys$close(&fab_out);
10787 PerlMem_free(vmsin);
10788 PerlMem_free(vmsout);
10792 PerlMem_free(esa_out);
10793 set_errno(EVMSERR); set_vaxc_errno(sts);
10797 while ((sts = sys$read(&rab_in))) { /* always true */
10798 if (sts == RMS$_EOF) break;
10799 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10800 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10801 sys$close(&fab_in); sys$close(&fab_out);
10802 PerlMem_free(vmsin);
10803 PerlMem_free(vmsout);
10807 PerlMem_free(esa_out);
10808 set_errno(EVMSERR); set_vaxc_errno(sts);
10814 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10815 sys$close(&fab_in); sys$close(&fab_out);
10816 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10818 PerlMem_free(vmsin);
10819 PerlMem_free(vmsout);
10823 PerlMem_free(esa_out);
10824 set_errno(EVMSERR); set_vaxc_errno(sts);
10828 PerlMem_free(vmsin);
10829 PerlMem_free(vmsout);
10833 PerlMem_free(esa_out);
10836 } /* end of rmscopy() */
10841 /*** The following glue provides 'hooks' to make some of the routines
10842 * from this file available from Perl. These routines are sufficiently
10843 * basic, and are required sufficiently early in the build process,
10844 * that's it's nice to have them available to miniperl as well as the
10845 * full Perl, so they're set up here instead of in an extension. The
10846 * Perl code which handles importation of these names into a given
10847 * package lives in [.VMS]Filespec.pm in @INC.
10851 rmsexpand_fromperl(pTHX_ CV *cv)
10854 char *fspec, *defspec = NULL, *rslt;
10857 if (!items || items > 2)
10858 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10859 fspec = SvPV(ST(0),n_a);
10860 if (!fspec || !*fspec) XSRETURN_UNDEF;
10861 if (items == 2) defspec = SvPV(ST(1),n_a);
10863 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10864 ST(0) = sv_newmortal();
10865 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10870 vmsify_fromperl(pTHX_ CV *cv)
10876 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10877 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10878 ST(0) = sv_newmortal();
10879 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10884 unixify_fromperl(pTHX_ CV *cv)
10890 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10891 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10892 ST(0) = sv_newmortal();
10893 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10898 fileify_fromperl(pTHX_ CV *cv)
10904 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10905 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10906 ST(0) = sv_newmortal();
10907 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10912 pathify_fromperl(pTHX_ CV *cv)
10918 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10919 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10920 ST(0) = sv_newmortal();
10921 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10926 vmspath_fromperl(pTHX_ CV *cv)
10932 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10933 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10934 ST(0) = sv_newmortal();
10935 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10940 unixpath_fromperl(pTHX_ CV *cv)
10946 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10947 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10948 ST(0) = sv_newmortal();
10949 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10954 candelete_fromperl(pTHX_ CV *cv)
10962 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10964 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10965 Newx(fspec, VMS_MAXRSS, char);
10966 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
10967 if (SvTYPE(mysv) == SVt_PVGV) {
10968 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10969 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10977 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10978 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10985 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10991 rmscopy_fromperl(pTHX_ CV *cv)
10994 char *inspec, *outspec, *inp, *outp;
10996 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10997 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10998 unsigned long int sts;
11003 if (items < 2 || items > 3)
11004 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11006 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11007 Newx(inspec, VMS_MAXRSS, char);
11008 if (SvTYPE(mysv) == SVt_PVGV) {
11009 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11010 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11018 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11019 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11025 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11026 Newx(outspec, VMS_MAXRSS, char);
11027 if (SvTYPE(mysv) == SVt_PVGV) {
11028 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11029 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11038 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11039 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11046 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11048 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11054 /* The mod2fname is limited to shorter filenames by design, so it should
11055 * not be modified to support longer EFS pathnames
11058 mod2fname(pTHX_ CV *cv)
11061 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11062 workbuff[NAM$C_MAXRSS*1 + 1];
11063 int total_namelen = 3, counter, num_entries;
11064 /* ODS-5 ups this, but we want to be consistent, so... */
11065 int max_name_len = 39;
11066 AV *in_array = (AV *)SvRV(ST(0));
11068 num_entries = av_len(in_array);
11070 /* All the names start with PL_. */
11071 strcpy(ultimate_name, "PL_");
11073 /* Clean up our working buffer */
11074 Zero(work_name, sizeof(work_name), char);
11076 /* Run through the entries and build up a working name */
11077 for(counter = 0; counter <= num_entries; counter++) {
11078 /* If it's not the first name then tack on a __ */
11080 strcat(work_name, "__");
11082 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11086 /* Check to see if we actually have to bother...*/
11087 if (strlen(work_name) + 3 <= max_name_len) {
11088 strcat(ultimate_name, work_name);
11090 /* It's too darned big, so we need to go strip. We use the same */
11091 /* algorithm as xsubpp does. First, strip out doubled __ */
11092 char *source, *dest, last;
11095 for (source = work_name; *source; source++) {
11096 if (last == *source && last == '_') {
11102 /* Go put it back */
11103 strcpy(work_name, workbuff);
11104 /* Is it still too big? */
11105 if (strlen(work_name) + 3 > max_name_len) {
11106 /* Strip duplicate letters */
11109 for (source = work_name; *source; source++) {
11110 if (last == toupper(*source)) {
11114 last = toupper(*source);
11116 strcpy(work_name, workbuff);
11119 /* Is it *still* too big? */
11120 if (strlen(work_name) + 3 > max_name_len) {
11121 /* Too bad, we truncate */
11122 work_name[max_name_len - 2] = 0;
11124 strcat(ultimate_name, work_name);
11127 /* Okay, return it */
11128 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11133 hushexit_fromperl(pTHX_ CV *cv)
11138 VMSISH_HUSHED = SvTRUE(ST(0));
11140 ST(0) = boolSV(VMSISH_HUSHED);
11146 Perl_vms_start_glob
11147 (pTHX_ SV *tmpglob,
11151 struct vs_str_st *rslt;
11155 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11158 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11159 struct dsc$descriptor_vs rsdsc;
11160 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11161 unsigned long hasver = 0, isunix = 0;
11162 unsigned long int lff_flags = 0;
11165 #ifdef VMS_LONGNAME_SUPPORT
11166 lff_flags = LIB$M_FIL_LONG_NAMES;
11168 /* The Newx macro will not allow me to assign a smaller array
11169 * to the rslt pointer, so we will assign it to the begin char pointer
11170 * and then copy the value into the rslt pointer.
11172 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11173 rslt = (struct vs_str_st *)begin;
11175 rstr = &rslt->str[0];
11176 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11177 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11178 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11179 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11181 Newx(vmsspec, VMS_MAXRSS, char);
11183 /* We could find out if there's an explicit dev/dir or version
11184 by peeking into lib$find_file's internal context at
11185 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11186 but that's unsupported, so I don't want to do it now and
11187 have it bite someone in the future. */
11188 /* Fix-me: vms_split_path() is the only way to do this, the
11189 existing method will fail with many legal EFS or UNIX specifications
11192 cp = SvPV(tmpglob,i);
11195 if (cp[i] == ';') hasver = 1;
11196 if (cp[i] == '.') {
11197 if (sts) hasver = 1;
11200 if (cp[i] == '/') {
11201 hasdir = isunix = 1;
11204 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11209 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11212 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11213 if (!stat_sts && S_ISDIR(st.st_mode)) {
11214 wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec);
11215 ok = (wilddsc.dsc$a_pointer != NULL);
11218 wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
11219 ok = (wilddsc.dsc$a_pointer != NULL);
11222 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11224 /* If not extended character set, replace ? with % */
11225 /* With extended character set, ? is a wildcard single character */
11226 if (!decc_efs_case_preserve) {
11227 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11228 if (*cp == '?') *cp = '%';
11231 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11232 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11233 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11235 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11236 &dfltdsc,NULL,&rms_sts,&lff_flags);
11237 if (!$VMS_STATUS_SUCCESS(sts))
11240 /* with varying string, 1st word of buffer contains result length */
11241 rstr[rslt->length] = '\0';
11243 /* Find where all the components are */
11244 v_sts = vms_split_path
11259 /* If no version on input, truncate the version on output */
11260 if (!hasver && (vs_len > 0)) {
11264 /* No version & a null extension on UNIX handling */
11265 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11271 if (!decc_efs_case_preserve) {
11272 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11276 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11280 /* Start with the name */
11283 strcat(begin,"\n");
11284 ok = (PerlIO_puts(tmpfp,begin) != EOF);
11286 if (cxt) (void)lib$find_file_end(&cxt);
11287 if (ok && sts != RMS$_NMF &&
11288 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11291 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11293 PerlIO_close(tmpfp);
11297 PerlIO_rewind(tmpfp);
11298 IoTYPE(io) = IoTYPE_RDONLY;
11299 IoIFP(io) = fp = tmpfp;
11300 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
11310 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
11313 vms_realpath_fromperl(pTHX_ CV *cv)
11316 char *fspec, *rslt_spec, *rslt;
11319 if (!items || items != 1)
11320 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11322 fspec = SvPV(ST(0),n_a);
11323 if (!fspec || !*fspec) XSRETURN_UNDEF;
11325 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11326 rslt = do_vms_realpath(fspec, rslt_spec);
11327 ST(0) = sv_newmortal();
11329 sv_usepvn(ST(0),rslt,strlen(rslt));
11331 Safefree(rslt_spec);
11336 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11337 int do_vms_case_tolerant(void);
11340 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11343 ST(0) = boolSV(do_vms_case_tolerant());
11349 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11350 struct interp_intern *dst)
11352 memcpy(dst,src,sizeof(struct interp_intern));
11356 Perl_sys_intern_clear(pTHX)
11361 Perl_sys_intern_init(pTHX)
11363 unsigned int ix = RAND_MAX;
11368 /* fix me later to track running under GNV */
11369 /* this allows some limited testing */
11370 MY_POSIX_EXIT = decc_filename_unix_report;
11373 MY_INV_RAND_MAX = 1./x;
11377 init_os_extras(void)
11380 char* file = __FILE__;
11381 if (decc_disable_to_vms_logname_translation) {
11382 no_translate_barewords = TRUE;
11384 no_translate_barewords = FALSE;
11387 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11388 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11389 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11390 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11391 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11392 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11393 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11394 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11395 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11396 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11397 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11399 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11401 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11402 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11405 store_pipelocs(aTHX); /* will redo any earlier attempts */
11412 #if __CRTL_VER == 80200000
11413 /* This missed getting in to the DECC SDK for 8.2 */
11414 char *realpath(const char *file_name, char * resolved_name, ...);
11417 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11418 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11419 * The perl fallback routine to provide realpath() is not as efficient
11423 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11425 return realpath(filespec, outbuf);
11429 /* External entry points */
11430 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11431 { return do_vms_realpath(filespec, outbuf); }
11433 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11438 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11439 /* case_tolerant */
11441 /*{{{int do_vms_case_tolerant(void)*/
11442 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11443 * controlled by a process setting.
11445 int do_vms_case_tolerant(void)
11447 return vms_process_case_tolerant;
11450 /* External entry points */
11451 int Perl_vms_case_tolerant(void)
11452 { return do_vms_case_tolerant(); }
11454 int Perl_vms_case_tolerant(void)
11455 { return vms_process_case_tolerant; }
11459 /* Start of DECC RTL Feature handling */
11461 static int sys_trnlnm
11462 (const char * logname,
11466 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11467 const unsigned long attr = LNM$M_CASE_BLIND;
11468 struct dsc$descriptor_s name_dsc;
11470 unsigned short result;
11471 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11474 name_dsc.dsc$w_length = strlen(logname);
11475 name_dsc.dsc$a_pointer = (char *)logname;
11476 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11477 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11479 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11481 if ($VMS_STATUS_SUCCESS(status)) {
11483 /* Null terminate and return the string */
11484 /*--------------------------------------*/
11491 static int sys_crelnm
11492 (const char * logname,
11493 const char * value)
11496 const char * proc_table = "LNM$PROCESS_TABLE";
11497 struct dsc$descriptor_s proc_table_dsc;
11498 struct dsc$descriptor_s logname_dsc;
11499 struct itmlst_3 item_list[2];
11501 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11502 proc_table_dsc.dsc$w_length = strlen(proc_table);
11503 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11504 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11506 logname_dsc.dsc$a_pointer = (char *) logname;
11507 logname_dsc.dsc$w_length = strlen(logname);
11508 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11509 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11511 item_list[0].buflen = strlen(value);
11512 item_list[0].itmcode = LNM$_STRING;
11513 item_list[0].bufadr = (char *)value;
11514 item_list[0].retlen = NULL;
11516 item_list[1].buflen = 0;
11517 item_list[1].itmcode = 0;
11519 ret_val = sys$crelnm
11521 (const struct dsc$descriptor_s *)&proc_table_dsc,
11522 (const struct dsc$descriptor_s *)&logname_dsc,
11524 (const struct item_list_3 *) item_list);
11530 /* C RTL Feature settings */
11532 static int set_features
11533 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
11534 int (* cli_routine)(void), /* Not documented */
11535 void *image_info) /* Not documented */
11542 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11543 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11544 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11545 unsigned long case_perm;
11546 unsigned long case_image;
11549 /* Allow an exception to bring Perl into the VMS debugger */
11550 vms_debug_on_exception = 0;
11551 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11552 if ($VMS_STATUS_SUCCESS(status)) {
11553 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11554 vms_debug_on_exception = 1;
11556 vms_debug_on_exception = 0;
11560 /* hacks to see if known bugs are still present for testing */
11562 /* Readdir is returning filenames in VMS syntax always */
11563 decc_bug_readdir_efs1 = 1;
11564 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11565 if ($VMS_STATUS_SUCCESS(status)) {
11566 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11567 decc_bug_readdir_efs1 = 1;
11569 decc_bug_readdir_efs1 = 0;
11572 /* PCP mode requires creating /dev/null special device file */
11573 decc_bug_devnull = 0;
11574 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11575 if ($VMS_STATUS_SUCCESS(status)) {
11576 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11577 decc_bug_devnull = 1;
11579 decc_bug_devnull = 0;
11582 /* fgetname returning a VMS name in UNIX mode */
11583 decc_bug_fgetname = 1;
11584 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11585 if ($VMS_STATUS_SUCCESS(status)) {
11586 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11587 decc_bug_fgetname = 1;
11589 decc_bug_fgetname = 0;
11592 /* UNIX directory names with no paths are broken in a lot of places */
11593 decc_dir_barename = 1;
11594 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11595 if ($VMS_STATUS_SUCCESS(status)) {
11596 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11597 decc_dir_barename = 1;
11599 decc_dir_barename = 0;
11602 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11603 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11605 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11606 if (decc_disable_to_vms_logname_translation < 0)
11607 decc_disable_to_vms_logname_translation = 0;
11610 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11612 decc_efs_case_preserve = decc$feature_get_value(s, 1);
11613 if (decc_efs_case_preserve < 0)
11614 decc_efs_case_preserve = 0;
11617 s = decc$feature_get_index("DECC$EFS_CHARSET");
11619 decc_efs_charset = decc$feature_get_value(s, 1);
11620 if (decc_efs_charset < 0)
11621 decc_efs_charset = 0;
11624 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11626 decc_filename_unix_report = decc$feature_get_value(s, 1);
11627 if (decc_filename_unix_report > 0)
11628 decc_filename_unix_report = 1;
11630 decc_filename_unix_report = 0;
11633 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11635 decc_filename_unix_only = decc$feature_get_value(s, 1);
11636 if (decc_filename_unix_only > 0) {
11637 decc_filename_unix_only = 1;
11640 decc_filename_unix_only = 0;
11644 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11646 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11647 if (decc_filename_unix_no_version < 0)
11648 decc_filename_unix_no_version = 0;
11651 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11653 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11654 if (decc_readdir_dropdotnotype < 0)
11655 decc_readdir_dropdotnotype = 0;
11658 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11659 if ($VMS_STATUS_SUCCESS(status)) {
11660 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11662 dflt = decc$feature_get_value(s, 4);
11664 decc_disable_posix_root = decc$feature_get_value(s, 1);
11665 if (decc_disable_posix_root <= 0) {
11666 decc$feature_set_value(s, 1, 1);
11667 decc_disable_posix_root = 1;
11671 /* Traditionally Perl assumes this is off */
11672 decc_disable_posix_root = 1;
11673 decc$feature_set_value(s, 1, 1);
11678 #if __CRTL_VER >= 80200000
11679 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11681 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11682 if (decc_posix_compliant_pathnames < 0)
11683 decc_posix_compliant_pathnames = 0;
11684 if (decc_posix_compliant_pathnames > 4)
11685 decc_posix_compliant_pathnames = 0;
11690 status = sys_trnlnm
11691 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11692 if ($VMS_STATUS_SUCCESS(status)) {
11693 val_str[0] = _toupper(val_str[0]);
11694 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11695 decc_disable_to_vms_logname_translation = 1;
11700 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11701 if ($VMS_STATUS_SUCCESS(status)) {
11702 val_str[0] = _toupper(val_str[0]);
11703 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11704 decc_efs_case_preserve = 1;
11709 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11710 if ($VMS_STATUS_SUCCESS(status)) {
11711 val_str[0] = _toupper(val_str[0]);
11712 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11713 decc_filename_unix_report = 1;
11716 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11717 if ($VMS_STATUS_SUCCESS(status)) {
11718 val_str[0] = _toupper(val_str[0]);
11719 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11720 decc_filename_unix_only = 1;
11721 decc_filename_unix_report = 1;
11724 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11725 if ($VMS_STATUS_SUCCESS(status)) {
11726 val_str[0] = _toupper(val_str[0]);
11727 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11728 decc_filename_unix_no_version = 1;
11731 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11732 if ($VMS_STATUS_SUCCESS(status)) {
11733 val_str[0] = _toupper(val_str[0]);
11734 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11735 decc_readdir_dropdotnotype = 1;
11740 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11742 /* Report true case tolerance */
11743 /*----------------------------*/
11744 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11745 if (!$VMS_STATUS_SUCCESS(status))
11746 case_perm = PPROP$K_CASE_BLIND;
11747 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11748 if (!$VMS_STATUS_SUCCESS(status))
11749 case_image = PPROP$K_CASE_BLIND;
11750 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11751 (case_image == PPROP$K_CASE_SENSITIVE))
11752 vms_process_case_tolerant = 0;
11757 /* CRTL can be initialized past this point, but not before. */
11758 /* DECC$CRTL_INIT(); */
11764 /* DECC dependent attributes */
11765 #if __DECC_VER < 60560002
11767 #define not_executable
11769 #define relative ,rel
11770 #define not_executable ,noexe
11773 #pragma extern_model save
11774 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11776 const __align (LONGWORD) int spare[8] = {0};
11777 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11780 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11781 nowrt,noshr relative not_executable
11783 const long vms_cc_features = (const long)set_features;
11786 ** Force a reference to LIB$INITIALIZE to ensure it
11787 ** exists in the image.
11789 int lib$initialize(void);
11791 #pragma extern_model strict_refdef
11793 int lib_init_ref = (int) lib$initialize;
11796 #pragma extern_model restore