3 * VMS-specific routines for perl5
6 * August 2005 Convert VMS status code to UNIX status codes
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
44 #include <str$routines.h>
51 /* Set the maximum filespec size here as it is larger for EFS file
53 * Not fully implemented at this time because the larger size
54 * will likely impact the stack local storage requirements of
55 * threaded code, and probably cause hard to diagnose failures.
56 * To implement the larger sizes, all places where filename
57 * storage is put on the stack need to be changed to use
58 * New()/SafeFree() instead.
63 #define VMS_MAXRSS (NAML$C_MAXRSS+1)
64 #ifndef VMS_LONGNAME_SUPPORT
65 #define VMS_LONGNAME_SUPPORT 1
66 #endif /* VMS_LONGNAME_SUPPORT */
67 #endif /* NAML$C_MAXRSS */
68 #endif /* VMS_MAXRSS */
71 /* temporary hack until support is complete */
72 #ifdef VMS_LONGNAME_SUPPORT
73 #undef VMS_LONGNAME_SUPPORT
76 /* end of temporary hack until support is complete */
79 #define VMS_MAXRSS (NAM$C_MAXRSS + 1)
82 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
83 int decc$feature_get_index(const char *name);
84 char* decc$feature_get_name(int index);
85 int decc$feature_get_value(int index, int mode);
86 int decc$feature_set_value(int index, int mode, int value);
91 #if __CRTL_VER >= 70300000 && !defined(__VAX)
93 static int set_feature_default(const char *name, int value)
98 index = decc$feature_get_index(name);
100 status = decc$feature_set_value(index, 1, value);
101 if (index == -1 || (status == -1)) {
105 status = decc$feature_get_value(index, 1);
106 if (status != value) {
114 /* Older versions of ssdef.h don't have these */
115 #ifndef SS$_INVFILFOROP
116 # define SS$_INVFILFOROP 3930
118 #ifndef SS$_NOSUCHOBJECT
119 # define SS$_NOSUCHOBJECT 2696
122 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
123 #define PERLIO_NOT_STDIO 0
125 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
126 * code below needs to get to the underlying CRTL routines. */
127 #define DONT_MASK_RTL_CALLS
131 /* Anticipating future expansion in lexical warnings . . . */
132 #ifndef WARN_INTERNAL
133 # define WARN_INTERNAL WARN_MISC
136 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
137 # define RTL_USES_UTC 1
141 /* gcc's header files don't #define direct access macros
142 * corresponding to VAXC's variant structs */
144 # define uic$v_format uic$r_uic_form.uic$v_format
145 # define uic$v_group uic$r_uic_form.uic$v_group
146 # define uic$v_member uic$r_uic_form.uic$v_member
147 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
148 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
149 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
150 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
153 #if defined(NEED_AN_H_ERRNO)
158 #pragma message disable pragma
159 #pragma member_alignment save
160 #pragma nomember_alignment longword
162 #pragma message disable misalgndmem
165 unsigned short int buflen;
166 unsigned short int itmcode;
168 unsigned short int *retlen;
171 struct filescan_itmlst_2 {
172 unsigned short length;
173 unsigned short itmcode;
178 unsigned short length;
183 #pragma message restore
184 #pragma member_alignment restore
187 #define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c)
188 #define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c)
189 #define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c)
190 #define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c)
191 #define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e)
192 #define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b)
193 #define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c)
194 #define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c)
195 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
196 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
197 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
199 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts);
200 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts);
201 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
202 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts);
204 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
205 #define PERL_LNM_MAX_ALLOWED_INDEX 127
207 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
208 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
211 #define PERL_LNM_MAX_ITER 10
213 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
214 #if __CRTL_VER >= 70302000 && !defined(__VAX)
215 #define MAX_DCL_SYMBOL (8192)
216 #define MAX_DCL_LINE_LENGTH (4096 - 4)
218 #define MAX_DCL_SYMBOL (1024)
219 #define MAX_DCL_LINE_LENGTH (1024 - 4)
222 static char *__mystrtolower(char *str)
224 if (str) for (; *str; ++str) *str= tolower(*str);
228 static struct dsc$descriptor_s fildevdsc =
229 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
230 static struct dsc$descriptor_s crtlenvdsc =
231 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
232 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
233 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
234 static struct dsc$descriptor_s **env_tables = defenv;
235 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
237 /* True if we shouldn't treat barewords as logicals during directory */
239 static int no_translate_barewords;
242 static int tz_updated = 1;
245 /* DECC Features that may need to affect how Perl interprets
246 * displays filename information
248 static int decc_disable_to_vms_logname_translation = 1;
249 static int decc_disable_posix_root = 1;
250 int decc_efs_case_preserve = 0;
251 static int decc_efs_charset = 0;
252 static int decc_filename_unix_no_version = 0;
253 static int decc_filename_unix_only = 0;
254 int decc_filename_unix_report = 0;
255 int decc_posix_compliant_pathnames = 0;
256 int decc_readdir_dropdotnotype = 0;
257 static int vms_process_case_tolerant = 1;
259 /* bug workarounds if needed */
260 int decc_bug_readdir_efs1 = 0;
261 int decc_bug_devnull = 1;
262 int decc_bug_fgetname = 0;
263 int decc_dir_barename = 0;
265 static int vms_debug_on_exception = 0;
267 /* Is this a UNIX file specification?
268 * No longer a simple check with EFS file specs
269 * For now, not a full check, but need to
270 * handle POSIX ^UP^ specifications
271 * Fixing to handle ^/ cases would require
272 * changes to many other conversion routines.
275 static int is_unix_filespec(const char *path)
281 if (strncmp(path,"\"^UP^",5) != 0) {
282 pch1 = strchr(path, '/');
287 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
288 if (decc_filename_unix_report || decc_filename_unix_only) {
289 if (strcmp(path,".") == 0)
297 /* This handles the expansion of a '^' prefix to the proper character
298 * in a UNIX file specification.
300 * The output count variable contains the number of characters added
301 * to the output string.
303 * The return value is the number of characters read from the input
306 static int copy_expand_vms_filename_escape
307 (char *outspec, const char *inspec, int *output_cnt)
314 if (*inspec == '^') {
318 /* Non trailing dots should just be passed through */
323 case '_': /* space */
329 case 'U': /* Unicode */
332 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
335 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
336 outspec[0] == c1 & 0xff;
337 outspec[1] == c2 & 0xff;
344 /* Error - do best we can to continue */
354 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
358 scnt = sscanf(inspec, "%2x", &c1);
359 outspec[0] = c1 & 0xff;
382 (const struct dsc$descriptor_s * srcstr,
383 struct filescan_itmlst_2 * valuelist,
384 unsigned long * fldflags,
385 struct dsc$descriptor_s *auxout,
386 unsigned short * retlen);
388 /* vms_split_path - Verify that the input file specification is a
389 * VMS format file specification, and provide pointers to the components of
390 * it. With EFS format filenames, this is virtually the only way to
391 * parse a VMS path specification into components.
393 * If the sum of the components do not add up to the length of the
394 * string, then the passed file specification is probably a UNIX style
397 static int vms_split_path
398 (pTHX_ const char * path,
412 struct dsc$descriptor path_desc;
416 struct filescan_itmlst_2 item_list[9];
417 const int filespec = 0;
418 const int nodespec = 1;
419 const int devspec = 2;
420 const int rootspec = 3;
421 const int dirspec = 4;
422 const int namespec = 5;
423 const int typespec = 6;
424 const int verspec = 7;
426 /* Assume the worst for an easy exit */
441 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
442 path_desc.dsc$w_length = strlen(path);
443 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
444 path_desc.dsc$b_class = DSC$K_CLASS_S;
446 /* Get the total length, if it is shorter than the string passed
447 * then this was probably not a VMS formatted file specification
449 item_list[filespec].itmcode = FSCN$_FILESPEC;
450 item_list[filespec].length = 0;
451 item_list[filespec].component = NULL;
453 /* If the node is present, then it gets considered as part of the
454 * volume name to hopefully make things simple.
456 item_list[nodespec].itmcode = FSCN$_NODE;
457 item_list[nodespec].length = 0;
458 item_list[nodespec].component = NULL;
460 item_list[devspec].itmcode = FSCN$_DEVICE;
461 item_list[devspec].length = 0;
462 item_list[devspec].component = NULL;
464 /* root is a special case, adding it to either the directory or
465 * the device components will probalby complicate things for the
466 * callers of this routine, so leave it separate.
468 item_list[rootspec].itmcode = FSCN$_ROOT;
469 item_list[rootspec].length = 0;
470 item_list[rootspec].component = NULL;
472 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
473 item_list[dirspec].length = 0;
474 item_list[dirspec].component = NULL;
476 item_list[namespec].itmcode = FSCN$_NAME;
477 item_list[namespec].length = 0;
478 item_list[namespec].component = NULL;
480 item_list[typespec].itmcode = FSCN$_TYPE;
481 item_list[typespec].length = 0;
482 item_list[typespec].component = NULL;
484 item_list[verspec].itmcode = FSCN$_VERSION;
485 item_list[verspec].length = 0;
486 item_list[verspec].component = NULL;
488 item_list[8].itmcode = 0;
489 item_list[8].length = 0;
490 item_list[8].component = NULL;
492 status = SYS$FILESCAN
493 ((const struct dsc$descriptor_s *)&path_desc, item_list,
495 _ckvmssts(status); /* All failure status values indicate a coding error */
497 /* If we parsed it successfully these two lengths should be the same */
498 if (path_desc.dsc$w_length != item_list[filespec].length)
501 /* If we got here, then it is a VMS file specification */
504 /* set the volume name */
505 if (item_list[nodespec].length > 0) {
506 *volume = item_list[nodespec].component;
507 *vol_len = item_list[nodespec].length + item_list[devspec].length;
510 *volume = item_list[devspec].component;
511 *vol_len = item_list[devspec].length;
514 *root = item_list[rootspec].component;
515 *root_len = item_list[rootspec].length;
517 *dir = item_list[dirspec].component;
518 *dir_len = item_list[dirspec].length;
520 /* Now fun with versions and EFS file specifications
521 * The parser can not tell the difference when a "." is a version
522 * delimiter or a part of the file specification.
524 if ((decc_efs_charset) &&
525 (item_list[verspec].length > 0) &&
526 (item_list[verspec].component[0] == '.')) {
527 *name = item_list[namespec].component;
528 *name_len = item_list[namespec].length + item_list[typespec].length;
529 *ext = item_list[verspec].component;
530 *ext_len = item_list[verspec].length;
535 *name = item_list[namespec].component;
536 *name_len = item_list[namespec].length;
537 *ext = item_list[typespec].component;
538 *ext_len = item_list[typespec].length;
539 *version = item_list[verspec].component;
540 *ver_len = item_list[verspec].length;
547 * Routine to retrieve the maximum equivalence index for an input
548 * logical name. Some calls to this routine have no knowledge if
549 * the variable is a logical or not. So on error we return a max
552 /*{{{int my_maxidx(const char *lnm) */
554 my_maxidx(const char *lnm)
558 int attr = LNM$M_CASE_BLIND;
559 struct dsc$descriptor lnmdsc;
560 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
563 lnmdsc.dsc$w_length = strlen(lnm);
564 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
565 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
566 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
568 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
569 if ((status & 1) == 0)
576 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
578 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
579 struct dsc$descriptor_s **tabvec, unsigned long int flags)
582 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
583 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
584 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
586 unsigned char acmode;
587 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
588 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
589 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
590 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
592 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
593 #if defined(PERL_IMPLICIT_CONTEXT)
596 aTHX = PERL_GET_INTERP;
602 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
603 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
605 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
606 *cp2 = _toupper(*cp1);
607 if (cp1 - lnm > LNM$C_NAMLENGTH) {
608 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
612 lnmdsc.dsc$w_length = cp1 - lnm;
613 lnmdsc.dsc$a_pointer = uplnm;
614 uplnm[lnmdsc.dsc$w_length] = '\0';
615 secure = flags & PERL__TRNENV_SECURE;
616 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
617 if (!tabvec || !*tabvec) tabvec = env_tables;
619 for (curtab = 0; tabvec[curtab]; curtab++) {
620 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
621 if (!ivenv && !secure) {
626 Perl_warn(aTHX_ "Can't read CRTL environ\n");
629 retsts = SS$_NOLOGNAM;
630 for (i = 0; environ[i]; i++) {
631 if ((eq = strchr(environ[i],'=')) &&
632 lnmdsc.dsc$w_length == (eq - environ[i]) &&
633 !strncmp(environ[i],uplnm,eq - environ[i])) {
635 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
636 if (!eqvlen) continue;
641 if (retsts != SS$_NOLOGNAM) break;
644 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
645 !str$case_blind_compare(&tmpdsc,&clisym)) {
646 if (!ivsym && !secure) {
647 unsigned short int deflen = LNM$C_NAMLENGTH;
648 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
649 /* dynamic dsc to accomodate possible long value */
650 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
651 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
653 if (eqvlen > MAX_DCL_SYMBOL) {
654 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
655 eqvlen = MAX_DCL_SYMBOL;
656 /* Special hack--we might be called before the interpreter's */
657 /* fully initialized, in which case either thr or PL_curcop */
658 /* might be bogus. We have to check, since ckWARN needs them */
659 /* both to be valid if running threaded */
660 if (ckWARN(WARN_MISC)) {
661 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
664 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
666 _ckvmssts(lib$sfree1_dd(&eqvdsc));
667 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
668 if (retsts == LIB$_NOSUCHSYM) continue;
673 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
674 midx = my_maxidx(lnm);
675 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
676 lnmlst[1].bufadr = cp2;
678 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
679 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
680 if (retsts == SS$_NOLOGNAM) break;
681 /* PPFs have a prefix */
684 *((int *)uplnm) == *((int *)"SYS$") &&
686 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
687 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
688 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
689 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
690 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
691 memmove(eqv,eqv+4,eqvlen-4);
697 if ((retsts == SS$_IVLOGNAM) ||
698 (retsts == SS$_NOLOGNAM)) { continue; }
701 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
702 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
703 if (retsts == SS$_NOLOGNAM) continue;
706 eqvlen = strlen(eqv);
710 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
711 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
712 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
713 retsts == SS$_NOLOGNAM) {
714 set_errno(EINVAL); set_vaxc_errno(retsts);
716 else _ckvmssts(retsts);
718 } /* end of vmstrnenv */
721 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
722 /* Define as a function so we can access statics. */
723 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
725 return vmstrnenv(lnm,eqv,idx,fildev,
726 #ifdef SECURE_INTERNAL_GETENV
727 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
736 * Note: Uses Perl temp to store result so char * can be returned to
737 * caller; this pointer will be invalidated at next Perl statement
739 * We define this as a function rather than a macro in terms of my_getenv_len()
740 * so that it'll work when PL_curinterp is undefined (and we therefore can't
743 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
745 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
748 static char *__my_getenv_eqv = NULL;
749 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
750 unsigned long int idx = 0;
751 int trnsuccess, success, secure, saverr, savvmserr;
755 midx = my_maxidx(lnm) + 1;
757 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
758 /* Set up a temporary buffer for the return value; Perl will
759 * clean it up at the next statement transition */
760 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
761 if (!tmpsv) return NULL;
765 /* Assume no interpreter ==> single thread */
766 if (__my_getenv_eqv != NULL) {
767 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
770 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
772 eqv = __my_getenv_eqv;
775 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
776 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
778 getcwd(eqv,LNM$C_NAMLENGTH);
782 /* Get rid of "000000/ in rooted filespecs */
785 zeros = strstr(eqv, "/000000/");
788 mlen = len - (zeros - eqv) - 7;
789 memmove(zeros, &zeros[7], mlen);
797 /* Impose security constraints only if tainting */
799 /* Impose security constraints only if tainting */
800 secure = PL_curinterp ? PL_tainting : will_taint;
801 saverr = errno; savvmserr = vaxc$errno;
808 #ifdef SECURE_INTERNAL_GETENV
809 secure ? PERL__TRNENV_SECURE : 0
815 /* For the getenv interface we combine all the equivalence names
816 * of a search list logical into one value to acquire a maximum
817 * value length of 255*128 (assuming %ENV is using logicals).
819 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
821 /* If the name contains a semicolon-delimited index, parse it
822 * off and make sure we only retrieve the equivalence name for
824 if ((cp2 = strchr(lnm,';')) != NULL) {
826 uplnm[cp2-lnm] = '\0';
827 idx = strtoul(cp2+1,NULL,0);
829 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
832 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
834 /* Discard NOLOGNAM on internal calls since we're often looking
835 * for an optional name, and this "error" often shows up as the
836 * (bogus) exit status for a die() call later on. */
837 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
838 return success ? eqv : Nullch;
841 } /* end of my_getenv() */
845 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
847 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
851 unsigned long idx = 0;
853 static char *__my_getenv_len_eqv = NULL;
854 int secure, saverr, savvmserr;
857 midx = my_maxidx(lnm) + 1;
859 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
860 /* Set up a temporary buffer for the return value; Perl will
861 * clean it up at the next statement transition */
862 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
863 if (!tmpsv) return NULL;
867 /* Assume no interpreter ==> single thread */
868 if (__my_getenv_len_eqv != NULL) {
869 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
872 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
874 buf = __my_getenv_len_eqv;
877 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
878 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
881 getcwd(buf,LNM$C_NAMLENGTH);
884 /* Get rid of "000000/ in rooted filespecs */
886 zeros = strstr(buf, "/000000/");
889 mlen = *len - (zeros - buf) - 7;
890 memmove(zeros, &zeros[7], mlen);
899 /* Impose security constraints only if tainting */
900 secure = PL_curinterp ? PL_tainting : will_taint;
901 saverr = errno; savvmserr = vaxc$errno;
908 #ifdef SECURE_INTERNAL_GETENV
909 secure ? PERL__TRNENV_SECURE : 0
915 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
917 if ((cp2 = strchr(lnm,';')) != NULL) {
920 idx = strtoul(cp2+1,NULL,0);
922 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
925 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
927 /* Get rid of "000000/ in rooted filespecs */
930 zeros = strstr(buf, "/000000/");
933 mlen = *len - (zeros - buf) - 7;
934 memmove(zeros, &zeros[7], mlen);
940 /* Discard NOLOGNAM on internal calls since we're often looking
941 * for an optional name, and this "error" often shows up as the
942 * (bogus) exit status for a die() call later on. */
943 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
944 return *len ? buf : Nullch;
947 } /* end of my_getenv_len() */
950 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
952 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
954 /*{{{ void prime_env_iter() */
957 /* Fill the %ENV associative array with all logical names we can
958 * find, in preparation for iterating over it.
961 static int primed = 0;
962 HV *seenhv = NULL, *envhv;
964 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
965 unsigned short int chan;
966 #ifndef CLI$M_TRUSTED
967 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
969 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
970 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
972 bool have_sym = FALSE, have_lnm = FALSE;
973 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
974 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
975 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
976 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
977 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
978 #if defined(PERL_IMPLICIT_CONTEXT)
981 #if defined(USE_ITHREADS)
982 static perl_mutex primenv_mutex;
983 MUTEX_INIT(&primenv_mutex);
986 #if defined(PERL_IMPLICIT_CONTEXT)
987 /* We jump through these hoops because we can be called at */
988 /* platform-specific initialization time, which is before anything is */
989 /* set up--we can't even do a plain dTHX since that relies on the */
990 /* interpreter structure to be initialized */
992 aTHX = PERL_GET_INTERP;
998 if (primed || !PL_envgv) return;
999 MUTEX_LOCK(&primenv_mutex);
1000 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1001 envhv = GvHVn(PL_envgv);
1002 /* Perform a dummy fetch as an lval to insure that the hash table is
1003 * set up. Otherwise, the hv_store() will turn into a nullop. */
1004 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1006 for (i = 0; env_tables[i]; i++) {
1007 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1008 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1009 if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1011 if (have_sym || have_lnm) {
1012 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1013 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1014 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1015 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1018 for (i--; i >= 0; i--) {
1019 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1022 for (j = 0; environ[j]; j++) {
1023 if (!(start = strchr(environ[j],'='))) {
1024 if (ckWARN(WARN_INTERNAL))
1025 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1029 sv = newSVpv(start,0);
1031 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1036 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1037 !str$case_blind_compare(&tmpdsc,&clisym)) {
1038 strcpy(cmd,"Show Symbol/Global *");
1039 cmddsc.dsc$w_length = 20;
1040 if (env_tables[i]->dsc$w_length == 12 &&
1041 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1042 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1043 flags = defflags | CLI$M_NOLOGNAM;
1046 strcpy(cmd,"Show Logical *");
1047 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1048 strcat(cmd," /Table=");
1049 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1050 cmddsc.dsc$w_length = strlen(cmd);
1052 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1053 flags = defflags | CLI$M_NOCLISYM;
1056 /* Create a new subprocess to execute each command, to exclude the
1057 * remote possibility that someone could subvert a mbx or file used
1058 * to write multiple commands to a single subprocess.
1061 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1062 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1063 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1064 defflags &= ~CLI$M_TRUSTED;
1065 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1067 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1068 if (seenhv) SvREFCNT_dec(seenhv);
1071 char *cp1, *cp2, *key;
1072 unsigned long int sts, iosb[2], retlen, keylen;
1075 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1076 if (sts & 1) sts = iosb[0] & 0xffff;
1077 if (sts == SS$_ENDOFFILE) {
1079 while (substs == 0) { sys$hiber(); wakect++;}
1080 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1085 retlen = iosb[0] >> 16;
1086 if (!retlen) continue; /* blank line */
1088 if (iosb[1] != subpid) {
1090 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1094 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1095 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1097 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1098 if (*cp1 == '(' || /* Logical name table name */
1099 *cp1 == '=' /* Next eqv of searchlist */) continue;
1100 if (*cp1 == '"') cp1++;
1101 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1102 key = cp1; keylen = cp2 - cp1;
1103 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1104 while (*cp2 && *cp2 != '=') cp2++;
1105 while (*cp2 && *cp2 == '=') cp2++;
1106 while (*cp2 && *cp2 == ' ') cp2++;
1107 if (*cp2 == '"') { /* String translation; may embed "" */
1108 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1109 cp2++; cp1--; /* Skip "" surrounding translation */
1111 else { /* Numeric translation */
1112 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1113 cp1--; /* stop on last non-space char */
1115 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1116 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1119 PERL_HASH(hash,key,keylen);
1121 if (cp1 == cp2 && *cp2 == '.') {
1122 /* A single dot usually means an unprintable character, such as a null
1123 * to indicate a zero-length value. Get the actual value to make sure.
1125 char lnm[LNM$C_NAMLENGTH+1];
1126 char eqv[MAX_DCL_SYMBOL+1];
1127 strncpy(lnm, key, keylen);
1128 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1129 sv = newSVpvn(eqv, strlen(eqv));
1132 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1136 hv_store(envhv,key,keylen,sv,hash);
1137 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1139 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1140 /* get the PPFs for this process, not the subprocess */
1141 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1142 char eqv[LNM$C_NAMLENGTH+1];
1144 for (i = 0; ppfs[i]; i++) {
1145 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1146 sv = newSVpv(eqv,trnlen);
1148 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1153 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1154 if (buf) Safefree(buf);
1155 if (seenhv) SvREFCNT_dec(seenhv);
1156 MUTEX_UNLOCK(&primenv_mutex);
1159 } /* end of prime_env_iter */
1163 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1164 /* Define or delete an element in the same "environment" as
1165 * vmstrnenv(). If an element is to be deleted, it's removed from
1166 * the first place it's found. If it's to be set, it's set in the
1167 * place designated by the first element of the table vector.
1168 * Like setenv() returns 0 for success, non-zero on error.
1171 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1174 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1175 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1177 unsigned long int retsts, usermode = PSL$C_USER;
1178 struct itmlst_3 *ile, *ilist;
1179 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1180 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1181 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1182 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1183 $DESCRIPTOR(local,"_LOCAL");
1186 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1187 return SS$_IVLOGNAM;
1190 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1191 *cp2 = _toupper(*cp1);
1192 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1193 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1194 return SS$_IVLOGNAM;
1197 lnmdsc.dsc$w_length = cp1 - lnm;
1198 if (!tabvec || !*tabvec) tabvec = env_tables;
1200 if (!eqv) { /* we're deleting n element */
1201 for (curtab = 0; tabvec[curtab]; curtab++) {
1202 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1204 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1205 if ((cp1 = strchr(environ[i],'=')) &&
1206 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1207 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1209 return setenv(lnm,"",1) ? vaxc$errno : 0;
1212 ivenv = 1; retsts = SS$_NOLOGNAM;
1214 if (ckWARN(WARN_INTERNAL))
1215 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1216 ivenv = 1; retsts = SS$_NOSUCHPGM;
1222 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1223 !str$case_blind_compare(&tmpdsc,&clisym)) {
1224 unsigned int symtype;
1225 if (tabvec[curtab]->dsc$w_length == 12 &&
1226 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1227 !str$case_blind_compare(&tmpdsc,&local))
1228 symtype = LIB$K_CLI_LOCAL_SYM;
1229 else symtype = LIB$K_CLI_GLOBAL_SYM;
1230 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1231 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1232 if (retsts == LIB$_NOSUCHSYM) continue;
1236 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1237 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1238 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1239 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1240 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1244 else { /* we're defining a value */
1245 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1247 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1249 if (ckWARN(WARN_INTERNAL))
1250 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1251 retsts = SS$_NOSUCHPGM;
1255 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1256 eqvdsc.dsc$w_length = strlen(eqv);
1257 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1258 !str$case_blind_compare(&tmpdsc,&clisym)) {
1259 unsigned int symtype;
1260 if (tabvec[0]->dsc$w_length == 12 &&
1261 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1262 !str$case_blind_compare(&tmpdsc,&local))
1263 symtype = LIB$K_CLI_LOCAL_SYM;
1264 else symtype = LIB$K_CLI_GLOBAL_SYM;
1265 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1268 if (!*eqv) eqvdsc.dsc$w_length = 1;
1269 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1271 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1272 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1273 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1274 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1275 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1276 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1279 Newx(ilist,nseg+1,struct itmlst_3);
1282 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1285 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1287 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1288 ile->itmcode = LNM$_STRING;
1290 if ((j+1) == nseg) {
1291 ile->buflen = strlen(c);
1292 /* in case we are truncating one that's too long */
1293 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1296 ile->buflen = LNM$C_NAMLENGTH;
1300 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1304 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1309 if (!(retsts & 1)) {
1311 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1312 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1313 set_errno(EVMSERR); break;
1314 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1315 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1316 set_errno(EINVAL); break;
1323 set_vaxc_errno(retsts);
1324 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1327 /* We reset error values on success because Perl does an hv_fetch()
1328 * before each hv_store(), and if the thing we're setting didn't
1329 * previously exist, we've got a leftover error message. (Of course,
1330 * this fails in the face of
1331 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1332 * in that the error reported in $! isn't spurious,
1333 * but it's right more often than not.)
1335 set_errno(0); set_vaxc_errno(retsts);
1339 } /* end of vmssetenv() */
1342 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1343 /* This has to be a function since there's a prototype for it in proto.h */
1345 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1348 int len = strlen(lnm);
1352 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1353 if (!strcmp(uplnm,"DEFAULT")) {
1354 if (eqv && *eqv) my_chdir(eqv);
1358 #ifndef RTL_USES_UTC
1359 if (len == 6 || len == 2) {
1362 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1364 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1365 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1369 (void) vmssetenv(lnm,eqv,NULL);
1373 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1375 * sets a user-mode logical in the process logical name table
1376 * used for redirection of sys$error
1379 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1381 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1382 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1383 unsigned long int iss, attr = LNM$M_CONFINE;
1384 unsigned char acmode = PSL$C_USER;
1385 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1387 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1388 d_name.dsc$w_length = strlen(name);
1390 lnmlst[0].buflen = strlen(eqv);
1391 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1393 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1394 if (!(iss&1)) lib$signal(iss);
1399 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1400 /* my_crypt - VMS password hashing
1401 * my_crypt() provides an interface compatible with the Unix crypt()
1402 * C library function, and uses sys$hash_password() to perform VMS
1403 * password hashing. The quadword hashed password value is returned
1404 * as a NUL-terminated 8 character string. my_crypt() does not change
1405 * the case of its string arguments; in order to match the behavior
1406 * of LOGINOUT et al., alphabetic characters in both arguments must
1407 * be upcased by the caller.
1409 * - fix me to call ACM services when available
1412 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1414 # ifndef UAI$C_PREFERRED_ALGORITHM
1415 # define UAI$C_PREFERRED_ALGORITHM 127
1417 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1418 unsigned short int salt = 0;
1419 unsigned long int sts;
1421 unsigned short int dsc$w_length;
1422 unsigned char dsc$b_type;
1423 unsigned char dsc$b_class;
1424 const char * dsc$a_pointer;
1425 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1426 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1427 struct itmlst_3 uailst[3] = {
1428 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1429 { sizeof salt, UAI$_SALT, &salt, 0},
1430 { 0, 0, NULL, NULL}};
1431 static char hash[9];
1433 usrdsc.dsc$w_length = strlen(usrname);
1434 usrdsc.dsc$a_pointer = usrname;
1435 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1437 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1441 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1446 set_vaxc_errno(sts);
1447 if (sts != RMS$_RNF) return NULL;
1450 txtdsc.dsc$w_length = strlen(textpasswd);
1451 txtdsc.dsc$a_pointer = textpasswd;
1452 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1453 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1456 return (char *) hash;
1458 } /* end of my_crypt() */
1462 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned);
1463 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int);
1464 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int);
1466 /* fixup barenames that are directories for internal use.
1467 * There have been problems with the consistent handling of UNIX
1468 * style directory names when routines are presented with a name that
1469 * has no directory delimitors at all. So this routine will eventually
1472 static char * fixup_bare_dirnames(const char * name)
1474 if (decc_disable_to_vms_logname_translation) {
1481 * A little hack to get around a bug in some implemenation of remove()
1482 * that do not know how to delete a directory
1484 * Delete any file to which user has control access, regardless of whether
1485 * delete access is explicitly allowed.
1486 * Limitations: User must have write access to parent directory.
1487 * Does not block signals or ASTs; if interrupted in midstream
1488 * may leave file with an altered ACL.
1491 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1493 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1495 char *vmsname, *rspec;
1497 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1498 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1499 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1501 unsigned char myace$b_length;
1502 unsigned char myace$b_type;
1503 unsigned short int myace$w_flags;
1504 unsigned long int myace$l_access;
1505 unsigned long int myace$l_ident;
1506 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1507 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1508 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1510 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1511 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1512 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1513 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1514 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1515 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1517 /* Expand the input spec using RMS, since the CRTL remove() and
1518 * system services won't do this by themselves, so we may miss
1519 * a file "hiding" behind a logical name or search list. */
1520 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1521 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1523 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1524 PerlMem_free(vmsname);
1528 if (decc_posix_compliant_pathnames) {
1529 /* In POSIX mode, we prefer to remove the UNIX name */
1531 remove_name = (char *)name;
1534 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1535 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1536 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) {
1537 PerlMem_free(rspec);
1538 PerlMem_free(vmsname);
1541 PerlMem_free(vmsname);
1542 remove_name = rspec;
1545 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1547 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1548 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1549 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1551 do_pathify_dirspec(name, remove_name, 0);
1552 if (!rmdir(remove_name)) {
1554 PerlMem_free(remove_name);
1555 PerlMem_free(rspec);
1556 return 0; /* Can we just get rid of it? */
1560 if (!rmdir(remove_name)) {
1561 PerlMem_free(rspec);
1562 return 0; /* Can we just get rid of it? */
1568 if (!remove(remove_name)) {
1569 PerlMem_free(rspec);
1570 return 0; /* Can we just get rid of it? */
1573 /* If not, can changing protections help? */
1574 if (vaxc$errno != RMS$_PRV) {
1575 PerlMem_free(rspec);
1579 /* No, so we get our own UIC to use as a rights identifier,
1580 * and the insert an ACE at the head of the ACL which allows us
1581 * to delete the file.
1583 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1584 fildsc.dsc$w_length = strlen(rspec);
1585 fildsc.dsc$a_pointer = rspec;
1587 newace.myace$l_ident = oldace.myace$l_ident;
1588 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1590 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1591 set_errno(ENOENT); break;
1593 set_errno(ENOTDIR); break;
1595 set_errno(ENODEV); break;
1596 case RMS$_SYN: case SS$_INVFILFOROP:
1597 set_errno(EINVAL); break;
1599 set_errno(EACCES); break;
1603 set_vaxc_errno(aclsts);
1604 PerlMem_free(rspec);
1607 /* Grab any existing ACEs with this identifier in case we fail */
1608 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1609 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1610 || fndsts == SS$_NOMOREACE ) {
1611 /* Add the new ACE . . . */
1612 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1615 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1617 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1618 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1619 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1621 do_pathify_dirspec(name, remove_name, 0);
1622 rmsts = rmdir(remove_name);
1623 PerlMem_free(remove_name);
1626 rmsts = rmdir(remove_name);
1630 rmsts = remove(remove_name);
1632 /* We blew it - dir with files in it, no write priv for
1633 * parent directory, etc. Put things back the way they were. */
1634 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1637 addlst[0].bufadr = &oldace;
1638 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1645 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1646 /* We just deleted it, so of course it's not there. Some versions of
1647 * VMS seem to return success on the unlock operation anyhow (after all
1648 * the unlock is successful), but others don't.
1650 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1651 if (aclsts & 1) aclsts = fndsts;
1652 if (!(aclsts & 1)) {
1654 set_vaxc_errno(aclsts);
1655 PerlMem_free(rspec);
1659 PerlMem_free(rspec);
1662 } /* end of kill_file() */
1666 /*{{{int do_rmdir(char *name)*/
1668 Perl_do_rmdir(pTHX_ const char *name)
1670 char dirfile[NAM$C_MAXRSS+1];
1674 if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
1675 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1676 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1679 } /* end of do_rmdir */
1683 * Delete any file to which user has control access, regardless of whether
1684 * delete access is explicitly allowed.
1685 * Limitations: User must have write access to parent directory.
1686 * Does not block signals or ASTs; if interrupted in midstream
1687 * may leave file with an altered ACL.
1690 /*{{{int kill_file(char *name)*/
1692 Perl_kill_file(pTHX_ const char *name)
1694 char rspec[NAM$C_MAXRSS+1];
1696 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1697 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1698 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1700 unsigned char myace$b_length;
1701 unsigned char myace$b_type;
1702 unsigned short int myace$w_flags;
1703 unsigned long int myace$l_access;
1704 unsigned long int myace$l_ident;
1705 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1706 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1707 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1709 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1710 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1711 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1712 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1713 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1714 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1716 /* Expand the input spec using RMS, since the CRTL remove() and
1717 * system services won't do this by themselves, so we may miss
1718 * a file "hiding" behind a logical name or search list. */
1719 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS);
1720 if (tspec == NULL) return -1;
1721 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1722 /* If not, can changing protections help? */
1723 if (vaxc$errno != RMS$_PRV) return -1;
1725 /* No, so we get our own UIC to use as a rights identifier,
1726 * and the insert an ACE at the head of the ACL which allows us
1727 * to delete the file.
1729 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1730 fildsc.dsc$w_length = strlen(rspec);
1731 fildsc.dsc$a_pointer = rspec;
1733 newace.myace$l_ident = oldace.myace$l_ident;
1734 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1736 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1737 set_errno(ENOENT); break;
1739 set_errno(ENOTDIR); break;
1741 set_errno(ENODEV); break;
1742 case RMS$_SYN: case SS$_INVFILFOROP:
1743 set_errno(EINVAL); break;
1745 set_errno(EACCES); break;
1749 set_vaxc_errno(aclsts);
1752 /* Grab any existing ACEs with this identifier in case we fail */
1753 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1754 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1755 || fndsts == SS$_NOMOREACE ) {
1756 /* Add the new ACE . . . */
1757 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1759 if ((rmsts = remove(name))) {
1760 /* We blew it - dir with files in it, no write priv for
1761 * parent directory, etc. Put things back the way they were. */
1762 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1765 addlst[0].bufadr = &oldace;
1766 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1773 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1774 /* We just deleted it, so of course it's not there. Some versions of
1775 * VMS seem to return success on the unlock operation anyhow (after all
1776 * the unlock is successful), but others don't.
1778 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1779 if (aclsts & 1) aclsts = fndsts;
1780 if (!(aclsts & 1)) {
1782 set_vaxc_errno(aclsts);
1788 } /* end of kill_file() */
1792 /*{{{int my_mkdir(char *,Mode_t)*/
1794 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1796 STRLEN dirlen = strlen(dir);
1798 /* zero length string sometimes gives ACCVIO */
1799 if (dirlen == 0) return -1;
1801 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1802 * null file name/type. However, it's commonplace under Unix,
1803 * so we'll allow it for a gain in portability.
1805 if (dir[dirlen-1] == '/') {
1806 char *newdir = savepvn(dir,dirlen-1);
1807 int ret = mkdir(newdir,mode);
1811 else return mkdir(dir,mode);
1812 } /* end of my_mkdir */
1815 /*{{{int my_chdir(char *)*/
1817 Perl_my_chdir(pTHX_ const char *dir)
1819 STRLEN dirlen = strlen(dir);
1821 /* zero length string sometimes gives ACCVIO */
1822 if (dirlen == 0) return -1;
1825 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
1826 * This does not work if DECC$EFS_CHARSET is active. Hack it here
1827 * so that existing scripts do not need to be changed.
1830 while ((dirlen > 0) && (*dir1 == ' ')) {
1835 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
1837 * null file name/type. However, it's commonplace under Unix,
1838 * so we'll allow it for a gain in portability.
1840 * - Preview- '/' will be valid soon on VMS
1842 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
1843 char *newdir = savepvn(dir1,dirlen-1);
1844 int ret = chdir(newdir);
1848 else return chdir(dir1);
1849 } /* end of my_chdir */
1853 /*{{{FILE *my_tmpfile()*/
1860 if ((fp = tmpfile())) return fp;
1862 cp = PerlMem_malloc(L_tmpnam+24);
1863 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1865 if (decc_filename_unix_only == 0)
1866 strcpy(cp,"Sys$Scratch:");
1869 tmpnam(cp+strlen(cp));
1870 strcat(cp,".Perltmp");
1871 fp = fopen(cp,"w+","fop=dlt");
1878 #ifndef HOMEGROWN_POSIX_SIGNALS
1880 * The C RTL's sigaction fails to check for invalid signal numbers so we
1881 * help it out a bit. The docs are correct, but the actual routine doesn't
1882 * do what the docs say it will.
1884 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
1886 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
1887 struct sigaction* oact)
1889 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
1890 SETERRNO(EINVAL, SS$_INVARG);
1893 return sigaction(sig, act, oact);
1898 #ifdef KILL_BY_SIGPRC
1899 #include <errnodef.h>
1901 /* We implement our own kill() using the undocumented system service
1902 sys$sigprc for one of two reasons:
1904 1.) If the kill() in an older CRTL uses sys$forcex, causing the
1905 target process to do a sys$exit, which usually can't be handled
1906 gracefully...certainly not by Perl and the %SIG{} mechanism.
1908 2.) If the kill() in the CRTL can't be called from a signal
1909 handler without disappearing into the ether, i.e., the signal
1910 it purportedly sends is never trapped. Still true as of VMS 7.3.
1912 sys$sigprc has the same parameters as sys$forcex, but throws an exception
1913 in the target process rather than calling sys$exit.
1915 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
1916 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
1917 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
1918 with condition codes C$_SIG0+nsig*8, catching the exception on the
1919 target process and resignaling with appropriate arguments.
1921 But we don't have that VMS 7.0+ exception handler, so if you
1922 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
1924 Also note that SIGTERM is listed in the docs as being "unimplemented",
1925 yet always seems to be signaled with a VMS condition code of 4 (and
1926 correctly handled for that code). So we hardwire it in.
1928 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
1929 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
1930 than signalling with an unrecognized (and unhandled by CRTL) code.
1933 #define _MY_SIG_MAX 17
1936 Perl_sig_to_vmscondition_int(int sig)
1938 static unsigned int sig_code[_MY_SIG_MAX+1] =
1941 SS$_HANGUP, /* 1 SIGHUP */
1942 SS$_CONTROLC, /* 2 SIGINT */
1943 SS$_CONTROLY, /* 3 SIGQUIT */
1944 SS$_RADRMOD, /* 4 SIGILL */
1945 SS$_BREAK, /* 5 SIGTRAP */
1946 SS$_OPCCUS, /* 6 SIGABRT */
1947 SS$_COMPAT, /* 7 SIGEMT */
1949 SS$_FLTOVF, /* 8 SIGFPE VAX */
1951 SS$_HPARITH, /* 8 SIGFPE AXP */
1953 SS$_ABORT, /* 9 SIGKILL */
1954 SS$_ACCVIO, /* 10 SIGBUS */
1955 SS$_ACCVIO, /* 11 SIGSEGV */
1956 SS$_BADPARAM, /* 12 SIGSYS */
1957 SS$_NOMBX, /* 13 SIGPIPE */
1958 SS$_ASTFLT, /* 14 SIGALRM */
1964 #if __VMS_VER >= 60200000
1965 static int initted = 0;
1968 sig_code[16] = C$_SIGUSR1;
1969 sig_code[17] = C$_SIGUSR2;
1973 if (sig < _SIG_MIN) return 0;
1974 if (sig > _MY_SIG_MAX) return 0;
1975 return sig_code[sig];
1979 Perl_sig_to_vmscondition(int sig)
1982 if (vms_debug_on_exception != 0)
1983 lib$signal(SS$_DEBUG);
1985 return Perl_sig_to_vmscondition_int(sig);
1990 Perl_my_kill(int pid, int sig)
1995 int sys$sigprc(unsigned int *pidadr,
1996 struct dsc$descriptor_s *prcname,
1999 /* sig 0 means validate the PID */
2000 /*------------------------------*/
2002 const unsigned long int jpicode = JPI$_PID;
2005 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2006 if ($VMS_STATUS_SUCCESS(status))
2009 case SS$_NOSUCHNODE:
2010 case SS$_UNREACHABLE:
2024 code = Perl_sig_to_vmscondition_int(sig);
2027 SETERRNO(EINVAL, SS$_BADPARAM);
2031 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2032 * signals are to be sent to multiple processes.
2033 * pid = 0 - all processes in group except ones that the system exempts
2034 * pid = -1 - all processes except ones that the system exempts
2035 * pid = -n - all processes in group (abs(n)) except ...
2036 * For now, just report as not supported.
2040 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2044 iss = sys$sigprc((unsigned int *)&pid,0,code);
2045 if (iss&1) return 0;
2049 set_errno(EPERM); break;
2051 case SS$_NOSUCHNODE:
2052 case SS$_UNREACHABLE:
2053 set_errno(ESRCH); break;
2055 set_errno(ENOMEM); break;
2060 set_vaxc_errno(iss);
2066 /* Routine to convert a VMS status code to a UNIX status code.
2067 ** More tricky than it appears because of conflicting conventions with
2070 ** VMS status codes are a bit mask, with the least significant bit set for
2073 ** Special UNIX status of EVMSERR indicates that no translation is currently
2074 ** available, and programs should check the VMS status code.
2076 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2080 #ifndef C_FACILITY_NO
2081 #define C_FACILITY_NO 0x350000
2084 #define DCL_IVVERB 0x38090
2087 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2095 /* Assume the best or the worst */
2096 if (vms_status & STS$M_SUCCESS)
2099 unix_status = EVMSERR;
2101 msg_status = vms_status & ~STS$M_CONTROL;
2103 facility = vms_status & STS$M_FAC_NO;
2104 fac_sp = vms_status & STS$M_FAC_SP;
2105 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2107 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2113 unix_status = EFAULT;
2115 case SS$_DEVOFFLINE:
2116 unix_status = EBUSY;
2119 unix_status = ENOTCONN;
2127 case SS$_INVFILFOROP:
2131 unix_status = EINVAL;
2133 case SS$_UNSUPPORTED:
2134 unix_status = ENOTSUP;
2139 unix_status = EACCES;
2141 case SS$_DEVICEFULL:
2142 unix_status = ENOSPC;
2145 unix_status = ENODEV;
2147 case SS$_NOSUCHFILE:
2148 case SS$_NOSUCHOBJECT:
2149 unix_status = ENOENT;
2151 case SS$_ABORT: /* Fatal case */
2152 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2153 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2154 unix_status = EINTR;
2157 unix_status = E2BIG;
2160 unix_status = ENOMEM;
2163 unix_status = EPERM;
2165 case SS$_NOSUCHNODE:
2166 case SS$_UNREACHABLE:
2167 unix_status = ESRCH;
2170 unix_status = ECHILD;
2173 if ((facility == 0) && (msg_no < 8)) {
2174 /* These are not real VMS status codes so assume that they are
2175 ** already UNIX status codes
2177 unix_status = msg_no;
2183 /* Translate a POSIX exit code to a UNIX exit code */
2184 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2185 unix_status = (msg_no & 0x07F8) >> 3;
2189 /* Documented traditional behavior for handling VMS child exits */
2190 /*--------------------------------------------------------------*/
2191 if (child_flag != 0) {
2193 /* Success / Informational return 0 */
2194 /*----------------------------------*/
2195 if (msg_no & STS$K_SUCCESS)
2198 /* Warning returns 1 */
2199 /*-------------------*/
2200 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2203 /* Everything else pass through the severity bits */
2204 /*------------------------------------------------*/
2205 return (msg_no & STS$M_SEVERITY);
2208 /* Normal VMS status to ERRNO mapping attempt */
2209 /*--------------------------------------------*/
2210 switch(msg_status) {
2211 /* case RMS$_EOF: */ /* End of File */
2212 case RMS$_FNF: /* File Not Found */
2213 case RMS$_DNF: /* Dir Not Found */
2214 unix_status = ENOENT;
2216 case RMS$_RNF: /* Record Not Found */
2217 unix_status = ESRCH;
2220 unix_status = ENOTDIR;
2223 unix_status = ENODEV;
2228 unix_status = EBADF;
2231 unix_status = EEXIST;
2235 case LIB$_INVSTRDES:
2237 case LIB$_NOSUCHSYM:
2238 case LIB$_INVSYMNAM:
2240 unix_status = EINVAL;
2246 unix_status = E2BIG;
2248 case RMS$_PRV: /* No privilege */
2249 case RMS$_ACC: /* ACP file access failed */
2250 case RMS$_WLK: /* Device write locked */
2251 unix_status = EACCES;
2253 /* case RMS$_NMF: */ /* No more files */
2261 /* Try to guess at what VMS error status should go with a UNIX errno
2262 * value. This is hard to do as there could be many possible VMS
2263 * error statuses that caused the errno value to be set.
2266 int Perl_unix_status_to_vms(int unix_status)
2268 int test_unix_status;
2270 /* Trivial cases first */
2271 /*---------------------*/
2272 if (unix_status == EVMSERR)
2275 /* Is vaxc$errno sane? */
2276 /*---------------------*/
2277 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2278 if (test_unix_status == unix_status)
2281 /* If way out of range, must be VMS code already */
2282 /*-----------------------------------------------*/
2283 if (unix_status > EVMSERR)
2286 /* If out of range, punt */
2287 /*-----------------------*/
2288 if (unix_status > __ERRNO_MAX)
2292 /* Ok, now we have to do it the hard way. */
2293 /*----------------------------------------*/
2294 switch(unix_status) {
2295 case 0: return SS$_NORMAL;
2296 case EPERM: return SS$_NOPRIV;
2297 case ENOENT: return SS$_NOSUCHOBJECT;
2298 case ESRCH: return SS$_UNREACHABLE;
2299 case EINTR: return SS$_ABORT;
2302 case E2BIG: return SS$_BUFFEROVF;
2304 case EBADF: return RMS$_IFI;
2305 case ECHILD: return SS$_NONEXPR;
2307 case ENOMEM: return SS$_INSFMEM;
2308 case EACCES: return SS$_FILACCERR;
2309 case EFAULT: return SS$_ACCVIO;
2311 case EBUSY: return SS$_DEVOFFLINE;
2312 case EEXIST: return RMS$_FEX;
2314 case ENODEV: return SS$_NOSUCHDEV;
2315 case ENOTDIR: return RMS$_DIR;
2317 case EINVAL: return SS$_INVARG;
2323 case ENOSPC: return SS$_DEVICEFULL;
2324 case ESPIPE: return LIB$_INVARG;
2329 case ERANGE: return LIB$_INVARG;
2330 /* case EWOULDBLOCK */
2331 /* case EINPROGRESS */
2334 /* case EDESTADDRREQ */
2336 /* case EPROTOTYPE */
2337 /* case ENOPROTOOPT */
2338 /* case EPROTONOSUPPORT */
2339 /* case ESOCKTNOSUPPORT */
2340 /* case EOPNOTSUPP */
2341 /* case EPFNOSUPPORT */
2342 /* case EAFNOSUPPORT */
2343 /* case EADDRINUSE */
2344 /* case EADDRNOTAVAIL */
2346 /* case ENETUNREACH */
2347 /* case ENETRESET */
2348 /* case ECONNABORTED */
2349 /* case ECONNRESET */
2352 case ENOTCONN: return SS$_CLEARED;
2353 /* case ESHUTDOWN */
2354 /* case ETOOMANYREFS */
2355 /* case ETIMEDOUT */
2356 /* case ECONNREFUSED */
2358 /* case ENAMETOOLONG */
2359 /* case EHOSTDOWN */
2360 /* case EHOSTUNREACH */
2361 /* case ENOTEMPTY */
2373 /* case ECANCELED */
2377 return SS$_UNSUPPORTED;
2383 /* case EABANDONED */
2385 return SS$_ABORT; /* punt */
2388 return SS$_ABORT; /* Should not get here */
2392 /* default piping mailbox size */
2393 #define PERL_BUFSIZ 512
2397 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2399 unsigned long int mbxbufsiz;
2400 static unsigned long int syssize = 0;
2401 unsigned long int dviitm = DVI$_DEVNAM;
2402 char csize[LNM$C_NAMLENGTH+1];
2406 unsigned long syiitm = SYI$_MAXBUF;
2408 * Get the SYSGEN parameter MAXBUF
2410 * If the logical 'PERL_MBX_SIZE' is defined
2411 * use the value of the logical instead of PERL_BUFSIZ, but
2412 * keep the size between 128 and MAXBUF.
2415 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2418 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2419 mbxbufsiz = atoi(csize);
2421 mbxbufsiz = PERL_BUFSIZ;
2423 if (mbxbufsiz < 128) mbxbufsiz = 128;
2424 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2426 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2428 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2429 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2431 } /* end of create_mbx() */
2434 /*{{{ my_popen and my_pclose*/
2436 typedef struct _iosb IOSB;
2437 typedef struct _iosb* pIOSB;
2438 typedef struct _pipe Pipe;
2439 typedef struct _pipe* pPipe;
2440 typedef struct pipe_details Info;
2441 typedef struct pipe_details* pInfo;
2442 typedef struct _srqp RQE;
2443 typedef struct _srqp* pRQE;
2444 typedef struct _tochildbuf CBuf;
2445 typedef struct _tochildbuf* pCBuf;
2448 unsigned short status;
2449 unsigned short count;
2450 unsigned long dvispec;
2453 #pragma member_alignment save
2454 #pragma nomember_alignment quadword
2455 struct _srqp { /* VMS self-relative queue entry */
2456 unsigned long qptr[2];
2458 #pragma member_alignment restore
2459 static RQE RQE_ZERO = {0,0};
2461 struct _tochildbuf {
2464 unsigned short size;
2472 unsigned short chan_in;
2473 unsigned short chan_out;
2475 unsigned int bufsize;
2487 #if defined(PERL_IMPLICIT_CONTEXT)
2488 void *thx; /* Either a thread or an interpreter */
2489 /* pointer, depending on how we're built */
2497 PerlIO *fp; /* file pointer to pipe mailbox */
2498 int useFILE; /* using stdio, not perlio */
2499 int pid; /* PID of subprocess */
2500 int mode; /* == 'r' if pipe open for reading */
2501 int done; /* subprocess has completed */
2502 int waiting; /* waiting for completion/closure */
2503 int closing; /* my_pclose is closing this pipe */
2504 unsigned long completion; /* termination status of subprocess */
2505 pPipe in; /* pipe in to sub */
2506 pPipe out; /* pipe out of sub */
2507 pPipe err; /* pipe of sub's sys$error */
2508 int in_done; /* true when in pipe finished */
2513 struct exit_control_block
2515 struct exit_control_block *flink;
2516 unsigned long int (*exit_routine)();
2517 unsigned long int arg_count;
2518 unsigned long int *status_address;
2519 unsigned long int exit_status;
2522 typedef struct _closed_pipes Xpipe;
2523 typedef struct _closed_pipes* pXpipe;
2525 struct _closed_pipes {
2526 int pid; /* PID of subprocess */
2527 unsigned long completion; /* termination status of subprocess */
2529 #define NKEEPCLOSED 50
2530 static Xpipe closed_list[NKEEPCLOSED];
2531 static int closed_index = 0;
2532 static int closed_num = 0;
2534 #define RETRY_DELAY "0 ::0.20"
2535 #define MAX_RETRY 50
2537 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2538 static unsigned long mypid;
2539 static unsigned long delaytime[2];
2541 static pInfo open_pipes = NULL;
2542 static $DESCRIPTOR(nl_desc, "NL:");
2544 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2548 static unsigned long int
2549 pipe_exit_routine(pTHX)
2552 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2553 int sts, did_stuff, need_eof, j;
2556 flush any pending i/o
2562 PerlIO_flush(info->fp); /* first, flush data */
2564 fflush((FILE *)info->fp);
2570 next we try sending an EOF...ignore if doesn't work, make sure we
2578 _ckvmssts_noperl(sys$setast(0));
2579 if (info->in && !info->in->shut_on_empty) {
2580 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2585 _ckvmssts_noperl(sys$setast(1));
2589 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2591 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2596 _ckvmssts_noperl(sys$setast(0));
2597 if (info->waiting && info->done)
2599 nwait += info->waiting;
2600 _ckvmssts_noperl(sys$setast(1));
2610 _ckvmssts_noperl(sys$setast(0));
2611 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2612 sts = sys$forcex(&info->pid,0,&abort);
2613 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2616 _ckvmssts_noperl(sys$setast(1));
2620 /* again, wait for effect */
2622 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2627 _ckvmssts_noperl(sys$setast(0));
2628 if (info->waiting && info->done)
2630 nwait += info->waiting;
2631 _ckvmssts_noperl(sys$setast(1));
2640 _ckvmssts_noperl(sys$setast(0));
2641 if (!info->done) { /* We tried to be nice . . . */
2642 sts = sys$delprc(&info->pid,0);
2643 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2645 _ckvmssts_noperl(sys$setast(1));
2650 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2651 else if (!(sts & 1)) retsts = sts;
2656 static struct exit_control_block pipe_exitblock =
2657 {(struct exit_control_block *) 0,
2658 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2660 static void pipe_mbxtofd_ast(pPipe p);
2661 static void pipe_tochild1_ast(pPipe p);
2662 static void pipe_tochild2_ast(pPipe p);
2665 popen_completion_ast(pInfo info)
2667 pInfo i = open_pipes;
2672 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2673 closed_list[closed_index].pid = info->pid;
2674 closed_list[closed_index].completion = info->completion;
2676 if (closed_index == NKEEPCLOSED)
2681 if (i == info) break;
2684 if (!i) return; /* unlinked, probably freed too */
2689 Writing to subprocess ...
2690 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2692 chan_out may be waiting for "done" flag, or hung waiting
2693 for i/o completion to child...cancel the i/o. This will
2694 put it into "snarf mode" (done but no EOF yet) that discards
2697 Output from subprocess (stdout, stderr) needs to be flushed and
2698 shut down. We try sending an EOF, but if the mbx is full the pipe
2699 routine should still catch the "shut_on_empty" flag, telling it to
2700 use immediate-style reads so that "mbx empty" -> EOF.
2704 if (info->in && !info->in_done) { /* only for mode=w */
2705 if (info->in->shut_on_empty && info->in->need_wake) {
2706 info->in->need_wake = FALSE;
2707 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2709 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2713 if (info->out && !info->out_done) { /* were we also piping output? */
2714 info->out->shut_on_empty = TRUE;
2715 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2716 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2717 _ckvmssts_noperl(iss);
2720 if (info->err && !info->err_done) { /* we were piping stderr */
2721 info->err->shut_on_empty = TRUE;
2722 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2723 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2724 _ckvmssts_noperl(iss);
2726 _ckvmssts_noperl(sys$setef(pipe_ef));
2730 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2731 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2734 we actually differ from vmstrnenv since we use this to
2735 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2736 are pointing to the same thing
2739 static unsigned short
2740 popen_translate(pTHX_ char *logical, char *result)
2743 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2744 $DESCRIPTOR(d_log,"");
2746 unsigned short length;
2747 unsigned short code;
2749 unsigned short *retlenaddr;
2751 unsigned short l, ifi;
2753 d_log.dsc$a_pointer = logical;
2754 d_log.dsc$w_length = strlen(logical);
2756 itmlst[0].code = LNM$_STRING;
2757 itmlst[0].length = 255;
2758 itmlst[0].buffer_addr = result;
2759 itmlst[0].retlenaddr = &l;
2762 itmlst[1].length = 0;
2763 itmlst[1].buffer_addr = 0;
2764 itmlst[1].retlenaddr = 0;
2766 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2767 if (iss == SS$_NOLOGNAM) {
2771 if (!(iss&1)) lib$signal(iss);
2774 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2775 strip it off and return the ifi, if any
2778 if (result[0] == 0x1b && result[1] == 0x00) {
2779 memmove(&ifi,result+2,2);
2780 strcpy(result,result+4);
2782 return ifi; /* this is the RMS internal file id */
2785 static void pipe_infromchild_ast(pPipe p);
2788 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2789 inside an AST routine without worrying about reentrancy and which Perl
2790 memory allocator is being used.
2792 We read data and queue up the buffers, then spit them out one at a
2793 time to the output mailbox when the output mailbox is ready for one.
2796 #define INITIAL_TOCHILDQUEUE 2
2799 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
2803 char mbx1[64], mbx2[64];
2804 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2805 DSC$K_CLASS_S, mbx1},
2806 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2807 DSC$K_CLASS_S, mbx2};
2808 unsigned int dviitm = DVI$_DEVBUFSIZ;
2812 _ckvmssts(lib$get_vm(&n, &p));
2814 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2815 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2816 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2819 p->shut_on_empty = FALSE;
2820 p->need_wake = FALSE;
2823 p->iosb.status = SS$_NORMAL;
2824 p->iosb2.status = SS$_NORMAL;
2830 #ifdef PERL_IMPLICIT_CONTEXT
2834 n = sizeof(CBuf) + p->bufsize;
2836 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
2837 _ckvmssts(lib$get_vm(&n, &b));
2838 b->buf = (char *) b + sizeof(CBuf);
2839 _ckvmssts(lib$insqhi(b, &p->free));
2842 pipe_tochild2_ast(p);
2843 pipe_tochild1_ast(p);
2849 /* reads the MBX Perl is writing, and queues */
2852 pipe_tochild1_ast(pPipe p)
2855 int iss = p->iosb.status;
2856 int eof = (iss == SS$_ENDOFFILE);
2858 #ifdef PERL_IMPLICIT_CONTEXT
2864 p->shut_on_empty = TRUE;
2866 _ckvmssts(sys$dassgn(p->chan_in));
2872 b->size = p->iosb.count;
2873 _ckvmssts(sts = lib$insqhi(b, &p->wait));
2875 p->need_wake = FALSE;
2876 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
2879 p->retry = 1; /* initial call */
2882 if (eof) { /* flush the free queue, return when done */
2883 int n = sizeof(CBuf) + p->bufsize;
2885 iss = lib$remqti(&p->free, &b);
2886 if (iss == LIB$_QUEWASEMP) return;
2888 _ckvmssts(lib$free_vm(&n, &b));
2892 iss = lib$remqti(&p->free, &b);
2893 if (iss == LIB$_QUEWASEMP) {
2894 int n = sizeof(CBuf) + p->bufsize;
2895 _ckvmssts(lib$get_vm(&n, &b));
2896 b->buf = (char *) b + sizeof(CBuf);
2902 iss = sys$qio(0,p->chan_in,
2903 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
2905 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
2906 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
2911 /* writes queued buffers to output, waits for each to complete before
2915 pipe_tochild2_ast(pPipe p)
2918 int iss = p->iosb2.status;
2919 int n = sizeof(CBuf) + p->bufsize;
2920 int done = (p->info && p->info->done) ||
2921 iss == SS$_CANCEL || iss == SS$_ABORT;
2922 #if defined(PERL_IMPLICIT_CONTEXT)
2927 if (p->type) { /* type=1 has old buffer, dispose */
2928 if (p->shut_on_empty) {
2929 _ckvmssts(lib$free_vm(&n, &b));
2931 _ckvmssts(lib$insqhi(b, &p->free));
2936 iss = lib$remqti(&p->wait, &b);
2937 if (iss == LIB$_QUEWASEMP) {
2938 if (p->shut_on_empty) {
2940 _ckvmssts(sys$dassgn(p->chan_out));
2941 *p->pipe_done = TRUE;
2942 _ckvmssts(sys$setef(pipe_ef));
2944 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2945 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2949 p->need_wake = TRUE;
2959 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
2960 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
2962 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
2963 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
2972 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
2975 char mbx1[64], mbx2[64];
2976 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
2977 DSC$K_CLASS_S, mbx1},
2978 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
2979 DSC$K_CLASS_S, mbx2};
2980 unsigned int dviitm = DVI$_DEVBUFSIZ;
2982 int n = sizeof(Pipe);
2983 _ckvmssts(lib$get_vm(&n, &p));
2984 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
2985 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
2987 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
2988 n = p->bufsize * sizeof(char);
2989 _ckvmssts(lib$get_vm(&n, &p->buf));
2990 p->shut_on_empty = FALSE;
2993 p->iosb.status = SS$_NORMAL;
2994 #if defined(PERL_IMPLICIT_CONTEXT)
2997 pipe_infromchild_ast(p);
3005 pipe_infromchild_ast(pPipe p)
3007 int iss = p->iosb.status;
3008 int eof = (iss == SS$_ENDOFFILE);
3009 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3010 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3011 #if defined(PERL_IMPLICIT_CONTEXT)
3015 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3016 _ckvmssts(sys$dassgn(p->chan_out));
3021 input shutdown if EOF from self (done or shut_on_empty)
3022 output shutdown if closing flag set (my_pclose)
3023 send data/eof from child or eof from self
3024 otherwise, re-read (snarf of data from child)
3029 if (myeof && p->chan_in) { /* input shutdown */
3030 _ckvmssts(sys$dassgn(p->chan_in));
3035 if (myeof || kideof) { /* pass EOF to parent */
3036 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3037 pipe_infromchild_ast, p,
3040 } else if (eof) { /* eat EOF --- fall through to read*/
3042 } else { /* transmit data */
3043 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3044 pipe_infromchild_ast,p,
3045 p->buf, p->iosb.count, 0, 0, 0, 0));
3051 /* everything shut? flag as done */
3053 if (!p->chan_in && !p->chan_out) {
3054 *p->pipe_done = TRUE;
3055 _ckvmssts(sys$setef(pipe_ef));
3059 /* write completed (or read, if snarfing from child)
3060 if still have input active,
3061 queue read...immediate mode if shut_on_empty so we get EOF if empty
3063 check if Perl reading, generate EOFs as needed
3069 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3070 pipe_infromchild_ast,p,
3071 p->buf, p->bufsize, 0, 0, 0, 0);
3072 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3074 } else { /* send EOFs for extra reads */
3075 p->iosb.status = SS$_ENDOFFILE;
3076 p->iosb.dvispec = 0;
3077 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3079 pipe_infromchild_ast, p, 0, 0, 0, 0));
3085 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3089 unsigned long dviitm = DVI$_DEVBUFSIZ;
3091 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3092 DSC$K_CLASS_S, mbx};
3093 int n = sizeof(Pipe);
3095 /* things like terminals and mbx's don't need this filter */
3096 if (fd && fstat(fd,&s) == 0) {
3097 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3098 struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T,
3099 DSC$K_CLASS_S, s.st_dev};
3101 _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0));
3102 if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/
3103 strcpy(out, s.st_dev);
3108 _ckvmssts(lib$get_vm(&n, &p));
3109 p->fd_out = dup(fd);
3110 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3111 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3112 n = (p->bufsize+1) * sizeof(char);
3113 _ckvmssts(lib$get_vm(&n, &p->buf));
3114 p->shut_on_empty = FALSE;
3119 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3120 pipe_mbxtofd_ast, p,
3121 p->buf, p->bufsize, 0, 0, 0, 0));
3127 pipe_mbxtofd_ast(pPipe p)
3129 int iss = p->iosb.status;
3130 int done = p->info->done;
3132 int eof = (iss == SS$_ENDOFFILE);
3133 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3134 int err = !(iss&1) && !eof;
3135 #if defined(PERL_IMPLICIT_CONTEXT)
3139 if (done && myeof) { /* end piping */
3141 sys$dassgn(p->chan_in);
3142 *p->pipe_done = TRUE;
3143 _ckvmssts(sys$setef(pipe_ef));
3147 if (!err && !eof) { /* good data to send to file */
3148 p->buf[p->iosb.count] = '\n';
3149 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3152 if (p->retry < MAX_RETRY) {
3153 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3163 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3164 pipe_mbxtofd_ast, p,
3165 p->buf, p->bufsize, 0, 0, 0, 0);
3166 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3171 typedef struct _pipeloc PLOC;
3172 typedef struct _pipeloc* pPLOC;
3176 char dir[NAM$C_MAXRSS+1];
3178 static pPLOC head_PLOC = 0;
3181 free_pipelocs(pTHX_ void *head)
3184 pPLOC *pHead = (pPLOC *)head;
3196 store_pipelocs(pTHX)
3205 char temp[NAM$C_MAXRSS+1];
3209 free_pipelocs(aTHX_ &head_PLOC);
3211 /* the . directory from @INC comes last */
3213 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3214 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3215 p->next = head_PLOC;
3217 strcpy(p->dir,"./");
3219 /* get the directory from $^X */
3221 unixdir = PerlMem_malloc(VMS_MAXRSS);
3222 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3224 #ifdef PERL_IMPLICIT_CONTEXT
3225 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3227 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3229 strcpy(temp, PL_origargv[0]);
3230 x = strrchr(temp,']');
3232 x = strrchr(temp,'>');
3234 /* It could be a UNIX path */
3235 x = strrchr(temp,'/');
3241 /* Got a bare name, so use default directory */
3246 if ((tounixpath(temp, unixdir)) != Nullch) {
3247 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3248 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3249 p->next = head_PLOC;
3251 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3252 p->dir[NAM$C_MAXRSS] = '\0';
3256 /* reverse order of @INC entries, skip "." since entered above */
3258 #ifdef PERL_IMPLICIT_CONTEXT
3261 if (PL_incgv) av = GvAVn(PL_incgv);
3263 for (i = 0; av && i <= AvFILL(av); i++) {
3264 dirsv = *av_fetch(av,i,TRUE);
3266 if (SvROK(dirsv)) continue;
3267 dir = SvPVx(dirsv,n_a);
3268 if (strcmp(dir,".") == 0) continue;
3269 if ((tounixpath(dir, unixdir)) == Nullch)
3272 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3273 p->next = head_PLOC;
3275 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3276 p->dir[NAM$C_MAXRSS] = '\0';
3279 /* most likely spot (ARCHLIB) put first in the list */
3282 if ((tounixpath(ARCHLIB_EXP, unixdir)) != Nullch) {
3283 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3284 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3285 p->next = head_PLOC;
3287 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3288 p->dir[NAM$C_MAXRSS] = '\0';
3291 PerlMem_free(unixdir);
3298 static int vmspipe_file_status = 0;
3299 static char vmspipe_file[NAM$C_MAXRSS+1];
3301 /* already found? Check and use ... need read+execute permission */
3303 if (vmspipe_file_status == 1) {
3304 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3305 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3306 return vmspipe_file;
3308 vmspipe_file_status = 0;
3311 /* scan through stored @INC, $^X */
3313 if (vmspipe_file_status == 0) {
3314 char file[NAM$C_MAXRSS+1];
3315 pPLOC p = head_PLOC;
3319 strcpy(file, p->dir);
3320 strncat(file, "vmspipe.com",NAM$C_MAXRSS);
3321 file[NAM$C_MAXRSS] = '\0';
3324 exp_res = do_rmsexpand
3325 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS);
3326 if (!exp_res) continue;
3328 if (cando_by_name(S_IRUSR, 0, vmspipe_file)
3329 && cando_by_name(S_IXUSR, 0, vmspipe_file)) {
3330 vmspipe_file_status = 1;
3331 return vmspipe_file;
3334 vmspipe_file_status = -1; /* failed, use tempfiles */
3341 vmspipe_tempfile(pTHX)
3343 char file[NAM$C_MAXRSS+1];
3345 static int index = 0;
3349 /* create a tempfile */
3351 /* we can't go from W, shr=get to R, shr=get without
3352 an intermediate vulnerable state, so don't bother trying...
3354 and lib$spawn doesn't shr=put, so have to close the write
3356 So... match up the creation date/time and the FID to
3357 make sure we're dealing with the same file
3362 if (!decc_filename_unix_only) {
3363 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3364 fp = fopen(file,"w");
3366 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3367 fp = fopen(file,"w");
3369 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3370 fp = fopen(file,"w");
3375 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3376 fp = fopen(file,"w");
3378 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3379 fp = fopen(file,"w");
3381 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3382 fp = fopen(file,"w");
3386 if (!fp) return 0; /* we're hosed */
3388 fprintf(fp,"$! 'f$verify(0)'\n");
3389 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3390 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3391 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3392 fprintf(fp,"$ perl_on = \"set noon\"\n");
3393 fprintf(fp,"$ perl_exit = \"exit\"\n");
3394 fprintf(fp,"$ perl_del = \"delete\"\n");
3395 fprintf(fp,"$ pif = \"if\"\n");
3396 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3397 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3398 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3399 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3400 fprintf(fp,"$! --- build command line to get max possible length\n");
3401 fprintf(fp,"$c=perl_popen_cmd0\n");
3402 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3403 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3404 fprintf(fp,"$x=perl_popen_cmd3\n");
3405 fprintf(fp,"$c=c+x\n");
3406 fprintf(fp,"$ perl_on\n");
3407 fprintf(fp,"$ 'c'\n");
3408 fprintf(fp,"$ perl_status = $STATUS\n");
3409 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3410 fprintf(fp,"$ perl_exit 'perl_status'\n");
3413 fgetname(fp, file, 1);
3414 fstat(fileno(fp), (struct stat *)&s0);
3417 if (decc_filename_unix_only)
3418 do_tounixspec(file, file, 0);
3419 fp = fopen(file,"r","shr=get");
3421 fstat(fileno(fp), (struct stat *)&s1);
3423 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3424 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3435 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3437 static int handler_set_up = FALSE;
3438 unsigned long int sts, flags = CLI$M_NOWAIT;
3439 /* The use of a GLOBAL table (as was done previously) rendered
3440 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3441 * environment. Hence we've switched to LOCAL symbol table.
3443 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3445 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3446 char in[512], out[512], err[512], mbx[512];
3448 char tfilebuf[NAM$C_MAXRSS+1];
3450 char cmd_sym_name[20];
3451 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3452 DSC$K_CLASS_S, symbol};
3453 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3455 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3456 DSC$K_CLASS_S, cmd_sym_name};
3457 struct dsc$descriptor_s *vmscmd;
3458 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3459 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3460 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3462 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3464 /* once-per-program initialization...
3465 note that the SETAST calls and the dual test of pipe_ef
3466 makes sure that only the FIRST thread through here does
3467 the initialization...all other threads wait until it's
3470 Yeah, uglier than a pthread call, it's got all the stuff inline
3471 rather than in a separate routine.
3475 _ckvmssts(sys$setast(0));
3477 unsigned long int pidcode = JPI$_PID;
3478 $DESCRIPTOR(d_delay, RETRY_DELAY);
3479 _ckvmssts(lib$get_ef(&pipe_ef));
3480 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3481 _ckvmssts(sys$bintim(&d_delay, delaytime));
3483 if (!handler_set_up) {
3484 _ckvmssts(sys$dclexh(&pipe_exitblock));
3485 handler_set_up = TRUE;
3487 _ckvmssts(sys$setast(1));
3490 /* see if we can find a VMSPIPE.COM */
3493 vmspipe = find_vmspipe(aTHX);
3495 strcpy(tfilebuf+1,vmspipe);
3496 } else { /* uh, oh...we're in tempfile hell */
3497 tpipe = vmspipe_tempfile(aTHX);
3498 if (!tpipe) { /* a fish popular in Boston */
3499 if (ckWARN(WARN_PIPE)) {
3500 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3504 fgetname(tpipe,tfilebuf+1,1);
3506 vmspipedsc.dsc$a_pointer = tfilebuf;
3507 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3509 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3512 case RMS$_FNF: case RMS$_DNF:
3513 set_errno(ENOENT); break;
3515 set_errno(ENOTDIR); break;
3517 set_errno(ENODEV); break;
3519 set_errno(EACCES); break;
3521 set_errno(EINVAL); break;
3522 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3523 set_errno(E2BIG); break;
3524 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3525 _ckvmssts(sts); /* fall through */
3526 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3529 set_vaxc_errno(sts);
3530 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3531 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3537 _ckvmssts(lib$get_vm(&n, &info));
3539 strcpy(mode,in_mode);
3542 info->completion = 0;
3543 info->closing = FALSE;
3550 info->in_done = TRUE;
3551 info->out_done = TRUE;
3552 info->err_done = TRUE;
3553 in[0] = out[0] = err[0] = '\0';
3555 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3559 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3564 if (*mode == 'r') { /* piping from subroutine */
3566 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3568 info->out->pipe_done = &info->out_done;
3569 info->out_done = FALSE;
3570 info->out->info = info;
3572 if (!info->useFILE) {
3573 info->fp = PerlIO_open(mbx, mode);
3575 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3576 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3579 if (!info->fp && info->out) {
3580 sys$cancel(info->out->chan_out);
3582 while (!info->out_done) {
3584 _ckvmssts(sys$setast(0));
3585 done = info->out_done;
3586 if (!done) _ckvmssts(sys$clref(pipe_ef));
3587 _ckvmssts(sys$setast(1));
3588 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3591 if (info->out->buf) {
3592 n = info->out->bufsize * sizeof(char);
3593 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3596 _ckvmssts(lib$free_vm(&n, &info->out));
3598 _ckvmssts(lib$free_vm(&n, &info));
3603 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3605 info->err->pipe_done = &info->err_done;
3606 info->err_done = FALSE;
3607 info->err->info = info;
3610 } else if (*mode == 'w') { /* piping to subroutine */
3612 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3614 info->out->pipe_done = &info->out_done;
3615 info->out_done = FALSE;
3616 info->out->info = info;
3619 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3621 info->err->pipe_done = &info->err_done;
3622 info->err_done = FALSE;
3623 info->err->info = info;
3626 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3627 if (!info->useFILE) {
3628 info->fp = PerlIO_open(mbx, mode);
3630 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3631 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3635 info->in->pipe_done = &info->in_done;
3636 info->in_done = FALSE;
3637 info->in->info = info;
3641 if (!info->fp && info->in) {
3643 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3644 0, 0, 0, 0, 0, 0, 0, 0));
3646 while (!info->in_done) {
3648 _ckvmssts(sys$setast(0));
3649 done = info->in_done;
3650 if (!done) _ckvmssts(sys$clref(pipe_ef));
3651 _ckvmssts(sys$setast(1));
3652 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3655 if (info->in->buf) {
3656 n = info->in->bufsize * sizeof(char);
3657 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3660 _ckvmssts(lib$free_vm(&n, &info->in));
3662 _ckvmssts(lib$free_vm(&n, &info));
3668 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3669 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3671 info->out->pipe_done = &info->out_done;
3672 info->out_done = FALSE;
3673 info->out->info = info;
3676 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3678 info->err->pipe_done = &info->err_done;
3679 info->err_done = FALSE;
3680 info->err->info = info;
3684 symbol[MAX_DCL_SYMBOL] = '\0';
3686 strncpy(symbol, in, MAX_DCL_SYMBOL);
3687 d_symbol.dsc$w_length = strlen(symbol);
3688 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3690 strncpy(symbol, err, MAX_DCL_SYMBOL);
3691 d_symbol.dsc$w_length = strlen(symbol);
3692 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3694 strncpy(symbol, out, MAX_DCL_SYMBOL);
3695 d_symbol.dsc$w_length = strlen(symbol);
3696 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3698 p = vmscmd->dsc$a_pointer;
3699 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
3700 if (*p == '$') p++; /* remove leading $ */
3701 while (*p == ' ' || *p == '\t') p++;
3703 for (j = 0; j < 4; j++) {
3704 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3705 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3707 strncpy(symbol, p, MAX_DCL_SYMBOL);
3708 d_symbol.dsc$w_length = strlen(symbol);
3709 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
3711 if (strlen(p) > MAX_DCL_SYMBOL) {
3712 p += MAX_DCL_SYMBOL;
3717 _ckvmssts(sys$setast(0));
3718 info->next=open_pipes; /* prepend to list */
3720 _ckvmssts(sys$setast(1));
3721 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
3722 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
3723 * have SYS$COMMAND if we need it.
3725 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
3726 0, &info->pid, &info->completion,
3727 0, popen_completion_ast,info,0,0,0));
3729 /* if we were using a tempfile, close it now */
3731 if (tpipe) fclose(tpipe);
3733 /* once the subprocess is spawned, it has copied the symbols and
3734 we can get rid of ours */
3736 for (j = 0; j < 4; j++) {
3737 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
3738 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
3739 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
3741 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
3742 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
3743 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
3744 vms_execfree(vmscmd);
3746 #ifdef PERL_IMPLICIT_CONTEXT
3749 PL_forkprocess = info->pid;
3754 _ckvmssts(sys$setast(0));
3756 if (!done) _ckvmssts(sys$clref(pipe_ef));
3757 _ckvmssts(sys$setast(1));
3758 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3760 *psts = info->completion;
3761 /* Caller thinks it is open and tries to close it. */
3762 /* This causes some problems, as it changes the error status */
3763 /* my_pclose(info->fp); */
3768 } /* end of safe_popen */
3771 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
3773 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
3777 TAINT_PROPER("popen");
3778 PERL_FLUSHALL_FOR_CHILD;
3779 return safe_popen(aTHX_ cmd,mode,&sts);
3784 /*{{{ I32 my_pclose(PerlIO *fp)*/
3785 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
3787 pInfo info, last = NULL;
3788 unsigned long int retsts;
3791 for (info = open_pipes; info != NULL; last = info, info = info->next)
3792 if (info->fp == fp) break;
3794 if (info == NULL) { /* no such pipe open */
3795 set_errno(ECHILD); /* quoth POSIX */
3796 set_vaxc_errno(SS$_NONEXPR);
3800 /* If we were writing to a subprocess, insure that someone reading from
3801 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
3802 * produce an EOF record in the mailbox.
3804 * well, at least sometimes it *does*, so we have to watch out for
3805 * the first EOF closing the pipe (and DASSGN'ing the channel)...
3809 PerlIO_flush(info->fp); /* first, flush data */
3811 fflush((FILE *)info->fp);
3814 _ckvmssts(sys$setast(0));
3815 info->closing = TRUE;
3816 done = info->done && info->in_done && info->out_done && info->err_done;
3817 /* hanging on write to Perl's input? cancel it */
3818 if (info->mode == 'r' && info->out && !info->out_done) {
3819 if (info->out->chan_out) {
3820 _ckvmssts(sys$cancel(info->out->chan_out));
3821 if (!info->out->chan_in) { /* EOF generation, need AST */
3822 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
3826 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
3827 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3829 _ckvmssts(sys$setast(1));
3832 PerlIO_close(info->fp);
3834 fclose((FILE *)info->fp);
3837 we have to wait until subprocess completes, but ALSO wait until all
3838 the i/o completes...otherwise we'll be freeing the "info" structure
3839 that the i/o ASTs could still be using...
3843 _ckvmssts(sys$setast(0));
3844 done = info->done && info->in_done && info->out_done && info->err_done;
3845 if (!done) _ckvmssts(sys$clref(pipe_ef));
3846 _ckvmssts(sys$setast(1));
3847 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3849 retsts = info->completion;
3851 /* remove from list of open pipes */
3852 _ckvmssts(sys$setast(0));
3853 if (last) last->next = info->next;
3854 else open_pipes = info->next;
3855 _ckvmssts(sys$setast(1));
3857 /* free buffers and structures */
3860 if (info->in->buf) {
3861 n = info->in->bufsize * sizeof(char);
3862 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3865 _ckvmssts(lib$free_vm(&n, &info->in));
3868 if (info->out->buf) {
3869 n = info->out->bufsize * sizeof(char);
3870 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3873 _ckvmssts(lib$free_vm(&n, &info->out));
3876 if (info->err->buf) {
3877 n = info->err->bufsize * sizeof(char);
3878 _ckvmssts(lib$free_vm(&n, &info->err->buf));
3881 _ckvmssts(lib$free_vm(&n, &info->err));
3884 _ckvmssts(lib$free_vm(&n, &info));
3888 } /* end of my_pclose() */
3890 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3891 /* Roll our own prototype because we want this regardless of whether
3892 * _VMS_WAIT is defined.
3894 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
3896 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
3897 created with popen(); otherwise partially emulate waitpid() unless
3898 we have a suitable one from the CRTL that came with VMS 7.2 and later.
3899 Also check processes not considered by the CRTL waitpid().
3901 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
3903 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
3910 if (statusp) *statusp = 0;
3912 for (info = open_pipes; info != NULL; info = info->next)
3913 if (info->pid == pid) break;
3915 if (info != NULL) { /* we know about this child */
3916 while (!info->done) {
3917 _ckvmssts(sys$setast(0));
3919 if (!done) _ckvmssts(sys$clref(pipe_ef));
3920 _ckvmssts(sys$setast(1));
3921 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3924 if (statusp) *statusp = info->completion;
3928 /* child that already terminated? */
3930 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
3931 if (closed_list[j].pid == pid) {
3932 if (statusp) *statusp = closed_list[j].completion;
3937 /* fall through if this child is not one of our own pipe children */
3939 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
3941 /* waitpid() became available in the CRTL as of VMS 7.0, but only
3942 * in 7.2 did we get a version that fills in the VMS completion
3943 * status as Perl has always tried to do.
3946 sts = __vms_waitpid( pid, statusp, flags );
3948 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
3951 /* If the real waitpid tells us the child does not exist, we
3952 * fall through here to implement waiting for a child that
3953 * was created by some means other than exec() (say, spawned
3954 * from DCL) or to wait for a process that is not a subprocess
3955 * of the current process.
3958 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
3961 $DESCRIPTOR(intdsc,"0 00:00:01");
3962 unsigned long int ownercode = JPI$_OWNER, ownerpid;
3963 unsigned long int pidcode = JPI$_PID, mypid;
3964 unsigned long int interval[2];
3965 unsigned int jpi_iosb[2];
3966 struct itmlst_3 jpilist[2] = {
3967 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
3972 /* Sorry folks, we don't presently implement rooting around for
3973 the first child we can find, and we definitely don't want to
3974 pass a pid of -1 to $getjpi, where it is a wildcard operation.
3980 /* Get the owner of the child so I can warn if it's not mine. If the
3981 * process doesn't exist or I don't have the privs to look at it,
3982 * I can go home early.
3984 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
3985 if (sts & 1) sts = jpi_iosb[0];
3997 set_vaxc_errno(sts);
4001 if (ckWARN(WARN_EXEC)) {
4002 /* remind folks they are asking for non-standard waitpid behavior */
4003 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4004 if (ownerpid != mypid)
4005 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4006 "waitpid: process %x is not a child of process %x",
4010 /* simply check on it once a second until it's not there anymore. */
4012 _ckvmssts(sys$bintim(&intdsc,interval));
4013 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4014 _ckvmssts(sys$schdwk(0,0,interval,0));
4015 _ckvmssts(sys$hiber());
4017 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4022 } /* end of waitpid() */
4027 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4029 my_gconvert(double val, int ndig, int trail, char *buf)
4031 static char __gcvtbuf[DBL_DIG+1];
4034 loc = buf ? buf : __gcvtbuf;
4036 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4038 sprintf(loc,"%.*g",ndig,val);
4044 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4045 return gcvt(val,ndig,loc);
4048 loc[0] = '0'; loc[1] = '\0';
4055 #if 1 /* defined(__VAX) || !defined(NAML$C_MAXRSS) */
4056 static int rms_free_search_context(struct FAB * fab)
4060 nam = fab->fab$l_nam;
4061 nam->nam$b_nop |= NAM$M_SYNCHK;
4062 nam->nam$l_rlf = NULL;
4064 return sys$parse(fab, NULL, NULL);
4067 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4068 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4069 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4070 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4071 #define rms_nam_esll(nam) nam.nam$b_esl
4072 #define rms_nam_esl(nam) nam.nam$b_esl
4073 #define rms_nam_name(nam) nam.nam$l_name
4074 #define rms_nam_namel(nam) nam.nam$l_name
4075 #define rms_nam_type(nam) nam.nam$l_type
4076 #define rms_nam_typel(nam) nam.nam$l_type
4077 #define rms_nam_ver(nam) nam.nam$l_ver
4078 #define rms_nam_verl(nam) nam.nam$l_ver
4079 #define rms_nam_rsll(nam) nam.nam$b_rsl
4080 #define rms_nam_rsl(nam) nam.nam$b_rsl
4081 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4082 #define rms_set_fna(fab, nam, name, size) \
4083 fab.fab$b_fns = size; fab.fab$l_fna = name;
4084 #define rms_get_fna(fab, nam) fab.fab$l_fna
4085 #define rms_set_dna(fab, nam, name, size) \
4086 fab.fab$b_dns = size; fab.fab$l_dna = name;
4087 #define rms_nam_dns(fab, nam) fab.fab$b_dns;
4088 #define rms_set_esa(fab, nam, name, size) \
4089 nam.nam$b_ess = size; nam.nam$l_esa = name;
4090 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4091 nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;
4092 #define rms_set_rsa(nam, name, size) \
4093 nam.nam$l_rsa = name; nam.nam$b_rss = size;
4094 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4095 nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size;
4098 static int rms_free_search_context(struct FAB * fab)
4102 nam = fab->fab$l_naml;
4103 nam->naml$b_nop |= NAM$M_SYNCHK;
4104 nam->naml$l_rlf = NULL;
4105 nam->naml$l_long_defname_size = 0;
4107 return sys$parse(fab, NULL, NULL);
4110 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4111 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4112 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4113 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4114 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4115 #define rms_nam_esl(nam) nam.naml$b_esl
4116 #define rms_nam_name(nam) nam.naml$l_name
4117 #define rms_nam_namel(nam) nam.naml$l_long_name
4118 #define rms_nam_type(nam) nam.naml$l_type
4119 #define rms_nam_typel(nam) nam.naml$l_long_type
4120 #define rms_nam_ver(nam) nam.naml$l_ver
4121 #define rms_nam_verl(nam) nam.naml$l_long_ver
4122 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4123 #define rms_nam_rsl(nam) nam.naml$b_rsl
4124 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4125 #define rms_set_fna(fab, nam, name, size) \
4126 fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4127 nam.naml$l_long_filename_size = size; \
4128 nam.naml$l_long_filename = name
4129 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4130 #define rms_set_dna(fab, nam, name, size) \
4131 fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4132 nam.naml$l_long_defname_size = size; \
4133 nam.naml$l_long_defname = name
4134 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4135 #define rms_set_esa(fab, nam, name, size) \
4136 nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4137 nam.naml$l_long_expand_alloc = size; \
4138 nam.naml$l_long_expand = name
4139 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4140 nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4141 nam.naml$l_long_expand = l_name; \
4142 nam.naml$l_long_expand_alloc = l_size;
4143 #define rms_set_rsa(nam, name, size) \
4144 nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4145 nam.naml$l_long_result = name; \
4146 nam.naml$l_long_result_alloc = size;
4147 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4148 nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4149 nam.naml$l_long_result = l_name; \
4150 nam.naml$l_long_result_alloc = l_size;
4155 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4156 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4157 * to expand file specification. Allows for a single default file
4158 * specification and a simple mask of options. If outbuf is non-NULL,
4159 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4160 * the resultant file specification is placed. If outbuf is NULL, the
4161 * resultant file specification is placed into a static buffer.
4162 * The third argument, if non-NULL, is taken to be a default file
4163 * specification string. The fourth argument is unused at present.
4164 * rmesexpand() returns the address of the resultant string if
4165 * successful, and NULL on error.
4167 * New functionality for previously unused opts value:
4168 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4170 static char *mp_do_tounixspec(pTHX_ const char *, char *, int);
4172 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4173 /* ODS-2 only version */
4175 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4177 static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
4178 char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
4179 char esa[NAM$C_MAXRSS], *cp, *out = NULL;
4180 struct FAB myfab = cc$rms_fab;
4181 struct NAM mynam = cc$rms_nam;
4183 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4186 if (!filespec || !*filespec) {
4187 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4191 if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char);
4192 else outbuf = __rmsexpand_retbuf;
4194 isunix = is_unix_filespec(filespec);
4196 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4201 filespec = vmsfspec;
4204 myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */
4205 myfab.fab$b_fns = strlen(filespec);
4206 myfab.fab$l_nam = &mynam;
4208 if (defspec && *defspec) {
4209 if (strchr(defspec,'/') != NULL) {
4210 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4217 myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */
4218 myfab.fab$b_dns = strlen(defspec);
4221 mynam.nam$l_esa = esa;
4222 mynam.nam$b_ess = sizeof esa;
4223 mynam.nam$l_rsa = outbuf;
4224 mynam.nam$b_rss = NAM$C_MAXRSS;
4226 #ifdef NAM$M_NO_SHORT_UPCASE
4227 if (decc_efs_case_preserve)
4228 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4231 retsts = sys$parse(&myfab,0,0);
4232 if (!(retsts & 1)) {
4233 mynam.nam$b_nop |= NAM$M_SYNCHK;
4234 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4235 retsts = sys$parse(&myfab,0,0);
4236 if (retsts & 1) goto expanded;
4238 mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0;
4239 sts = sys$parse(&myfab,0,0); /* Free search context */
4240 if (out) Safefree(out);
4241 set_vaxc_errno(retsts);
4242 if (retsts == RMS$_PRV) set_errno(EACCES);
4243 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4244 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4245 else set_errno(EVMSERR);
4248 retsts = sys$search(&myfab,0,0);
4249 if (!(retsts & 1) && retsts != RMS$_FNF) {
4250 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4251 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4252 if (out) Safefree(out);
4253 set_vaxc_errno(retsts);
4254 if (retsts == RMS$_PRV) set_errno(EACCES);
4255 else set_errno(EVMSERR);
4259 /* If the input filespec contained any lowercase characters,
4260 * downcase the result for compatibility with Unix-minded code. */
4262 if (!decc_efs_case_preserve) {
4263 for (out = myfab.fab$l_fna; *out; out++)
4264 if (islower(*out)) { haslower = 1; break; }
4266 if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
4267 else { out = esa; speclen = mynam.nam$b_esl; }
4268 /* Trim off null fields added by $PARSE
4269 * If type > 1 char, must have been specified in original or default spec
4270 * (not true for version; $SEARCH may have added version of existing file).
4272 trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER);
4273 trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) &&
4274 (mynam.nam$l_ver - mynam.nam$l_type == 1);
4275 if (trimver || trimtype) {
4276 if (defspec && *defspec) {
4277 char defesa[NAM$C_MAXRSS];
4278 struct FAB deffab = cc$rms_fab;
4279 struct NAM defnam = cc$rms_nam;
4281 deffab.fab$l_nam = &defnam;
4282 /* cast below ok for read only pointer */
4283 deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns;
4284 defnam.nam$l_esa = defesa; defnam.nam$b_ess = sizeof defesa;
4285 defnam.nam$b_nop = NAM$M_SYNCHK;
4286 #ifdef NAM$M_NO_SHORT_UPCASE
4287 if (decc_efs_case_preserve)
4288 defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
4290 if (sys$parse(&deffab,0,0) & 1) {
4291 if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER);
4292 if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE);
4296 if (*mynam.nam$l_ver != '\"')
4297 speclen = mynam.nam$l_ver - out;
4300 /* If we didn't already trim version, copy down */
4301 if (speclen > mynam.nam$l_ver - out)
4302 memmove(mynam.nam$l_type, mynam.nam$l_ver,
4303 speclen - (mynam.nam$l_ver - out));
4304 speclen -= mynam.nam$l_ver - mynam.nam$l_type;
4307 /* If we just had a directory spec on input, $PARSE "helpfully"
4308 * adds an empty name and type for us */
4309 if (mynam.nam$l_name == mynam.nam$l_type &&
4310 mynam.nam$l_ver == mynam.nam$l_type + 1 &&
4311 !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
4312 speclen = mynam.nam$l_name - out;
4314 /* Posix format specifications must have matching quotes */
4315 if (decc_posix_compliant_pathnames && (out[0] == '\"')) {
4316 if ((speclen > 1) && (out[speclen-1] != '\"')) {
4317 out[speclen] = '\"';
4322 out[speclen] = '\0';
4323 if (haslower && !decc_efs_case_preserve) __mystrtolower(out);
4325 /* Have we been working with an expanded, but not resultant, spec? */
4326 /* Also, convert back to Unix syntax if necessary. */
4327 if ((opts & PERL_RMSEXPAND_M_VMS) != 0)
4330 if (!mynam.nam$b_rsl) {
4332 if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
4334 else strcpy(outbuf,esa);
4337 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
4338 strcpy(outbuf,tmpfspec);
4340 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
4341 mynam.nam$l_rsa = NULL;
4342 mynam.nam$b_rss = 0;
4343 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */
4347 /* ODS-5 supporting routine */
4349 mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts)
4351 static char __rmsexpand_retbuf[NAML$C_MAXRSS+1];
4352 char * vmsfspec, *tmpfspec;
4353 char * esa, *cp, *out = NULL;
4357 struct FAB myfab = cc$rms_fab;
4358 rms_setup_nam(mynam);
4360 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4363 if (!filespec || !*filespec) {
4364 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4368 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4369 else outbuf = __rmsexpand_retbuf;
4375 isunix = is_unix_filespec(filespec);
4377 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4378 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4379 if (do_tovmsspec(filespec,vmsfspec,0) == NULL) {
4380 PerlMem_free(vmsfspec);
4385 filespec = vmsfspec;
4387 /* Unless we are forcing to VMS format, a UNIX input means
4388 * UNIX output, and that requires long names to be used
4390 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4391 opts |= PERL_RMSEXPAND_M_LONG;
4397 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4398 rms_bind_fab_nam(myfab, mynam);
4400 if (defspec && *defspec) {
4402 t_isunix = is_unix_filespec(defspec);
4404 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4405 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4406 if (do_tovmsspec(defspec,tmpfspec,0) == NULL) {
4407 PerlMem_free(tmpfspec);
4408 if (vmsfspec != NULL)
4409 PerlMem_free(vmsfspec);
4416 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4419 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4420 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4421 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4422 esal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4423 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4425 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS);
4427 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4428 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4431 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4432 outbufl = PerlMem_malloc(VMS_MAXRSS);
4433 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4434 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4436 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4440 #ifdef NAM$M_NO_SHORT_UPCASE
4441 if (decc_efs_case_preserve)
4442 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4445 /* First attempt to parse as an existing file */
4446 retsts = sys$parse(&myfab,0,0);
4447 if (!(retsts & STS$K_SUCCESS)) {
4449 /* Could not find the file, try as syntax only if error is not fatal */
4450 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4451 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4452 retsts = sys$parse(&myfab,0,0);
4453 if (retsts & STS$K_SUCCESS) goto expanded;
4456 /* Still could not parse the file specification */
4457 /*----------------------------------------------*/
4458 sts = rms_free_search_context(&myfab); /* Free search context */
4459 if (out) Safefree(out);
4460 if (tmpfspec != NULL)
4461 PerlMem_free(tmpfspec);
4462 if (vmsfspec != NULL)
4463 PerlMem_free(vmsfspec);
4464 if (outbufl != NULL)
4465 PerlMem_free(outbufl);
4468 set_vaxc_errno(retsts);
4469 if (retsts == RMS$_PRV) set_errno(EACCES);
4470 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4471 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4472 else set_errno(EVMSERR);
4475 retsts = sys$search(&myfab,0,0);
4476 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4477 sts = rms_free_search_context(&myfab); /* Free search context */
4478 if (out) Safefree(out);
4479 if (tmpfspec != NULL)
4480 PerlMem_free(tmpfspec);
4481 if (vmsfspec != NULL)
4482 PerlMem_free(vmsfspec);
4483 if (outbufl != NULL)
4484 PerlMem_free(outbufl);
4487 set_vaxc_errno(retsts);
4488 if (retsts == RMS$_PRV) set_errno(EACCES);
4489 else set_errno(EVMSERR);
4493 /* If the input filespec contained any lowercase characters,
4494 * downcase the result for compatibility with Unix-minded code. */
4496 if (!decc_efs_case_preserve) {
4497 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4498 if (islower(*tbuf)) { haslower = 1; break; }
4501 /* Is a long or a short name expected */
4502 /*------------------------------------*/
4503 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4504 if (rms_nam_rsll(mynam)) {
4506 speclen = rms_nam_rsll(mynam);
4509 tbuf = esal; /* Not esa */
4510 speclen = rms_nam_esll(mynam);
4514 if (rms_nam_rsl(mynam)) {
4516 speclen = rms_nam_rsl(mynam);
4519 tbuf = esa; /* Not esal */
4520 speclen = rms_nam_esl(mynam);
4523 /* Trim off null fields added by $PARSE
4524 * If type > 1 char, must have been specified in original or default spec
4525 * (not true for version; $SEARCH may have added version of existing file).
4527 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4528 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4529 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4530 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4533 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4534 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4536 if (trimver || trimtype) {
4537 if (defspec && *defspec) {
4538 char *defesal = NULL;
4539 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4540 if (defesal != NULL) {
4541 struct FAB deffab = cc$rms_fab;
4542 rms_setup_nam(defnam);
4544 rms_bind_fab_nam(deffab, defnam);
4548 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4550 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4552 rms_set_nam_nop(defnam, 0);
4553 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4554 #ifdef NAM$M_NO_SHORT_UPCASE
4555 if (decc_efs_case_preserve)
4556 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4558 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4560 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4563 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4566 PerlMem_free(defesal);
4570 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4571 if (*(rms_nam_verl(mynam)) != '\"')
4572 speclen = rms_nam_verl(mynam) - tbuf;
4575 if (*(rms_nam_ver(mynam)) != '\"')
4576 speclen = rms_nam_ver(mynam) - tbuf;
4580 /* If we didn't already trim version, copy down */
4581 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4582 if (speclen > rms_nam_verl(mynam) - tbuf)
4584 (rms_nam_typel(mynam),
4585 rms_nam_verl(mynam),
4586 speclen - (rms_nam_verl(mynam) - tbuf));
4587 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4590 if (speclen > rms_nam_ver(mynam) - tbuf)
4592 (rms_nam_type(mynam),
4594 speclen - (rms_nam_ver(mynam) - tbuf));
4595 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4600 /* Done with these copies of the input files */
4601 /*-------------------------------------------*/
4602 if (vmsfspec != NULL)
4603 PerlMem_free(vmsfspec);
4604 if (tmpfspec != NULL)
4605 PerlMem_free(tmpfspec);
4607 /* If we just had a directory spec on input, $PARSE "helpfully"
4608 * adds an empty name and type for us */
4609 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4610 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4611 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4612 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4613 speclen = rms_nam_namel(mynam) - tbuf;
4616 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4617 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4618 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4619 speclen = rms_nam_name(mynam) - tbuf;
4622 /* Posix format specifications must have matching quotes */
4623 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4624 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4625 tbuf[speclen] = '\"';
4629 tbuf[speclen] = '\0';
4630 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4632 /* Have we been working with an expanded, but not resultant, spec? */
4633 /* Also, convert back to Unix syntax if necessary. */
4635 if (!rms_nam_rsll(mynam)) {
4637 if (do_tounixspec(esa,outbuf,0) == NULL) {
4638 if (out) Safefree(out);
4641 if (outbufl != NULL)
4642 PerlMem_free(outbufl);
4646 else strcpy(outbuf,esa);
4649 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4650 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4651 if (do_tounixspec(outbuf,tmpfspec,0) == NULL) {
4652 if (out) Safefree(out);
4655 PerlMem_free(tmpfspec);
4656 if (outbufl != NULL)
4657 PerlMem_free(outbufl);
4660 strcpy(outbuf,tmpfspec);
4661 PerlMem_free(tmpfspec);
4664 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4665 sts = rms_free_search_context(&myfab); /* Free search context */
4668 if (outbufl != NULL)
4669 PerlMem_free(outbufl);
4674 /* External entry points */
4675 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4676 { return do_rmsexpand(spec,buf,0,def,opt); }
4677 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4678 { return do_rmsexpand(spec,buf,1,def,opt); }
4682 ** The following routines are provided to make life easier when
4683 ** converting among VMS-style and Unix-style directory specifications.
4684 ** All will take input specifications in either VMS or Unix syntax. On
4685 ** failure, all return NULL. If successful, the routines listed below
4686 ** return a pointer to a buffer containing the appropriately
4687 ** reformatted spec (and, therefore, subsequent calls to that routine
4688 ** will clobber the result), while the routines of the same names with
4689 ** a _ts suffix appended will return a pointer to a mallocd string
4690 ** containing the appropriately reformatted spec.
4691 ** In all cases, only explicit syntax is altered; no check is made that
4692 ** the resulting string is valid or that the directory in question
4695 ** fileify_dirspec() - convert a directory spec into the name of the
4696 ** directory file (i.e. what you can stat() to see if it's a dir).
4697 ** The style (VMS or Unix) of the result is the same as the style
4698 ** of the parameter passed in.
4699 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4700 ** what you prepend to a filename to indicate what directory it's in).
4701 ** The style (VMS or Unix) of the result is the same as the style
4702 ** of the parameter passed in.
4703 ** tounixpath() - convert a directory spec into a Unix-style path.
4704 ** tovmspath() - convert a directory spec into a VMS-style path.
4705 ** tounixspec() - convert any file spec into a Unix-style file spec.
4706 ** tovmsspec() - convert any file spec into a VMS-style spec.
4708 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4709 ** Permission is given to distribute this code as part of the Perl
4710 ** standard distribution under the terms of the GNU General Public
4711 ** License or the Perl Artistic License. Copies of each may be
4712 ** found in the Perl standard distribution.
4715 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/
4716 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts)
4718 static char __fileify_retbuf[VMS_MAXRSS];
4719 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4720 char *retspec, *cp1, *cp2, *lastdir;
4721 char *trndir, *vmsdir;
4722 unsigned short int trnlnm_iter_count;
4725 if (!dir || !*dir) {
4726 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4728 dirlen = strlen(dir);
4729 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4730 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4731 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4738 if (dirlen > (VMS_MAXRSS - 1)) {
4739 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4742 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4743 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4744 if (!strpbrk(dir+1,"/]>:") &&
4745 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4746 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4747 trnlnm_iter_count = 0;
4748 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4749 trnlnm_iter_count++;
4750 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4752 dirlen = strlen(trndir);
4755 strncpy(trndir,dir,dirlen);
4756 trndir[dirlen] = '\0';
4759 /* At this point we are done with *dir and use *trndir which is a
4760 * copy that can be modified. *dir must not be modified.
4763 /* If we were handed a rooted logical name or spec, treat it like a
4764 * simple directory, so that
4765 * $ Define myroot dev:[dir.]
4766 * ... do_fileify_dirspec("myroot",buf,1) ...
4767 * does something useful.
4769 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4770 trndir[--dirlen] = '\0';
4771 trndir[dirlen-1] = ']';
4773 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4774 trndir[--dirlen] = '\0';
4775 trndir[dirlen-1] = '>';
4778 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4779 /* If we've got an explicit filename, we can just shuffle the string. */
4780 if (*(cp1+1)) hasfilename = 1;
4781 /* Similarly, we can just back up a level if we've got multiple levels
4782 of explicit directories in a VMS spec which ends with directories. */
4784 for (cp2 = cp1; cp2 > trndir; cp2--) {
4786 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4787 /* fix-me, can not scan EFS file specs backward like this */
4788 *cp2 = *cp1; *cp1 = '\0';
4793 if (*cp2 == '[' || *cp2 == '<') break;
4798 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4799 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4800 cp1 = strpbrk(trndir,"]:>");
4801 if (hasfilename || !cp1) { /* Unix-style path or filename */
4802 if (trndir[0] == '.') {
4803 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4804 PerlMem_free(trndir);
4805 PerlMem_free(vmsdir);
4806 return do_fileify_dirspec("[]",buf,ts);
4808 else if (trndir[1] == '.' &&
4809 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4810 PerlMem_free(trndir);
4811 PerlMem_free(vmsdir);
4812 return do_fileify_dirspec("[-]",buf,ts);
4815 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4816 dirlen -= 1; /* to last element */
4817 lastdir = strrchr(trndir,'/');
4819 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4820 /* If we have "/." or "/..", VMSify it and let the VMS code
4821 * below expand it, rather than repeating the code to handle
4822 * relative components of a filespec here */
4824 if (*(cp1+2) == '.') cp1++;
4825 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4827 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4828 PerlMem_free(trndir);
4829 PerlMem_free(vmsdir);
4832 if (strchr(vmsdir,'/') != NULL) {
4833 /* If do_tovmsspec() returned it, it must have VMS syntax
4834 * delimiters in it, so it's a mixed VMS/Unix spec. We take
4835 * the time to check this here only so we avoid a recursion
4836 * loop; otherwise, gigo.
4838 PerlMem_free(trndir);
4839 PerlMem_free(vmsdir);
4840 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
4843 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4844 PerlMem_free(trndir);
4845 PerlMem_free(vmsdir);
4848 ret_chr = do_tounixspec(trndir,buf,ts);
4849 PerlMem_free(trndir);
4850 PerlMem_free(vmsdir);
4854 } while ((cp1 = strstr(cp1,"/.")) != NULL);
4855 lastdir = strrchr(trndir,'/');
4857 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
4859 /* Ditto for specs that end in an MFD -- let the VMS code
4860 * figure out whether it's a real device or a rooted logical. */
4862 /* This should not happen any more. Allowing the fake /000000
4863 * in a UNIX pathname causes all sorts of problems when trying
4864 * to run in UNIX emulation. So the VMS to UNIX conversions
4865 * now remove the fake /000000 directories.
4868 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
4869 if (do_tovmsspec(trndir,vmsdir,0) == NULL) {
4870 PerlMem_free(trndir);
4871 PerlMem_free(vmsdir);
4874 if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) {
4875 PerlMem_free(trndir);
4876 PerlMem_free(vmsdir);
4879 ret_chr = do_tounixspec(trndir,buf,ts);
4880 PerlMem_free(trndir);
4881 PerlMem_free(vmsdir);
4886 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
4887 !(lastdir = cp1 = strrchr(trndir,']')) &&
4888 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
4889 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
4892 /* For EFS or ODS-5 look for the last dot */
4893 if (decc_efs_charset) {
4894 cp2 = strrchr(cp1,'.');
4896 if (vms_process_case_tolerant) {
4897 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
4898 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
4899 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
4900 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4901 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4902 (ver || *cp3)))))) {
4903 PerlMem_free(trndir);
4904 PerlMem_free(vmsdir);
4906 set_vaxc_errno(RMS$_DIR);
4911 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
4912 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
4913 !*(cp2+3) || *(cp2+3) != 'R' ||
4914 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
4915 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
4916 (ver || *cp3)))))) {
4917 PerlMem_free(trndir);
4918 PerlMem_free(vmsdir);
4920 set_vaxc_errno(RMS$_DIR);
4924 dirlen = cp2 - trndir;
4928 retlen = dirlen + 6;
4929 if (buf) retspec = buf;
4930 else if (ts) Newx(retspec,retlen+1,char);
4931 else retspec = __fileify_retbuf;
4932 memcpy(retspec,trndir,dirlen);
4933 retspec[dirlen] = '\0';
4935 /* We've picked up everything up to the directory file name.
4936 Now just add the type and version, and we're set. */
4937 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
4938 strcat(retspec,".dir;1");
4940 strcat(retspec,".DIR;1");
4941 PerlMem_free(trndir);
4942 PerlMem_free(vmsdir);
4945 else { /* VMS-style directory spec */
4947 char *esa, term, *cp;
4948 unsigned long int sts, cmplen, haslower = 0;
4949 unsigned int nam_fnb;
4951 struct FAB dirfab = cc$rms_fab;
4952 rms_setup_nam(savnam);
4953 rms_setup_nam(dirnam);
4955 esa = PerlMem_malloc(VMS_MAXRSS + 1);
4956 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4957 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
4958 rms_bind_fab_nam(dirfab, dirnam);
4959 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
4960 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
4961 #ifdef NAM$M_NO_SHORT_UPCASE
4962 if (decc_efs_case_preserve)
4963 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
4966 for (cp = trndir; *cp; cp++)
4967 if (islower(*cp)) { haslower = 1; break; }
4968 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
4969 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
4970 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
4971 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
4975 PerlMem_free(trndir);
4976 PerlMem_free(vmsdir);
4978 set_vaxc_errno(dirfab.fab$l_sts);
4984 /* Does the file really exist? */
4985 if (sys$search(&dirfab)& STS$K_SUCCESS) {
4986 /* Yes; fake the fnb bits so we'll check type below */
4987 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
4989 else { /* No; just work with potential name */
4990 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
4993 PerlMem_free(trndir);
4994 PerlMem_free(vmsdir);
4995 set_errno(EVMSERR); set_vaxc_errno(dirfab.fab$l_sts);
4996 sts = rms_free_search_context(&dirfab);
5001 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5002 cp1 = strchr(esa,']');
5003 if (!cp1) cp1 = strchr(esa,'>');
5004 if (cp1) { /* Should always be true */
5005 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5006 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5009 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5010 /* Yep; check version while we're at it, if it's there. */
5011 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5012 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5013 /* Something other than .DIR[;1]. Bzzt. */
5014 sts = rms_free_search_context(&dirfab);
5016 PerlMem_free(trndir);
5017 PerlMem_free(vmsdir);
5019 set_vaxc_errno(RMS$_DIR);
5023 esa[rms_nam_esll(dirnam)] = '\0';
5024 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5025 /* They provided at least the name; we added the type, if necessary, */
5026 if (buf) retspec = buf; /* in sys$parse() */
5027 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5028 else retspec = __fileify_retbuf;
5029 strcpy(retspec,esa);
5030 sts = rms_free_search_context(&dirfab);
5031 PerlMem_free(trndir);
5033 PerlMem_free(vmsdir);
5036 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5037 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5039 rms_nam_esll(dirnam) -= 9;
5041 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5042 if (cp1 == NULL) { /* should never happen */
5043 sts = rms_free_search_context(&dirfab);
5044 PerlMem_free(trndir);
5046 PerlMem_free(vmsdir);
5051 retlen = strlen(esa);
5052 cp1 = strrchr(esa,'.');
5053 /* ODS-5 directory specifications can have extra "." in them. */
5054 /* Fix-me, can not scan EFS file specifications backwards */
5055 while (cp1 != NULL) {
5056 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5060 while ((cp1 > esa) && (*cp1 != '.'))
5067 if ((cp1) != NULL) {
5068 /* There's more than one directory in the path. Just roll back. */
5070 if (buf) retspec = buf;
5071 else if (ts) Newx(retspec,retlen+7,char);
5072 else retspec = __fileify_retbuf;
5073 strcpy(retspec,esa);
5076 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5077 /* Go back and expand rooted logical name */
5078 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5079 #ifdef NAM$M_NO_SHORT_UPCASE
5080 if (decc_efs_case_preserve)
5081 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5083 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5084 sts = rms_free_search_context(&dirfab);
5086 PerlMem_free(trndir);
5087 PerlMem_free(vmsdir);
5089 set_vaxc_errno(dirfab.fab$l_sts);
5092 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5093 if (buf) retspec = buf;
5094 else if (ts) Newx(retspec,retlen+16,char);
5095 else retspec = __fileify_retbuf;
5096 cp1 = strstr(esa,"][");
5097 if (!cp1) cp1 = strstr(esa,"]<");
5099 memcpy(retspec,esa,dirlen);
5100 if (!strncmp(cp1+2,"000000]",7)) {
5101 retspec[dirlen-1] = '\0';
5102 /* fix-me Not full ODS-5, just extra dots in directories for now */
5103 cp1 = retspec + dirlen - 1;
5104 while (cp1 > retspec)
5109 if (*(cp1-1) != '^')
5114 if (*cp1 == '.') *cp1 = ']';
5116 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5117 memmove(cp1+1,"000000]",7);
5121 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5122 retspec[retlen] = '\0';
5123 /* Convert last '.' to ']' */
5124 cp1 = retspec+retlen-1;
5125 while (*cp != '[') {
5128 /* Do not trip on extra dots in ODS-5 directories */
5129 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5133 if (*cp1 == '.') *cp1 = ']';
5135 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5136 memmove(cp1+1,"000000]",7);
5140 else { /* This is a top-level dir. Add the MFD to the path. */
5141 if (buf) retspec = buf;
5142 else if (ts) Newx(retspec,retlen+16,char);
5143 else retspec = __fileify_retbuf;
5146 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5147 strcpy(cp2,":[000000]");
5152 sts = rms_free_search_context(&dirfab);
5153 /* We've set up the string up through the filename. Add the
5154 type and version, and we're done. */
5155 strcat(retspec,".DIR;1");
5157 /* $PARSE may have upcased filespec, so convert output to lower
5158 * case if input contained any lowercase characters. */
5159 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5160 PerlMem_free(trndir);
5162 PerlMem_free(vmsdir);
5165 } /* end of do_fileify_dirspec() */
5167 /* External entry points */
5168 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5169 { return do_fileify_dirspec(dir,buf,0); }
5170 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5171 { return do_fileify_dirspec(dir,buf,1); }
5173 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5174 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts)
5176 static char __pathify_retbuf[VMS_MAXRSS];
5177 unsigned long int retlen;
5178 char *retpath, *cp1, *cp2, *trndir;
5179 unsigned short int trnlnm_iter_count;
5183 if (!dir || !*dir) {
5184 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5187 trndir = PerlMem_malloc(VMS_MAXRSS);
5188 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5189 if (*dir) strcpy(trndir,dir);
5190 else getcwd(trndir,VMS_MAXRSS - 1);
5192 trnlnm_iter_count = 0;
5193 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5194 && my_trnlnm(trndir,trndir,0)) {
5195 trnlnm_iter_count++;
5196 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5197 trnlen = strlen(trndir);
5199 /* Trap simple rooted lnms, and return lnm:[000000] */
5200 if (!strcmp(trndir+trnlen-2,".]")) {
5201 if (buf) retpath = buf;
5202 else if (ts) Newx(retpath,strlen(dir)+10,char);
5203 else retpath = __pathify_retbuf;
5204 strcpy(retpath,dir);
5205 strcat(retpath,":[000000]");
5206 PerlMem_free(trndir);
5211 /* At this point we do not work with *dir, but the copy in
5212 * *trndir that is modifiable.
5215 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5216 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5217 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5218 retlen = 2 + (*(trndir+1) != '\0');
5220 if ( !(cp1 = strrchr(trndir,'/')) &&
5221 !(cp1 = strrchr(trndir,']')) &&
5222 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5223 if ((cp2 = strchr(cp1,'.')) != NULL &&
5224 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5225 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5226 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5227 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5230 /* For EFS or ODS-5 look for the last dot */
5231 if (decc_efs_charset) {
5232 cp2 = strrchr(cp1,'.');
5234 if (vms_process_case_tolerant) {
5235 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5236 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5237 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5238 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5239 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5240 (ver || *cp3)))))) {
5241 PerlMem_free(trndir);
5243 set_vaxc_errno(RMS$_DIR);
5248 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5249 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5250 !*(cp2+3) || *(cp2+3) != 'R' ||
5251 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5252 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5253 (ver || *cp3)))))) {
5254 PerlMem_free(trndir);
5256 set_vaxc_errno(RMS$_DIR);
5260 retlen = cp2 - trndir + 1;
5262 else { /* No file type present. Treat the filename as a directory. */
5263 retlen = strlen(trndir) + 1;
5266 if (buf) retpath = buf;
5267 else if (ts) Newx(retpath,retlen+1,char);
5268 else retpath = __pathify_retbuf;
5269 strncpy(retpath, trndir, retlen-1);
5270 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5271 retpath[retlen-1] = '/'; /* with '/', add it. */
5272 retpath[retlen] = '\0';
5274 else retpath[retlen-1] = '\0';
5276 else { /* VMS-style directory spec */
5278 unsigned long int sts, cmplen, haslower;
5279 struct FAB dirfab = cc$rms_fab;
5281 rms_setup_nam(savnam);
5282 rms_setup_nam(dirnam);
5284 /* If we've got an explicit filename, we can just shuffle the string. */
5285 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5286 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5287 if ((cp2 = strchr(cp1,'.')) != NULL) {
5289 if (vms_process_case_tolerant) {
5290 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5291 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5292 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5293 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5294 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5295 (ver || *cp3)))))) {
5296 PerlMem_free(trndir);
5298 set_vaxc_errno(RMS$_DIR);
5303 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5304 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5305 !*(cp2+3) || *(cp2+3) != 'R' ||
5306 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5307 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5308 (ver || *cp3)))))) {
5309 PerlMem_free(trndir);
5311 set_vaxc_errno(RMS$_DIR);
5316 else { /* No file type, so just draw name into directory part */
5317 for (cp2 = cp1; *cp2; cp2++) ;
5320 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5322 /* We've now got a VMS 'path'; fall through */
5325 dirlen = strlen(trndir);
5326 if (trndir[dirlen-1] == ']' ||
5327 trndir[dirlen-1] == '>' ||
5328 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5329 if (buf) retpath = buf;
5330 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5331 else retpath = __pathify_retbuf;
5332 strcpy(retpath,trndir);
5333 PerlMem_free(trndir);
5336 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5337 esa = PerlMem_malloc(VMS_MAXRSS);
5338 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5339 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5340 rms_bind_fab_nam(dirfab, dirnam);
5341 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5342 #ifdef NAM$M_NO_SHORT_UPCASE
5343 if (decc_efs_case_preserve)
5344 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5347 for (cp = trndir; *cp; cp++)
5348 if (islower(*cp)) { haslower = 1; break; }
5350 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5351 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5352 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5353 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5356 PerlMem_free(trndir);
5359 set_vaxc_errno(dirfab.fab$l_sts);
5365 /* Does the file really exist? */
5366 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5367 if (dirfab.fab$l_sts != RMS$_FNF) {
5369 sts1 = rms_free_search_context(&dirfab);
5370 PerlMem_free(trndir);
5373 set_vaxc_errno(dirfab.fab$l_sts);
5376 dirnam = savnam; /* No; just work with potential name */
5379 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5380 /* Yep; check version while we're at it, if it's there. */
5381 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5382 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5384 /* Something other than .DIR[;1]. Bzzt. */
5385 sts2 = rms_free_search_context(&dirfab);
5386 PerlMem_free(trndir);
5389 set_vaxc_errno(RMS$_DIR);
5393 /* OK, the type was fine. Now pull any file name into the
5395 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5397 cp1 = strrchr(esa,'>');
5398 *(rms_nam_typel(dirnam)) = '>';
5401 *(rms_nam_typel(dirnam) + 1) = '\0';
5402 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5403 if (buf) retpath = buf;
5404 else if (ts) Newx(retpath,retlen,char);
5405 else retpath = __pathify_retbuf;
5406 strcpy(retpath,esa);
5408 sts = rms_free_search_context(&dirfab);
5409 /* $PARSE may have upcased filespec, so convert output to lower
5410 * case if input contained any lowercase characters. */
5411 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5414 PerlMem_free(trndir);
5416 } /* end of do_pathify_dirspec() */
5418 /* External entry points */
5419 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5420 { return do_pathify_dirspec(dir,buf,0); }
5421 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5422 { return do_pathify_dirspec(dir,buf,1); }
5424 /*{{{ char *tounixspec[_ts](char *spec, char *buf)*/
5425 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts)
5427 static char __tounixspec_retbuf[VMS_MAXRSS];
5428 char *dirend, *rslt, *cp1, *cp3, *tmp;
5430 int devlen, dirlen, retlen = VMS_MAXRSS;
5431 int expand = 1; /* guarantee room for leading and trailing slashes */
5432 unsigned short int trnlnm_iter_count;
5435 if (spec == NULL) return NULL;
5436 if (strlen(spec) > NAM$C_MAXRSS) return NULL;
5437 if (buf) rslt = buf;
5439 retlen = strlen(spec);
5440 cp1 = strchr(spec,'[');
5441 if (!cp1) cp1 = strchr(spec,'<');
5443 for (cp1++; *cp1; cp1++) {
5444 if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
5445 if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
5446 { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
5449 Newx(rslt,retlen+2+2*expand,char);
5451 else rslt = __tounixspec_retbuf;
5453 /* New VMS specific format needs translation
5454 * glob passes filenames with trailing '\n' and expects this preserved.
5456 if (decc_posix_compliant_pathnames) {
5457 if (strncmp(spec, "\"^UP^", 5) == 0) {
5463 tunix = PerlMem_malloc(VMS_MAXRSS);
5464 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5465 strcpy(tunix, spec);
5466 tunix_len = strlen(tunix);
5468 if (tunix[tunix_len - 1] == '\n') {
5469 tunix[tunix_len - 1] = '\"';
5470 tunix[tunix_len] = '\0';
5474 uspec = decc$translate_vms(tunix);
5475 PerlMem_free(tunix);
5476 if ((int)uspec > 0) {
5482 /* If we can not translate it, makemaker wants as-is */
5490 cmp_rslt = 0; /* Presume VMS */
5491 cp1 = strchr(spec, '/');
5495 /* Look for EFS ^/ */
5496 if (decc_efs_charset) {
5497 while (cp1 != NULL) {
5500 /* Found illegal VMS, assume UNIX */
5505 cp1 = strchr(cp1, '/');
5509 /* Look for "." and ".." */
5510 if (decc_filename_unix_report) {
5511 if (spec[0] == '.') {
5512 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5516 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5522 /* This is already UNIX or at least nothing VMS understands */
5530 dirend = strrchr(spec,']');
5531 if (dirend == NULL) dirend = strrchr(spec,'>');
5532 if (dirend == NULL) dirend = strchr(spec,':');
5533 if (dirend == NULL) {
5538 /* Special case 1 - sys$posix_root = / */
5539 #if __CRTL_VER >= 70000000
5540 if (!decc_disable_posix_root) {
5541 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5549 /* Special case 2 - Convert NLA0: to /dev/null */
5550 #if __CRTL_VER < 70000000
5551 cmp_rslt = strncmp(spec,"NLA0:", 5);
5553 cmp_rslt = strncmp(spec,"nla0:", 5);
5555 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5557 if (cmp_rslt == 0) {
5558 strcpy(rslt, "/dev/null");
5561 if (spec[6] != '\0') {
5568 /* Also handle special case "SYS$SCRATCH:" */
5569 #if __CRTL_VER < 70000000
5570 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5572 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5574 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5576 tmp = PerlMem_malloc(VMS_MAXRSS);
5577 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5578 if (cmp_rslt == 0) {
5581 islnm = my_trnlnm(tmp, "TMP", 0);
5583 strcpy(rslt, "/tmp");
5586 if (spec[12] != '\0') {
5594 if (*cp2 != '[' && *cp2 != '<') {
5597 else { /* the VMS spec begins with directories */
5599 if (*cp2 == ']' || *cp2 == '>') {
5600 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5604 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5605 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5606 if (ts) Safefree(rslt);
5610 trnlnm_iter_count = 0;
5613 while (*cp3 != ':' && *cp3) cp3++;
5615 if (strchr(cp3,']') != NULL) break;
5616 trnlnm_iter_count++;
5617 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5618 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5620 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5621 retlen = devlen + dirlen;
5622 Renew(rslt,retlen+1+2*expand,char);
5628 *(cp1++) = *(cp3++);
5629 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5631 return NULL; /* No room */
5636 if ((*cp2 == '^')) {
5637 /* EFS file escape, pass the next character as is */
5638 /* Fix me: HEX encoding for UNICODE not implemented */
5641 else if ( *cp2 == '.') {
5642 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5643 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5650 for (; cp2 <= dirend; cp2++) {
5651 if ((*cp2 == '^')) {
5652 /* EFS file escape, pass the next character as is */
5653 /* Fix me: HEX encoding for UNICODE not implemented */
5659 if (*(cp2+1) == '[') cp2++;
5661 else if (*cp2 == ']' || *cp2 == '>') {
5662 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5664 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5666 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5667 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5668 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5669 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5670 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5672 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5673 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5677 else if (*cp2 == '-') {
5678 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5679 while (*cp2 == '-') {
5681 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5683 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5684 if (ts) Safefree(rslt); /* filespecs like */
5685 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5689 else *(cp1++) = *cp2;
5691 else *(cp1++) = *cp2;
5693 while (*cp2) *(cp1++) = *(cp2++);
5696 /* This still leaves /000000/ when working with a
5697 * VMS device root or concealed root.
5703 ulen = strlen(rslt);
5705 /* Get rid of "000000/ in rooted filespecs */
5707 zeros = strstr(rslt, "/000000/");
5708 if (zeros != NULL) {
5710 mlen = ulen - (zeros - rslt) - 7;
5711 memmove(zeros, &zeros[7], mlen);
5720 } /* end of do_tounixspec() */
5722 /* External entry points */
5723 char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); }
5724 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); }
5726 #if __CRTL_VER >= 80200000 && !defined(__VAX)
5728 static int posix_to_vmsspec
5729 (char *vmspath, int vmspath_len, const char *unixpath) {
5731 struct FAB myfab = cc$rms_fab;
5732 struct NAML mynam = cc$rms_naml;
5733 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5734 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5740 /* If not a posix spec already, convert it */
5742 unixlen = strlen(unixpath);
5747 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5748 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5751 /* This is already a VMS specification, no conversion */
5753 strncpy(vmspath,unixpath, vmspath_len);
5755 vmspath[vmspath_len] = 0;
5756 if (unixpath[unixlen - 1] == '/')
5758 esa = PerlMem_malloc(VMS_MAXRSS);
5759 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5760 myfab.fab$l_fna = vmspath;
5761 myfab.fab$b_fns = strlen(vmspath);
5762 myfab.fab$l_naml = &mynam;
5763 mynam.naml$l_esa = NULL;
5764 mynam.naml$b_ess = 0;
5765 mynam.naml$l_long_expand = esa;
5766 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
5767 mynam.naml$l_rsa = NULL;
5768 mynam.naml$b_rss = 0;
5769 if (decc_efs_case_preserve)
5770 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
5771 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
5773 /* Set up the remaining naml fields */
5774 sts = sys$parse(&myfab);
5776 /* It failed! Try again as a UNIX filespec */
5782 /* get the Device ID and the FID */
5783 sts = sys$search(&myfab);
5784 /* on any failure, returned the POSIX ^UP^ filespec */
5789 specdsc.dsc$a_pointer = vmspath;
5790 specdsc.dsc$w_length = vmspath_len;
5792 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
5793 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
5794 sts = lib$fid_to_name
5795 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
5797 /* on any failure, returned the POSIX ^UP^ filespec */
5799 /* This can happen if user does not have permission to read directories */
5800 if (strncmp(unixpath,"\"^UP^",5) != 0)
5801 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5803 strcpy(vmspath, unixpath);
5806 vmspath[specdsc.dsc$w_length] = 0;
5808 /* Are we expecting a directory? */
5809 if (dir_flag != 0) {
5815 i = specdsc.dsc$w_length - 1;
5819 /* Version must be '1' */
5820 if (vmspath[i--] != '1')
5822 /* Version delimiter is one of ".;" */
5823 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
5826 if (vmspath[i--] != 'R')
5828 if (vmspath[i--] != 'I')
5830 if (vmspath[i--] != 'D')
5832 if (vmspath[i--] != '.')
5834 eptr = &vmspath[i+1];
5836 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
5837 if (vmspath[i-1] != '^') {
5845 /* Get rid of 6 imaginary zero directory filename */
5846 vmspath[i+1] = '\0';
5850 if (vmspath[i] == '0')
5864 /* Can not use LIB$FID_TO_NAME, so doing a manual conversion */
5865 static int posix_to_vmsspec_hardway
5866 (char *vmspath, int vmspath_len, const char *unixpath) {
5869 const char *unixptr;
5871 const char *lastslash;
5872 const char *lastdot;
5883 /* Ignore leading "/" characters */
5884 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
5887 unixlen = strlen(unixptr);
5889 /* Do nothing with blank paths */
5895 lastslash = strrchr(unixptr,'/');
5896 lastdot = strrchr(unixptr,'.');
5899 /* last dot is last dot or past end of string */
5900 if (lastdot == NULL)
5901 lastdot = unixptr + unixlen;
5903 /* if no directories, set last slash to beginning of string */
5904 if (lastslash == NULL) {
5905 lastslash = unixptr;
5908 /* Watch out for trailing "." after last slash, still a directory */
5909 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
5910 lastslash = unixptr + unixlen;
5913 /* Watch out for traiing ".." after last slash, still a directory */
5914 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
5915 lastslash = unixptr + unixlen;
5918 /* dots in directories are aways escaped */
5919 if (lastdot < lastslash)
5920 lastdot = unixptr + unixlen;
5923 /* if (unixptr < lastslash) then we are in a directory */
5931 /* This could have a "^UP^ on the front */
5932 if (strncmp(unixptr,"\"^UP^",5) == 0) {
5937 /* Start with the UNIX path */
5938 if (*unixptr != '/') {
5939 /* relative paths */
5940 if (lastslash > unixptr) {
5943 /* skip leading ./ */
5945 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
5951 /* Are we still in a directory? */
5952 if (unixptr <= lastslash) {
5957 /* if not backing up, then it is relative forward. */
5958 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
5959 ((unixptr[2] == '/') || (unixptr[2] == '\0')))) {
5967 /* Perl wants an empty directory here to tell the difference
5968 * between a DCL commmand and a filename
5977 /* Handle two special files . and .. */
5978 if (unixptr[0] == '.') {
5979 if (unixptr[1] == '\0') {
5986 if ((unixptr[1] == '.') && (unixptr[2] == '\0')) {
5997 else { /* Absolute PATH handling */
6001 /* Need to find out where root is */
6003 /* In theory, this procedure should never get an absolute POSIX pathname
6004 * that can not be found on the POSIX root.
6005 * In practice, that can not be relied on, and things will show up
6006 * here that are a VMS device name or concealed logical name instead.
6007 * So to make things work, this procedure must be tolerant.
6009 esa = PerlMem_malloc(vmspath_len);
6010 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6013 nextslash = strchr(&unixptr[1],'/');
6015 if (nextslash != NULL) {
6016 seg_len = nextslash - &unixptr[1];
6017 strncpy(vmspath, unixptr, seg_len + 1);
6018 vmspath[seg_len+1] = 0;
6019 sts = posix_to_vmsspec(esa, vmspath_len, vmspath);
6023 /* This is verified to be a real path */
6025 sts = posix_to_vmsspec(esa, vmspath_len, "/");
6026 strcpy(vmspath, esa);
6027 vmslen = strlen(vmspath);
6028 vmsptr = vmspath + vmslen;
6030 if (unixptr < lastslash) {
6039 cmp = strcmp(rptr,"000000.");
6044 } /* removing 6 zeros */
6045 } /* vmslen < 7, no 6 zeros possible */
6046 } /* Not in a directory */
6047 } /* end of verified real path handling */
6052 /* Ok, we have a device or a concealed root that is not in POSIX
6053 * or we have garbage. Make the best of it.
6056 /* Posix to VMS destroyed this, so copy it again */
6057 strncpy(vmspath, &unixptr[1], seg_len);
6058 vmspath[seg_len] = 0;
6060 vmsptr = &vmsptr[vmslen];
6063 /* Now do we need to add the fake 6 zero directory to it? */
6065 if ((*lastslash == '/') && (nextslash < lastslash)) {
6066 /* No there is another directory */
6072 /* now we have foo:bar or foo:[000000]bar to decide from */
6073 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6074 trnend = islnm ? islnm - 1 : 0;
6076 /* if this was a logical name, ']' or '>' must be present */
6077 /* if not a logical name, then assume a device and hope. */
6078 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6080 /* if log name and trailing '.' then rooted - treat as device */
6081 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6083 /* Fix me, if not a logical name, a device lookup should be
6084 * done to see if the device is file structured. If the device
6085 * is not file structured, the 6 zeros should not be put on.
6087 * As it is, perl is occasionally looking for dev:[000000]tty.
6088 * which looks a little strange.
6091 if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) {
6092 /* No real directory present */
6097 /* Put the device delimiter on */
6100 unixptr = nextslash;
6103 /* Start directory if needed */
6104 if (!islnm || add_6zero) {
6110 /* add fake 000000] if needed */
6123 } /* non-POSIX translation */
6125 } /* End of relative/absolute path handling */
6127 while ((*unixptr) && (vmslen < vmspath_len)){
6132 if (dir_start != 0) {
6134 /* First characters in a directory are handled special */
6135 while ((*unixptr == '/') ||
6136 ((*unixptr == '.') &&
6137 ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) {
6142 /* Skip redundant / in specification */
6143 while ((*unixptr == '/') && (dir_start != 0)) {
6146 if (unixptr == lastslash)
6149 if (unixptr == lastslash)
6152 /* Skip redundant ./ characters */
6153 while ((*unixptr == '.') &&
6154 ((unixptr[1] == '/')||(unixptr[1] == '\0'))) {
6157 if (unixptr == lastslash)
6159 if (*unixptr == '/')
6162 if (unixptr == lastslash)
6165 /* Skip redundant ../ characters */
6166 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6167 ((unixptr[2] == '/') || (unixptr[2] == '\0'))) {
6168 /* Set the backing up flag */
6174 unixptr++; /* first . */
6175 unixptr++; /* second . */
6176 if (unixptr == lastslash)
6178 if (*unixptr == '/') /* The slash */
6181 if (unixptr == lastslash)
6184 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6185 /* Not needed when VMS is pretending to be UNIX. */
6187 /* Is this loop stuck because of too many dots? */
6188 if (loop_flag == 0) {
6189 /* Exit the loop and pass the rest through */
6194 /* Are we done with directories yet? */
6195 if (unixptr >= lastslash) {
6197 /* Watch out for trailing dots */
6206 if (*unixptr == '/')
6210 /* Have we stopped backing up? */
6215 /* dir_start continues to be = 1 */
6217 if (*unixptr == '-') {
6219 *vmsptr++ = *unixptr++;
6223 /* Now are we done with directories yet? */
6224 if (unixptr >= lastslash) {
6226 /* Watch out for trailing dots */
6242 if (*unixptr == '\0')
6245 /* Normal characters - More EFS work probably needed */
6251 /* remove multiple / */
6252 while (unixptr[1] == '/') {
6255 if (unixptr == lastslash) {
6256 /* Watch out for trailing dots */
6268 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6269 /* Not needed when VMS is pretending to be UNIX. */
6273 if (*unixptr != '\0')
6289 if ((unixptr < lastdot) || (unixptr[1] == '\0')) {
6295 /* trailing dot ==> '^..' on VMS */
6296 if (*unixptr == '\0') {
6300 *vmsptr++ = *unixptr++;
6303 if (quoted && (unixptr[1] == '\0')) {
6308 *vmsptr++ = *unixptr++;
6315 *vmsptr++ = *unixptr++;
6319 if (*unixptr != '\0') {
6320 *vmsptr++ = *unixptr++;
6327 /* Make sure directory is closed */
6328 if (unixptr == lastslash) {
6330 vmsptr2 = vmsptr - 1;
6332 if (*vmsptr2 != ']') {
6335 /* directories do not end in a dot bracket */
6336 if (*vmsptr2 == '.') {
6340 if (*vmsptr2 != '^') {
6341 vmsptr--; /* back up over the dot */
6349 /* Add a trailing dot if a file with no extension */
6350 vmsptr2 = vmsptr - 1;
6351 if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6352 (*lastdot != '.')) {
6363 /*{{{ char *tovmsspec[_ts](char *path, char *buf)*/
6364 static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) {
6365 static char __tovmsspec_retbuf[VMS_MAXRSS];
6366 char *rslt, *dirend;
6371 unsigned long int infront = 0, hasdir = 1;
6375 if (path == NULL) return NULL;
6376 rslt_len = VMS_MAXRSS;
6377 if (buf) rslt = buf;
6378 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6379 else rslt = __tovmsspec_retbuf;
6380 if (strpbrk(path,"]:>") ||
6381 (dirend = strrchr(path,'/')) == NULL) {
6382 if (path[0] == '.') {
6383 if (path[1] == '\0') strcpy(rslt,"[]");
6384 else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]");
6385 else strcpy(rslt,path); /* probably garbage */
6387 else strcpy(rslt,path);
6391 /* Posix specifications are now a native VMS format */
6392 /*--------------------------------------------------*/
6393 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6394 if (decc_posix_compliant_pathnames) {
6395 if (strncmp(path,"\"^UP^",5) == 0) {
6396 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6402 vms_delim = strpbrk(path,"]:>");
6404 if ((vms_delim != NULL) ||
6405 ((dirend = strrchr(path,'/')) == NULL)) {
6407 /* VMS special characters found! */
6409 if (path[0] == '.') {
6410 if (path[1] == '\0') strcpy(rslt,"[]");
6411 else if (path[1] == '.' && path[2] == '\0')
6414 /* Dot preceeding a device or directory ? */
6416 /* If not in POSIX mode, pass it through and hope it works */
6417 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6418 if (!decc_posix_compliant_pathnames)
6419 strcpy(rslt,path); /* probably garbage */
6421 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6423 strcpy(rslt,path); /* probably garbage */
6429 /* If no VMS characters and in POSIX mode, convert it!
6430 * This is the easiest way to get directory specifications
6431 * handled correctly in POSIX mode
6433 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6434 if ((vms_delim == NULL) && decc_posix_compliant_pathnames)
6435 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6437 /* No unix path separators - presume VMS already */
6441 strcpy(rslt,path); /* probably garbage */
6447 /* If POSIX mode active, handle the conversion */
6448 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6449 if (decc_posix_compliant_pathnames) {
6450 posix_to_vmsspec_hardway(rslt, rslt_len, path);
6455 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
6456 if (!*(dirend+2)) dirend +=2;
6457 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
6458 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
6463 lastdot = strrchr(cp2,'.');
6469 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6471 if (decc_disable_posix_root) {
6472 strcpy(rslt,"sys$disk:[000000]");
6475 strcpy(rslt,"sys$posix_root:[000000]");
6479 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
6481 trndev = PerlMem_malloc(VMS_MAXRSS);
6482 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
6483 islnm = my_trnlnm(rslt,trndev,0);
6485 /* DECC special handling */
6487 if (strcmp(rslt,"bin") == 0) {
6488 strcpy(rslt,"sys$system");
6491 islnm = my_trnlnm(rslt,trndev,0);
6493 else if (strcmp(rslt,"tmp") == 0) {
6494 strcpy(rslt,"sys$scratch");
6497 islnm = my_trnlnm(rslt,trndev,0);
6499 else if (!decc_disable_posix_root) {
6500 strcpy(rslt, "sys$posix_root");
6504 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
6505 islnm = my_trnlnm(rslt,trndev,0);
6507 else if (strcmp(rslt,"dev") == 0) {
6508 if (strncmp(cp2,"/null", 5) == 0) {
6509 if ((cp2[5] == 0) || (cp2[5] == '/')) {
6510 strcpy(rslt,"NLA0");
6514 islnm = my_trnlnm(rslt,trndev,0);
6520 trnend = islnm ? strlen(trndev) - 1 : 0;
6521 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
6522 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
6523 /* If the first element of the path is a logical name, determine
6524 * whether it has to be translated so we can add more directories. */
6525 if (!islnm || rooted) {
6528 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
6532 if (cp2 != dirend) {
6533 strcpy(rslt,trndev);
6534 cp1 = rslt + trnend;
6541 if (decc_disable_posix_root) {
6547 PerlMem_free(trndev);
6552 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
6553 cp2 += 2; /* skip over "./" - it's redundant */
6554 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
6556 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6557 *(cp1++) = '-'; /* "../" --> "-" */
6560 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
6561 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
6562 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6563 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
6566 else if ((cp2 != lastdot) || (lastdot < dirend)) {
6567 /* Escape the extra dots in EFS file specifications */
6570 if (cp2 > dirend) cp2 = dirend;
6572 else *(cp1++) = '.';
6574 for (; cp2 < dirend; cp2++) {
6576 if (*(cp2-1) == '/') continue;
6577 if (*(cp1-1) != '.') *(cp1++) = '.';
6580 else if (!infront && *cp2 == '.') {
6581 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
6582 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
6583 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
6584 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
6585 else if (*(cp1-2) == '[') *(cp1-1) = '-';
6586 else { /* back up over previous directory name */
6588 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
6589 if (*(cp1-1) == '[') {
6590 memcpy(cp1,"000000.",7);
6595 if (cp2 == dirend) break;
6597 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
6598 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
6599 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
6600 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
6602 *(cp1++) = '.'; /* Simulate trailing '/' */
6603 cp2 += 2; /* for loop will incr this to == dirend */
6605 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
6608 if (decc_efs_charset == 0)
6609 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
6611 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
6617 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
6619 if (decc_efs_charset == 0)
6626 else *(cp1++) = *cp2;
6630 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
6631 if (hasdir) *(cp1++) = ']';
6632 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
6633 /* fixme for ODS5 */
6648 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
6649 decc_readdir_dropdotnotype) {
6654 /* trailing dot ==> '^..' on VMS */
6661 *(cp1++) = *(cp2++);
6689 *(cp1++) = *(cp2++);
6692 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
6693 * which is wrong. UNIX notation should be ".dir." unless
6694 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
6695 * changing this behavior could break more things at this time.
6696 * efs character set effectively does not allow "." to be a version
6697 * delimiter as a further complication about changing this.
6699 if (decc_filename_unix_report != 0) {
6702 *(cp1++) = *(cp2++);
6705 *(cp1++) = *(cp2++);
6708 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
6712 /* Fix me for "^]", but that requires making sure that you do
6713 * not back up past the start of the filename
6715 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
6722 } /* end of do_tovmsspec() */
6724 /* External entry points */
6725 char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); }
6726 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); }
6728 /*{{{ char *tovmspath[_ts](char *path, char *buf)*/
6729 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) {
6730 static char __tovmspath_retbuf[VMS_MAXRSS];
6732 char *pathified, *vmsified, *cp;
6734 if (path == NULL) return NULL;
6735 pathified = PerlMem_malloc(VMS_MAXRSS);
6736 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6737 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6738 PerlMem_free(pathified);
6744 Newx(vmsified, VMS_MAXRSS, char);
6745 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) {
6746 PerlMem_free(pathified);
6747 if (vmsified) Safefree(vmsified);
6750 PerlMem_free(pathified);
6755 vmslen = strlen(vmsified);
6756 Newx(cp,vmslen+1,char);
6757 memcpy(cp,vmsified,vmslen);
6763 strcpy(__tovmspath_retbuf,vmsified);
6765 return __tovmspath_retbuf;
6768 } /* end of do_tovmspath() */
6770 /* External entry points */
6771 char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); }
6772 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); }
6775 /*{{{ char *tounixpath[_ts](char *path, char *buf)*/
6776 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) {
6777 static char __tounixpath_retbuf[VMS_MAXRSS];
6779 char *pathified, *unixified, *cp;
6781 if (path == NULL) return NULL;
6782 pathified = PerlMem_malloc(VMS_MAXRSS);
6783 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
6784 if (do_pathify_dirspec(path,pathified,0) == NULL) {
6785 PerlMem_free(pathified);
6791 Newx(unixified, VMS_MAXRSS, char);
6793 if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) {
6794 PerlMem_free(pathified);
6795 if (unixified) Safefree(unixified);
6798 PerlMem_free(pathified);
6803 unixlen = strlen(unixified);
6804 Newx(cp,unixlen+1,char);
6805 memcpy(cp,unixified,unixlen);
6807 Safefree(unixified);
6811 strcpy(__tounixpath_retbuf,unixified);
6812 Safefree(unixified);
6813 return __tounixpath_retbuf;
6816 } /* end of do_tounixpath() */
6818 /* External entry points */
6819 char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); }
6820 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); }
6823 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
6825 *****************************************************************************
6827 * Copyright (C) 1989-1994 by *
6828 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
6830 * Permission is hereby granted for the reproduction of this software, *
6831 * on condition that this copyright notice is included in the reproduction, *
6832 * and that such reproduction is not for purposes of profit or material *
6835 * 27-Aug-1994 Modified for inclusion in perl5 *
6836 * by Charles Bailey bailey@newman.upenn.edu *
6837 *****************************************************************************
6841 * getredirection() is intended to aid in porting C programs
6842 * to VMS (Vax-11 C). The native VMS environment does not support
6843 * '>' and '<' I/O redirection, or command line wild card expansion,
6844 * or a command line pipe mechanism using the '|' AND background
6845 * command execution '&'. All of these capabilities are provided to any
6846 * C program which calls this procedure as the first thing in the
6848 * The piping mechanism will probably work with almost any 'filter' type
6849 * of program. With suitable modification, it may useful for other
6850 * portability problems as well.
6852 * Author: Mark Pizzolato mark@infocomm.com
6856 struct list_item *next;
6860 static void add_item(struct list_item **head,
6861 struct list_item **tail,
6865 static void mp_expand_wild_cards(pTHX_ char *item,
6866 struct list_item **head,
6867 struct list_item **tail,
6870 static int background_process(pTHX_ int argc, char **argv);
6872 static void pipe_and_fork(pTHX_ char **cmargv);
6874 /*{{{ void getredirection(int *ac, char ***av)*/
6876 mp_getredirection(pTHX_ int *ac, char ***av)
6878 * Process vms redirection arg's. Exit if any error is seen.
6879 * If getredirection() processes an argument, it is erased
6880 * from the vector. getredirection() returns a new argc and argv value.
6881 * In the event that a background command is requested (by a trailing "&"),
6882 * this routine creates a background subprocess, and simply exits the program.
6884 * Warning: do not try to simplify the code for vms. The code
6885 * presupposes that getredirection() is called before any data is
6886 * read from stdin or written to stdout.
6888 * Normal usage is as follows:
6894 * getredirection(&argc, &argv);
6898 int argc = *ac; /* Argument Count */
6899 char **argv = *av; /* Argument Vector */
6900 char *ap; /* Argument pointer */
6901 int j; /* argv[] index */
6902 int item_count = 0; /* Count of Items in List */
6903 struct list_item *list_head = 0; /* First Item in List */
6904 struct list_item *list_tail; /* Last Item in List */
6905 char *in = NULL; /* Input File Name */
6906 char *out = NULL; /* Output File Name */
6907 char *outmode = "w"; /* Mode to Open Output File */
6908 char *err = NULL; /* Error File Name */
6909 char *errmode = "w"; /* Mode to Open Error File */
6910 int cmargc = 0; /* Piped Command Arg Count */
6911 char **cmargv = NULL;/* Piped Command Arg Vector */
6914 * First handle the case where the last thing on the line ends with
6915 * a '&'. This indicates the desire for the command to be run in a
6916 * subprocess, so we satisfy that desire.
6919 if (0 == strcmp("&", ap))
6920 exit(background_process(aTHX_ --argc, argv));
6921 if (*ap && '&' == ap[strlen(ap)-1])
6923 ap[strlen(ap)-1] = '\0';
6924 exit(background_process(aTHX_ argc, argv));
6927 * Now we handle the general redirection cases that involve '>', '>>',
6928 * '<', and pipes '|'.
6930 for (j = 0; j < argc; ++j)
6932 if (0 == strcmp("<", argv[j]))
6936 fprintf(stderr,"No input file after < on command line");
6937 exit(LIB$_WRONUMARG);
6942 if ('<' == *(ap = argv[j]))
6947 if (0 == strcmp(">", ap))
6951 fprintf(stderr,"No output file after > on command line");
6952 exit(LIB$_WRONUMARG);
6971 fprintf(stderr,"No output file after > or >> on command line");
6972 exit(LIB$_WRONUMARG);
6976 if (('2' == *ap) && ('>' == ap[1]))
6993 fprintf(stderr,"No output file after 2> or 2>> on command line");
6994 exit(LIB$_WRONUMARG);
6998 if (0 == strcmp("|", argv[j]))
7002 fprintf(stderr,"No command into which to pipe on command line");
7003 exit(LIB$_WRONUMARG);
7005 cmargc = argc-(j+1);
7006 cmargv = &argv[j+1];
7010 if ('|' == *(ap = argv[j]))
7018 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7021 * Allocate and fill in the new argument vector, Some Unix's terminate
7022 * the list with an extra null pointer.
7024 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7025 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7027 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7028 argv[j] = list_head->value;
7034 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7035 exit(LIB$_INVARGORD);
7037 pipe_and_fork(aTHX_ cmargv);
7040 /* Check for input from a pipe (mailbox) */
7042 if (in == NULL && 1 == isapipe(0))
7044 char mbxname[L_tmpnam];
7046 long int dvi_item = DVI$_DEVBUFSIZ;
7047 $DESCRIPTOR(mbxnam, "");
7048 $DESCRIPTOR(mbxdevnam, "");
7050 /* Input from a pipe, reopen it in binary mode to disable */
7051 /* carriage control processing. */
7053 fgetname(stdin, mbxname);
7054 mbxnam.dsc$a_pointer = mbxname;
7055 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7056 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7057 mbxdevnam.dsc$a_pointer = mbxname;
7058 mbxdevnam.dsc$w_length = sizeof(mbxname);
7059 dvi_item = DVI$_DEVNAM;
7060 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7061 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7064 freopen(mbxname, "rb", stdin);
7067 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7071 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7073 fprintf(stderr,"Can't open input file %s as stdin",in);
7076 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7078 fprintf(stderr,"Can't open output file %s as stdout",out);
7081 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7084 if (strcmp(err,"&1") == 0) {
7085 dup2(fileno(stdout), fileno(stderr));
7086 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7089 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7091 fprintf(stderr,"Can't open error file %s as stderr",err);
7095 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7099 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7102 #ifdef ARGPROC_DEBUG
7103 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7104 for (j = 0; j < *ac; ++j)
7105 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7107 /* Clear errors we may have hit expanding wildcards, so they don't
7108 show up in Perl's $! later */
7109 set_errno(0); set_vaxc_errno(1);
7110 } /* end of getredirection() */
7113 static void add_item(struct list_item **head,
7114 struct list_item **tail,
7120 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7121 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7125 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7126 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7127 *tail = (*tail)->next;
7129 (*tail)->value = value;
7133 static void mp_expand_wild_cards(pTHX_ char *item,
7134 struct list_item **head,
7135 struct list_item **tail,
7139 unsigned long int context = 0;
7147 $DESCRIPTOR(filespec, "");
7148 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7149 $DESCRIPTOR(resultspec, "");
7150 unsigned long int lff_flags = 0;
7154 #ifdef VMS_LONGNAME_SUPPORT
7155 lff_flags = LIB$M_FIL_LONG_NAMES;
7158 for (cp = item; *cp; cp++) {
7159 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7160 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7162 if (!*cp || isspace(*cp))
7164 add_item(head, tail, item, count);
7169 /* "double quoted" wild card expressions pass as is */
7170 /* From DCL that means using e.g.: */
7171 /* perl program """perl.*""" */
7172 item_len = strlen(item);
7173 if ( '"' == *item && '"' == item[item_len-1] )
7176 item[item_len-2] = '\0';
7177 add_item(head, tail, item, count);
7181 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7182 resultspec.dsc$b_class = DSC$K_CLASS_D;
7183 resultspec.dsc$a_pointer = NULL;
7184 vmsspec = PerlMem_malloc(VMS_MAXRSS);
7185 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7186 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7187 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0);
7188 if (!isunix || !filespec.dsc$a_pointer)
7189 filespec.dsc$a_pointer = item;
7190 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7192 * Only return version specs, if the caller specified a version
7194 had_version = strchr(item, ';');
7196 * Only return device and directory specs, if the caller specifed either.
7198 had_device = strchr(item, ':');
7199 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7201 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7202 (&filespec, &resultspec, &context,
7203 &defaultspec, 0, &rms_sts, &lff_flags)))
7208 string = PerlMem_malloc(resultspec.dsc$w_length+1);
7209 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7210 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7211 string[resultspec.dsc$w_length] = '\0';
7212 if (NULL == had_version)
7213 *(strrchr(string, ';')) = '\0';
7214 if ((!had_directory) && (had_device == NULL))
7216 if (NULL == (devdir = strrchr(string, ']')))
7217 devdir = strrchr(string, '>');
7218 strcpy(string, devdir + 1);
7221 * Be consistent with what the C RTL has already done to the rest of
7222 * the argv items and lowercase all of these names.
7224 if (!decc_efs_case_preserve) {
7225 for (c = string; *c; ++c)
7229 if (isunix) trim_unixpath(string,item,1);
7230 add_item(head, tail, string, count);
7233 PerlMem_free(vmsspec);
7234 if (sts != RMS$_NMF)
7236 set_vaxc_errno(sts);
7239 case RMS$_FNF: case RMS$_DNF:
7240 set_errno(ENOENT); break;
7242 set_errno(ENOTDIR); break;
7244 set_errno(ENODEV); break;
7245 case RMS$_FNM: case RMS$_SYN:
7246 set_errno(EINVAL); break;
7248 set_errno(EACCES); break;
7250 _ckvmssts_noperl(sts);
7254 add_item(head, tail, item, count);
7255 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7256 _ckvmssts_noperl(lib$find_file_end(&context));
7259 static int child_st[2];/* Event Flag set when child process completes */
7261 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
7263 static unsigned long int exit_handler(int *status)
7267 if (0 == child_st[0])
7269 #ifdef ARGPROC_DEBUG
7270 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7272 fflush(stdout); /* Have to flush pipe for binary data to */
7273 /* terminate properly -- <tp@mccall.com> */
7274 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7275 sys$dassgn(child_chan);
7277 sys$synch(0, child_st);
7282 static void sig_child(int chan)
7284 #ifdef ARGPROC_DEBUG
7285 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7287 if (child_st[0] == 0)
7291 static struct exit_control_block exit_block =
7296 &exit_block.exit_status,
7301 pipe_and_fork(pTHX_ char **cmargv)
7304 struct dsc$descriptor_s *vmscmd;
7305 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7306 int sts, j, l, ismcr, quote, tquote = 0;
7308 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
7309 vms_execfree(vmscmd);
7314 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7315 && toupper(*(q+2)) == 'R' && !*(q+3);
7317 while (q && l < MAX_DCL_LINE_LENGTH) {
7319 if (j > 0 && quote) {
7325 if (ismcr && j > 1) quote = 1;
7326 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7329 if (quote || tquote) {
7335 if ((quote||tquote) && *q == '"') {
7345 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7347 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7351 static int background_process(pTHX_ int argc, char **argv)
7353 char command[MAX_DCL_SYMBOL + 1] = "$";
7354 $DESCRIPTOR(value, "");
7355 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7356 static $DESCRIPTOR(null, "NLA0:");
7357 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7359 $DESCRIPTOR(pidstr, "");
7361 unsigned long int flags = 17, one = 1, retsts;
7364 strcat(command, argv[0]);
7365 len = strlen(command);
7366 while (--argc && (len < MAX_DCL_SYMBOL))
7368 strcat(command, " \"");
7369 strcat(command, *(++argv));
7370 strcat(command, "\"");
7371 len = strlen(command);
7373 value.dsc$a_pointer = command;
7374 value.dsc$w_length = strlen(value.dsc$a_pointer);
7375 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7376 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7377 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7378 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
7381 _ckvmssts_noperl(retsts);
7383 #ifdef ARGPROC_DEBUG
7384 PerlIO_printf(Perl_debug_log, "%s\n", command);
7386 sprintf(pidstring, "%08X", pid);
7387 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
7388 pidstr.dsc$a_pointer = pidstring;
7389 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
7390 lib$set_symbol(&pidsymbol, &pidstr);
7394 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
7397 /* OS-specific initialization at image activation (not thread startup) */
7398 /* Older VAXC header files lack these constants */
7399 #ifndef JPI$_RIGHTS_SIZE
7400 # define JPI$_RIGHTS_SIZE 817
7402 #ifndef KGB$M_SUBSYSTEM
7403 # define KGB$M_SUBSYSTEM 0x8
7406 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
7408 /*{{{void vms_image_init(int *, char ***)*/
7410 vms_image_init(int *argcp, char ***argvp)
7412 char eqv[LNM$C_NAMLENGTH+1] = "";
7413 unsigned int len, tabct = 8, tabidx = 0;
7414 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
7415 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
7416 unsigned short int dummy, rlen;
7417 struct dsc$descriptor_s **tabvec;
7418 #if defined(PERL_IMPLICIT_CONTEXT)
7421 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
7422 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
7423 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
7426 #ifdef KILL_BY_SIGPRC
7427 Perl_csighandler_init();
7430 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
7431 _ckvmssts_noperl(iosb[0]);
7432 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
7433 if (iprv[i]) { /* Running image installed with privs? */
7434 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
7439 /* Rights identifiers might trigger tainting as well. */
7440 if (!will_taint && (rlen || rsz)) {
7441 while (rlen < rsz) {
7442 /* We didn't get all the identifiers on the first pass. Allocate a
7443 * buffer much larger than $GETJPI wants (rsz is size in bytes that
7444 * were needed to hold all identifiers at time of last call; we'll
7445 * allocate that many unsigned long ints), and go back and get 'em.
7446 * If it gave us less than it wanted to despite ample buffer space,
7447 * something's broken. Is your system missing a system identifier?
7449 if (rsz <= jpilist[1].buflen) {
7450 /* Perl_croak accvios when used this early in startup. */
7451 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
7452 rsz, (unsigned long) jpilist[1].buflen,
7453 "Check your rights database for corruption.\n");
7456 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
7457 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
7458 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7459 jpilist[1].buflen = rsz * sizeof(unsigned long int);
7460 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
7461 _ckvmssts_noperl(iosb[0]);
7463 mask = jpilist[1].bufadr;
7464 /* Check attribute flags for each identifier (2nd longword); protected
7465 * subsystem identifiers trigger tainting.
7467 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
7468 if (mask[i] & KGB$M_SUBSYSTEM) {
7473 if (mask != rlst) PerlMem_free(mask);
7476 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
7477 * logical, some versions of the CRTL will add a phanthom /000000/
7478 * directory. This needs to be removed.
7480 if (decc_filename_unix_report) {
7483 ulen = strlen(argvp[0][0]);
7485 zeros = strstr(argvp[0][0], "/000000/");
7486 if (zeros != NULL) {
7488 mlen = ulen - (zeros - argvp[0][0]) - 7;
7489 memmove(zeros, &zeros[7], mlen);
7491 argvp[0][0][ulen] = '\0';
7494 /* It also may have a trailing dot that needs to be removed otherwise
7495 * it will be converted to VMS mode incorrectly.
7498 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
7499 argvp[0][0][ulen] = '\0';
7502 /* We need to use this hack to tell Perl it should run with tainting,
7503 * since its tainting flag may be part of the PL_curinterp struct, which
7504 * hasn't been allocated when vms_image_init() is called.
7507 char **newargv, **oldargv;
7509 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
7510 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7511 newargv[0] = oldargv[0];
7512 newargv[1] = PerlMem_malloc(3 * sizeof(char));
7513 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7514 strcpy(newargv[1], "-T");
7515 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
7517 newargv[*argcp] = NULL;
7518 /* We orphan the old argv, since we don't know where it's come from,
7519 * so we don't know how to free it.
7523 else { /* Did user explicitly request tainting? */
7525 char *cp, **av = *argvp;
7526 for (i = 1; i < *argcp; i++) {
7527 if (*av[i] != '-') break;
7528 for (cp = av[i]+1; *cp; cp++) {
7529 if (*cp == 'T') { will_taint = 1; break; }
7530 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
7531 strchr("DFIiMmx",*cp)) break;
7533 if (will_taint) break;
7538 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
7541 tabvec = (struct dsc$descriptor_s **)
7542 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
7543 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7545 else if (tabidx >= tabct) {
7547 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
7548 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7550 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
7551 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7552 tabvec[tabidx]->dsc$w_length = 0;
7553 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
7554 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
7555 tabvec[tabidx]->dsc$a_pointer = NULL;
7556 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
7558 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
7560 getredirection(argcp,argvp);
7561 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
7563 # include <reentrancy.h>
7564 decc$set_reentrancy(C$C_MULTITHREAD);
7573 * Trim Unix-style prefix off filespec, so it looks like what a shell
7574 * glob expansion would return (i.e. from specified prefix on, not
7575 * full path). Note that returned filespec is Unix-style, regardless
7576 * of whether input filespec was VMS-style or Unix-style.
7578 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
7579 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
7580 * vector of options; at present, only bit 0 is used, and if set tells
7581 * trim unixpath to try the current default directory as a prefix when
7582 * presented with a possibly ambiguous ... wildcard.
7584 * Returns !=0 on success, with trimmed filespec replacing contents of
7585 * fspec, and 0 on failure, with contents of fpsec unchanged.
7587 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
7589 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
7591 char *unixified, *unixwild,
7592 *template, *base, *end, *cp1, *cp2;
7593 register int tmplen, reslen = 0, dirs = 0;
7595 unixwild = PerlMem_malloc(VMS_MAXRSS);
7596 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
7597 if (!wildspec || !fspec) return 0;
7598 template = unixwild;
7599 if (strpbrk(wildspec,"]>:") != NULL) {
7600 if (do_tounixspec(wildspec,unixwild,0) == NULL) {
7601 PerlMem_free(unixwild);
7606 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
7607 unixwild[VMS_MAXRSS-1] = 0;
7609 unixified = PerlMem_malloc(VMS_MAXRSS);
7610 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
7611 if (strpbrk(fspec,"]>:") != NULL) {
7612 if (do_tounixspec(fspec,unixified,0) == NULL) {
7613 PerlMem_free(unixwild);
7614 PerlMem_free(unixified);
7617 else base = unixified;
7618 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
7619 * check to see that final result fits into (isn't longer than) fspec */
7620 reslen = strlen(fspec);
7624 /* No prefix or absolute path on wildcard, so nothing to remove */
7625 if (!*template || *template == '/') {
7626 PerlMem_free(unixwild);
7627 if (base == fspec) {
7628 PerlMem_free(unixified);
7631 tmplen = strlen(unixified);
7632 if (tmplen > reslen) {
7633 PerlMem_free(unixified);
7634 return 0; /* not enough space */
7636 /* Copy unixified resultant, including trailing NUL */
7637 memmove(fspec,unixified,tmplen+1);
7638 PerlMem_free(unixified);
7642 for (end = base; *end; end++) ; /* Find end of resultant filespec */
7643 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
7644 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
7645 for (cp1 = end ;cp1 >= base; cp1--)
7646 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
7648 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
7649 PerlMem_free(unixified);
7650 PerlMem_free(unixwild);
7655 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
7656 int ells = 1, totells, segdirs, match;
7657 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
7658 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7660 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
7662 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
7663 tpl = PerlMem_malloc(VMS_MAXRSS);
7664 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
7665 if (ellipsis == template && opts & 1) {
7666 /* Template begins with an ellipsis. Since we can't tell how many
7667 * directory names at the front of the resultant to keep for an
7668 * arbitrary starting point, we arbitrarily choose the current
7669 * default directory as a starting point. If it's there as a prefix,
7670 * clip it off. If not, fall through and act as if the leading
7671 * ellipsis weren't there (i.e. return shortest possible path that
7672 * could match template).
7674 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
7676 PerlMem_free(unixified);
7677 PerlMem_free(unixwild);
7680 if (!decc_efs_case_preserve) {
7681 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7682 if (_tolower(*cp1) != _tolower(*cp2)) break;
7684 segdirs = dirs - totells; /* Min # of dirs we must have left */
7685 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
7686 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
7687 memmove(fspec,cp2+1,end - cp2);
7689 PerlMem_free(unixified);
7690 PerlMem_free(unixwild);
7694 /* First off, back up over constant elements at end of path */
7696 for (front = end ; front >= base; front--)
7697 if (*front == '/' && !dirs--) { front++; break; }
7699 lcres = PerlMem_malloc(VMS_MAXRSS);
7700 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
7701 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
7703 if (!decc_efs_case_preserve) {
7704 *cp2 = _tolower(*cp1); /* Make lc copy for match */
7712 PerlMem_free(unixified);
7713 PerlMem_free(unixwild);
7714 PerlMem_free(lcres);
7715 return 0; /* Path too long. */
7718 *cp2 = '\0'; /* Pick up with memcpy later */
7719 lcfront = lcres + (front - base);
7720 /* Now skip over each ellipsis and try to match the path in front of it. */
7722 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
7723 if (*(cp1) == '.' && *(cp1+1) == '.' &&
7724 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
7725 if (cp1 < template) break; /* template started with an ellipsis */
7726 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
7727 ellipsis = cp1; continue;
7729 wilddsc.dsc$a_pointer = tpl;
7730 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
7732 for (segdirs = 0, cp2 = tpl;
7733 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
7735 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
7737 if (!decc_efs_case_preserve) {
7738 *cp2 = _tolower(*cp1); /* else lowercase for match */
7741 *cp2 = *cp1; /* else preserve case for match */
7744 if (*cp2 == '/') segdirs++;
7746 if (cp1 != ellipsis - 1) {
7748 PerlMem_free(unixified);
7749 PerlMem_free(unixwild);
7750 PerlMem_free(lcres);
7751 return 0; /* Path too long */
7753 /* Back up at least as many dirs as in template before matching */
7754 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
7755 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
7756 for (match = 0; cp1 > lcres;) {
7757 resdsc.dsc$a_pointer = cp1;
7758 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
7760 if (match == 1) lcfront = cp1;
7762 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
7766 PerlMem_free(unixified);
7767 PerlMem_free(unixwild);
7768 PerlMem_free(lcres);
7769 return 0; /* Can't find prefix ??? */
7771 if (match > 1 && opts & 1) {
7772 /* This ... wildcard could cover more than one set of dirs (i.e.
7773 * a set of similar dir names is repeated). If the template
7774 * contains more than 1 ..., upstream elements could resolve the
7775 * ambiguity, but it's not worth a full backtracking setup here.
7776 * As a quick heuristic, clip off the current default directory
7777 * if it's present to find the trimmed spec, else use the
7778 * shortest string that this ... could cover.
7780 char def[NAM$C_MAXRSS+1], *st;
7782 if (getcwd(def, sizeof def,0) == NULL) {
7783 Safefree(unixified);
7789 if (!decc_efs_case_preserve) {
7790 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
7791 if (_tolower(*cp1) != _tolower(*cp2)) break;
7793 segdirs = dirs - totells; /* Min # of dirs we must have left */
7794 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
7795 if (*cp1 == '\0' && *cp2 == '/') {
7796 memmove(fspec,cp2+1,end - cp2);
7798 PerlMem_free(unixified);
7799 PerlMem_free(unixwild);
7800 PerlMem_free(lcres);
7803 /* Nope -- stick with lcfront from above and keep going. */
7806 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
7808 PerlMem_free(unixified);
7809 PerlMem_free(unixwild);
7810 PerlMem_free(lcres);
7815 } /* end of trim_unixpath() */
7820 * VMS readdir() routines.
7821 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
7823 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
7824 * Minor modifications to original routines.
7827 /* readdir may have been redefined by reentr.h, so make sure we get
7828 * the local version for what we do here.
7833 #if !defined(PERL_IMPLICIT_CONTEXT)
7834 # define readdir Perl_readdir
7836 # define readdir(a) Perl_readdir(aTHX_ a)
7839 /* Number of elements in vms_versions array */
7840 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
7843 * Open a directory, return a handle for later use.
7845 /*{{{ DIR *opendir(char*name) */
7847 Perl_opendir(pTHX_ const char *name)
7855 if (decc_efs_charset) {
7856 unix_flag = is_unix_filespec(name);
7859 Newx(dir, VMS_MAXRSS, char);
7860 if (do_tovmspath(name,dir,0) == NULL) {
7864 /* Check access before stat; otherwise stat does not
7865 * accurately report whether it's a directory.
7867 if (!cando_by_name(S_IRUSR,0,dir)) {
7868 /* cando_by_name has already set errno */
7872 if (flex_stat(dir,&sb) == -1) return NULL;
7873 if (!S_ISDIR(sb.st_mode)) {
7875 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
7878 /* Get memory for the handle, and the pattern. */
7880 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
7882 /* Fill in the fields; mainly playing with the descriptor. */
7883 sprintf(dd->pattern, "%s*.*",dir);
7889 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
7890 dd->pat.dsc$a_pointer = dd->pattern;
7891 dd->pat.dsc$w_length = strlen(dd->pattern);
7892 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
7893 dd->pat.dsc$b_class = DSC$K_CLASS_S;
7894 #if defined(USE_ITHREADS)
7895 Newx(dd->mutex,1,perl_mutex);
7896 MUTEX_INIT( (perl_mutex *) dd->mutex );
7902 } /* end of opendir() */
7906 * Set the flag to indicate we want versions or not.
7908 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
7910 vmsreaddirversions(DIR *dd, int flag)
7913 dd->flags |= PERL_VMSDIR_M_VERSIONS;
7915 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
7920 * Free up an opened directory.
7922 /*{{{ void closedir(DIR *dd)*/
7924 Perl_closedir(DIR *dd)
7928 sts = lib$find_file_end(&dd->context);
7929 Safefree(dd->pattern);
7930 #if defined(USE_ITHREADS)
7931 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
7932 Safefree(dd->mutex);
7939 * Collect all the version numbers for the current file.
7942 collectversions(pTHX_ DIR *dd)
7944 struct dsc$descriptor_s pat;
7945 struct dsc$descriptor_s res;
7947 char *p, *text, *buff;
7949 unsigned long context, tmpsts;
7951 /* Convenient shorthand. */
7954 /* Add the version wildcard, ignoring the "*.*" put on before */
7955 i = strlen(dd->pattern);
7956 Newx(text,i + e->d_namlen + 3,char);
7957 strcpy(text, dd->pattern);
7958 sprintf(&text[i - 3], "%s;*", e->d_name);
7960 /* Set up the pattern descriptor. */
7961 pat.dsc$a_pointer = text;
7962 pat.dsc$w_length = i + e->d_namlen - 1;
7963 pat.dsc$b_dtype = DSC$K_DTYPE_T;
7964 pat.dsc$b_class = DSC$K_CLASS_S;
7966 /* Set up result descriptor. */
7967 Newx(buff, VMS_MAXRSS, char);
7968 res.dsc$a_pointer = buff;
7969 res.dsc$w_length = VMS_MAXRSS - 1;
7970 res.dsc$b_dtype = DSC$K_DTYPE_T;
7971 res.dsc$b_class = DSC$K_CLASS_S;
7973 /* Read files, collecting versions. */
7974 for (context = 0, e->vms_verscount = 0;
7975 e->vms_verscount < VERSIZE(e);
7976 e->vms_verscount++) {
7978 unsigned long flags = 0;
7980 #ifdef VMS_LONGNAME_SUPPORT
7981 flags = LIB$M_FIL_LONG_NAMES
7983 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
7984 if (tmpsts == RMS$_NMF || context == 0) break;
7986 buff[VMS_MAXRSS - 1] = '\0';
7987 if ((p = strchr(buff, ';')))
7988 e->vms_versions[e->vms_verscount] = atoi(p + 1);
7990 e->vms_versions[e->vms_verscount] = -1;
7993 _ckvmssts(lib$find_file_end(&context));
7997 } /* end of collectversions() */
8000 * Read the next entry from the directory.
8002 /*{{{ struct dirent *readdir(DIR *dd)*/
8004 Perl_readdir(pTHX_ DIR *dd)
8006 struct dsc$descriptor_s res;
8008 unsigned long int tmpsts;
8010 unsigned long flags = 0;
8011 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8012 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8014 /* Set up result descriptor, and get next file. */
8015 Newx(buff, VMS_MAXRSS, char);
8016 res.dsc$a_pointer = buff;
8017 res.dsc$w_length = VMS_MAXRSS - 1;
8018 res.dsc$b_dtype = DSC$K_DTYPE_T;
8019 res.dsc$b_class = DSC$K_CLASS_S;
8021 #ifdef VMS_LONGNAME_SUPPORT
8022 flags = LIB$M_FIL_LONG_NAMES
8025 tmpsts = lib$find_file
8026 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8027 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8028 if (!(tmpsts & 1)) {
8029 set_vaxc_errno(tmpsts);
8032 set_errno(EACCES); break;
8034 set_errno(ENODEV); break;
8036 set_errno(ENOTDIR); break;
8037 case RMS$_FNF: case RMS$_DNF:
8038 set_errno(ENOENT); break;
8046 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8047 if (!decc_efs_case_preserve) {
8048 buff[VMS_MAXRSS - 1] = '\0';
8049 for (p = buff; *p; p++) *p = _tolower(*p);
8052 /* we don't want to force to lowercase, just null terminate */
8053 buff[res.dsc$w_length] = '\0';
8055 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8058 /* Skip any directory component and just copy the name. */
8059 sts = vms_split_path
8074 /* Drop NULL extensions on UNIX file specification */
8075 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8076 (e_len == 1) && decc_readdir_dropdotnotype)) {
8081 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8082 dd->entry.d_name[n_len + e_len] = '\0';
8083 dd->entry.d_namlen = strlen(dd->entry.d_name);
8085 /* Convert the filename to UNIX format if needed */
8086 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8088 /* Translate the encoded characters. */
8089 /* Fixme: unicode handling could result in embedded 0 characters */
8090 if (strchr(dd->entry.d_name, '^') != NULL) {
8094 p = dd->entry.d_name;
8098 x = copy_expand_vms_filename_escape(q, p, &y);
8102 /* if y > 1, then this is a wide file specification */
8103 /* Wide file specifications need to be passed in Perl */
8104 /* counted strings apparently with a unicode flag */
8107 strcpy(dd->entry.d_name, new_name);
8111 dd->entry.vms_verscount = 0;
8112 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8116 } /* end of readdir() */
8120 * Read the next entry from the directory -- thread-safe version.
8122 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8124 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8128 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8130 entry = readdir(dd);
8132 retval = ( *result == NULL ? errno : 0 );
8134 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8138 } /* end of readdir_r() */
8142 * Return something that can be used in a seekdir later.
8144 /*{{{ long telldir(DIR *dd)*/
8146 Perl_telldir(DIR *dd)
8153 * Return to a spot where we used to be. Brute force.
8155 /*{{{ void seekdir(DIR *dd,long count)*/
8157 Perl_seekdir(pTHX_ DIR *dd, long count)
8161 /* If we haven't done anything yet... */
8165 /* Remember some state, and clear it. */
8166 old_flags = dd->flags;
8167 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8168 _ckvmssts(lib$find_file_end(&dd->context));
8171 /* The increment is in readdir(). */
8172 for (dd->count = 0; dd->count < count; )
8175 dd->flags = old_flags;
8177 } /* end of seekdir() */
8180 /* VMS subprocess management
8182 * my_vfork() - just a vfork(), after setting a flag to record that
8183 * the current script is trying a Unix-style fork/exec.
8185 * vms_do_aexec() and vms_do_exec() are called in response to the
8186 * perl 'exec' function. If this follows a vfork call, then they
8187 * call out the regular perl routines in doio.c which do an
8188 * execvp (for those who really want to try this under VMS).
8189 * Otherwise, they do exactly what the perl docs say exec should
8190 * do - terminate the current script and invoke a new command
8191 * (See below for notes on command syntax.)
8193 * do_aspawn() and do_spawn() implement the VMS side of the perl
8194 * 'system' function.
8196 * Note on command arguments to perl 'exec' and 'system': When handled
8197 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8198 * are concatenated to form a DCL command string. If the first arg
8199 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8200 * the command string is handed off to DCL directly. Otherwise,
8201 * the first token of the command is taken as the filespec of an image
8202 * to run. The filespec is expanded using a default type of '.EXE' and
8203 * the process defaults for device, directory, etc., and if found, the resultant
8204 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8205 * the command string as parameters. This is perhaps a bit complicated,
8206 * but I hope it will form a happy medium between what VMS folks expect
8207 * from lib$spawn and what Unix folks expect from exec.
8210 static int vfork_called;
8212 /*{{{int my_vfork()*/
8223 vms_execfree(struct dsc$descriptor_s *vmscmd)
8226 if (vmscmd->dsc$a_pointer) {
8227 PerlMem_free(vmscmd->dsc$a_pointer);
8229 PerlMem_free(vmscmd);
8234 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8236 char *junk, *tmps = Nullch;
8237 register size_t cmdlen = 0;
8244 tmps = SvPV(really,rlen);
8251 for (idx++; idx <= sp; idx++) {
8253 junk = SvPVx(*idx,rlen);
8254 cmdlen += rlen ? rlen + 1 : 0;
8257 Newx(PL_Cmd, cmdlen+1, char);
8259 if (tmps && *tmps) {
8260 strcpy(PL_Cmd,tmps);
8263 else *PL_Cmd = '\0';
8264 while (++mark <= sp) {
8266 char *s = SvPVx(*mark,n_a);
8268 if (*PL_Cmd) strcat(PL_Cmd," ");
8274 } /* end of setup_argstr() */
8277 static unsigned long int
8278 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8279 struct dsc$descriptor_s **pvmscmd)
8281 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8282 char image_name[NAM$C_MAXRSS+1];
8283 char image_argv[NAM$C_MAXRSS+1];
8284 $DESCRIPTOR(defdsc,".EXE");
8285 $DESCRIPTOR(defdsc2,".");
8286 $DESCRIPTOR(resdsc,resspec);
8287 struct dsc$descriptor_s *vmscmd;
8288 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8289 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8290 register char *s, *rest, *cp, *wordbreak;
8295 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8296 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8298 /* Make a copy for modification */
8299 cmdlen = strlen(incmd);
8300 cmd = PerlMem_malloc(cmdlen+1);
8301 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8302 strncpy(cmd, incmd, cmdlen);
8307 vmscmd->dsc$a_pointer = NULL;
8308 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8309 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8310 vmscmd->dsc$w_length = 0;
8311 if (pvmscmd) *pvmscmd = vmscmd;
8313 if (suggest_quote) *suggest_quote = 0;
8315 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8317 return CLI$_BUFOVF; /* continuation lines currently unsupported */
8322 while (*s && isspace(*s)) s++;
8324 if (*s == '@' || *s == '$') {
8325 vmsspec[0] = *s; rest = s + 1;
8326 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8328 else { cp = vmsspec; rest = s; }
8329 if (*rest == '.' || *rest == '/') {
8332 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8333 rest++, cp2++) *cp2 = *rest;
8335 if (do_tovmsspec(resspec,cp,0)) {
8338 for (cp2 = vmsspec + strlen(vmsspec);
8339 *rest && cp2 - vmsspec < sizeof vmsspec;
8340 rest++, cp2++) *cp2 = *rest;
8345 /* Intuit whether verb (first word of cmd) is a DCL command:
8346 * - if first nonspace char is '@', it's a DCL indirection
8348 * - if verb contains a filespec separator, it's not a DCL command
8349 * - if it doesn't, caller tells us whether to default to a DCL
8350 * command, or to a local image unless told it's DCL (by leading '$')
8354 if (suggest_quote) *suggest_quote = 1;
8356 register char *filespec = strpbrk(s,":<[.;");
8357 rest = wordbreak = strpbrk(s," \"\t/");
8358 if (!wordbreak) wordbreak = s + strlen(s);
8359 if (*s == '$') check_img = 0;
8360 if (filespec && (filespec < wordbreak)) isdcl = 0;
8361 else isdcl = !check_img;
8366 imgdsc.dsc$a_pointer = s;
8367 imgdsc.dsc$w_length = wordbreak - s;
8368 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8370 _ckvmssts(lib$find_file_end(&cxt));
8371 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8372 if (!(retsts & 1) && *s == '$') {
8373 _ckvmssts(lib$find_file_end(&cxt));
8374 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8375 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8377 _ckvmssts(lib$find_file_end(&cxt));
8378 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8382 _ckvmssts(lib$find_file_end(&cxt));
8387 while (*s && !isspace(*s)) s++;
8390 /* check that it's really not DCL with no file extension */
8391 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
8393 char b[256] = {0,0,0,0};
8394 read(fileno(fp), b, 256);
8395 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
8399 /* Check for script */
8401 if ((b[0] == '#') && (b[1] == '!'))
8403 #ifdef ALTERNATE_SHEBANG
8405 shebang_len = strlen(ALTERNATE_SHEBANG);
8406 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
8408 perlstr = strstr("perl",b);
8409 if (perlstr == NULL)
8417 if (shebang_len > 0) {
8420 char tmpspec[NAM$C_MAXRSS + 1];
8423 /* Image is following after white space */
8424 /*--------------------------------------*/
8425 while (isprint(b[i]) && isspace(b[i]))
8429 while (isprint(b[i]) && !isspace(b[i])) {
8430 tmpspec[j++] = b[i++];
8431 if (j >= NAM$C_MAXRSS)
8436 /* There may be some default parameters to the image */
8437 /*---------------------------------------------------*/
8439 while (isprint(b[i])) {
8440 image_argv[j++] = b[i++];
8441 if (j >= NAM$C_MAXRSS)
8444 while ((j > 0) && !isprint(image_argv[j-1]))
8448 /* It will need to be converted to VMS format and validated */
8449 if (tmpspec[0] != '\0') {
8452 /* Try to find the exact program requested to be run */
8453 /*---------------------------------------------------*/
8454 iname = do_rmsexpand
8455 (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS);
8456 if (iname != NULL) {
8457 if (cando_by_name(S_IXUSR,0,image_name)) {
8458 /* MCR prefix needed */
8462 /* Try again with a null type */
8463 /*----------------------------*/
8464 iname = do_rmsexpand
8465 (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS);
8466 if (iname != NULL) {
8467 if (cando_by_name(S_IXUSR,0,image_name)) {
8468 /* MCR prefix needed */
8474 /* Did we find the image to run the script? */
8475 /*------------------------------------------*/
8479 /* Assume DCL or foreign command exists */
8480 /*--------------------------------------*/
8481 tchr = strrchr(tmpspec, '/');
8488 strcpy(image_name, tchr);
8496 if (check_img && isdcl) return RMS$_FNF;
8498 if (cando_by_name(S_IXUSR,0,resspec)) {
8499 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
8500 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
8502 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
8503 if (image_name[0] != 0) {
8504 strcat(vmscmd->dsc$a_pointer, image_name);
8505 strcat(vmscmd->dsc$a_pointer, " ");
8507 } else if (image_name[0] != 0) {
8508 strcpy(vmscmd->dsc$a_pointer, image_name);
8509 strcat(vmscmd->dsc$a_pointer, " ");
8511 strcpy(vmscmd->dsc$a_pointer,"@");
8513 if (suggest_quote) *suggest_quote = 1;
8515 /* If there is an image name, use original command */
8516 if (image_name[0] == 0)
8517 strcat(vmscmd->dsc$a_pointer,resspec);
8520 while (*rest && isspace(*rest)) rest++;
8523 if (image_argv[0] != 0) {
8524 strcat(vmscmd->dsc$a_pointer,image_argv);
8525 strcat(vmscmd->dsc$a_pointer, " ");
8531 rest_len = strlen(rest);
8532 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
8533 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
8534 strcat(vmscmd->dsc$a_pointer,rest);
8536 retsts = CLI$_BUFOVF;
8538 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
8540 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8546 /* It's either a DCL command or we couldn't find a suitable image */
8547 vmscmd->dsc$w_length = strlen(cmd);
8549 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
8550 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
8551 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
8555 /* check if it's a symbol (for quoting purposes) */
8556 if (suggest_quote && !*suggest_quote) {
8558 char equiv[LNM$C_NAMLENGTH];
8559 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8560 eqvdsc.dsc$a_pointer = equiv;
8562 iss = lib$get_symbol(vmscmd,&eqvdsc);
8563 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
8565 if (!(retsts & 1)) {
8566 /* just hand off status values likely to be due to user error */
8567 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
8568 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
8569 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
8570 else { _ckvmssts(retsts); }
8573 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
8575 } /* end of setup_cmddsc() */
8578 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
8580 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
8586 if (vfork_called) { /* this follows a vfork - act Unixish */
8588 if (vfork_called < 0) {
8589 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8592 else return do_aexec(really,mark,sp);
8594 /* no vfork - act VMSish */
8595 cmd = setup_argstr(aTHX_ really,mark,sp);
8596 exec_sts = vms_do_exec(cmd);
8597 Safefree(cmd); /* Clean up from setup_argstr() */
8602 } /* end of vms_do_aexec() */
8605 /* {{{bool vms_do_exec(char *cmd) */
8607 Perl_vms_do_exec(pTHX_ const char *cmd)
8609 struct dsc$descriptor_s *vmscmd;
8611 if (vfork_called) { /* this follows a vfork - act Unixish */
8613 if (vfork_called < 0) {
8614 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
8617 else return do_exec(cmd);
8620 { /* no vfork - act VMSish */
8621 unsigned long int retsts;
8624 TAINT_PROPER("exec");
8625 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
8626 retsts = lib$do_command(vmscmd);
8629 case RMS$_FNF: case RMS$_DNF:
8630 set_errno(ENOENT); break;
8632 set_errno(ENOTDIR); break;
8634 set_errno(ENODEV); break;
8636 set_errno(EACCES); break;
8638 set_errno(EINVAL); break;
8639 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8640 set_errno(E2BIG); break;
8641 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8642 _ckvmssts(retsts); /* fall through */
8643 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8646 set_vaxc_errno(retsts);
8647 if (ckWARN(WARN_EXEC)) {
8648 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
8649 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
8651 vms_execfree(vmscmd);
8656 } /* end of vms_do_exec() */
8659 unsigned long int Perl_do_spawn(pTHX_ const char *);
8661 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
8663 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
8665 unsigned long int sts;
8669 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
8670 sts = do_spawn(cmd);
8671 /* pp_sys will clean up cmd */
8675 } /* end of do_aspawn() */
8678 /* {{{unsigned long int do_spawn(char *cmd) */
8680 Perl_do_spawn(pTHX_ const char *cmd)
8682 unsigned long int sts, substs;
8684 /* The caller of this routine expects to Safefree(PL_Cmd) */
8685 Newx(PL_Cmd,10,char);
8688 TAINT_PROPER("spawn");
8689 if (!cmd || !*cmd) {
8690 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
8693 case RMS$_FNF: case RMS$_DNF:
8694 set_errno(ENOENT); break;
8696 set_errno(ENOTDIR); break;
8698 set_errno(ENODEV); break;
8700 set_errno(EACCES); break;
8702 set_errno(EINVAL); break;
8703 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
8704 set_errno(E2BIG); break;
8705 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
8706 _ckvmssts(sts); /* fall through */
8707 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
8710 set_vaxc_errno(sts);
8711 if (ckWARN(WARN_EXEC)) {
8712 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
8720 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
8725 } /* end of do_spawn() */
8729 static unsigned int *sockflags, sockflagsize;
8732 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
8733 * routines found in some versions of the CRTL can't deal with sockets.
8734 * We don't shim the other file open routines since a socket isn't
8735 * likely to be opened by a name.
8737 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
8738 FILE *my_fdopen(int fd, const char *mode)
8740 FILE *fp = fdopen(fd, mode);
8743 unsigned int fdoff = fd / sizeof(unsigned int);
8744 Stat_t sbuf; /* native stat; we don't need flex_stat */
8745 if (!sockflagsize || fdoff > sockflagsize) {
8746 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
8747 else Newx (sockflags,fdoff+2,unsigned int);
8748 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
8749 sockflagsize = fdoff + 2;
8751 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
8752 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
8761 * Clear the corresponding bit when the (possibly) socket stream is closed.
8762 * There still a small hole: we miss an implicit close which might occur
8763 * via freopen(). >> Todo
8765 /*{{{ int my_fclose(FILE *fp)*/
8766 int my_fclose(FILE *fp) {
8768 unsigned int fd = fileno(fp);
8769 unsigned int fdoff = fd / sizeof(unsigned int);
8771 if (sockflagsize && fdoff <= sockflagsize)
8772 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
8780 * A simple fwrite replacement which outputs itmsz*nitm chars without
8781 * introducing record boundaries every itmsz chars.
8782 * We are using fputs, which depends on a terminating null. We may
8783 * well be writing binary data, so we need to accommodate not only
8784 * data with nulls sprinkled in the middle but also data with no null
8787 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
8789 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
8791 register char *cp, *end, *cpd, *data;
8792 register unsigned int fd = fileno(dest);
8793 register unsigned int fdoff = fd / sizeof(unsigned int);
8795 int bufsize = itmsz * nitm + 1;
8797 if (fdoff < sockflagsize &&
8798 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
8799 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
8803 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
8804 memcpy( data, src, itmsz*nitm );
8805 data[itmsz*nitm] = '\0';
8807 end = data + itmsz * nitm;
8808 retval = (int) nitm; /* on success return # items written */
8811 while (cpd <= end) {
8812 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
8813 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
8815 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
8819 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
8822 } /* end of my_fwrite() */
8825 /*{{{ int my_flush(FILE *fp)*/
8827 Perl_my_flush(pTHX_ FILE *fp)
8830 if ((res = fflush(fp)) == 0 && fp) {
8831 #ifdef VMS_DO_SOCKETS
8833 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
8835 res = fsync(fileno(fp));
8838 * If the flush succeeded but set end-of-file, we need to clear
8839 * the error because our caller may check ferror(). BTW, this
8840 * probably means we just flushed an empty file.
8842 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
8849 * Here are replacements for the following Unix routines in the VMS environment:
8850 * getpwuid Get information for a particular UIC or UID
8851 * getpwnam Get information for a named user
8852 * getpwent Get information for each user in the rights database
8853 * setpwent Reset search to the start of the rights database
8854 * endpwent Finish searching for users in the rights database
8856 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
8857 * (defined in pwd.h), which contains the following fields:-
8859 * char *pw_name; Username (in lower case)
8860 * char *pw_passwd; Hashed password
8861 * unsigned int pw_uid; UIC
8862 * unsigned int pw_gid; UIC group number
8863 * char *pw_unixdir; Default device/directory (VMS-style)
8864 * char *pw_gecos; Owner name
8865 * char *pw_dir; Default device/directory (Unix-style)
8866 * char *pw_shell; Default CLI name (eg. DCL)
8868 * If the specified user does not exist, getpwuid and getpwnam return NULL.
8870 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
8871 * not the UIC member number (eg. what's returned by getuid()),
8872 * getpwuid() can accept either as input (if uid is specified, the caller's
8873 * UIC group is used), though it won't recognise gid=0.
8875 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
8876 * information about other users in your group or in other groups, respectively.
8877 * If the required privilege is not available, then these routines fill only
8878 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
8881 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
8884 /* sizes of various UAF record fields */
8885 #define UAI$S_USERNAME 12
8886 #define UAI$S_IDENT 31
8887 #define UAI$S_OWNER 31
8888 #define UAI$S_DEFDEV 31
8889 #define UAI$S_DEFDIR 63
8890 #define UAI$S_DEFCLI 31
8893 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
8894 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
8895 (uic).uic$v_group != UIC$K_WILD_GROUP)
8897 static char __empty[]= "";
8898 static struct passwd __passwd_empty=
8899 {(char *) __empty, (char *) __empty, 0, 0,
8900 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
8901 static int contxt= 0;
8902 static struct passwd __pwdcache;
8903 static char __pw_namecache[UAI$S_IDENT+1];
8906 * This routine does most of the work extracting the user information.
8908 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
8911 unsigned char length;
8912 char pw_gecos[UAI$S_OWNER+1];
8914 static union uicdef uic;
8916 unsigned char length;
8917 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
8920 unsigned char length;
8921 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
8924 unsigned char length;
8925 char pw_shell[UAI$S_DEFCLI+1];
8927 static char pw_passwd[UAI$S_PWD+1];
8929 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
8930 struct dsc$descriptor_s name_desc;
8931 unsigned long int sts;
8933 static struct itmlst_3 itmlst[]= {
8934 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
8935 {sizeof(uic), UAI$_UIC, &uic, &luic},
8936 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
8937 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
8938 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
8939 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
8940 {0, 0, NULL, NULL}};
8942 name_desc.dsc$w_length= strlen(name);
8943 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
8944 name_desc.dsc$b_class= DSC$K_CLASS_S;
8945 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
8947 /* Note that sys$getuai returns many fields as counted strings. */
8948 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
8949 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
8950 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
8952 else { _ckvmssts(sts); }
8953 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
8955 if ((int) owner.length < lowner) lowner= (int) owner.length;
8956 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
8957 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
8958 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
8959 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
8960 owner.pw_gecos[lowner]= '\0';
8961 defdev.pw_dir[ldefdev+ldefdir]= '\0';
8962 defcli.pw_shell[ldefcli]= '\0';
8963 if (valid_uic(uic)) {
8964 pwd->pw_uid= uic.uic$l_uic;
8965 pwd->pw_gid= uic.uic$v_group;
8968 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
8969 pwd->pw_passwd= pw_passwd;
8970 pwd->pw_gecos= owner.pw_gecos;
8971 pwd->pw_dir= defdev.pw_dir;
8972 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1);
8973 pwd->pw_shell= defcli.pw_shell;
8974 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
8976 ldir= strlen(pwd->pw_unixdir) - 1;
8977 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
8980 strcpy(pwd->pw_unixdir, pwd->pw_dir);
8981 if (!decc_efs_case_preserve)
8982 __mystrtolower(pwd->pw_unixdir);
8987 * Get information for a named user.
8989 /*{{{struct passwd *getpwnam(char *name)*/
8990 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
8992 struct dsc$descriptor_s name_desc;
8994 unsigned long int status, sts;
8996 __pwdcache = __passwd_empty;
8997 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
8998 /* We still may be able to determine pw_uid and pw_gid */
8999 name_desc.dsc$w_length= strlen(name);
9000 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9001 name_desc.dsc$b_class= DSC$K_CLASS_S;
9002 name_desc.dsc$a_pointer= (char *) name;
9003 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9004 __pwdcache.pw_uid= uic.uic$l_uic;
9005 __pwdcache.pw_gid= uic.uic$v_group;
9008 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9009 set_vaxc_errno(sts);
9010 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9013 else { _ckvmssts(sts); }
9016 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9017 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9018 __pwdcache.pw_name= __pw_namecache;
9020 } /* end of my_getpwnam() */
9024 * Get information for a particular UIC or UID.
9025 * Called by my_getpwent with uid=-1 to list all users.
9027 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9028 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9030 const $DESCRIPTOR(name_desc,__pw_namecache);
9031 unsigned short lname;
9033 unsigned long int status;
9035 if (uid == (unsigned int) -1) {
9037 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9038 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9039 set_vaxc_errno(status);
9040 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9044 else { _ckvmssts(status); }
9045 } while (!valid_uic (uic));
9049 if (!uic.uic$v_group)
9050 uic.uic$v_group= PerlProc_getgid();
9052 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9053 else status = SS$_IVIDENT;
9054 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9055 status == RMS$_PRV) {
9056 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9059 else { _ckvmssts(status); }
9061 __pw_namecache[lname]= '\0';
9062 __mystrtolower(__pw_namecache);
9064 __pwdcache = __passwd_empty;
9065 __pwdcache.pw_name = __pw_namecache;
9067 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9068 The identifier's value is usually the UIC, but it doesn't have to be,
9069 so if we can, we let fillpasswd update this. */
9070 __pwdcache.pw_uid = uic.uic$l_uic;
9071 __pwdcache.pw_gid = uic.uic$v_group;
9073 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9076 } /* end of my_getpwuid() */
9080 * Get information for next user.
9082 /*{{{struct passwd *my_getpwent()*/
9083 struct passwd *Perl_my_getpwent(pTHX)
9085 return (my_getpwuid((unsigned int) -1));
9090 * Finish searching rights database for users.
9092 /*{{{void my_endpwent()*/
9093 void Perl_my_endpwent(pTHX)
9096 _ckvmssts(sys$finish_rdb(&contxt));
9102 #ifdef HOMEGROWN_POSIX_SIGNALS
9103 /* Signal handling routines, pulled into the core from POSIX.xs.
9105 * We need these for threads, so they've been rolled into the core,
9106 * rather than left in POSIX.xs.
9108 * (DRS, Oct 23, 1997)
9111 /* sigset_t is atomic under VMS, so these routines are easy */
9112 /*{{{int my_sigemptyset(sigset_t *) */
9113 int my_sigemptyset(sigset_t *set) {
9114 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9120 /*{{{int my_sigfillset(sigset_t *)*/
9121 int my_sigfillset(sigset_t *set) {
9123 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9124 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9130 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9131 int my_sigaddset(sigset_t *set, int sig) {
9132 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9133 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9134 *set |= (1 << (sig - 1));
9140 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9141 int my_sigdelset(sigset_t *set, int sig) {
9142 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9143 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9144 *set &= ~(1 << (sig - 1));
9150 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9151 int my_sigismember(sigset_t *set, int sig) {
9152 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9153 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9154 return *set & (1 << (sig - 1));
9159 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9160 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9163 /* If set and oset are both null, then things are badly wrong. Bail out. */
9164 if ((oset == NULL) && (set == NULL)) {
9165 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9169 /* If set's null, then we're just handling a fetch. */
9171 tempmask = sigblock(0);
9176 tempmask = sigsetmask(*set);
9179 tempmask = sigblock(*set);
9182 tempmask = sigblock(0);
9183 sigsetmask(*oset & ~tempmask);
9186 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9191 /* Did they pass us an oset? If so, stick our holding mask into it */
9198 #endif /* HOMEGROWN_POSIX_SIGNALS */
9201 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9202 * my_utime(), and flex_stat(), all of which operate on UTC unless
9203 * VMSISH_TIMES is true.
9205 /* method used to handle UTC conversions:
9206 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
9208 static int gmtime_emulation_type;
9209 /* number of secs to add to UTC POSIX-style time to get local time */
9210 static long int utc_offset_secs;
9212 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9213 * in vmsish.h. #undef them here so we can call the CRTL routines
9222 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9223 * qualifier with the extern prefix pragma. This provisional
9224 * hack circumvents this prefix pragma problem in previous
9227 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9228 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9229 # pragma __extern_prefix save
9230 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
9231 # define gmtime decc$__utctz_gmtime
9232 # define localtime decc$__utctz_localtime
9233 # define time decc$__utc_time
9234 # pragma __extern_prefix restore
9236 struct tm *gmtime(), *localtime();
9242 static time_t toutc_dst(time_t loc) {
9245 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9246 loc -= utc_offset_secs;
9247 if (rsltmp->tm_isdst) loc -= 3600;
9250 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9251 ((gmtime_emulation_type || my_time(NULL)), \
9252 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9253 ((secs) - utc_offset_secs))))
9255 static time_t toloc_dst(time_t utc) {
9258 utc += utc_offset_secs;
9259 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9260 if (rsltmp->tm_isdst) utc += 3600;
9263 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9264 ((gmtime_emulation_type || my_time(NULL)), \
9265 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9266 ((secs) + utc_offset_secs))))
9268 #ifndef RTL_USES_UTC
9271 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9272 DST starts on 1st sun of april at 02:00 std time
9273 ends on last sun of october at 02:00 dst time
9274 see the UCX management command reference, SET CONFIG TIMEZONE
9275 for formatting info.
9277 No, it's not as general as it should be, but then again, NOTHING
9278 will handle UK times in a sensible way.
9283 parse the DST start/end info:
9284 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9288 tz_parse_startend(char *s, struct tm *w, int *past)
9290 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9291 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9296 if (!past) return 0;
9299 if (w->tm_year % 4 == 0) ly = 1;
9300 if (w->tm_year % 100 == 0) ly = 0;
9301 if (w->tm_year+1900 % 400 == 0) ly = 1;
9304 dozjd = isdigit(*s);
9305 if (*s == 'J' || *s == 'j' || dozjd) {
9306 if (!dozjd && !isdigit(*++s)) return 0;
9309 d = d*10 + *s++ - '0';
9311 d = d*10 + *s++ - '0';
9314 if (d == 0) return 0;
9315 if (d > 366) return 0;
9317 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9320 } else if (*s == 'M' || *s == 'm') {
9321 if (!isdigit(*++s)) return 0;
9323 if (isdigit(*s)) m = 10*m + *s++ - '0';
9324 if (*s != '.') return 0;
9325 if (!isdigit(*++s)) return 0;
9327 if (n < 1 || n > 5) return 0;
9328 if (*s != '.') return 0;
9329 if (!isdigit(*++s)) return 0;
9331 if (d > 6) return 0;
9335 if (!isdigit(*++s)) return 0;
9337 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9339 if (!isdigit(*++s)) return 0;
9341 if (isdigit(*s)) min = 10*min + *s++ - '0';
9343 if (!isdigit(*++s)) return 0;
9345 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9355 if (w->tm_yday < d) goto before;
9356 if (w->tm_yday > d) goto after;
9358 if (w->tm_mon+1 < m) goto before;
9359 if (w->tm_mon+1 > m) goto after;
9361 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9362 k = d - j; /* mday of first d */
9364 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9365 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9366 if (w->tm_mday < k) goto before;
9367 if (w->tm_mday > k) goto after;
9370 if (w->tm_hour < hour) goto before;
9371 if (w->tm_hour > hour) goto after;
9372 if (w->tm_min < min) goto before;
9373 if (w->tm_min > min) goto after;
9374 if (w->tm_sec < sec) goto before;
9388 /* parse the offset: (+|-)hh[:mm[:ss]] */
9391 tz_parse_offset(char *s, int *offset)
9393 int hour = 0, min = 0, sec = 0;
9396 if (!offset) return 0;
9398 if (*s == '-') {neg++; s++;}
9400 if (!isdigit(*s)) return 0;
9402 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
9403 if (hour > 24) return 0;
9405 if (!isdigit(*++s)) return 0;
9407 if (isdigit(*s)) min = min*10 + (*s++ - '0');
9408 if (min > 59) return 0;
9410 if (!isdigit(*++s)) return 0;
9412 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
9413 if (sec > 59) return 0;
9417 *offset = (hour*60+min)*60 + sec;
9418 if (neg) *offset = -*offset;
9423 input time is w, whatever type of time the CRTL localtime() uses.
9424 sets dst, the zone, and the gmtoff (seconds)
9426 caches the value of TZ and UCX$TZ env variables; note that
9427 my_setenv looks for these and sets a flag if they're changed
9430 We have to watch out for the "australian" case (dst starts in
9431 october, ends in april)...flagged by "reverse" and checked by
9432 scanning through the months of the previous year.
9437 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
9442 char *dstzone, *tz, *s_start, *s_end;
9443 int std_off, dst_off, isdst;
9444 int y, dststart, dstend;
9445 static char envtz[1025]; /* longer than any logical, symbol, ... */
9446 static char ucxtz[1025];
9447 static char reversed = 0;
9453 reversed = -1; /* flag need to check */
9454 envtz[0] = ucxtz[0] = '\0';
9455 tz = my_getenv("TZ",0);
9456 if (tz) strcpy(envtz, tz);
9457 tz = my_getenv("UCX$TZ",0);
9458 if (tz) strcpy(ucxtz, tz);
9459 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
9462 if (!*tz) tz = ucxtz;
9465 while (isalpha(*s)) s++;
9466 s = tz_parse_offset(s, &std_off);
9468 if (!*s) { /* no DST, hurray we're done! */
9474 while (isalpha(*s)) s++;
9475 s2 = tz_parse_offset(s, &dst_off);
9479 dst_off = std_off - 3600;
9482 if (!*s) { /* default dst start/end?? */
9483 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
9484 s = strchr(ucxtz,',');
9486 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
9488 if (*s != ',') return 0;
9491 when = _toutc(when); /* convert to utc */
9492 when = when - std_off; /* convert to pseudolocal time*/
9494 w2 = localtime(&when);
9497 s = tz_parse_startend(s_start,w2,&dststart);
9499 if (*s != ',') return 0;
9502 when = _toutc(when); /* convert to utc */
9503 when = when - dst_off; /* convert to pseudolocal time*/
9504 w2 = localtime(&when);
9505 if (w2->tm_year != y) { /* spans a year, just check one time */
9506 when += dst_off - std_off;
9507 w2 = localtime(&when);
9510 s = tz_parse_startend(s_end,w2,&dstend);
9513 if (reversed == -1) { /* need to check if start later than end */
9517 if (when < 2*365*86400) {
9518 when += 2*365*86400;
9522 w2 =localtime(&when);
9523 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
9525 for (j = 0; j < 12; j++) {
9526 w2 =localtime(&when);
9527 tz_parse_startend(s_start,w2,&ds);
9528 tz_parse_startend(s_end,w2,&de);
9529 if (ds != de) break;
9533 if (de && !ds) reversed = 1;
9536 isdst = dststart && !dstend;
9537 if (reversed) isdst = dststart || !dstend;
9540 if (dst) *dst = isdst;
9541 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
9542 if (isdst) tz = dstzone;
9544 while(isalpha(*tz)) *zone++ = *tz++;
9550 #endif /* !RTL_USES_UTC */
9552 /* my_time(), my_localtime(), my_gmtime()
9553 * By default traffic in UTC time values, using CRTL gmtime() or
9554 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
9555 * Note: We need to use these functions even when the CRTL has working
9556 * UTC support, since they also handle C<use vmsish qw(times);>
9558 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
9559 * Modified by Charles Bailey <bailey@newman.upenn.edu>
9562 /*{{{time_t my_time(time_t *timep)*/
9563 time_t Perl_my_time(pTHX_ time_t *timep)
9568 if (gmtime_emulation_type == 0) {
9570 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
9571 /* results of calls to gmtime() and localtime() */
9572 /* for same &base */
9574 gmtime_emulation_type++;
9575 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
9576 char off[LNM$C_NAMLENGTH+1];;
9578 gmtime_emulation_type++;
9579 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
9580 gmtime_emulation_type++;
9581 utc_offset_secs = 0;
9582 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
9584 else { utc_offset_secs = atol(off); }
9586 else { /* We've got a working gmtime() */
9587 struct tm gmt, local;
9590 tm_p = localtime(&base);
9592 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
9593 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
9594 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
9595 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
9601 # ifdef RTL_USES_UTC
9602 if (VMSISH_TIME) when = _toloc(when);
9604 if (!VMSISH_TIME) when = _toutc(when);
9607 if (timep != NULL) *timep = when;
9610 } /* end of my_time() */
9614 /*{{{struct tm *my_gmtime(const time_t *timep)*/
9616 Perl_my_gmtime(pTHX_ const time_t *timep)
9622 if (timep == NULL) {
9623 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9626 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9630 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
9632 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
9633 return gmtime(&when);
9635 /* CRTL localtime() wants local time as input, so does no tz correction */
9636 rsltmp = localtime(&when);
9637 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
9640 } /* end of my_gmtime() */
9644 /*{{{struct tm *my_localtime(const time_t *timep)*/
9646 Perl_my_localtime(pTHX_ const time_t *timep)
9648 time_t when, whenutc;
9652 if (timep == NULL) {
9653 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9656 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
9657 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
9660 # ifdef RTL_USES_UTC
9662 if (VMSISH_TIME) when = _toutc(when);
9664 /* CRTL localtime() wants UTC as input, does tz correction itself */
9665 return localtime(&when);
9667 # else /* !RTL_USES_UTC */
9670 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
9671 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
9674 #ifndef RTL_USES_UTC
9675 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
9676 when = whenutc - offset; /* pseudolocal time*/
9679 /* CRTL localtime() wants local time as input, so does no tz correction */
9680 rsltmp = localtime(&when);
9681 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
9685 } /* end of my_localtime() */
9688 /* Reset definitions for later calls */
9689 #define gmtime(t) my_gmtime(t)
9690 #define localtime(t) my_localtime(t)
9691 #define time(t) my_time(t)
9694 /* my_utime - update modification time of a file
9695 * calling sequence is identical to POSIX utime(), but under
9696 * VMS only the modification time is changed; ODS-2 does not
9697 * maintain access times. Restrictions differ from the POSIX
9698 * definition in that the time can be changed as long as the
9699 * caller has permission to execute the necessary IO$_MODIFY $QIO;
9700 * no separate checks are made to insure that the caller is the
9701 * owner of the file or has special privs enabled.
9702 * Code here is based on Joe Meadows' FILE utility.
9705 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
9706 * to VMS epoch (01-JAN-1858 00:00:00.00)
9707 * in 100 ns intervals.
9709 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
9711 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
9712 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
9716 long int bintime[2], len = 2, lowbit, unixtime,
9717 secscale = 10000000; /* seconds --> 100 ns intervals */
9718 unsigned long int chan, iosb[2], retsts;
9719 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
9720 struct FAB myfab = cc$rms_fab;
9721 struct NAM mynam = cc$rms_nam;
9722 #if defined (__DECC) && defined (__VAX)
9723 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
9724 * at least through VMS V6.1, which causes a type-conversion warning.
9726 # pragma message save
9727 # pragma message disable cvtdiftypes
9729 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
9730 struct fibdef myfib;
9731 #if defined (__DECC) && defined (__VAX)
9732 /* This should be right after the declaration of myatr, but due
9733 * to a bug in VAX DEC C, this takes effect a statement early.
9735 # pragma message restore
9737 /* cast ok for read only parameter */
9738 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
9739 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
9740 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
9742 if (file == NULL || *file == '\0') {
9744 set_vaxc_errno(LIB$_INVARG);
9747 if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
9749 if (utimes != NULL) {
9750 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
9751 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
9752 * Since time_t is unsigned long int, and lib$emul takes a signed long int
9753 * as input, we force the sign bit to be clear by shifting unixtime right
9754 * one bit, then multiplying by an extra factor of 2 in lib$emul().
9756 lowbit = (utimes->modtime & 1) ? secscale : 0;
9757 unixtime = (long int) utimes->modtime;
9759 /* If input was UTC; convert to local for sys svc */
9760 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
9762 unixtime >>= 1; secscale <<= 1;
9763 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
9764 if (!(retsts & 1)) {
9766 set_vaxc_errno(retsts);
9769 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
9770 if (!(retsts & 1)) {
9772 set_vaxc_errno(retsts);
9777 /* Just get the current time in VMS format directly */
9778 retsts = sys$gettim(bintime);
9779 if (!(retsts & 1)) {
9781 set_vaxc_errno(retsts);
9786 myfab.fab$l_fna = vmsspec;
9787 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
9788 myfab.fab$l_nam = &mynam;
9789 mynam.nam$l_esa = esa;
9790 mynam.nam$b_ess = (unsigned char) sizeof esa;
9791 mynam.nam$l_rsa = rsa;
9792 mynam.nam$b_rss = (unsigned char) sizeof rsa;
9793 if (decc_efs_case_preserve)
9794 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
9796 /* Look for the file to be affected, letting RMS parse the file
9797 * specification for us as well. I have set errno using only
9798 * values documented in the utime() man page for VMS POSIX.
9800 retsts = sys$parse(&myfab,0,0);
9801 if (!(retsts & 1)) {
9802 set_vaxc_errno(retsts);
9803 if (retsts == RMS$_PRV) set_errno(EACCES);
9804 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
9805 else set_errno(EVMSERR);
9808 retsts = sys$search(&myfab,0,0);
9809 if (!(retsts & 1)) {
9810 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9811 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9812 set_vaxc_errno(retsts);
9813 if (retsts == RMS$_PRV) set_errno(EACCES);
9814 else if (retsts == RMS$_FNF) set_errno(ENOENT);
9815 else set_errno(EVMSERR);
9819 devdsc.dsc$w_length = mynam.nam$b_dev;
9820 /* cast ok for read only parameter */
9821 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
9823 retsts = sys$assign(&devdsc,&chan,0,0);
9824 if (!(retsts & 1)) {
9825 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9826 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9827 set_vaxc_errno(retsts);
9828 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
9829 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
9830 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
9831 else set_errno(EVMSERR);
9835 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
9836 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
9838 memset((void *) &myfib, 0, sizeof myfib);
9839 #if defined(__DECC) || defined(__DECCXX)
9840 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
9841 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
9842 /* This prevents the revision time of the file being reset to the current
9843 * time as a result of our IO$_MODIFY $QIO. */
9844 myfib.fib$l_acctl = FIB$M_NORECORD;
9846 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
9847 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
9848 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
9850 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
9851 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
9852 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
9853 _ckvmssts(sys$dassgn(chan));
9854 if (retsts & 1) retsts = iosb[0];
9855 if (!(retsts & 1)) {
9856 set_vaxc_errno(retsts);
9857 if (retsts == SS$_NOPRIV) set_errno(EACCES);
9858 else set_errno(EVMSERR);
9863 } /* end of my_utime() */
9867 * flex_stat, flex_lstat, flex_fstat
9868 * basic stat, but gets it right when asked to stat
9869 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
9872 #ifndef _USE_STD_STAT
9873 /* encode_dev packs a VMS device name string into an integer to allow
9874 * simple comparisons. This can be used, for example, to check whether two
9875 * files are located on the same device, by comparing their encoded device
9876 * names. Even a string comparison would not do, because stat() reuses the
9877 * device name buffer for each call; so without encode_dev, it would be
9878 * necessary to save the buffer and use strcmp (this would mean a number of
9879 * changes to the standard Perl code, to say nothing of what a Perl script
9882 * The device lock id, if it exists, should be unique (unless perhaps compared
9883 * with lock ids transferred from other nodes). We have a lock id if the disk is
9884 * mounted cluster-wide, which is when we tend to get long (host-qualified)
9885 * device names. Thus we use the lock id in preference, and only if that isn't
9886 * available, do we try to pack the device name into an integer (flagged by
9887 * the sign bit (LOCKID_MASK) being set).
9889 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
9890 * name and its encoded form, but it seems very unlikely that we will find
9891 * two files on different disks that share the same encoded device names,
9892 * and even more remote that they will share the same file id (if the test
9893 * is to check for the same file).
9895 * A better method might be to use sys$device_scan on the first call, and to
9896 * search for the device, returning an index into the cached array.
9897 * The number returned would be more intelligable.
9898 * This is probably not worth it, and anyway would take quite a bit longer
9899 * on the first call.
9901 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
9902 static mydev_t encode_dev (pTHX_ const char *dev)
9905 unsigned long int f;
9910 if (!dev || !dev[0]) return 0;
9914 struct dsc$descriptor_s dev_desc;
9915 unsigned long int status, lockid, item = DVI$_LOCKID;
9917 /* For cluster-mounted disks, the disk lock identifier is unique, so we
9918 can try that first. */
9919 dev_desc.dsc$w_length = strlen (dev);
9920 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
9921 dev_desc.dsc$b_class = DSC$K_CLASS_S;
9922 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
9923 _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0));
9924 if (lockid) return (lockid & ~LOCKID_MASK);
9928 /* Otherwise we try to encode the device name */
9932 for (q = dev + strlen(dev); q--; q >= dev) {
9935 else if (isalpha (toupper (*q)))
9936 c= toupper (*q) - 'A' + (char)10;
9938 continue; /* Skip '$'s */
9940 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
9942 enc += f * (unsigned long int) c;
9944 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
9946 } /* end of encode_dev() */
9949 static char namecache[NAM$C_MAXRSS+1];
9952 is_null_device(name)
9955 if (decc_bug_devnull != 0) {
9956 if (strncmp("/dev/null", name, 9) == 0)
9959 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
9960 The underscore prefix, controller letter, and unit number are
9961 independently optional; for our purposes, the colon punctuation
9962 is not. The colon can be trailed by optional directory and/or
9963 filename, but two consecutive colons indicates a nodename rather
9964 than a device. [pr] */
9965 if (*name == '_') ++name;
9966 if (tolower(*name++) != 'n') return 0;
9967 if (tolower(*name++) != 'l') return 0;
9968 if (tolower(*name) == 'a') ++name;
9969 if (*name == '0') ++name;
9970 return (*name++ == ':') && (*name != ':');
9973 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
9974 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
9975 * subset of the applicable information.
9978 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
9980 char fname_phdev[NAM$C_MAXRSS+1];
9981 #if __CRTL_VER >= 80200000 && !defined(__VAX)
9982 /* Namecache not workable with symbolic links, as symbolic links do
9983 * not have extensions and directories do in VMS mode. So in order
9984 * to test this, the did and ino_t must be used.
9986 * Fix-me - Hide the information in the new stat structure
9987 * Get rid of the namecache.
9989 if (decc_posix_compliant_pathnames == 0)
9991 if (statbufp == &PL_statcache)
9992 return cando_by_name(bit,effective,namecache);
9994 char fname[NAM$C_MAXRSS+1];
9995 unsigned long int retsts;
9996 struct dsc$descriptor_s devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
9997 namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9999 /* If the struct mystat is stale, we're OOL; stat() overwrites the
10000 device name on successive calls */
10001 devdsc.dsc$a_pointer = ((Stat_t *)statbufp)->st_devnam;
10002 devdsc.dsc$w_length = strlen(((Stat_t *)statbufp)->st_devnam);
10003 namdsc.dsc$a_pointer = fname;
10004 namdsc.dsc$w_length = sizeof fname - 1;
10006 retsts = lib$fid_to_name(&devdsc,&(((Stat_t *)statbufp)->st_ino),
10007 &namdsc,&namdsc.dsc$w_length,0,0);
10009 fname[namdsc.dsc$w_length] = '\0';
10011 * lib$fid_to_name returns DVI$_LOGVOLNAM as the device part of the name,
10012 * but if someone has redefined that logical, Perl gets very lost. Since
10013 * we have the physical device name from the stat buffer, just paste it on.
10015 strcpy( fname_phdev, statbufp->st_devnam );
10016 strcat( fname_phdev, strrchr(fname, ':') );
10018 return cando_by_name(bit,effective,fname_phdev);
10020 else if (retsts == SS$_NOSUCHDEV || retsts == SS$_NOSUCHFILE) {
10021 Perl_warn(aTHX_ "Can't get filespec - stale stat buffer?\n");
10025 return FALSE; /* Should never get to here */
10027 } /* end of cando() */
10031 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10033 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10035 static char usrname[L_cuserid];
10036 static struct dsc$descriptor_s usrdsc =
10037 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10038 char vmsname[NAM$C_MAXRSS+1];
10040 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2];
10041 unsigned short int retlen, trnlnm_iter_count;
10042 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10043 union prvdef curprv;
10044 struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10045 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}};
10046 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10047 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10049 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10051 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10053 if (!fname || !*fname) return FALSE;
10054 /* Make sure we expand logical names, since sys$check_access doesn't */
10055 fileified = PerlMem_malloc(VMS_MAXRSS);
10056 if (!strpbrk(fname,"/]>:")) {
10057 strcpy(fileified,fname);
10058 trnlnm_iter_count = 0;
10059 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10060 trnlnm_iter_count++;
10061 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10065 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) {
10066 PerlMem_free(fileified);
10069 retlen = namdsc.dsc$w_length = strlen(vmsname);
10070 namdsc.dsc$a_pointer = vmsname;
10071 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10072 vmsname[retlen-1] == ':') {
10073 if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE;
10074 namdsc.dsc$w_length = strlen(fileified);
10075 namdsc.dsc$a_pointer = fileified;
10079 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10080 access = ARM$M_EXECUTE; break;
10081 case S_IRUSR: case S_IRGRP: case S_IROTH:
10082 access = ARM$M_READ; break;
10083 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10084 access = ARM$M_WRITE; break;
10085 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10086 access = ARM$M_DELETE; break;
10088 PerlMem_free(fileified);
10092 /* Before we call $check_access, create a user profile with the current
10093 * process privs since otherwise it just uses the default privs from the
10094 * UAF and might give false positives or negatives. This only works on
10095 * VMS versions v6.0 and later since that's when sys$create_user_profile
10096 * became available.
10099 /* get current process privs and username */
10100 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10101 _ckvmssts(iosb[0]);
10103 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10105 /* find out the space required for the profile */
10106 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10107 &usrprodsc.dsc$w_length,0));
10109 /* allocate space for the profile and get it filled in */
10110 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10111 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10112 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10113 &usrprodsc.dsc$w_length,0));
10115 /* use the profile to check access to the file; free profile & analyze results */
10116 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10117 PerlMem_free(usrprodsc.dsc$a_pointer);
10118 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10122 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10126 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
10127 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10128 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10129 set_vaxc_errno(retsts);
10130 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10131 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10132 else set_errno(ENOENT);
10133 PerlMem_free(fileified);
10136 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10137 PerlMem_free(fileified);
10142 PerlMem_free(fileified);
10143 return FALSE; /* Should never get here */
10145 } /* end of cando_by_name() */
10149 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10151 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10153 if (!fstat(fd,(stat_t *) statbufp)) {
10154 if (statbufp == (Stat_t *) &PL_statcache) {
10157 /* Save name for cando by name in VMS format */
10158 cptr = getname(fd, namecache, 1);
10160 /* This should not happen, but just in case */
10162 namecache[0] = '\0';
10165 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10166 #ifndef _USE_STD_STAT
10167 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10168 statbufp->st_devnam[63] = 0;
10169 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10172 * The device is only encoded so that Perl_cando can use it to
10173 * look up ACLS. So rmsexpand it to the 255 character version
10174 * and store it in ->st_devnam. rmsexpand needs to be fixed
10175 * for long filenames and symbolic links first. This also seems
10176 * to remove the need for a namecache that could be stale.
10180 # ifdef RTL_USES_UTC
10181 # ifdef VMSISH_TIME
10183 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10184 statbufp->st_atime = _toloc(statbufp->st_atime);
10185 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10189 # ifdef VMSISH_TIME
10190 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10194 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10195 statbufp->st_atime = _toutc(statbufp->st_atime);
10196 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10203 } /* end of flex_fstat() */
10206 #if !defined(__VAX) && __CRTL_VER >= 80200000
10214 #define lstat(_x, _y) stat(_x, _y)
10217 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10220 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10222 char fileified[NAM$C_MAXRSS+1];
10223 char temp_fspec[NAM$C_MAXRSS+300];
10225 int saved_errno, saved_vaxc_errno;
10227 if (!fspec) return retval;
10228 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10229 strcpy(temp_fspec, fspec);
10230 if (statbufp == (Stat_t *) &PL_statcache)
10231 do_tovmsspec(temp_fspec,namecache,0);
10232 if (decc_bug_devnull != 0) {
10233 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10234 memset(statbufp,0,sizeof *statbufp);
10235 statbufp->st_dev = encode_dev(aTHX_ "_NLA0:");
10236 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10237 statbufp->st_uid = 0x00010001;
10238 statbufp->st_gid = 0x0001;
10239 time((time_t *)&statbufp->st_mtime);
10240 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10245 /* Try for a directory name first. If fspec contains a filename without
10246 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10247 * and sea:[wine.dark]water. exist, we prefer the directory here.
10248 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10249 * not sea:[wine.dark]., if the latter exists. If the intended target is
10250 * the file with null type, specify this by calling flex_stat() with
10251 * a '.' at the end of fspec.
10253 * If we are in Posix filespec mode, accept the filename as is.
10255 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10256 if (decc_posix_compliant_pathnames == 0) {
10258 if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) {
10259 if (lstat_flag == 0)
10260 retval = stat(fileified,(stat_t *) statbufp);
10262 retval = lstat(fileified,(stat_t *) statbufp);
10263 if (!retval && statbufp == (Stat_t *) &PL_statcache)
10264 strcpy(namecache,fileified);
10267 if (lstat_flag == 0)
10268 retval = stat(temp_fspec,(stat_t *) statbufp);
10270 retval = lstat(temp_fspec,(stat_t *) statbufp);
10272 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10274 if (lstat_flag == 0)
10275 retval = stat(temp_fspec,(stat_t *) statbufp);
10277 retval = lstat(temp_fspec,(stat_t *) statbufp);
10281 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10282 #ifndef _USE_STD_STAT
10283 strncpy(statbufp->st_devnam, statbufp->crtl_stat.st_dev, 63);
10284 statbufp->st_devnam[63] = 0;
10285 statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam);
10288 * The device is only encoded so that Perl_cando can use it to
10289 * look up ACLS. So rmsexpand it to the 255 character version
10290 * and store it in ->st_devnam. rmsexpand needs to be fixed
10291 * for long filenames and symbolic links first. This also seems
10292 * to remove the need for a namecache that could be stale.
10295 # ifdef RTL_USES_UTC
10296 # ifdef VMSISH_TIME
10298 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10299 statbufp->st_atime = _toloc(statbufp->st_atime);
10300 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10304 # ifdef VMSISH_TIME
10305 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10309 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10310 statbufp->st_atime = _toutc(statbufp->st_atime);
10311 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10315 /* If we were successful, leave errno where we found it */
10316 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10319 } /* end of flex_stat_int() */
10322 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10324 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10326 return flex_stat_int(fspec, statbufp, 0);
10330 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10332 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10334 return flex_stat_int(fspec, statbufp, 1);
10339 /*{{{char *my_getlogin()*/
10340 /* VMS cuserid == Unix getlogin, except calling sequence */
10344 static char user[L_cuserid];
10345 return cuserid(user);
10350 /* rmscopy - copy a file using VMS RMS routines
10352 * Copies contents and attributes of spec_in to spec_out, except owner
10353 * and protection information. Name and type of spec_in are used as
10354 * defaults for spec_out. The third parameter specifies whether rmscopy()
10355 * should try to propagate timestamps from the input file to the output file.
10356 * If it is less than 0, no timestamps are preserved. If it is 0, then
10357 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
10358 * propagated to the output file at creation iff the output file specification
10359 * did not contain an explicit name or type, and the revision date is always
10360 * updated at the end of the copy operation. If it is greater than 0, then
10361 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
10362 * other than the revision date should be propagated, and bit 1 indicates
10363 * that the revision date should be propagated.
10365 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
10367 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
10368 * Incorporates, with permission, some code from EZCOPY by Tim Adye
10369 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
10370 * as part of the Perl standard distribution under the terms of the
10371 * GNU General Public License or the Perl Artistic License. Copies
10372 * of each may be found in the Perl standard distribution.
10374 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
10375 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
10377 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10379 char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS],
10380 rsa[NAM$C_MAXRSS], ubf[32256];
10381 unsigned long int i, sts, sts2;
10382 struct FAB fab_in, fab_out;
10383 struct RAB rab_in, rab_out;
10385 struct XABDAT xabdat;
10386 struct XABFHC xabfhc;
10387 struct XABRDT xabrdt;
10388 struct XABSUM xabsum;
10390 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10391 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10392 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10396 fab_in = cc$rms_fab;
10397 fab_in.fab$l_fna = vmsin;
10398 fab_in.fab$b_fns = strlen(vmsin);
10399 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10400 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10401 fab_in.fab$l_fop = FAB$M_SQO;
10402 fab_in.fab$l_nam = &nam;
10403 fab_in.fab$l_xab = (void *) &xabdat;
10406 nam.nam$l_rsa = rsa;
10407 nam.nam$b_rss = sizeof(rsa);
10408 nam.nam$l_esa = esa;
10409 nam.nam$b_ess = sizeof (esa);
10410 nam.nam$b_esl = nam.nam$b_rsl = 0;
10411 #ifdef NAM$M_NO_SHORT_UPCASE
10412 if (decc_efs_case_preserve)
10413 nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10416 xabdat = cc$rms_xabdat; /* To get creation date */
10417 xabdat.xab$l_nxt = (void *) &xabfhc;
10419 xabfhc = cc$rms_xabfhc; /* To get record length */
10420 xabfhc.xab$l_nxt = (void *) &xabsum;
10422 xabsum = cc$rms_xabsum; /* To get key and area information */
10424 if (!((sts = sys$open(&fab_in)) & 1)) {
10425 set_vaxc_errno(sts);
10427 case RMS$_FNF: case RMS$_DNF:
10428 set_errno(ENOENT); break;
10430 set_errno(ENOTDIR); break;
10432 set_errno(ENODEV); break;
10434 set_errno(EINVAL); break;
10436 set_errno(EACCES); break;
10438 set_errno(EVMSERR);
10444 fab_out.fab$w_ifi = 0;
10445 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10446 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10447 fab_out.fab$l_fop = FAB$M_SQO;
10448 fab_out.fab$l_fna = vmsout;
10449 fab_out.fab$b_fns = strlen(vmsout);
10450 fab_out.fab$l_dna = nam.nam$l_name;
10451 fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0;
10453 if (preserve_dates == 0) { /* Act like DCL COPY */
10454 nam.nam$b_nop |= NAM$M_SYNCHK;
10455 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10456 if (!((sts = sys$parse(&fab_out)) & 1)) {
10457 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10458 set_vaxc_errno(sts);
10461 fab_out.fab$l_xab = (void *) &xabdat;
10462 if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10464 fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */
10465 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10466 preserve_dates =0; /* bitmask from this point forward */
10468 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10469 if (!((sts = sys$create(&fab_out)) & 1)) {
10470 set_vaxc_errno(sts);
10473 set_errno(ENOENT); break;
10475 set_errno(ENOTDIR); break;
10477 set_errno(ENODEV); break;
10479 set_errno(EINVAL); break;
10481 set_errno(EACCES); break;
10483 set_errno(EVMSERR);
10487 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10488 if (preserve_dates & 2) {
10489 /* sys$close() will process xabrdt, not xabdat */
10490 xabrdt = cc$rms_xabrdt;
10492 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10494 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10495 * is unsigned long[2], while DECC & VAXC use a struct */
10496 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10498 fab_out.fab$l_xab = (void *) &xabrdt;
10501 rab_in = cc$rms_rab;
10502 rab_in.rab$l_fab = &fab_in;
10503 rab_in.rab$l_rop = RAB$M_BIO;
10504 rab_in.rab$l_ubf = ubf;
10505 rab_in.rab$w_usz = sizeof ubf;
10506 if (!((sts = sys$connect(&rab_in)) & 1)) {
10507 sys$close(&fab_in); sys$close(&fab_out);
10508 set_errno(EVMSERR); set_vaxc_errno(sts);
10512 rab_out = cc$rms_rab;
10513 rab_out.rab$l_fab = &fab_out;
10514 rab_out.rab$l_rbf = ubf;
10515 if (!((sts = sys$connect(&rab_out)) & 1)) {
10516 sys$close(&fab_in); sys$close(&fab_out);
10517 set_errno(EVMSERR); set_vaxc_errno(sts);
10521 while ((sts = sys$read(&rab_in))) { /* always true */
10522 if (sts == RMS$_EOF) break;
10523 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10524 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10525 sys$close(&fab_in); sys$close(&fab_out);
10526 set_errno(EVMSERR); set_vaxc_errno(sts);
10531 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10532 sys$close(&fab_in); sys$close(&fab_out);
10533 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10535 set_errno(EVMSERR); set_vaxc_errno(sts);
10541 } /* end of rmscopy() */
10543 /* ODS-5 support version */
10545 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
10547 char *vmsin, * vmsout, *esa, *esa_out,
10549 unsigned long int i, sts, sts2;
10550 struct FAB fab_in, fab_out;
10551 struct RAB rab_in, rab_out;
10553 struct NAML nam_out;
10554 struct XABDAT xabdat;
10555 struct XABFHC xabfhc;
10556 struct XABRDT xabrdt;
10557 struct XABSUM xabsum;
10559 vmsin = PerlMem_malloc(VMS_MAXRSS);
10560 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
10561 vmsout = PerlMem_malloc(VMS_MAXRSS);
10562 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
10563 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) ||
10564 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) {
10565 PerlMem_free(vmsin);
10566 PerlMem_free(vmsout);
10567 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10571 esa = PerlMem_malloc(VMS_MAXRSS);
10572 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
10574 fab_in = cc$rms_fab;
10575 fab_in.fab$l_fna = (char *) -1;
10576 fab_in.fab$b_fns = 0;
10577 nam.naml$l_long_filename = vmsin;
10578 nam.naml$l_long_filename_size = strlen(vmsin);
10579 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
10580 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
10581 fab_in.fab$l_fop = FAB$M_SQO;
10582 fab_in.fab$l_naml = &nam;
10583 fab_in.fab$l_xab = (void *) &xabdat;
10585 rsa = PerlMem_malloc(VMS_MAXRSS);
10586 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
10587 nam.naml$l_rsa = NULL;
10588 nam.naml$b_rss = 0;
10589 nam.naml$l_long_result = rsa;
10590 nam.naml$l_long_result_alloc = VMS_MAXRSS - 1;
10591 nam.naml$l_esa = NULL;
10592 nam.naml$b_ess = 0;
10593 nam.naml$l_long_expand = esa;
10594 nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10595 nam.naml$b_esl = nam.naml$b_rsl = 0;
10596 nam.naml$l_long_expand_size = 0;
10597 nam.naml$l_long_result_size = 0;
10598 #ifdef NAM$M_NO_SHORT_UPCASE
10599 if (decc_efs_case_preserve)
10600 nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
10603 xabdat = cc$rms_xabdat; /* To get creation date */
10604 xabdat.xab$l_nxt = (void *) &xabfhc;
10606 xabfhc = cc$rms_xabfhc; /* To get record length */
10607 xabfhc.xab$l_nxt = (void *) &xabsum;
10609 xabsum = cc$rms_xabsum; /* To get key and area information */
10611 if (!((sts = sys$open(&fab_in)) & 1)) {
10612 PerlMem_free(vmsin);
10613 PerlMem_free(vmsout);
10616 set_vaxc_errno(sts);
10618 case RMS$_FNF: case RMS$_DNF:
10619 set_errno(ENOENT); break;
10621 set_errno(ENOTDIR); break;
10623 set_errno(ENODEV); break;
10625 set_errno(EINVAL); break;
10627 set_errno(EACCES); break;
10629 set_errno(EVMSERR);
10636 fab_out.fab$w_ifi = 0;
10637 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
10638 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
10639 fab_out.fab$l_fop = FAB$M_SQO;
10640 fab_out.fab$l_naml = &nam_out;
10641 fab_out.fab$l_fna = (char *) -1;
10642 fab_out.fab$b_fns = 0;
10643 nam_out.naml$l_long_filename = vmsout;
10644 nam_out.naml$l_long_filename_size = strlen(vmsout);
10645 fab_out.fab$l_dna = (char *) -1;
10646 fab_out.fab$b_dns = 0;
10647 nam_out.naml$l_long_defname = nam.naml$l_long_name;
10648 nam_out.naml$l_long_defname_size =
10649 nam.naml$l_long_name ?
10650 nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0;
10652 esa_out = PerlMem_malloc(VMS_MAXRSS);
10653 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
10654 nam_out.naml$l_rsa = NULL;
10655 nam_out.naml$b_rss = 0;
10656 nam_out.naml$l_long_result = NULL;
10657 nam_out.naml$l_long_result_alloc = 0;
10658 nam_out.naml$l_esa = NULL;
10659 nam_out.naml$b_ess = 0;
10660 nam_out.naml$l_long_expand = esa_out;
10661 nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1;
10663 if (preserve_dates == 0) { /* Act like DCL COPY */
10664 nam_out.naml$b_nop |= NAM$M_SYNCHK;
10665 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
10666 if (!((sts = sys$parse(&fab_out)) & 1)) {
10667 PerlMem_free(vmsin);
10668 PerlMem_free(vmsout);
10671 PerlMem_free(esa_out);
10672 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
10673 set_vaxc_errno(sts);
10676 fab_out.fab$l_xab = (void *) &xabdat;
10677 if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1;
10679 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
10680 preserve_dates =0; /* bitmask from this point forward */
10682 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
10683 if (!((sts = sys$create(&fab_out)) & 1)) {
10684 PerlMem_free(vmsin);
10685 PerlMem_free(vmsout);
10688 PerlMem_free(esa_out);
10689 set_vaxc_errno(sts);
10692 set_errno(ENOENT); break;
10694 set_errno(ENOTDIR); break;
10696 set_errno(ENODEV); break;
10698 set_errno(EINVAL); break;
10700 set_errno(EACCES); break;
10702 set_errno(EVMSERR);
10706 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
10707 if (preserve_dates & 2) {
10708 /* sys$close() will process xabrdt, not xabdat */
10709 xabrdt = cc$rms_xabrdt;
10711 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
10713 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
10714 * is unsigned long[2], while DECC & VAXC use a struct */
10715 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
10717 fab_out.fab$l_xab = (void *) &xabrdt;
10720 ubf = PerlMem_malloc(32256);
10721 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
10722 rab_in = cc$rms_rab;
10723 rab_in.rab$l_fab = &fab_in;
10724 rab_in.rab$l_rop = RAB$M_BIO;
10725 rab_in.rab$l_ubf = ubf;
10726 rab_in.rab$w_usz = 32256;
10727 if (!((sts = sys$connect(&rab_in)) & 1)) {
10728 sys$close(&fab_in); sys$close(&fab_out);
10729 PerlMem_free(vmsin);
10730 PerlMem_free(vmsout);
10734 PerlMem_free(esa_out);
10735 set_errno(EVMSERR); set_vaxc_errno(sts);
10739 rab_out = cc$rms_rab;
10740 rab_out.rab$l_fab = &fab_out;
10741 rab_out.rab$l_rbf = ubf;
10742 if (!((sts = sys$connect(&rab_out)) & 1)) {
10743 sys$close(&fab_in); sys$close(&fab_out);
10744 PerlMem_free(vmsin);
10745 PerlMem_free(vmsout);
10749 PerlMem_free(esa_out);
10750 set_errno(EVMSERR); set_vaxc_errno(sts);
10754 while ((sts = sys$read(&rab_in))) { /* always true */
10755 if (sts == RMS$_EOF) break;
10756 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
10757 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
10758 sys$close(&fab_in); sys$close(&fab_out);
10759 PerlMem_free(vmsin);
10760 PerlMem_free(vmsout);
10764 PerlMem_free(esa_out);
10765 set_errno(EVMSERR); set_vaxc_errno(sts);
10771 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
10772 sys$close(&fab_in); sys$close(&fab_out);
10773 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
10775 PerlMem_free(vmsin);
10776 PerlMem_free(vmsout);
10780 PerlMem_free(esa_out);
10781 set_errno(EVMSERR); set_vaxc_errno(sts);
10785 PerlMem_free(vmsin);
10786 PerlMem_free(vmsout);
10790 PerlMem_free(esa_out);
10793 } /* end of rmscopy() */
10798 /*** The following glue provides 'hooks' to make some of the routines
10799 * from this file available from Perl. These routines are sufficiently
10800 * basic, and are required sufficiently early in the build process,
10801 * that's it's nice to have them available to miniperl as well as the
10802 * full Perl, so they're set up here instead of in an extension. The
10803 * Perl code which handles importation of these names into a given
10804 * package lives in [.VMS]Filespec.pm in @INC.
10808 rmsexpand_fromperl(pTHX_ CV *cv)
10811 char *fspec, *defspec = NULL, *rslt;
10814 if (!items || items > 2)
10815 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
10816 fspec = SvPV(ST(0),n_a);
10817 if (!fspec || !*fspec) XSRETURN_UNDEF;
10818 if (items == 2) defspec = SvPV(ST(1),n_a);
10820 rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
10821 ST(0) = sv_newmortal();
10822 if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
10827 vmsify_fromperl(pTHX_ CV *cv)
10833 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
10834 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1);
10835 ST(0) = sv_newmortal();
10836 if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified));
10841 unixify_fromperl(pTHX_ CV *cv)
10847 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
10848 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1);
10849 ST(0) = sv_newmortal();
10850 if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified));
10855 fileify_fromperl(pTHX_ CV *cv)
10861 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
10862 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1);
10863 ST(0) = sv_newmortal();
10864 if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified));
10869 pathify_fromperl(pTHX_ CV *cv)
10875 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
10876 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1);
10877 ST(0) = sv_newmortal();
10878 if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified));
10883 vmspath_fromperl(pTHX_ CV *cv)
10889 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
10890 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1);
10891 ST(0) = sv_newmortal();
10892 if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath));
10897 unixpath_fromperl(pTHX_ CV *cv)
10903 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
10904 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1);
10905 ST(0) = sv_newmortal();
10906 if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath));
10911 candelete_fromperl(pTHX_ CV *cv)
10914 char fspec[NAM$C_MAXRSS+1], *fsp;
10919 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
10921 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10922 if (SvTYPE(mysv) == SVt_PVGV) {
10923 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
10924 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10931 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
10932 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10938 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
10943 rmscopy_fromperl(pTHX_ CV *cv)
10946 char *inspec, *outspec, *inp, *outp;
10948 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
10949 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10950 unsigned long int sts;
10955 if (items < 2 || items > 3)
10956 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
10958 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
10959 Newx(inspec, VMS_MAXRSS, char);
10960 if (SvTYPE(mysv) == SVt_PVGV) {
10961 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
10962 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10970 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
10971 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10977 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
10978 Newx(outspec, VMS_MAXRSS, char);
10979 if (SvTYPE(mysv) == SVt_PVGV) {
10980 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
10981 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10990 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
10991 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10998 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11000 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11006 /* The mod2fname is limited to shorter filenames by design, so it should
11007 * not be modified to support longer EFS pathnames
11010 mod2fname(pTHX_ CV *cv)
11013 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11014 workbuff[NAM$C_MAXRSS*1 + 1];
11015 int total_namelen = 3, counter, num_entries;
11016 /* ODS-5 ups this, but we want to be consistent, so... */
11017 int max_name_len = 39;
11018 AV *in_array = (AV *)SvRV(ST(0));
11020 num_entries = av_len(in_array);
11022 /* All the names start with PL_. */
11023 strcpy(ultimate_name, "PL_");
11025 /* Clean up our working buffer */
11026 Zero(work_name, sizeof(work_name), char);
11028 /* Run through the entries and build up a working name */
11029 for(counter = 0; counter <= num_entries; counter++) {
11030 /* If it's not the first name then tack on a __ */
11032 strcat(work_name, "__");
11034 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11038 /* Check to see if we actually have to bother...*/
11039 if (strlen(work_name) + 3 <= max_name_len) {
11040 strcat(ultimate_name, work_name);
11042 /* It's too darned big, so we need to go strip. We use the same */
11043 /* algorithm as xsubpp does. First, strip out doubled __ */
11044 char *source, *dest, last;
11047 for (source = work_name; *source; source++) {
11048 if (last == *source && last == '_') {
11054 /* Go put it back */
11055 strcpy(work_name, workbuff);
11056 /* Is it still too big? */
11057 if (strlen(work_name) + 3 > max_name_len) {
11058 /* Strip duplicate letters */
11061 for (source = work_name; *source; source++) {
11062 if (last == toupper(*source)) {
11066 last = toupper(*source);
11068 strcpy(work_name, workbuff);
11071 /* Is it *still* too big? */
11072 if (strlen(work_name) + 3 > max_name_len) {
11073 /* Too bad, we truncate */
11074 work_name[max_name_len - 2] = 0;
11076 strcat(ultimate_name, work_name);
11079 /* Okay, return it */
11080 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11085 hushexit_fromperl(pTHX_ CV *cv)
11090 VMSISH_HUSHED = SvTRUE(ST(0));
11092 ST(0) = boolSV(VMSISH_HUSHED);
11098 Perl_vms_start_glob
11099 (pTHX_ SV *tmpglob,
11103 struct vs_str_st *rslt;
11107 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11110 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11111 struct dsc$descriptor_vs rsdsc;
11112 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11113 unsigned long hasver = 0, isunix = 0;
11114 unsigned long int lff_flags = 0;
11117 #ifdef VMS_LONGNAME_SUPPORT
11118 lff_flags = LIB$M_FIL_LONG_NAMES;
11120 /* The Newx macro will not allow me to assign a smaller array
11121 * to the rslt pointer, so we will assign it to the begin char pointer
11122 * and then copy the value into the rslt pointer.
11124 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11125 rslt = (struct vs_str_st *)begin;
11127 rstr = &rslt->str[0];
11128 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11129 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11130 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11131 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11133 Newx(vmsspec, VMS_MAXRSS, char);
11135 /* We could find out if there's an explicit dev/dir or version
11136 by peeking into lib$find_file's internal context at
11137 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11138 but that's unsupported, so I don't want to do it now and
11139 have it bite someone in the future. */
11140 /* Fix-me: vms_split_path() is the only way to do this, the
11141 existing method will fail with many legal EFS or UNIX specifications
11144 cp = SvPV(tmpglob,i);
11147 if (cp[i] == ';') hasver = 1;
11148 if (cp[i] == '.') {
11149 if (sts) hasver = 1;
11152 if (cp[i] == '/') {
11153 hasdir = isunix = 1;
11156 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11161 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11164 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11165 if (!stat_sts && S_ISDIR(st.st_mode)) {
11166 wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec);
11167 ok = (wilddsc.dsc$a_pointer != NULL);
11170 wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec);
11171 ok = (wilddsc.dsc$a_pointer != NULL);
11174 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11176 /* If not extended character set, replace ? with % */
11177 /* With extended character set, ? is a wildcard single character */
11178 if (!decc_efs_case_preserve) {
11179 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11180 if (*cp == '?') *cp = '%';
11183 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11184 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11185 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11187 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11188 &dfltdsc,NULL,&rms_sts,&lff_flags);
11189 if (!$VMS_STATUS_SUCCESS(sts))
11192 /* with varying string, 1st word of buffer contains result length */
11193 rstr[rslt->length] = '\0';
11195 /* Find where all the components are */
11196 v_sts = vms_split_path
11211 /* If no version on input, truncate the version on output */
11212 if (!hasver && (vs_len > 0)) {
11216 /* No version & a null extension on UNIX handling */
11217 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11223 if (!decc_efs_case_preserve) {
11224 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11228 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11232 /* Start with the name */
11235 strcat(begin,"\n");
11236 ok = (PerlIO_puts(tmpfp,begin) != EOF);
11238 if (cxt) (void)lib$find_file_end(&cxt);
11239 if (ok && sts != RMS$_NMF &&
11240 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11243 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11245 PerlIO_close(tmpfp);
11249 PerlIO_rewind(tmpfp);
11250 IoTYPE(io) = IoTYPE_RDONLY;
11251 IoIFP(io) = fp = tmpfp;
11252 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
11262 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec);
11265 vms_realpath_fromperl(pTHX_ CV *cv)
11268 char *fspec, *rslt_spec, *rslt;
11271 if (!items || items != 1)
11272 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11274 fspec = SvPV(ST(0),n_a);
11275 if (!fspec || !*fspec) XSRETURN_UNDEF;
11277 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11278 rslt = do_vms_realpath(fspec, rslt_spec);
11279 ST(0) = sv_newmortal();
11281 sv_usepvn(ST(0),rslt,strlen(rslt));
11283 Safefree(rslt_spec);
11288 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11289 int do_vms_case_tolerant(void);
11292 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11295 ST(0) = boolSV(do_vms_case_tolerant());
11301 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11302 struct interp_intern *dst)
11304 memcpy(dst,src,sizeof(struct interp_intern));
11308 Perl_sys_intern_clear(pTHX)
11313 Perl_sys_intern_init(pTHX)
11315 unsigned int ix = RAND_MAX;
11320 /* fix me later to track running under GNV */
11321 /* this allows some limited testing */
11322 MY_POSIX_EXIT = decc_filename_unix_report;
11325 MY_INV_RAND_MAX = 1./x;
11329 init_os_extras(void)
11332 char* file = __FILE__;
11333 char temp_buff[512];
11334 if (my_trnlnm("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", temp_buff, 0)) {
11335 no_translate_barewords = TRUE;
11337 no_translate_barewords = FALSE;
11340 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11341 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11342 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11343 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11344 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11345 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11346 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11347 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11348 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11349 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11350 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11352 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11354 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11355 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11358 store_pipelocs(aTHX); /* will redo any earlier attempts */
11365 #if __CRTL_VER == 80200000
11366 /* This missed getting in to the DECC SDK for 8.2 */
11367 char *realpath(const char *file_name, char * resolved_name, ...);
11370 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11371 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11372 * The perl fallback routine to provide realpath() is not as efficient
11376 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11378 return realpath(filespec, outbuf);
11382 /* External entry points */
11383 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11384 { return do_vms_realpath(filespec, outbuf); }
11386 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf)
11391 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11392 /* case_tolerant */
11394 /*{{{int do_vms_case_tolerant(void)*/
11395 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11396 * controlled by a process setting.
11398 int do_vms_case_tolerant(void)
11400 return vms_process_case_tolerant;
11403 /* External entry points */
11404 int Perl_vms_case_tolerant(void)
11405 { return do_vms_case_tolerant(); }
11407 int Perl_vms_case_tolerant(void)
11408 { return vms_process_case_tolerant; }
11412 /* Start of DECC RTL Feature handling */
11414 static int sys_trnlnm
11415 (const char * logname,
11419 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11420 const unsigned long attr = LNM$M_CASE_BLIND;
11421 struct dsc$descriptor_s name_dsc;
11423 unsigned short result;
11424 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11427 name_dsc.dsc$w_length = strlen(logname);
11428 name_dsc.dsc$a_pointer = (char *)logname;
11429 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11430 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11432 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11434 if ($VMS_STATUS_SUCCESS(status)) {
11436 /* Null terminate and return the string */
11437 /*--------------------------------------*/
11444 static int sys_crelnm
11445 (const char * logname,
11446 const char * value)
11449 const char * proc_table = "LNM$PROCESS_TABLE";
11450 struct dsc$descriptor_s proc_table_dsc;
11451 struct dsc$descriptor_s logname_dsc;
11452 struct itmlst_3 item_list[2];
11454 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11455 proc_table_dsc.dsc$w_length = strlen(proc_table);
11456 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11457 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11459 logname_dsc.dsc$a_pointer = (char *) logname;
11460 logname_dsc.dsc$w_length = strlen(logname);
11461 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11462 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11464 item_list[0].buflen = strlen(value);
11465 item_list[0].itmcode = LNM$_STRING;
11466 item_list[0].bufadr = (char *)value;
11467 item_list[0].retlen = NULL;
11469 item_list[1].buflen = 0;
11470 item_list[1].itmcode = 0;
11472 ret_val = sys$crelnm
11474 (const struct dsc$descriptor_s *)&proc_table_dsc,
11475 (const struct dsc$descriptor_s *)&logname_dsc,
11477 (const struct item_list_3 *) item_list);
11483 /* C RTL Feature settings */
11485 static int set_features
11486 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
11487 int (* cli_routine)(void), /* Not documented */
11488 void *image_info) /* Not documented */
11495 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11496 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
11497 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
11498 unsigned long case_perm;
11499 unsigned long case_image;
11502 /* Allow an exception to bring Perl into the VMS debugger */
11503 vms_debug_on_exception = 0;
11504 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
11505 if ($VMS_STATUS_SUCCESS(status)) {
11506 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11507 vms_debug_on_exception = 1;
11509 vms_debug_on_exception = 0;
11513 /* hacks to see if known bugs are still present for testing */
11515 /* Readdir is returning filenames in VMS syntax always */
11516 decc_bug_readdir_efs1 = 1;
11517 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
11518 if ($VMS_STATUS_SUCCESS(status)) {
11519 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11520 decc_bug_readdir_efs1 = 1;
11522 decc_bug_readdir_efs1 = 0;
11525 /* PCP mode requires creating /dev/null special device file */
11526 decc_bug_devnull = 1;
11527 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
11528 if ($VMS_STATUS_SUCCESS(status)) {
11529 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11530 decc_bug_devnull = 1;
11532 decc_bug_devnull = 0;
11535 /* fgetname returning a VMS name in UNIX mode */
11536 decc_bug_fgetname = 1;
11537 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
11538 if ($VMS_STATUS_SUCCESS(status)) {
11539 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11540 decc_bug_fgetname = 1;
11542 decc_bug_fgetname = 0;
11545 /* UNIX directory names with no paths are broken in a lot of places */
11546 decc_dir_barename = 1;
11547 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
11548 if ($VMS_STATUS_SUCCESS(status)) {
11549 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
11550 decc_dir_barename = 1;
11552 decc_dir_barename = 0;
11555 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11556 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
11558 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
11559 if (decc_disable_to_vms_logname_translation < 0)
11560 decc_disable_to_vms_logname_translation = 0;
11563 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
11565 decc_efs_case_preserve = decc$feature_get_value(s, 1);
11566 if (decc_efs_case_preserve < 0)
11567 decc_efs_case_preserve = 0;
11570 s = decc$feature_get_index("DECC$EFS_CHARSET");
11572 decc_efs_charset = decc$feature_get_value(s, 1);
11573 if (decc_efs_charset < 0)
11574 decc_efs_charset = 0;
11577 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
11579 decc_filename_unix_report = decc$feature_get_value(s, 1);
11580 if (decc_filename_unix_report > 0)
11581 decc_filename_unix_report = 1;
11583 decc_filename_unix_report = 0;
11586 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
11588 decc_filename_unix_only = decc$feature_get_value(s, 1);
11589 if (decc_filename_unix_only > 0) {
11590 decc_filename_unix_only = 1;
11593 decc_filename_unix_only = 0;
11597 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
11599 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
11600 if (decc_filename_unix_no_version < 0)
11601 decc_filename_unix_no_version = 0;
11604 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
11606 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
11607 if (decc_readdir_dropdotnotype < 0)
11608 decc_readdir_dropdotnotype = 0;
11611 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
11612 if ($VMS_STATUS_SUCCESS(status)) {
11613 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
11615 dflt = decc$feature_get_value(s, 4);
11617 decc_disable_posix_root = decc$feature_get_value(s, 1);
11618 if (decc_disable_posix_root <= 0) {
11619 decc$feature_set_value(s, 1, 1);
11620 decc_disable_posix_root = 1;
11624 /* Traditionally Perl assumes this is off */
11625 decc_disable_posix_root = 1;
11626 decc$feature_set_value(s, 1, 1);
11631 #if __CRTL_VER >= 80200000
11632 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
11634 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
11635 if (decc_posix_compliant_pathnames < 0)
11636 decc_posix_compliant_pathnames = 0;
11637 if (decc_posix_compliant_pathnames > 4)
11638 decc_posix_compliant_pathnames = 0;
11643 status = sys_trnlnm
11644 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
11645 if ($VMS_STATUS_SUCCESS(status)) {
11646 val_str[0] = _toupper(val_str[0]);
11647 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11648 decc_disable_to_vms_logname_translation = 1;
11653 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
11654 if ($VMS_STATUS_SUCCESS(status)) {
11655 val_str[0] = _toupper(val_str[0]);
11656 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11657 decc_efs_case_preserve = 1;
11662 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
11663 if ($VMS_STATUS_SUCCESS(status)) {
11664 val_str[0] = _toupper(val_str[0]);
11665 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11666 decc_filename_unix_report = 1;
11669 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
11670 if ($VMS_STATUS_SUCCESS(status)) {
11671 val_str[0] = _toupper(val_str[0]);
11672 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11673 decc_filename_unix_only = 1;
11674 decc_filename_unix_report = 1;
11677 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
11678 if ($VMS_STATUS_SUCCESS(status)) {
11679 val_str[0] = _toupper(val_str[0]);
11680 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11681 decc_filename_unix_no_version = 1;
11684 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
11685 if ($VMS_STATUS_SUCCESS(status)) {
11686 val_str[0] = _toupper(val_str[0]);
11687 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
11688 decc_readdir_dropdotnotype = 1;
11693 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
11695 /* Report true case tolerance */
11696 /*----------------------------*/
11697 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
11698 if (!$VMS_STATUS_SUCCESS(status))
11699 case_perm = PPROP$K_CASE_BLIND;
11700 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
11701 if (!$VMS_STATUS_SUCCESS(status))
11702 case_image = PPROP$K_CASE_BLIND;
11703 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
11704 (case_image == PPROP$K_CASE_SENSITIVE))
11705 vms_process_case_tolerant = 0;
11710 /* CRTL can be initialized past this point, but not before. */
11711 /* DECC$CRTL_INIT(); */
11717 /* DECC dependent attributes */
11718 #if __DECC_VER < 60560002
11720 #define not_executable
11722 #define relative ,rel
11723 #define not_executable ,noexe
11726 #pragma extern_model save
11727 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
11729 const __align (LONGWORD) int spare[8] = {0};
11730 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
11733 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
11734 nowrt,noshr relative not_executable
11736 const long vms_cc_features = (const long)set_features;
11739 ** Force a reference to LIB$INITIALIZE to ensure it
11740 ** exists in the image.
11742 int lib$initialize(void);
11744 #pragma extern_model strict_refdef
11746 int lib_init_ref = (int) lib$initialize;
11749 #pragma extern_model restore