3 * VMS-specific routines for perl5
6 * August 2005 Convert VMS status code to UNIX status codes
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
44 #include <str$routines.h>
50 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
52 #define NO_EFN EFN$C_ENF
57 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
58 int decc$feature_get_index(const char *name);
59 char* decc$feature_get_name(int index);
60 int decc$feature_get_value(int index, int mode);
61 int decc$feature_set_value(int index, int mode, int value);
66 #pragma member_alignment save
67 #pragma nomember_alignment longword
72 unsigned short * retadr;
74 #pragma member_alignment restore
76 /* More specific prototype than in starlet_c.h makes programming errors
85 const struct dsc$descriptor_s * devnam,
86 const struct item_list_3 * itmlst,
88 void * (astadr)(unsigned long),
92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
94 static int set_feature_default(const char *name, int value)
99 index = decc$feature_get_index(name);
101 status = decc$feature_set_value(index, 1, value);
102 if (index == -1 || (status == -1)) {
106 status = decc$feature_get_value(index, 1);
107 if (status != value) {
115 /* Older versions of ssdef.h don't have these */
116 #ifndef SS$_INVFILFOROP
117 # define SS$_INVFILFOROP 3930
119 #ifndef SS$_NOSUCHOBJECT
120 # define SS$_NOSUCHOBJECT 2696
123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
124 #define PERLIO_NOT_STDIO 0
126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
127 * code below needs to get to the underlying CRTL routines. */
128 #define DONT_MASK_RTL_CALLS
132 /* Anticipating future expansion in lexical warnings . . . */
133 #ifndef WARN_INTERNAL
134 # define WARN_INTERNAL WARN_MISC
137 #ifdef VMS_LONGNAME_SUPPORT
138 #include <libfildef.h>
141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
142 # define RTL_USES_UTC 1
146 /* gcc's header files don't #define direct access macros
147 * corresponding to VAXC's variant structs */
149 # define uic$v_format uic$r_uic_form.uic$v_format
150 # define uic$v_group uic$r_uic_form.uic$v_group
151 # define uic$v_member uic$r_uic_form.uic$v_member
152 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
153 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
154 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
155 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
158 #if defined(NEED_AN_H_ERRNO)
163 #pragma message disable pragma
164 #pragma member_alignment save
165 #pragma nomember_alignment longword
167 #pragma message disable misalgndmem
170 unsigned short int buflen;
171 unsigned short int itmcode;
173 unsigned short int *retlen;
176 struct filescan_itmlst_2 {
177 unsigned short length;
178 unsigned short itmcode;
183 unsigned short length;
188 #pragma message restore
189 #pragma member_alignment restore
192 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
193 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
194 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
195 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
196 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
197 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
198 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
199 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
200 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
201 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
202 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
204 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
205 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
206 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
207 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
213 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
216 #define PERL_LNM_MAX_ITER 10
218 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
220 #define MAX_DCL_SYMBOL (8192)
221 #define MAX_DCL_LINE_LENGTH (4096 - 4)
223 #define MAX_DCL_SYMBOL (1024)
224 #define MAX_DCL_LINE_LENGTH (1024 - 4)
227 static char *__mystrtolower(char *str)
229 if (str) for (; *str; ++str) *str= tolower(*str);
233 static struct dsc$descriptor_s fildevdsc =
234 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
235 static struct dsc$descriptor_s crtlenvdsc =
236 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
239 static struct dsc$descriptor_s **env_tables = defenv;
240 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
242 /* True if we shouldn't treat barewords as logicals during directory */
244 static int no_translate_barewords;
247 static int tz_updated = 1;
250 /* DECC Features that may need to affect how Perl interprets
251 * displays filename information
253 static int decc_disable_to_vms_logname_translation = 1;
254 static int decc_disable_posix_root = 1;
255 int decc_efs_case_preserve = 0;
256 static int decc_efs_charset = 0;
257 static int decc_filename_unix_no_version = 0;
258 static int decc_filename_unix_only = 0;
259 int decc_filename_unix_report = 0;
260 int decc_posix_compliant_pathnames = 0;
261 int decc_readdir_dropdotnotype = 0;
262 static int vms_process_case_tolerant = 1;
263 int vms_vtf7_filenames = 0;
264 int gnv_unix_shell = 0;
266 /* bug workarounds if needed */
267 int decc_bug_readdir_efs1 = 0;
268 int decc_bug_devnull = 1;
269 int decc_bug_fgetname = 0;
270 int decc_dir_barename = 0;
272 static int vms_debug_on_exception = 0;
274 /* Is this a UNIX file specification?
275 * No longer a simple check with EFS file specs
276 * For now, not a full check, but need to
277 * handle POSIX ^UP^ specifications
278 * Fixing to handle ^/ cases would require
279 * changes to many other conversion routines.
282 static int is_unix_filespec(const char *path)
288 if (strncmp(path,"\"^UP^",5) != 0) {
289 pch1 = strchr(path, '/');
294 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
295 if (decc_filename_unix_report || decc_filename_unix_only) {
296 if (strcmp(path,".") == 0)
304 /* This routine converts a UCS-2 character to be VTF-7 encoded.
307 static void ucs2_to_vtf7
309 unsigned long ucs2_char,
312 unsigned char * ucs_ptr;
315 ucs_ptr = (unsigned char *)&ucs2_char;
319 hex = (ucs_ptr[1] >> 4) & 0xf;
321 outspec[2] = hex + '0';
323 outspec[2] = (hex - 9) + 'A';
324 hex = ucs_ptr[1] & 0xF;
326 outspec[3] = hex + '0';
328 outspec[3] = (hex - 9) + 'A';
330 hex = (ucs_ptr[0] >> 4) & 0xf;
332 outspec[4] = hex + '0';
334 outspec[4] = (hex - 9) + 'A';
335 hex = ucs_ptr[1] & 0xF;
337 outspec[5] = hex + '0';
339 outspec[5] = (hex - 9) + 'A';
345 /* This handles the conversion of a UNIX extended character set to a ^
346 * escaped VMS character.
347 * in a UNIX file specification.
349 * The output count variable contains the number of characters added
350 * to the output string.
352 * The return value is the number of characters read from the input string
354 static int copy_expand_unix_filename_escape
355 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
363 utf8_flag = *utf8_fl;
367 if (*inspec >= 0x80) {
368 if (utf8_fl && vms_vtf7_filenames) {
369 unsigned long ucs_char;
373 if ((*inspec & 0xE0) == 0xC0) {
375 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
376 if (ucs_char >= 0x80) {
377 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
380 } else if ((*inspec & 0xF0) == 0xE0) {
382 ucs_char = ((inspec[0] & 0xF) << 12) +
383 ((inspec[1] & 0x3f) << 6) +
385 if (ucs_char >= 0x800) {
386 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
390 #if 0 /* I do not see longer sequences supported by OpenVMS */
391 /* Maybe some one can fix this later */
392 } else if ((*inspec & 0xF8) == 0xF0) {
395 } else if ((*inspec & 0xFC) == 0xF8) {
398 } else if ((*inspec & 0xFE) == 0xFC) {
405 /* High bit set, but not a unicode character! */
407 /* Non printing DECMCS or ISO Latin-1 character? */
408 if (*inspec <= 0x9F) {
412 hex = (*inspec >> 4) & 0xF;
414 outspec[1] = hex + '0';
416 outspec[1] = (hex - 9) + 'A';
420 outspec[2] = hex + '0';
422 outspec[2] = (hex - 9) + 'A';
426 } else if (*inspec == 0xA0) {
432 } else if (*inspec == 0xFF) {
444 /* Is this a macro that needs to be passed through?
445 * Macros start with $( and an alpha character, followed
446 * by a string of alpha numeric characters ending with a )
447 * If this does not match, then encode it as ODS-5.
449 if ((inspec[0] == '$') && (inspec[1] == '(')) {
452 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
454 outspec[0] = inspec[0];
455 outspec[1] = inspec[1];
456 outspec[2] = inspec[2];
458 while(isalnum(inspec[tcnt]) ||
459 (inspec[2] == '.') || (inspec[2] == '_')) {
460 outspec[tcnt] = inspec[tcnt];
463 if (inspec[tcnt] == ')') {
464 outspec[tcnt] = inspec[tcnt];
481 if (decc_efs_charset == 0)
508 /* Assume that this is to be escaped */
510 outspec[1] = *inspec;
514 case ' ': /* space */
515 /* Assume that this is to be escaped */
530 /* This handles the expansion of a '^' prefix to the proper character
531 * in a UNIX file specification.
533 * The output count variable contains the number of characters added
534 * to the output string.
536 * The return value is the number of characters read from the input
539 static int copy_expand_vms_filename_escape
540 (char *outspec, const char *inspec, int *output_cnt)
547 if (*inspec == '^') {
551 /* Non trailing dots should just be passed through */
556 case '_': /* space */
562 case 'U': /* Unicode - FIX-ME this is wrong. */
565 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
568 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
569 outspec[0] == c1 & 0xff;
570 outspec[1] == c2 & 0xff;
577 /* Error - do best we can to continue */
587 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
591 scnt = sscanf(inspec, "%2x", &c1);
592 outspec[0] = c1 & 0xff;
615 (const struct dsc$descriptor_s * srcstr,
616 struct filescan_itmlst_2 * valuelist,
617 unsigned long * fldflags,
618 struct dsc$descriptor_s *auxout,
619 unsigned short * retlen);
621 /* vms_split_path - Verify that the input file specification is a
622 * VMS format file specification, and provide pointers to the components of
623 * it. With EFS format filenames, this is virtually the only way to
624 * parse a VMS path specification into components.
626 * If the sum of the components do not add up to the length of the
627 * string, then the passed file specification is probably a UNIX style
630 static int vms_split_path
645 struct dsc$descriptor path_desc;
649 struct filescan_itmlst_2 item_list[9];
650 const int filespec = 0;
651 const int nodespec = 1;
652 const int devspec = 2;
653 const int rootspec = 3;
654 const int dirspec = 4;
655 const int namespec = 5;
656 const int typespec = 6;
657 const int verspec = 7;
659 /* Assume the worst for an easy exit */
674 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
675 path_desc.dsc$w_length = strlen(path);
676 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
677 path_desc.dsc$b_class = DSC$K_CLASS_S;
679 /* Get the total length, if it is shorter than the string passed
680 * then this was probably not a VMS formatted file specification
682 item_list[filespec].itmcode = FSCN$_FILESPEC;
683 item_list[filespec].length = 0;
684 item_list[filespec].component = NULL;
686 /* If the node is present, then it gets considered as part of the
687 * volume name to hopefully make things simple.
689 item_list[nodespec].itmcode = FSCN$_NODE;
690 item_list[nodespec].length = 0;
691 item_list[nodespec].component = NULL;
693 item_list[devspec].itmcode = FSCN$_DEVICE;
694 item_list[devspec].length = 0;
695 item_list[devspec].component = NULL;
697 /* root is a special case, adding it to either the directory or
698 * the device components will probalby complicate things for the
699 * callers of this routine, so leave it separate.
701 item_list[rootspec].itmcode = FSCN$_ROOT;
702 item_list[rootspec].length = 0;
703 item_list[rootspec].component = NULL;
705 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
706 item_list[dirspec].length = 0;
707 item_list[dirspec].component = NULL;
709 item_list[namespec].itmcode = FSCN$_NAME;
710 item_list[namespec].length = 0;
711 item_list[namespec].component = NULL;
713 item_list[typespec].itmcode = FSCN$_TYPE;
714 item_list[typespec].length = 0;
715 item_list[typespec].component = NULL;
717 item_list[verspec].itmcode = FSCN$_VERSION;
718 item_list[verspec].length = 0;
719 item_list[verspec].component = NULL;
721 item_list[8].itmcode = 0;
722 item_list[8].length = 0;
723 item_list[8].component = NULL;
725 status = SYS$FILESCAN
726 ((const struct dsc$descriptor_s *)&path_desc, item_list,
728 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
730 /* If we parsed it successfully these two lengths should be the same */
731 if (path_desc.dsc$w_length != item_list[filespec].length)
734 /* If we got here, then it is a VMS file specification */
737 /* set the volume name */
738 if (item_list[nodespec].length > 0) {
739 *volume = item_list[nodespec].component;
740 *vol_len = item_list[nodespec].length + item_list[devspec].length;
743 *volume = item_list[devspec].component;
744 *vol_len = item_list[devspec].length;
747 *root = item_list[rootspec].component;
748 *root_len = item_list[rootspec].length;
750 *dir = item_list[dirspec].component;
751 *dir_len = item_list[dirspec].length;
753 /* Now fun with versions and EFS file specifications
754 * The parser can not tell the difference when a "." is a version
755 * delimiter or a part of the file specification.
757 if ((decc_efs_charset) &&
758 (item_list[verspec].length > 0) &&
759 (item_list[verspec].component[0] == '.')) {
760 *name = item_list[namespec].component;
761 *name_len = item_list[namespec].length + item_list[typespec].length;
762 *ext = item_list[verspec].component;
763 *ext_len = item_list[verspec].length;
768 *name = item_list[namespec].component;
769 *name_len = item_list[namespec].length;
770 *ext = item_list[typespec].component;
771 *ext_len = item_list[typespec].length;
772 *version = item_list[verspec].component;
773 *ver_len = item_list[verspec].length;
780 * Routine to retrieve the maximum equivalence index for an input
781 * logical name. Some calls to this routine have no knowledge if
782 * the variable is a logical or not. So on error we return a max
785 /*{{{int my_maxidx(const char *lnm) */
787 my_maxidx(const char *lnm)
791 int attr = LNM$M_CASE_BLIND;
792 struct dsc$descriptor lnmdsc;
793 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
796 lnmdsc.dsc$w_length = strlen(lnm);
797 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
798 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
799 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
801 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
802 if ((status & 1) == 0)
809 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
811 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
812 struct dsc$descriptor_s **tabvec, unsigned long int flags)
815 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
816 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
817 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
819 unsigned char acmode;
820 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
821 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
822 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
823 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
825 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
826 #if defined(PERL_IMPLICIT_CONTEXT)
829 aTHX = PERL_GET_INTERP;
835 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
836 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
838 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
839 *cp2 = _toupper(*cp1);
840 if (cp1 - lnm > LNM$C_NAMLENGTH) {
841 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
845 lnmdsc.dsc$w_length = cp1 - lnm;
846 lnmdsc.dsc$a_pointer = uplnm;
847 uplnm[lnmdsc.dsc$w_length] = '\0';
848 secure = flags & PERL__TRNENV_SECURE;
849 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
850 if (!tabvec || !*tabvec) tabvec = env_tables;
852 for (curtab = 0; tabvec[curtab]; curtab++) {
853 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
854 if (!ivenv && !secure) {
859 Perl_warn(aTHX_ "Can't read CRTL environ\n");
862 retsts = SS$_NOLOGNAM;
863 for (i = 0; environ[i]; i++) {
864 if ((eq = strchr(environ[i],'=')) &&
865 lnmdsc.dsc$w_length == (eq - environ[i]) &&
866 !strncmp(environ[i],uplnm,eq - environ[i])) {
868 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
869 if (!eqvlen) continue;
874 if (retsts != SS$_NOLOGNAM) break;
877 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
878 !str$case_blind_compare(&tmpdsc,&clisym)) {
879 if (!ivsym && !secure) {
880 unsigned short int deflen = LNM$C_NAMLENGTH;
881 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
882 /* dynamic dsc to accomodate possible long value */
883 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
884 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
886 if (eqvlen > MAX_DCL_SYMBOL) {
887 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
888 eqvlen = MAX_DCL_SYMBOL;
889 /* Special hack--we might be called before the interpreter's */
890 /* fully initialized, in which case either thr or PL_curcop */
891 /* might be bogus. We have to check, since ckWARN needs them */
892 /* both to be valid if running threaded */
893 if (ckWARN(WARN_MISC)) {
894 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
897 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
899 _ckvmssts(lib$sfree1_dd(&eqvdsc));
900 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
901 if (retsts == LIB$_NOSUCHSYM) continue;
906 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
907 midx = my_maxidx(lnm);
908 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
909 lnmlst[1].bufadr = cp2;
911 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
912 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
913 if (retsts == SS$_NOLOGNAM) break;
914 /* PPFs have a prefix */
917 *((int *)uplnm) == *((int *)"SYS$") &&
919 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
920 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
921 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
922 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
923 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
924 memmove(eqv,eqv+4,eqvlen-4);
930 if ((retsts == SS$_IVLOGNAM) ||
931 (retsts == SS$_NOLOGNAM)) { continue; }
934 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
935 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
936 if (retsts == SS$_NOLOGNAM) continue;
939 eqvlen = strlen(eqv);
943 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
944 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
945 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
946 retsts == SS$_NOLOGNAM) {
947 set_errno(EINVAL); set_vaxc_errno(retsts);
949 else _ckvmssts(retsts);
951 } /* end of vmstrnenv */
954 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
955 /* Define as a function so we can access statics. */
956 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
958 return vmstrnenv(lnm,eqv,idx,fildev,
959 #ifdef SECURE_INTERNAL_GETENV
960 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
969 * Note: Uses Perl temp to store result so char * can be returned to
970 * caller; this pointer will be invalidated at next Perl statement
972 * We define this as a function rather than a macro in terms of my_getenv_len()
973 * so that it'll work when PL_curinterp is undefined (and we therefore can't
976 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
978 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
981 static char *__my_getenv_eqv = NULL;
982 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
983 unsigned long int idx = 0;
984 int trnsuccess, success, secure, saverr, savvmserr;
988 midx = my_maxidx(lnm) + 1;
990 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
991 /* Set up a temporary buffer for the return value; Perl will
992 * clean it up at the next statement transition */
993 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
994 if (!tmpsv) return NULL;
998 /* Assume no interpreter ==> single thread */
999 if (__my_getenv_eqv != NULL) {
1000 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1003 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1005 eqv = __my_getenv_eqv;
1008 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1009 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1011 getcwd(eqv,LNM$C_NAMLENGTH);
1015 /* Get rid of "000000/ in rooted filespecs */
1018 zeros = strstr(eqv, "/000000/");
1019 if (zeros != NULL) {
1021 mlen = len - (zeros - eqv) - 7;
1022 memmove(zeros, &zeros[7], mlen);
1030 /* Impose security constraints only if tainting */
1032 /* Impose security constraints only if tainting */
1033 secure = PL_curinterp ? PL_tainting : will_taint;
1034 saverr = errno; savvmserr = vaxc$errno;
1041 #ifdef SECURE_INTERNAL_GETENV
1042 secure ? PERL__TRNENV_SECURE : 0
1048 /* For the getenv interface we combine all the equivalence names
1049 * of a search list logical into one value to acquire a maximum
1050 * value length of 255*128 (assuming %ENV is using logicals).
1052 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1054 /* If the name contains a semicolon-delimited index, parse it
1055 * off and make sure we only retrieve the equivalence name for
1057 if ((cp2 = strchr(lnm,';')) != NULL) {
1059 uplnm[cp2-lnm] = '\0';
1060 idx = strtoul(cp2+1,NULL,0);
1062 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1065 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1067 /* Discard NOLOGNAM on internal calls since we're often looking
1068 * for an optional name, and this "error" often shows up as the
1069 * (bogus) exit status for a die() call later on. */
1070 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1071 return success ? eqv : Nullch;
1074 } /* end of my_getenv() */
1078 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1080 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1084 unsigned long idx = 0;
1086 static char *__my_getenv_len_eqv = NULL;
1087 int secure, saverr, savvmserr;
1090 midx = my_maxidx(lnm) + 1;
1092 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1093 /* Set up a temporary buffer for the return value; Perl will
1094 * clean it up at the next statement transition */
1095 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1096 if (!tmpsv) return NULL;
1100 /* Assume no interpreter ==> single thread */
1101 if (__my_getenv_len_eqv != NULL) {
1102 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1105 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1107 buf = __my_getenv_len_eqv;
1110 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1111 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1114 getcwd(buf,LNM$C_NAMLENGTH);
1117 /* Get rid of "000000/ in rooted filespecs */
1119 zeros = strstr(buf, "/000000/");
1120 if (zeros != NULL) {
1122 mlen = *len - (zeros - buf) - 7;
1123 memmove(zeros, &zeros[7], mlen);
1132 /* Impose security constraints only if tainting */
1133 secure = PL_curinterp ? PL_tainting : will_taint;
1134 saverr = errno; savvmserr = vaxc$errno;
1141 #ifdef SECURE_INTERNAL_GETENV
1142 secure ? PERL__TRNENV_SECURE : 0
1148 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1150 if ((cp2 = strchr(lnm,';')) != NULL) {
1152 buf[cp2-lnm] = '\0';
1153 idx = strtoul(cp2+1,NULL,0);
1155 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1158 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1160 /* Get rid of "000000/ in rooted filespecs */
1163 zeros = strstr(buf, "/000000/");
1164 if (zeros != NULL) {
1166 mlen = *len - (zeros - buf) - 7;
1167 memmove(zeros, &zeros[7], mlen);
1173 /* Discard NOLOGNAM on internal calls since we're often looking
1174 * for an optional name, and this "error" often shows up as the
1175 * (bogus) exit status for a die() call later on. */
1176 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1177 return *len ? buf : Nullch;
1180 } /* end of my_getenv_len() */
1183 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1185 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1187 /*{{{ void prime_env_iter() */
1189 prime_env_iter(void)
1190 /* Fill the %ENV associative array with all logical names we can
1191 * find, in preparation for iterating over it.
1194 static int primed = 0;
1195 HV *seenhv = NULL, *envhv;
1197 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1198 unsigned short int chan;
1199 #ifndef CLI$M_TRUSTED
1200 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1202 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1203 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1205 bool have_sym = FALSE, have_lnm = FALSE;
1206 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1207 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1208 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1209 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1210 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1211 #if defined(PERL_IMPLICIT_CONTEXT)
1214 #if defined(USE_ITHREADS)
1215 static perl_mutex primenv_mutex;
1216 MUTEX_INIT(&primenv_mutex);
1219 #if defined(PERL_IMPLICIT_CONTEXT)
1220 /* We jump through these hoops because we can be called at */
1221 /* platform-specific initialization time, which is before anything is */
1222 /* set up--we can't even do a plain dTHX since that relies on the */
1223 /* interpreter structure to be initialized */
1225 aTHX = PERL_GET_INTERP;
1231 if (primed || !PL_envgv) return;
1232 MUTEX_LOCK(&primenv_mutex);
1233 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1234 envhv = GvHVn(PL_envgv);
1235 /* Perform a dummy fetch as an lval to insure that the hash table is
1236 * set up. Otherwise, the hv_store() will turn into a nullop. */
1237 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1239 for (i = 0; env_tables[i]; i++) {
1240 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1241 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1242 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1244 if (have_sym || have_lnm) {
1245 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1246 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1247 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1248 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1251 for (i--; i >= 0; i--) {
1252 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1255 for (j = 0; environ[j]; j++) {
1256 if (!(start = strchr(environ[j],'='))) {
1257 if (ckWARN(WARN_INTERNAL))
1258 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1262 sv = newSVpv(start,0);
1264 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1269 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1270 !str$case_blind_compare(&tmpdsc,&clisym)) {
1271 strcpy(cmd,"Show Symbol/Global *");
1272 cmddsc.dsc$w_length = 20;
1273 if (env_tables[i]->dsc$w_length == 12 &&
1274 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1275 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1276 flags = defflags | CLI$M_NOLOGNAM;
1279 strcpy(cmd,"Show Logical *");
1280 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1281 strcat(cmd," /Table=");
1282 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1283 cmddsc.dsc$w_length = strlen(cmd);
1285 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1286 flags = defflags | CLI$M_NOCLISYM;
1289 /* Create a new subprocess to execute each command, to exclude the
1290 * remote possibility that someone could subvert a mbx or file used
1291 * to write multiple commands to a single subprocess.
1294 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1295 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1296 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1297 defflags &= ~CLI$M_TRUSTED;
1298 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1300 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1301 if (seenhv) SvREFCNT_dec(seenhv);
1304 char *cp1, *cp2, *key;
1305 unsigned long int sts, iosb[2], retlen, keylen;
1308 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1309 if (sts & 1) sts = iosb[0] & 0xffff;
1310 if (sts == SS$_ENDOFFILE) {
1312 while (substs == 0) { sys$hiber(); wakect++;}
1313 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1318 retlen = iosb[0] >> 16;
1319 if (!retlen) continue; /* blank line */
1321 if (iosb[1] != subpid) {
1323 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1327 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1328 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1330 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1331 if (*cp1 == '(' || /* Logical name table name */
1332 *cp1 == '=' /* Next eqv of searchlist */) continue;
1333 if (*cp1 == '"') cp1++;
1334 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1335 key = cp1; keylen = cp2 - cp1;
1336 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1337 while (*cp2 && *cp2 != '=') cp2++;
1338 while (*cp2 && *cp2 == '=') cp2++;
1339 while (*cp2 && *cp2 == ' ') cp2++;
1340 if (*cp2 == '"') { /* String translation; may embed "" */
1341 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1342 cp2++; cp1--; /* Skip "" surrounding translation */
1344 else { /* Numeric translation */
1345 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1346 cp1--; /* stop on last non-space char */
1348 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1349 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1352 PERL_HASH(hash,key,keylen);
1354 if (cp1 == cp2 && *cp2 == '.') {
1355 /* A single dot usually means an unprintable character, such as a null
1356 * to indicate a zero-length value. Get the actual value to make sure.
1358 char lnm[LNM$C_NAMLENGTH+1];
1359 char eqv[MAX_DCL_SYMBOL+1];
1361 strncpy(lnm, key, keylen);
1362 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1363 sv = newSVpvn(eqv, strlen(eqv));
1366 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1370 hv_store(envhv,key,keylen,sv,hash);
1371 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1373 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1374 /* get the PPFs for this process, not the subprocess */
1375 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1376 char eqv[LNM$C_NAMLENGTH+1];
1378 for (i = 0; ppfs[i]; i++) {
1379 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1380 sv = newSVpv(eqv,trnlen);
1382 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1387 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1388 if (buf) Safefree(buf);
1389 if (seenhv) SvREFCNT_dec(seenhv);
1390 MUTEX_UNLOCK(&primenv_mutex);
1393 } /* end of prime_env_iter */
1397 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1398 /* Define or delete an element in the same "environment" as
1399 * vmstrnenv(). If an element is to be deleted, it's removed from
1400 * the first place it's found. If it's to be set, it's set in the
1401 * place designated by the first element of the table vector.
1402 * Like setenv() returns 0 for success, non-zero on error.
1405 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1408 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1409 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1411 unsigned long int retsts, usermode = PSL$C_USER;
1412 struct itmlst_3 *ile, *ilist;
1413 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1414 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1415 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1416 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1417 $DESCRIPTOR(local,"_LOCAL");
1420 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1421 return SS$_IVLOGNAM;
1424 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1425 *cp2 = _toupper(*cp1);
1426 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1427 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1428 return SS$_IVLOGNAM;
1431 lnmdsc.dsc$w_length = cp1 - lnm;
1432 if (!tabvec || !*tabvec) tabvec = env_tables;
1434 if (!eqv) { /* we're deleting n element */
1435 for (curtab = 0; tabvec[curtab]; curtab++) {
1436 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1438 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1439 if ((cp1 = strchr(environ[i],'=')) &&
1440 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1441 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1443 return setenv(lnm,"",1) ? vaxc$errno : 0;
1446 ivenv = 1; retsts = SS$_NOLOGNAM;
1448 if (ckWARN(WARN_INTERNAL))
1449 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1450 ivenv = 1; retsts = SS$_NOSUCHPGM;
1456 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1457 !str$case_blind_compare(&tmpdsc,&clisym)) {
1458 unsigned int symtype;
1459 if (tabvec[curtab]->dsc$w_length == 12 &&
1460 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1461 !str$case_blind_compare(&tmpdsc,&local))
1462 symtype = LIB$K_CLI_LOCAL_SYM;
1463 else symtype = LIB$K_CLI_GLOBAL_SYM;
1464 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1465 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1466 if (retsts == LIB$_NOSUCHSYM) continue;
1470 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1471 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1472 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1473 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1474 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1478 else { /* we're defining a value */
1479 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1481 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1483 if (ckWARN(WARN_INTERNAL))
1484 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1485 retsts = SS$_NOSUCHPGM;
1489 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1490 eqvdsc.dsc$w_length = strlen(eqv);
1491 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1492 !str$case_blind_compare(&tmpdsc,&clisym)) {
1493 unsigned int symtype;
1494 if (tabvec[0]->dsc$w_length == 12 &&
1495 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1496 !str$case_blind_compare(&tmpdsc,&local))
1497 symtype = LIB$K_CLI_LOCAL_SYM;
1498 else symtype = LIB$K_CLI_GLOBAL_SYM;
1499 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1502 if (!*eqv) eqvdsc.dsc$w_length = 1;
1503 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1505 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1506 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1507 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1508 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1509 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1510 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1513 Newx(ilist,nseg+1,struct itmlst_3);
1516 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1519 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1521 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1522 ile->itmcode = LNM$_STRING;
1524 if ((j+1) == nseg) {
1525 ile->buflen = strlen(c);
1526 /* in case we are truncating one that's too long */
1527 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1530 ile->buflen = LNM$C_NAMLENGTH;
1534 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1538 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1543 if (!(retsts & 1)) {
1545 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1546 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1547 set_errno(EVMSERR); break;
1548 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1549 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1550 set_errno(EINVAL); break;
1552 set_errno(EACCES); break;
1557 set_vaxc_errno(retsts);
1558 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1561 /* We reset error values on success because Perl does an hv_fetch()
1562 * before each hv_store(), and if the thing we're setting didn't
1563 * previously exist, we've got a leftover error message. (Of course,
1564 * this fails in the face of
1565 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1566 * in that the error reported in $! isn't spurious,
1567 * but it's right more often than not.)
1569 set_errno(0); set_vaxc_errno(retsts);
1573 } /* end of vmssetenv() */
1576 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1577 /* This has to be a function since there's a prototype for it in proto.h */
1579 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1582 int len = strlen(lnm);
1586 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1587 if (!strcmp(uplnm,"DEFAULT")) {
1588 if (eqv && *eqv) my_chdir(eqv);
1592 #ifndef RTL_USES_UTC
1593 if (len == 6 || len == 2) {
1596 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1598 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1599 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1603 (void) vmssetenv(lnm,eqv,NULL);
1607 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1609 * sets a user-mode logical in the process logical name table
1610 * used for redirection of sys$error
1613 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1615 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1616 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1617 unsigned long int iss, attr = LNM$M_CONFINE;
1618 unsigned char acmode = PSL$C_USER;
1619 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1621 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1622 d_name.dsc$w_length = strlen(name);
1624 lnmlst[0].buflen = strlen(eqv);
1625 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1627 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1628 if (!(iss&1)) lib$signal(iss);
1633 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1634 /* my_crypt - VMS password hashing
1635 * my_crypt() provides an interface compatible with the Unix crypt()
1636 * C library function, and uses sys$hash_password() to perform VMS
1637 * password hashing. The quadword hashed password value is returned
1638 * as a NUL-terminated 8 character string. my_crypt() does not change
1639 * the case of its string arguments; in order to match the behavior
1640 * of LOGINOUT et al., alphabetic characters in both arguments must
1641 * be upcased by the caller.
1643 * - fix me to call ACM services when available
1646 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1648 # ifndef UAI$C_PREFERRED_ALGORITHM
1649 # define UAI$C_PREFERRED_ALGORITHM 127
1651 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1652 unsigned short int salt = 0;
1653 unsigned long int sts;
1655 unsigned short int dsc$w_length;
1656 unsigned char dsc$b_type;
1657 unsigned char dsc$b_class;
1658 const char * dsc$a_pointer;
1659 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1660 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1661 struct itmlst_3 uailst[3] = {
1662 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1663 { sizeof salt, UAI$_SALT, &salt, 0},
1664 { 0, 0, NULL, NULL}};
1665 static char hash[9];
1667 usrdsc.dsc$w_length = strlen(usrname);
1668 usrdsc.dsc$a_pointer = usrname;
1669 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1671 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1675 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1680 set_vaxc_errno(sts);
1681 if (sts != RMS$_RNF) return NULL;
1684 txtdsc.dsc$w_length = strlen(textpasswd);
1685 txtdsc.dsc$a_pointer = textpasswd;
1686 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1687 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1690 return (char *) hash;
1692 } /* end of my_crypt() */
1696 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1697 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1698 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1700 /* fixup barenames that are directories for internal use.
1701 * There have been problems with the consistent handling of UNIX
1702 * style directory names when routines are presented with a name that
1703 * has no directory delimitors at all. So this routine will eventually
1706 static char * fixup_bare_dirnames(const char * name)
1708 if (decc_disable_to_vms_logname_translation) {
1715 * A little hack to get around a bug in some implemenation of remove()
1716 * that do not know how to delete a directory
1718 * Delete any file to which user has control access, regardless of whether
1719 * delete access is explicitly allowed.
1720 * Limitations: User must have write access to parent directory.
1721 * Does not block signals or ASTs; if interrupted in midstream
1722 * may leave file with an altered ACL.
1725 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1727 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1729 char *vmsname, *rspec;
1731 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1732 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1733 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1735 unsigned char myace$b_length;
1736 unsigned char myace$b_type;
1737 unsigned short int myace$w_flags;
1738 unsigned long int myace$l_access;
1739 unsigned long int myace$l_ident;
1740 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1741 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1742 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1744 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1745 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1746 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1747 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1748 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1749 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1751 /* Expand the input spec using RMS, since the CRTL remove() and
1752 * system services won't do this by themselves, so we may miss
1753 * a file "hiding" behind a logical name or search list. */
1754 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1755 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1757 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1758 PerlMem_free(vmsname);
1762 if (decc_posix_compliant_pathnames) {
1763 /* In POSIX mode, we prefer to remove the UNIX name */
1765 remove_name = (char *)name;
1768 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1769 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1770 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1771 PerlMem_free(rspec);
1772 PerlMem_free(vmsname);
1775 PerlMem_free(vmsname);
1776 remove_name = rspec;
1779 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1781 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1782 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1783 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1785 do_pathify_dirspec(name, remove_name, 0, NULL);
1786 if (!rmdir(remove_name)) {
1788 PerlMem_free(remove_name);
1789 PerlMem_free(rspec);
1790 return 0; /* Can we just get rid of it? */
1794 if (!rmdir(remove_name)) {
1795 PerlMem_free(rspec);
1796 return 0; /* Can we just get rid of it? */
1802 if (!remove(remove_name)) {
1803 PerlMem_free(rspec);
1804 return 0; /* Can we just get rid of it? */
1807 /* If not, can changing protections help? */
1808 if (vaxc$errno != RMS$_PRV) {
1809 PerlMem_free(rspec);
1813 /* No, so we get our own UIC to use as a rights identifier,
1814 * and the insert an ACE at the head of the ACL which allows us
1815 * to delete the file.
1817 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1818 fildsc.dsc$w_length = strlen(rspec);
1819 fildsc.dsc$a_pointer = rspec;
1821 newace.myace$l_ident = oldace.myace$l_ident;
1822 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1824 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1825 set_errno(ENOENT); break;
1827 set_errno(ENOTDIR); break;
1829 set_errno(ENODEV); break;
1830 case RMS$_SYN: case SS$_INVFILFOROP:
1831 set_errno(EINVAL); break;
1833 set_errno(EACCES); break;
1837 set_vaxc_errno(aclsts);
1838 PerlMem_free(rspec);
1841 /* Grab any existing ACEs with this identifier in case we fail */
1842 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1843 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1844 || fndsts == SS$_NOMOREACE ) {
1845 /* Add the new ACE . . . */
1846 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1849 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1851 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1852 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1853 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1855 do_pathify_dirspec(name, remove_name, 0, NULL);
1856 rmsts = rmdir(remove_name);
1857 PerlMem_free(remove_name);
1860 rmsts = rmdir(remove_name);
1864 rmsts = remove(remove_name);
1866 /* We blew it - dir with files in it, no write priv for
1867 * parent directory, etc. Put things back the way they were. */
1868 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1871 addlst[0].bufadr = &oldace;
1872 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1879 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1880 /* We just deleted it, so of course it's not there. Some versions of
1881 * VMS seem to return success on the unlock operation anyhow (after all
1882 * the unlock is successful), but others don't.
1884 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1885 if (aclsts & 1) aclsts = fndsts;
1886 if (!(aclsts & 1)) {
1888 set_vaxc_errno(aclsts);
1889 PerlMem_free(rspec);
1893 PerlMem_free(rspec);
1896 } /* end of kill_file() */
1900 /*{{{int do_rmdir(char *name)*/
1902 Perl_do_rmdir(pTHX_ const char *name)
1904 char dirfile[NAM$C_MAXRSS+1];
1908 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1909 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1910 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1913 } /* end of do_rmdir */
1917 * Delete any file to which user has control access, regardless of whether
1918 * delete access is explicitly allowed.
1919 * Limitations: User must have write access to parent directory.
1920 * Does not block signals or ASTs; if interrupted in midstream
1921 * may leave file with an altered ACL.
1924 /*{{{int kill_file(char *name)*/
1926 Perl_kill_file(pTHX_ const char *name)
1928 char rspec[NAM$C_MAXRSS+1];
1930 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1931 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1932 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1934 unsigned char myace$b_length;
1935 unsigned char myace$b_type;
1936 unsigned short int myace$w_flags;
1937 unsigned long int myace$l_access;
1938 unsigned long int myace$l_ident;
1939 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1940 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1941 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1943 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1944 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1945 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1946 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1947 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1948 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1950 /* Expand the input spec using RMS, since the CRTL remove() and
1951 * system services won't do this by themselves, so we may miss
1952 * a file "hiding" behind a logical name or search list. */
1953 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1954 if (tspec == NULL) return -1;
1955 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1956 /* If not, can changing protections help? */
1957 if (vaxc$errno != RMS$_PRV) return -1;
1959 /* No, so we get our own UIC to use as a rights identifier,
1960 * and the insert an ACE at the head of the ACL which allows us
1961 * to delete the file.
1963 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1964 fildsc.dsc$w_length = strlen(rspec);
1965 fildsc.dsc$a_pointer = rspec;
1967 newace.myace$l_ident = oldace.myace$l_ident;
1968 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1970 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1971 set_errno(ENOENT); break;
1973 set_errno(ENOTDIR); break;
1975 set_errno(ENODEV); break;
1976 case RMS$_SYN: case SS$_INVFILFOROP:
1977 set_errno(EINVAL); break;
1979 set_errno(EACCES); break;
1983 set_vaxc_errno(aclsts);
1986 /* Grab any existing ACEs with this identifier in case we fail */
1987 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1988 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1989 || fndsts == SS$_NOMOREACE ) {
1990 /* Add the new ACE . . . */
1991 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1993 if ((rmsts = remove(name))) {
1994 /* We blew it - dir with files in it, no write priv for
1995 * parent directory, etc. Put things back the way they were. */
1996 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1999 addlst[0].bufadr = &oldace;
2000 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2007 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2008 /* We just deleted it, so of course it's not there. Some versions of
2009 * VMS seem to return success on the unlock operation anyhow (after all
2010 * the unlock is successful), but others don't.
2012 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2013 if (aclsts & 1) aclsts = fndsts;
2014 if (!(aclsts & 1)) {
2016 set_vaxc_errno(aclsts);
2022 } /* end of kill_file() */
2026 /*{{{int my_mkdir(char *,Mode_t)*/
2028 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2030 STRLEN dirlen = strlen(dir);
2032 /* zero length string sometimes gives ACCVIO */
2033 if (dirlen == 0) return -1;
2035 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2036 * null file name/type. However, it's commonplace under Unix,
2037 * so we'll allow it for a gain in portability.
2039 if (dir[dirlen-1] == '/') {
2040 char *newdir = savepvn(dir,dirlen-1);
2041 int ret = mkdir(newdir,mode);
2045 else return mkdir(dir,mode);
2046 } /* end of my_mkdir */
2049 /*{{{int my_chdir(char *)*/
2051 Perl_my_chdir(pTHX_ const char *dir)
2053 STRLEN dirlen = strlen(dir);
2055 /* zero length string sometimes gives ACCVIO */
2056 if (dirlen == 0) return -1;
2059 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2061 * so that existing scripts do not need to be changed.
2064 while ((dirlen > 0) && (*dir1 == ' ')) {
2069 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2071 * null file name/type. However, it's commonplace under Unix,
2072 * so we'll allow it for a gain in portability.
2074 * - Preview- '/' will be valid soon on VMS
2076 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2077 char *newdir = savepvn(dir1,dirlen-1);
2078 int ret = chdir(newdir);
2082 else return chdir(dir1);
2083 } /* end of my_chdir */
2087 /*{{{FILE *my_tmpfile()*/
2094 if ((fp = tmpfile())) return fp;
2096 cp = PerlMem_malloc(L_tmpnam+24);
2097 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2099 if (decc_filename_unix_only == 0)
2100 strcpy(cp,"Sys$Scratch:");
2103 tmpnam(cp+strlen(cp));
2104 strcat(cp,".Perltmp");
2105 fp = fopen(cp,"w+","fop=dlt");
2112 #ifndef HOMEGROWN_POSIX_SIGNALS
2114 * The C RTL's sigaction fails to check for invalid signal numbers so we
2115 * help it out a bit. The docs are correct, but the actual routine doesn't
2116 * do what the docs say it will.
2118 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2120 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2121 struct sigaction* oact)
2123 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2124 SETERRNO(EINVAL, SS$_INVARG);
2127 return sigaction(sig, act, oact);
2132 #ifdef KILL_BY_SIGPRC
2133 #include <errnodef.h>
2135 /* We implement our own kill() using the undocumented system service
2136 sys$sigprc for one of two reasons:
2138 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2139 target process to do a sys$exit, which usually can't be handled
2140 gracefully...certainly not by Perl and the %SIG{} mechanism.
2142 2.) If the kill() in the CRTL can't be called from a signal
2143 handler without disappearing into the ether, i.e., the signal
2144 it purportedly sends is never trapped. Still true as of VMS 7.3.
2146 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2147 in the target process rather than calling sys$exit.
2149 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2150 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2151 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2152 with condition codes C$_SIG0+nsig*8, catching the exception on the
2153 target process and resignaling with appropriate arguments.
2155 But we don't have that VMS 7.0+ exception handler, so if you
2156 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2158 Also note that SIGTERM is listed in the docs as being "unimplemented",
2159 yet always seems to be signaled with a VMS condition code of 4 (and
2160 correctly handled for that code). So we hardwire it in.
2162 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2163 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2164 than signalling with an unrecognized (and unhandled by CRTL) code.
2167 #define _MY_SIG_MAX 28
2170 Perl_sig_to_vmscondition_int(int sig)
2172 static unsigned int sig_code[_MY_SIG_MAX+1] =
2175 SS$_HANGUP, /* 1 SIGHUP */
2176 SS$_CONTROLC, /* 2 SIGINT */
2177 SS$_CONTROLY, /* 3 SIGQUIT */
2178 SS$_RADRMOD, /* 4 SIGILL */
2179 SS$_BREAK, /* 5 SIGTRAP */
2180 SS$_OPCCUS, /* 6 SIGABRT */
2181 SS$_COMPAT, /* 7 SIGEMT */
2183 SS$_FLTOVF, /* 8 SIGFPE VAX */
2185 SS$_HPARITH, /* 8 SIGFPE AXP */
2187 SS$_ABORT, /* 9 SIGKILL */
2188 SS$_ACCVIO, /* 10 SIGBUS */
2189 SS$_ACCVIO, /* 11 SIGSEGV */
2190 SS$_BADPARAM, /* 12 SIGSYS */
2191 SS$_NOMBX, /* 13 SIGPIPE */
2192 SS$_ASTFLT, /* 14 SIGALRM */
2209 #if __VMS_VER >= 60200000
2210 static int initted = 0;
2213 sig_code[16] = C$_SIGUSR1;
2214 sig_code[17] = C$_SIGUSR2;
2215 #if __CRTL_VER >= 70000000
2216 sig_code[20] = C$_SIGCHLD;
2218 #if __CRTL_VER >= 70300000
2219 sig_code[28] = C$_SIGWINCH;
2224 if (sig < _SIG_MIN) return 0;
2225 if (sig > _MY_SIG_MAX) return 0;
2226 return sig_code[sig];
2230 Perl_sig_to_vmscondition(int sig)
2233 if (vms_debug_on_exception != 0)
2234 lib$signal(SS$_DEBUG);
2236 return Perl_sig_to_vmscondition_int(sig);
2241 Perl_my_kill(int pid, int sig)
2246 int sys$sigprc(unsigned int *pidadr,
2247 struct dsc$descriptor_s *prcname,
2250 /* sig 0 means validate the PID */
2251 /*------------------------------*/
2253 const unsigned long int jpicode = JPI$_PID;
2256 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2257 if ($VMS_STATUS_SUCCESS(status))
2260 case SS$_NOSUCHNODE:
2261 case SS$_UNREACHABLE:
2275 code = Perl_sig_to_vmscondition_int(sig);
2278 SETERRNO(EINVAL, SS$_BADPARAM);
2282 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2283 * signals are to be sent to multiple processes.
2284 * pid = 0 - all processes in group except ones that the system exempts
2285 * pid = -1 - all processes except ones that the system exempts
2286 * pid = -n - all processes in group (abs(n)) except ...
2287 * For now, just report as not supported.
2291 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2295 iss = sys$sigprc((unsigned int *)&pid,0,code);
2296 if (iss&1) return 0;
2300 set_errno(EPERM); break;
2302 case SS$_NOSUCHNODE:
2303 case SS$_UNREACHABLE:
2304 set_errno(ESRCH); break;
2306 set_errno(ENOMEM); break;
2311 set_vaxc_errno(iss);
2317 /* Routine to convert a VMS status code to a UNIX status code.
2318 ** More tricky than it appears because of conflicting conventions with
2321 ** VMS status codes are a bit mask, with the least significant bit set for
2324 ** Special UNIX status of EVMSERR indicates that no translation is currently
2325 ** available, and programs should check the VMS status code.
2327 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2331 #ifndef C_FACILITY_NO
2332 #define C_FACILITY_NO 0x350000
2335 #define DCL_IVVERB 0x38090
2338 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2346 /* Assume the best or the worst */
2347 if (vms_status & STS$M_SUCCESS)
2350 unix_status = EVMSERR;
2352 msg_status = vms_status & ~STS$M_CONTROL;
2354 facility = vms_status & STS$M_FAC_NO;
2355 fac_sp = vms_status & STS$M_FAC_SP;
2356 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2358 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2364 unix_status = EFAULT;
2366 case SS$_DEVOFFLINE:
2367 unix_status = EBUSY;
2370 unix_status = ENOTCONN;
2378 case SS$_INVFILFOROP:
2382 unix_status = EINVAL;
2384 case SS$_UNSUPPORTED:
2385 unix_status = ENOTSUP;
2390 unix_status = EACCES;
2392 case SS$_DEVICEFULL:
2393 unix_status = ENOSPC;
2396 unix_status = ENODEV;
2398 case SS$_NOSUCHFILE:
2399 case SS$_NOSUCHOBJECT:
2400 unix_status = ENOENT;
2402 case SS$_ABORT: /* Fatal case */
2403 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2404 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2405 unix_status = EINTR;
2408 unix_status = E2BIG;
2411 unix_status = ENOMEM;
2414 unix_status = EPERM;
2416 case SS$_NOSUCHNODE:
2417 case SS$_UNREACHABLE:
2418 unix_status = ESRCH;
2421 unix_status = ECHILD;
2424 if ((facility == 0) && (msg_no < 8)) {
2425 /* These are not real VMS status codes so assume that they are
2426 ** already UNIX status codes
2428 unix_status = msg_no;
2434 /* Translate a POSIX exit code to a UNIX exit code */
2435 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2436 unix_status = (msg_no & 0x07F8) >> 3;
2440 /* Documented traditional behavior for handling VMS child exits */
2441 /*--------------------------------------------------------------*/
2442 if (child_flag != 0) {
2444 /* Success / Informational return 0 */
2445 /*----------------------------------*/
2446 if (msg_no & STS$K_SUCCESS)
2449 /* Warning returns 1 */
2450 /*-------------------*/
2451 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2454 /* Everything else pass through the severity bits */
2455 /*------------------------------------------------*/
2456 return (msg_no & STS$M_SEVERITY);
2459 /* Normal VMS status to ERRNO mapping attempt */
2460 /*--------------------------------------------*/
2461 switch(msg_status) {
2462 /* case RMS$_EOF: */ /* End of File */
2463 case RMS$_FNF: /* File Not Found */
2464 case RMS$_DNF: /* Dir Not Found */
2465 unix_status = ENOENT;
2467 case RMS$_RNF: /* Record Not Found */
2468 unix_status = ESRCH;
2471 unix_status = ENOTDIR;
2474 unix_status = ENODEV;
2479 unix_status = EBADF;
2482 unix_status = EEXIST;
2486 case LIB$_INVSTRDES:
2488 case LIB$_NOSUCHSYM:
2489 case LIB$_INVSYMNAM:
2491 unix_status = EINVAL;
2497 unix_status = E2BIG;
2499 case RMS$_PRV: /* No privilege */
2500 case RMS$_ACC: /* ACP file access failed */
2501 case RMS$_WLK: /* Device write locked */
2502 unix_status = EACCES;
2504 /* case RMS$_NMF: */ /* No more files */
2512 /* Try to guess at what VMS error status should go with a UNIX errno
2513 * value. This is hard to do as there could be many possible VMS
2514 * error statuses that caused the errno value to be set.
2517 int Perl_unix_status_to_vms(int unix_status)
2519 int test_unix_status;
2521 /* Trivial cases first */
2522 /*---------------------*/
2523 if (unix_status == EVMSERR)
2526 /* Is vaxc$errno sane? */
2527 /*---------------------*/
2528 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2529 if (test_unix_status == unix_status)
2532 /* If way out of range, must be VMS code already */
2533 /*-----------------------------------------------*/
2534 if (unix_status > EVMSERR)
2537 /* If out of range, punt */
2538 /*-----------------------*/
2539 if (unix_status > __ERRNO_MAX)
2543 /* Ok, now we have to do it the hard way. */
2544 /*----------------------------------------*/
2545 switch(unix_status) {
2546 case 0: return SS$_NORMAL;
2547 case EPERM: return SS$_NOPRIV;
2548 case ENOENT: return SS$_NOSUCHOBJECT;
2549 case ESRCH: return SS$_UNREACHABLE;
2550 case EINTR: return SS$_ABORT;
2553 case E2BIG: return SS$_BUFFEROVF;
2555 case EBADF: return RMS$_IFI;
2556 case ECHILD: return SS$_NONEXPR;
2558 case ENOMEM: return SS$_INSFMEM;
2559 case EACCES: return SS$_FILACCERR;
2560 case EFAULT: return SS$_ACCVIO;
2562 case EBUSY: return SS$_DEVOFFLINE;
2563 case EEXIST: return RMS$_FEX;
2565 case ENODEV: return SS$_NOSUCHDEV;
2566 case ENOTDIR: return RMS$_DIR;
2568 case EINVAL: return SS$_INVARG;
2574 case ENOSPC: return SS$_DEVICEFULL;
2575 case ESPIPE: return LIB$_INVARG;
2580 case ERANGE: return LIB$_INVARG;
2581 /* case EWOULDBLOCK */
2582 /* case EINPROGRESS */
2585 /* case EDESTADDRREQ */
2587 /* case EPROTOTYPE */
2588 /* case ENOPROTOOPT */
2589 /* case EPROTONOSUPPORT */
2590 /* case ESOCKTNOSUPPORT */
2591 /* case EOPNOTSUPP */
2592 /* case EPFNOSUPPORT */
2593 /* case EAFNOSUPPORT */
2594 /* case EADDRINUSE */
2595 /* case EADDRNOTAVAIL */
2597 /* case ENETUNREACH */
2598 /* case ENETRESET */
2599 /* case ECONNABORTED */
2600 /* case ECONNRESET */
2603 case ENOTCONN: return SS$_CLEARED;
2604 /* case ESHUTDOWN */
2605 /* case ETOOMANYREFS */
2606 /* case ETIMEDOUT */
2607 /* case ECONNREFUSED */
2609 /* case ENAMETOOLONG */
2610 /* case EHOSTDOWN */
2611 /* case EHOSTUNREACH */
2612 /* case ENOTEMPTY */
2624 /* case ECANCELED */
2628 return SS$_UNSUPPORTED;
2634 /* case EABANDONED */
2636 return SS$_ABORT; /* punt */
2639 return SS$_ABORT; /* Should not get here */
2643 /* default piping mailbox size */
2644 #define PERL_BUFSIZ 512
2648 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2650 unsigned long int mbxbufsiz;
2651 static unsigned long int syssize = 0;
2652 unsigned long int dviitm = DVI$_DEVNAM;
2653 char csize[LNM$C_NAMLENGTH+1];
2657 unsigned long syiitm = SYI$_MAXBUF;
2659 * Get the SYSGEN parameter MAXBUF
2661 * If the logical 'PERL_MBX_SIZE' is defined
2662 * use the value of the logical instead of PERL_BUFSIZ, but
2663 * keep the size between 128 and MAXBUF.
2666 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2669 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2670 mbxbufsiz = atoi(csize);
2672 mbxbufsiz = PERL_BUFSIZ;
2674 if (mbxbufsiz < 128) mbxbufsiz = 128;
2675 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2677 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2679 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2680 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2682 } /* end of create_mbx() */
2685 /*{{{ my_popen and my_pclose*/
2687 typedef struct _iosb IOSB;
2688 typedef struct _iosb* pIOSB;
2689 typedef struct _pipe Pipe;
2690 typedef struct _pipe* pPipe;
2691 typedef struct pipe_details Info;
2692 typedef struct pipe_details* pInfo;
2693 typedef struct _srqp RQE;
2694 typedef struct _srqp* pRQE;
2695 typedef struct _tochildbuf CBuf;
2696 typedef struct _tochildbuf* pCBuf;
2699 unsigned short status;
2700 unsigned short count;
2701 unsigned long dvispec;
2704 #pragma member_alignment save
2705 #pragma nomember_alignment quadword
2706 struct _srqp { /* VMS self-relative queue entry */
2707 unsigned long qptr[2];
2709 #pragma member_alignment restore
2710 static RQE RQE_ZERO = {0,0};
2712 struct _tochildbuf {
2715 unsigned short size;
2723 unsigned short chan_in;
2724 unsigned short chan_out;
2726 unsigned int bufsize;
2738 #if defined(PERL_IMPLICIT_CONTEXT)
2739 void *thx; /* Either a thread or an interpreter */
2740 /* pointer, depending on how we're built */
2748 PerlIO *fp; /* file pointer to pipe mailbox */
2749 int useFILE; /* using stdio, not perlio */
2750 int pid; /* PID of subprocess */
2751 int mode; /* == 'r' if pipe open for reading */
2752 int done; /* subprocess has completed */
2753 int waiting; /* waiting for completion/closure */
2754 int closing; /* my_pclose is closing this pipe */
2755 unsigned long completion; /* termination status of subprocess */
2756 pPipe in; /* pipe in to sub */
2757 pPipe out; /* pipe out of sub */
2758 pPipe err; /* pipe of sub's sys$error */
2759 int in_done; /* true when in pipe finished */
2764 struct exit_control_block
2766 struct exit_control_block *flink;
2767 unsigned long int (*exit_routine)();
2768 unsigned long int arg_count;
2769 unsigned long int *status_address;
2770 unsigned long int exit_status;
2773 typedef struct _closed_pipes Xpipe;
2774 typedef struct _closed_pipes* pXpipe;
2776 struct _closed_pipes {
2777 int pid; /* PID of subprocess */
2778 unsigned long completion; /* termination status of subprocess */
2780 #define NKEEPCLOSED 50
2781 static Xpipe closed_list[NKEEPCLOSED];
2782 static int closed_index = 0;
2783 static int closed_num = 0;
2785 #define RETRY_DELAY "0 ::0.20"
2786 #define MAX_RETRY 50
2788 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2789 static unsigned long mypid;
2790 static unsigned long delaytime[2];
2792 static pInfo open_pipes = NULL;
2793 static $DESCRIPTOR(nl_desc, "NL:");
2795 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2799 static unsigned long int
2800 pipe_exit_routine(pTHX)
2803 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2804 int sts, did_stuff, need_eof, j;
2807 flush any pending i/o
2813 PerlIO_flush(info->fp); /* first, flush data */
2815 fflush((FILE *)info->fp);
2821 next we try sending an EOF...ignore if doesn't work, make sure we
2829 _ckvmssts_noperl(sys$setast(0));
2830 if (info->in && !info->in->shut_on_empty) {
2831 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2836 _ckvmssts_noperl(sys$setast(1));
2840 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2842 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2847 _ckvmssts_noperl(sys$setast(0));
2848 if (info->waiting && info->done)
2850 nwait += info->waiting;
2851 _ckvmssts_noperl(sys$setast(1));
2861 _ckvmssts_noperl(sys$setast(0));
2862 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2863 sts = sys$forcex(&info->pid,0,&abort);
2864 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2867 _ckvmssts_noperl(sys$setast(1));
2871 /* again, wait for effect */
2873 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2878 _ckvmssts_noperl(sys$setast(0));
2879 if (info->waiting && info->done)
2881 nwait += info->waiting;
2882 _ckvmssts_noperl(sys$setast(1));
2891 _ckvmssts_noperl(sys$setast(0));
2892 if (!info->done) { /* We tried to be nice . . . */
2893 sts = sys$delprc(&info->pid,0);
2894 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2895 info->done = 1; /* sys$delprc is as done as we're going to get. */
2897 _ckvmssts_noperl(sys$setast(1));
2902 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2903 else if (!(sts & 1)) retsts = sts;
2908 static struct exit_control_block pipe_exitblock =
2909 {(struct exit_control_block *) 0,
2910 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2912 static void pipe_mbxtofd_ast(pPipe p);
2913 static void pipe_tochild1_ast(pPipe p);
2914 static void pipe_tochild2_ast(pPipe p);
2917 popen_completion_ast(pInfo info)
2919 pInfo i = open_pipes;
2924 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2925 closed_list[closed_index].pid = info->pid;
2926 closed_list[closed_index].completion = info->completion;
2928 if (closed_index == NKEEPCLOSED)
2933 if (i == info) break;
2936 if (!i) return; /* unlinked, probably freed too */
2941 Writing to subprocess ...
2942 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2944 chan_out may be waiting for "done" flag, or hung waiting
2945 for i/o completion to child...cancel the i/o. This will
2946 put it into "snarf mode" (done but no EOF yet) that discards
2949 Output from subprocess (stdout, stderr) needs to be flushed and
2950 shut down. We try sending an EOF, but if the mbx is full the pipe
2951 routine should still catch the "shut_on_empty" flag, telling it to
2952 use immediate-style reads so that "mbx empty" -> EOF.
2956 if (info->in && !info->in_done) { /* only for mode=w */
2957 if (info->in->shut_on_empty && info->in->need_wake) {
2958 info->in->need_wake = FALSE;
2959 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2961 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2965 if (info->out && !info->out_done) { /* were we also piping output? */
2966 info->out->shut_on_empty = TRUE;
2967 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2968 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2969 _ckvmssts_noperl(iss);
2972 if (info->err && !info->err_done) { /* we were piping stderr */
2973 info->err->shut_on_empty = TRUE;
2974 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2975 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2976 _ckvmssts_noperl(iss);
2978 _ckvmssts_noperl(sys$setef(pipe_ef));
2982 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2983 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2986 we actually differ from vmstrnenv since we use this to
2987 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2988 are pointing to the same thing
2991 static unsigned short
2992 popen_translate(pTHX_ char *logical, char *result)
2995 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2996 $DESCRIPTOR(d_log,"");
2998 unsigned short length;
2999 unsigned short code;
3001 unsigned short *retlenaddr;
3003 unsigned short l, ifi;
3005 d_log.dsc$a_pointer = logical;
3006 d_log.dsc$w_length = strlen(logical);
3008 itmlst[0].code = LNM$_STRING;
3009 itmlst[0].length = 255;
3010 itmlst[0].buffer_addr = result;
3011 itmlst[0].retlenaddr = &l;
3014 itmlst[1].length = 0;
3015 itmlst[1].buffer_addr = 0;
3016 itmlst[1].retlenaddr = 0;
3018 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3019 if (iss == SS$_NOLOGNAM) {
3023 if (!(iss&1)) lib$signal(iss);
3026 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3027 strip it off and return the ifi, if any
3030 if (result[0] == 0x1b && result[1] == 0x00) {
3031 memmove(&ifi,result+2,2);
3032 strcpy(result,result+4);
3034 return ifi; /* this is the RMS internal file id */
3037 static void pipe_infromchild_ast(pPipe p);
3040 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3041 inside an AST routine without worrying about reentrancy and which Perl
3042 memory allocator is being used.
3044 We read data and queue up the buffers, then spit them out one at a
3045 time to the output mailbox when the output mailbox is ready for one.
3048 #define INITIAL_TOCHILDQUEUE 2
3051 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3055 char mbx1[64], mbx2[64];
3056 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3057 DSC$K_CLASS_S, mbx1},
3058 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3059 DSC$K_CLASS_S, mbx2};
3060 unsigned int dviitm = DVI$_DEVBUFSIZ;
3064 _ckvmssts(lib$get_vm(&n, &p));
3066 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3067 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3068 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3071 p->shut_on_empty = FALSE;
3072 p->need_wake = FALSE;
3075 p->iosb.status = SS$_NORMAL;
3076 p->iosb2.status = SS$_NORMAL;
3082 #ifdef PERL_IMPLICIT_CONTEXT
3086 n = sizeof(CBuf) + p->bufsize;
3088 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3089 _ckvmssts(lib$get_vm(&n, &b));
3090 b->buf = (char *) b + sizeof(CBuf);
3091 _ckvmssts(lib$insqhi(b, &p->free));
3094 pipe_tochild2_ast(p);
3095 pipe_tochild1_ast(p);
3101 /* reads the MBX Perl is writing, and queues */
3104 pipe_tochild1_ast(pPipe p)
3107 int iss = p->iosb.status;
3108 int eof = (iss == SS$_ENDOFFILE);
3110 #ifdef PERL_IMPLICIT_CONTEXT
3116 p->shut_on_empty = TRUE;
3118 _ckvmssts(sys$dassgn(p->chan_in));
3124 b->size = p->iosb.count;
3125 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3127 p->need_wake = FALSE;
3128 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3131 p->retry = 1; /* initial call */
3134 if (eof) { /* flush the free queue, return when done */
3135 int n = sizeof(CBuf) + p->bufsize;
3137 iss = lib$remqti(&p->free, &b);
3138 if (iss == LIB$_QUEWASEMP) return;
3140 _ckvmssts(lib$free_vm(&n, &b));
3144 iss = lib$remqti(&p->free, &b);
3145 if (iss == LIB$_QUEWASEMP) {
3146 int n = sizeof(CBuf) + p->bufsize;
3147 _ckvmssts(lib$get_vm(&n, &b));
3148 b->buf = (char *) b + sizeof(CBuf);
3154 iss = sys$qio(0,p->chan_in,
3155 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3157 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3158 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3163 /* writes queued buffers to output, waits for each to complete before
3167 pipe_tochild2_ast(pPipe p)
3170 int iss = p->iosb2.status;
3171 int n = sizeof(CBuf) + p->bufsize;
3172 int done = (p->info && p->info->done) ||
3173 iss == SS$_CANCEL || iss == SS$_ABORT;
3174 #if defined(PERL_IMPLICIT_CONTEXT)
3179 if (p->type) { /* type=1 has old buffer, dispose */
3180 if (p->shut_on_empty) {
3181 _ckvmssts(lib$free_vm(&n, &b));
3183 _ckvmssts(lib$insqhi(b, &p->free));
3188 iss = lib$remqti(&p->wait, &b);
3189 if (iss == LIB$_QUEWASEMP) {
3190 if (p->shut_on_empty) {
3192 _ckvmssts(sys$dassgn(p->chan_out));
3193 *p->pipe_done = TRUE;
3194 _ckvmssts(sys$setef(pipe_ef));
3196 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3197 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3201 p->need_wake = TRUE;
3211 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3212 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3214 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3215 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3224 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3227 char mbx1[64], mbx2[64];
3228 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3229 DSC$K_CLASS_S, mbx1},
3230 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3231 DSC$K_CLASS_S, mbx2};
3232 unsigned int dviitm = DVI$_DEVBUFSIZ;
3234 int n = sizeof(Pipe);
3235 _ckvmssts(lib$get_vm(&n, &p));
3236 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3237 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3239 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3240 n = p->bufsize * sizeof(char);
3241 _ckvmssts(lib$get_vm(&n, &p->buf));
3242 p->shut_on_empty = FALSE;
3245 p->iosb.status = SS$_NORMAL;
3246 #if defined(PERL_IMPLICIT_CONTEXT)
3249 pipe_infromchild_ast(p);
3257 pipe_infromchild_ast(pPipe p)
3259 int iss = p->iosb.status;
3260 int eof = (iss == SS$_ENDOFFILE);
3261 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3262 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3263 #if defined(PERL_IMPLICIT_CONTEXT)
3267 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3268 _ckvmssts(sys$dassgn(p->chan_out));
3273 input shutdown if EOF from self (done or shut_on_empty)
3274 output shutdown if closing flag set (my_pclose)
3275 send data/eof from child or eof from self
3276 otherwise, re-read (snarf of data from child)
3281 if (myeof && p->chan_in) { /* input shutdown */
3282 _ckvmssts(sys$dassgn(p->chan_in));
3287 if (myeof || kideof) { /* pass EOF to parent */
3288 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3289 pipe_infromchild_ast, p,
3292 } else if (eof) { /* eat EOF --- fall through to read*/
3294 } else { /* transmit data */
3295 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3296 pipe_infromchild_ast,p,
3297 p->buf, p->iosb.count, 0, 0, 0, 0));
3303 /* everything shut? flag as done */
3305 if (!p->chan_in && !p->chan_out) {
3306 *p->pipe_done = TRUE;
3307 _ckvmssts(sys$setef(pipe_ef));
3311 /* write completed (or read, if snarfing from child)
3312 if still have input active,
3313 queue read...immediate mode if shut_on_empty so we get EOF if empty
3315 check if Perl reading, generate EOFs as needed
3321 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3322 pipe_infromchild_ast,p,
3323 p->buf, p->bufsize, 0, 0, 0, 0);
3324 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3326 } else { /* send EOFs for extra reads */
3327 p->iosb.status = SS$_ENDOFFILE;
3328 p->iosb.dvispec = 0;
3329 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3331 pipe_infromchild_ast, p, 0, 0, 0, 0));
3337 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3341 unsigned long dviitm = DVI$_DEVBUFSIZ;
3343 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3344 DSC$K_CLASS_S, mbx};
3345 int n = sizeof(Pipe);
3347 /* things like terminals and mbx's don't need this filter */
3348 if (fd && fstat(fd,&s) == 0) {
3349 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3351 unsigned short dev_len;
3352 struct dsc$descriptor_s d_dev;
3354 struct item_list_3 items[3];
3356 unsigned short dvi_iosb[4];
3358 cptr = getname(fd, out, 1);
3359 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3360 d_dev.dsc$a_pointer = out;
3361 d_dev.dsc$w_length = strlen(out);
3362 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3363 d_dev.dsc$b_class = DSC$K_CLASS_S;
3366 items[0].code = DVI$_DEVCHAR;
3367 items[0].bufadr = &devchar;
3368 items[0].retadr = NULL;
3370 items[1].code = DVI$_FULLDEVNAM;
3371 items[1].bufadr = device;
3372 items[1].retadr = &dev_len;
3376 status = sys$getdviw
3377 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3379 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3380 device[dev_len] = 0;
3382 if (!(devchar & DEV$M_DIR)) {
3383 strcpy(out, device);
3389 _ckvmssts(lib$get_vm(&n, &p));
3390 p->fd_out = dup(fd);
3391 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3392 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3393 n = (p->bufsize+1) * sizeof(char);
3394 _ckvmssts(lib$get_vm(&n, &p->buf));
3395 p->shut_on_empty = FALSE;
3400 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3401 pipe_mbxtofd_ast, p,
3402 p->buf, p->bufsize, 0, 0, 0, 0));
3408 pipe_mbxtofd_ast(pPipe p)
3410 int iss = p->iosb.status;
3411 int done = p->info->done;
3413 int eof = (iss == SS$_ENDOFFILE);
3414 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3415 int err = !(iss&1) && !eof;
3416 #if defined(PERL_IMPLICIT_CONTEXT)
3420 if (done && myeof) { /* end piping */
3422 sys$dassgn(p->chan_in);
3423 *p->pipe_done = TRUE;
3424 _ckvmssts(sys$setef(pipe_ef));
3428 if (!err && !eof) { /* good data to send to file */
3429 p->buf[p->iosb.count] = '\n';
3430 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3433 if (p->retry < MAX_RETRY) {
3434 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3444 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3445 pipe_mbxtofd_ast, p,
3446 p->buf, p->bufsize, 0, 0, 0, 0);
3447 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3452 typedef struct _pipeloc PLOC;
3453 typedef struct _pipeloc* pPLOC;
3457 char dir[NAM$C_MAXRSS+1];
3459 static pPLOC head_PLOC = 0;
3462 free_pipelocs(pTHX_ void *head)
3465 pPLOC *pHead = (pPLOC *)head;
3477 store_pipelocs(pTHX)
3486 char temp[NAM$C_MAXRSS+1];
3490 free_pipelocs(aTHX_ &head_PLOC);
3492 /* the . directory from @INC comes last */
3494 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3495 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3496 p->next = head_PLOC;
3498 strcpy(p->dir,"./");
3500 /* get the directory from $^X */
3502 unixdir = PerlMem_malloc(VMS_MAXRSS);
3503 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3505 #ifdef PERL_IMPLICIT_CONTEXT
3506 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3508 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3510 strcpy(temp, PL_origargv[0]);
3511 x = strrchr(temp,']');
3513 x = strrchr(temp,'>');
3515 /* It could be a UNIX path */
3516 x = strrchr(temp,'/');
3522 /* Got a bare name, so use default directory */
3527 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3528 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3529 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3530 p->next = head_PLOC;
3532 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3533 p->dir[NAM$C_MAXRSS] = '\0';
3537 /* reverse order of @INC entries, skip "." since entered above */
3539 #ifdef PERL_IMPLICIT_CONTEXT
3542 if (PL_incgv) av = GvAVn(PL_incgv);
3544 for (i = 0; av && i <= AvFILL(av); i++) {
3545 dirsv = *av_fetch(av,i,TRUE);
3547 if (SvROK(dirsv)) continue;
3548 dir = SvPVx(dirsv,n_a);
3549 if (strcmp(dir,".") == 0) continue;
3550 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3553 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3554 p->next = head_PLOC;
3556 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3557 p->dir[NAM$C_MAXRSS] = '\0';
3560 /* most likely spot (ARCHLIB) put first in the list */
3563 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3564 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3565 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3566 p->next = head_PLOC;
3568 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3569 p->dir[NAM$C_MAXRSS] = '\0';
3572 PerlMem_free(unixdir);
3576 Perl_cando_by_name_int
3577 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3578 #if !defined(PERL_IMPLICIT_CONTEXT)
3579 #define cando_by_name_int Perl_cando_by_name_int
3581 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3587 static int vmspipe_file_status = 0;
3588 static char vmspipe_file[NAM$C_MAXRSS+1];
3590 /* already found? Check and use ... need read+execute permission */
3592 if (vmspipe_file_status == 1) {
3593 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3594 && cando_by_name_int
3595 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3596 return vmspipe_file;
3598 vmspipe_file_status = 0;
3601 /* scan through stored @INC, $^X */
3603 if (vmspipe_file_status == 0) {
3604 char file[NAM$C_MAXRSS+1];
3605 pPLOC p = head_PLOC;
3610 strcpy(file, p->dir);
3611 dirlen = strlen(file);
3612 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3613 file[NAM$C_MAXRSS] = '\0';
3616 exp_res = do_rmsexpand
3617 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3618 if (!exp_res) continue;
3620 if (cando_by_name_int
3621 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3622 && cando_by_name_int
3623 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3624 vmspipe_file_status = 1;
3625 return vmspipe_file;
3628 vmspipe_file_status = -1; /* failed, use tempfiles */
3635 vmspipe_tempfile(pTHX)
3637 char file[NAM$C_MAXRSS+1];
3639 static int index = 0;
3643 /* create a tempfile */
3645 /* we can't go from W, shr=get to R, shr=get without
3646 an intermediate vulnerable state, so don't bother trying...
3648 and lib$spawn doesn't shr=put, so have to close the write
3650 So... match up the creation date/time and the FID to
3651 make sure we're dealing with the same file
3656 if (!decc_filename_unix_only) {
3657 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3658 fp = fopen(file,"w");
3660 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3661 fp = fopen(file,"w");
3663 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3664 fp = fopen(file,"w");
3669 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3670 fp = fopen(file,"w");
3672 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3673 fp = fopen(file,"w");
3675 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3676 fp = fopen(file,"w");
3680 if (!fp) return 0; /* we're hosed */
3682 fprintf(fp,"$! 'f$verify(0)'\n");
3683 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3684 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3685 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3686 fprintf(fp,"$ perl_on = \"set noon\"\n");
3687 fprintf(fp,"$ perl_exit = \"exit\"\n");
3688 fprintf(fp,"$ perl_del = \"delete\"\n");
3689 fprintf(fp,"$ pif = \"if\"\n");
3690 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3691 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3692 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3693 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3694 fprintf(fp,"$! --- build command line to get max possible length\n");
3695 fprintf(fp,"$c=perl_popen_cmd0\n");
3696 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3697 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3698 fprintf(fp,"$x=perl_popen_cmd3\n");
3699 fprintf(fp,"$c=c+x\n");
3700 fprintf(fp,"$ perl_on\n");
3701 fprintf(fp,"$ 'c'\n");
3702 fprintf(fp,"$ perl_status = $STATUS\n");
3703 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3704 fprintf(fp,"$ perl_exit 'perl_status'\n");
3707 fgetname(fp, file, 1);
3708 fstat(fileno(fp), (struct stat *)&s0);
3711 if (decc_filename_unix_only)
3712 do_tounixspec(file, file, 0, NULL);
3713 fp = fopen(file,"r","shr=get");
3715 fstat(fileno(fp), (struct stat *)&s1);
3717 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3718 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3729 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3731 static int handler_set_up = FALSE;
3732 unsigned long int sts, flags = CLI$M_NOWAIT;
3733 /* The use of a GLOBAL table (as was done previously) rendered
3734 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3735 * environment. Hence we've switched to LOCAL symbol table.
3737 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3739 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3740 char *in, *out, *err, mbx[512];
3742 char tfilebuf[NAM$C_MAXRSS+1];
3744 char cmd_sym_name[20];
3745 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3746 DSC$K_CLASS_S, symbol};
3747 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3749 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3750 DSC$K_CLASS_S, cmd_sym_name};
3751 struct dsc$descriptor_s *vmscmd;
3752 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3753 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3754 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3756 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3758 /* once-per-program initialization...
3759 note that the SETAST calls and the dual test of pipe_ef
3760 makes sure that only the FIRST thread through here does
3761 the initialization...all other threads wait until it's
3764 Yeah, uglier than a pthread call, it's got all the stuff inline
3765 rather than in a separate routine.
3769 _ckvmssts(sys$setast(0));
3771 unsigned long int pidcode = JPI$_PID;
3772 $DESCRIPTOR(d_delay, RETRY_DELAY);
3773 _ckvmssts(lib$get_ef(&pipe_ef));
3774 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3775 _ckvmssts(sys$bintim(&d_delay, delaytime));
3777 if (!handler_set_up) {
3778 _ckvmssts(sys$dclexh(&pipe_exitblock));
3779 handler_set_up = TRUE;
3781 _ckvmssts(sys$setast(1));
3784 /* see if we can find a VMSPIPE.COM */
3787 vmspipe = find_vmspipe(aTHX);
3789 strcpy(tfilebuf+1,vmspipe);
3790 } else { /* uh, oh...we're in tempfile hell */
3791 tpipe = vmspipe_tempfile(aTHX);
3792 if (!tpipe) { /* a fish popular in Boston */
3793 if (ckWARN(WARN_PIPE)) {
3794 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3798 fgetname(tpipe,tfilebuf+1,1);
3800 vmspipedsc.dsc$a_pointer = tfilebuf;
3801 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3803 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3806 case RMS$_FNF: case RMS$_DNF:
3807 set_errno(ENOENT); break;
3809 set_errno(ENOTDIR); break;
3811 set_errno(ENODEV); break;
3813 set_errno(EACCES); break;
3815 set_errno(EINVAL); break;
3816 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3817 set_errno(E2BIG); break;
3818 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3819 _ckvmssts(sts); /* fall through */
3820 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3823 set_vaxc_errno(sts);
3824 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3825 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3831 _ckvmssts(lib$get_vm(&n, &info));
3833 strcpy(mode,in_mode);
3836 info->completion = 0;
3837 info->closing = FALSE;
3844 info->in_done = TRUE;
3845 info->out_done = TRUE;
3846 info->err_done = TRUE;
3848 in = PerlMem_malloc(VMS_MAXRSS);
3849 if (in == NULL) _ckvmssts(SS$_INSFMEM);
3850 out = PerlMem_malloc(VMS_MAXRSS);
3851 if (out == NULL) _ckvmssts(SS$_INSFMEM);
3852 err = PerlMem_malloc(VMS_MAXRSS);
3853 if (err == NULL) _ckvmssts(SS$_INSFMEM);
3855 in[0] = out[0] = err[0] = '\0';
3857 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3861 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3866 if (*mode == 'r') { /* piping from subroutine */
3868 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3870 info->out->pipe_done = &info->out_done;
3871 info->out_done = FALSE;
3872 info->out->info = info;
3874 if (!info->useFILE) {
3875 info->fp = PerlIO_open(mbx, mode);
3877 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3878 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3881 if (!info->fp && info->out) {
3882 sys$cancel(info->out->chan_out);
3884 while (!info->out_done) {
3886 _ckvmssts(sys$setast(0));
3887 done = info->out_done;
3888 if (!done) _ckvmssts(sys$clref(pipe_ef));
3889 _ckvmssts(sys$setast(1));
3890 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3893 if (info->out->buf) {
3894 n = info->out->bufsize * sizeof(char);
3895 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3898 _ckvmssts(lib$free_vm(&n, &info->out));
3900 _ckvmssts(lib$free_vm(&n, &info));
3905 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3907 info->err->pipe_done = &info->err_done;
3908 info->err_done = FALSE;
3909 info->err->info = info;
3912 } else if (*mode == 'w') { /* piping to subroutine */
3914 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3916 info->out->pipe_done = &info->out_done;
3917 info->out_done = FALSE;
3918 info->out->info = info;
3921 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3923 info->err->pipe_done = &info->err_done;
3924 info->err_done = FALSE;
3925 info->err->info = info;
3928 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3929 if (!info->useFILE) {
3930 info->fp = PerlIO_open(mbx, mode);
3932 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3933 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3937 info->in->pipe_done = &info->in_done;
3938 info->in_done = FALSE;
3939 info->in->info = info;
3943 if (!info->fp && info->in) {
3945 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3946 0, 0, 0, 0, 0, 0, 0, 0));
3948 while (!info->in_done) {
3950 _ckvmssts(sys$setast(0));
3951 done = info->in_done;
3952 if (!done) _ckvmssts(sys$clref(pipe_ef));
3953 _ckvmssts(sys$setast(1));
3954 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3957 if (info->in->buf) {
3958 n = info->in->bufsize * sizeof(char);
3959 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3962 _ckvmssts(lib$free_vm(&n, &info->in));
3964 _ckvmssts(lib$free_vm(&n, &info));
3970 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3971 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3973 info->out->pipe_done = &info->out_done;
3974 info->out_done = FALSE;
3975 info->out->info = info;
3978 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3980 info->err->pipe_done = &info->err_done;
3981 info->err_done = FALSE;
3982 info->err->info = info;
3986 symbol[MAX_DCL_SYMBOL] = '\0';
3988 strncpy(symbol, in, MAX_DCL_SYMBOL);
3989 d_symbol.dsc$w_length = strlen(symbol);
3990 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3992 strncpy(symbol, err, MAX_DCL_SYMBOL);
3993 d_symbol.dsc$w_length = strlen(symbol);
3994 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3996 strncpy(symbol, out, MAX_DCL_SYMBOL);
3997 d_symbol.dsc$w_length = strlen(symbol);
3998 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4000 /* Done with the names for the pipes */
4005 p = vmscmd->dsc$a_pointer;
4006 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4007 if (*p == '$') p++; /* remove leading $ */
4008 while (*p == ' ' || *p == '\t') p++;
4010 for (j = 0; j < 4; j++) {
4011 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4012 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4014 strncpy(symbol, p, MAX_DCL_SYMBOL);
4015 d_symbol.dsc$w_length = strlen(symbol);
4016 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4018 if (strlen(p) > MAX_DCL_SYMBOL) {
4019 p += MAX_DCL_SYMBOL;
4024 _ckvmssts(sys$setast(0));
4025 info->next=open_pipes; /* prepend to list */
4027 _ckvmssts(sys$setast(1));
4028 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4029 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4030 * have SYS$COMMAND if we need it.
4032 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4033 0, &info->pid, &info->completion,
4034 0, popen_completion_ast,info,0,0,0));
4036 /* if we were using a tempfile, close it now */
4038 if (tpipe) fclose(tpipe);
4040 /* once the subprocess is spawned, it has copied the symbols and
4041 we can get rid of ours */
4043 for (j = 0; j < 4; j++) {
4044 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4045 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4046 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4048 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4049 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4050 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4051 vms_execfree(vmscmd);
4053 #ifdef PERL_IMPLICIT_CONTEXT
4056 PL_forkprocess = info->pid;
4061 _ckvmssts(sys$setast(0));
4063 if (!done) _ckvmssts(sys$clref(pipe_ef));
4064 _ckvmssts(sys$setast(1));
4065 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4067 *psts = info->completion;
4068 /* Caller thinks it is open and tries to close it. */
4069 /* This causes some problems, as it changes the error status */
4070 /* my_pclose(info->fp); */
4075 } /* end of safe_popen */
4078 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4080 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4084 TAINT_PROPER("popen");
4085 PERL_FLUSHALL_FOR_CHILD;
4086 return safe_popen(aTHX_ cmd,mode,&sts);
4091 /*{{{ I32 my_pclose(PerlIO *fp)*/
4092 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4094 pInfo info, last = NULL;
4095 unsigned long int retsts;
4098 for (info = open_pipes; info != NULL; last = info, info = info->next)
4099 if (info->fp == fp) break;
4101 if (info == NULL) { /* no such pipe open */
4102 set_errno(ECHILD); /* quoth POSIX */
4103 set_vaxc_errno(SS$_NONEXPR);
4107 /* If we were writing to a subprocess, insure that someone reading from
4108 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4109 * produce an EOF record in the mailbox.
4111 * well, at least sometimes it *does*, so we have to watch out for
4112 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4116 PerlIO_flush(info->fp); /* first, flush data */
4118 fflush((FILE *)info->fp);
4121 _ckvmssts(sys$setast(0));
4122 info->closing = TRUE;
4123 done = info->done && info->in_done && info->out_done && info->err_done;
4124 /* hanging on write to Perl's input? cancel it */
4125 if (info->mode == 'r' && info->out && !info->out_done) {
4126 if (info->out->chan_out) {
4127 _ckvmssts(sys$cancel(info->out->chan_out));
4128 if (!info->out->chan_in) { /* EOF generation, need AST */
4129 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4133 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4134 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4136 _ckvmssts(sys$setast(1));
4139 PerlIO_close(info->fp);
4141 fclose((FILE *)info->fp);
4144 we have to wait until subprocess completes, but ALSO wait until all
4145 the i/o completes...otherwise we'll be freeing the "info" structure
4146 that the i/o ASTs could still be using...
4150 _ckvmssts(sys$setast(0));
4151 done = info->done && info->in_done && info->out_done && info->err_done;
4152 if (!done) _ckvmssts(sys$clref(pipe_ef));
4153 _ckvmssts(sys$setast(1));
4154 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4156 retsts = info->completion;
4158 /* remove from list of open pipes */
4159 _ckvmssts(sys$setast(0));
4160 if (last) last->next = info->next;
4161 else open_pipes = info->next;
4162 _ckvmssts(sys$setast(1));
4164 /* free buffers and structures */
4167 if (info->in->buf) {
4168 n = info->in->bufsize * sizeof(char);
4169 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4172 _ckvmssts(lib$free_vm(&n, &info->in));
4175 if (info->out->buf) {
4176 n = info->out->bufsize * sizeof(char);
4177 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4180 _ckvmssts(lib$free_vm(&n, &info->out));
4183 if (info->err->buf) {
4184 n = info->err->bufsize * sizeof(char);
4185 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4188 _ckvmssts(lib$free_vm(&n, &info->err));
4191 _ckvmssts(lib$free_vm(&n, &info));
4195 } /* end of my_pclose() */
4197 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4198 /* Roll our own prototype because we want this regardless of whether
4199 * _VMS_WAIT is defined.
4201 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4203 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4204 created with popen(); otherwise partially emulate waitpid() unless
4205 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4206 Also check processes not considered by the CRTL waitpid().
4208 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4210 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4217 if (statusp) *statusp = 0;
4219 for (info = open_pipes; info != NULL; info = info->next)
4220 if (info->pid == pid) break;
4222 if (info != NULL) { /* we know about this child */
4223 while (!info->done) {
4224 _ckvmssts(sys$setast(0));
4226 if (!done) _ckvmssts(sys$clref(pipe_ef));
4227 _ckvmssts(sys$setast(1));
4228 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4231 if (statusp) *statusp = info->completion;
4235 /* child that already terminated? */
4237 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4238 if (closed_list[j].pid == pid) {
4239 if (statusp) *statusp = closed_list[j].completion;
4244 /* fall through if this child is not one of our own pipe children */
4246 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4248 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4249 * in 7.2 did we get a version that fills in the VMS completion
4250 * status as Perl has always tried to do.
4253 sts = __vms_waitpid( pid, statusp, flags );
4255 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4258 /* If the real waitpid tells us the child does not exist, we
4259 * fall through here to implement waiting for a child that
4260 * was created by some means other than exec() (say, spawned
4261 * from DCL) or to wait for a process that is not a subprocess
4262 * of the current process.
4265 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4268 $DESCRIPTOR(intdsc,"0 00:00:01");
4269 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4270 unsigned long int pidcode = JPI$_PID, mypid;
4271 unsigned long int interval[2];
4272 unsigned int jpi_iosb[2];
4273 struct itmlst_3 jpilist[2] = {
4274 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4279 /* Sorry folks, we don't presently implement rooting around for
4280 the first child we can find, and we definitely don't want to
4281 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4287 /* Get the owner of the child so I can warn if it's not mine. If the
4288 * process doesn't exist or I don't have the privs to look at it,
4289 * I can go home early.
4291 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4292 if (sts & 1) sts = jpi_iosb[0];
4304 set_vaxc_errno(sts);
4308 if (ckWARN(WARN_EXEC)) {
4309 /* remind folks they are asking for non-standard waitpid behavior */
4310 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4311 if (ownerpid != mypid)
4312 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4313 "waitpid: process %x is not a child of process %x",
4317 /* simply check on it once a second until it's not there anymore. */
4319 _ckvmssts(sys$bintim(&intdsc,interval));
4320 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4321 _ckvmssts(sys$schdwk(0,0,interval,0));
4322 _ckvmssts(sys$hiber());
4324 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4329 } /* end of waitpid() */
4334 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4336 my_gconvert(double val, int ndig, int trail, char *buf)
4338 static char __gcvtbuf[DBL_DIG+1];
4341 loc = buf ? buf : __gcvtbuf;
4343 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4345 sprintf(loc,"%.*g",ndig,val);
4351 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4352 return gcvt(val,ndig,loc);
4355 loc[0] = '0'; loc[1] = '\0';
4362 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4363 static int rms_free_search_context(struct FAB * fab)
4367 nam = fab->fab$l_nam;
4368 nam->nam$b_nop |= NAM$M_SYNCHK;
4369 nam->nam$l_rlf = NULL;
4371 return sys$parse(fab, NULL, NULL);
4374 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4375 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4376 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4377 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4378 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4379 #define rms_nam_esll(nam) nam.nam$b_esl
4380 #define rms_nam_esl(nam) nam.nam$b_esl
4381 #define rms_nam_name(nam) nam.nam$l_name
4382 #define rms_nam_namel(nam) nam.nam$l_name
4383 #define rms_nam_type(nam) nam.nam$l_type
4384 #define rms_nam_typel(nam) nam.nam$l_type
4385 #define rms_nam_ver(nam) nam.nam$l_ver
4386 #define rms_nam_verl(nam) nam.nam$l_ver
4387 #define rms_nam_rsll(nam) nam.nam$b_rsl
4388 #define rms_nam_rsl(nam) nam.nam$b_rsl
4389 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4390 #define rms_set_fna(fab, nam, name, size) \
4391 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4392 #define rms_get_fna(fab, nam) fab.fab$l_fna
4393 #define rms_set_dna(fab, nam, name, size) \
4394 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4395 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4396 #define rms_set_esa(fab, nam, name, size) \
4397 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4398 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4399 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4400 #define rms_set_rsa(nam, name, size) \
4401 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4402 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4403 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4404 #define rms_nam_name_type_l_size(nam) \
4405 (nam.nam$b_name + nam.nam$b_type)
4407 static int rms_free_search_context(struct FAB * fab)
4411 nam = fab->fab$l_naml;
4412 nam->naml$b_nop |= NAM$M_SYNCHK;
4413 nam->naml$l_rlf = NULL;
4414 nam->naml$l_long_defname_size = 0;
4417 return sys$parse(fab, NULL, NULL);
4420 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4421 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4422 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4423 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4424 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4425 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4426 #define rms_nam_esl(nam) nam.naml$b_esl
4427 #define rms_nam_name(nam) nam.naml$l_name
4428 #define rms_nam_namel(nam) nam.naml$l_long_name
4429 #define rms_nam_type(nam) nam.naml$l_type
4430 #define rms_nam_typel(nam) nam.naml$l_long_type
4431 #define rms_nam_ver(nam) nam.naml$l_ver
4432 #define rms_nam_verl(nam) nam.naml$l_long_ver
4433 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4434 #define rms_nam_rsl(nam) nam.naml$b_rsl
4435 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4436 #define rms_set_fna(fab, nam, name, size) \
4437 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4438 nam.naml$l_long_filename_size = size; \
4439 nam.naml$l_long_filename = name;}
4440 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4441 #define rms_set_dna(fab, nam, name, size) \
4442 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4443 nam.naml$l_long_defname_size = size; \
4444 nam.naml$l_long_defname = name; }
4445 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4446 #define rms_set_esa(fab, nam, name, size) \
4447 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4448 nam.naml$l_long_expand_alloc = size; \
4449 nam.naml$l_long_expand = name; }
4450 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4451 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4452 nam.naml$l_long_expand = l_name; \
4453 nam.naml$l_long_expand_alloc = l_size; }
4454 #define rms_set_rsa(nam, name, size) \
4455 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4456 nam.naml$l_long_result = name; \
4457 nam.naml$l_long_result_alloc = size; }
4458 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4459 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4460 nam.naml$l_long_result = l_name; \
4461 nam.naml$l_long_result_alloc = l_size; }
4462 #define rms_nam_name_type_l_size(nam) \
4463 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4467 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4468 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4469 * to expand file specification. Allows for a single default file
4470 * specification and a simple mask of options. If outbuf is non-NULL,
4471 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4472 * the resultant file specification is placed. If outbuf is NULL, the
4473 * resultant file specification is placed into a static buffer.
4474 * The third argument, if non-NULL, is taken to be a default file
4475 * specification string. The fourth argument is unused at present.
4476 * rmesexpand() returns the address of the resultant string if
4477 * successful, and NULL on error.
4479 * New functionality for previously unused opts value:
4480 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4481 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4482 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4484 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4488 (pTHX_ const char *filespec,
4491 const char *defspec,
4496 static char __rmsexpand_retbuf[VMS_MAXRSS];
4497 char * vmsfspec, *tmpfspec;
4498 char * esa, *cp, *out = NULL;
4502 struct FAB myfab = cc$rms_fab;
4503 rms_setup_nam(mynam);
4505 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4508 /* temp hack until UTF8 is actually implemented */
4509 if (fs_utf8 != NULL)
4512 if (!filespec || !*filespec) {
4513 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4517 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4518 else outbuf = __rmsexpand_retbuf;
4526 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4527 isunix = is_unix_filespec(filespec);
4529 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4530 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4531 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4532 PerlMem_free(vmsfspec);
4537 filespec = vmsfspec;
4539 /* Unless we are forcing to VMS format, a UNIX input means
4540 * UNIX output, and that requires long names to be used
4542 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4543 opts |= PERL_RMSEXPAND_M_LONG;
4550 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4551 rms_bind_fab_nam(myfab, mynam);
4553 if (defspec && *defspec) {
4555 t_isunix = is_unix_filespec(defspec);
4557 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4558 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4559 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4560 PerlMem_free(tmpfspec);
4561 if (vmsfspec != NULL)
4562 PerlMem_free(vmsfspec);
4569 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4572 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4573 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4574 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4575 esal = PerlMem_malloc(VMS_MAXRSS);
4576 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4578 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4580 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4581 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4584 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4585 outbufl = PerlMem_malloc(VMS_MAXRSS);
4586 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4587 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4589 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4593 #ifdef NAM$M_NO_SHORT_UPCASE
4594 if (decc_efs_case_preserve)
4595 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4598 /* First attempt to parse as an existing file */
4599 retsts = sys$parse(&myfab,0,0);
4600 if (!(retsts & STS$K_SUCCESS)) {
4602 /* Could not find the file, try as syntax only if error is not fatal */
4603 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4604 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4605 retsts = sys$parse(&myfab,0,0);
4606 if (retsts & STS$K_SUCCESS) goto expanded;
4609 /* Still could not parse the file specification */
4610 /*----------------------------------------------*/
4611 sts = rms_free_search_context(&myfab); /* Free search context */
4612 if (out) Safefree(out);
4613 if (tmpfspec != NULL)
4614 PerlMem_free(tmpfspec);
4615 if (vmsfspec != NULL)
4616 PerlMem_free(vmsfspec);
4617 if (outbufl != NULL)
4618 PerlMem_free(outbufl);
4621 set_vaxc_errno(retsts);
4622 if (retsts == RMS$_PRV) set_errno(EACCES);
4623 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4624 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4625 else set_errno(EVMSERR);
4628 retsts = sys$search(&myfab,0,0);
4629 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4630 sts = rms_free_search_context(&myfab); /* Free search context */
4631 if (out) Safefree(out);
4632 if (tmpfspec != NULL)
4633 PerlMem_free(tmpfspec);
4634 if (vmsfspec != NULL)
4635 PerlMem_free(vmsfspec);
4636 if (outbufl != NULL)
4637 PerlMem_free(outbufl);
4640 set_vaxc_errno(retsts);
4641 if (retsts == RMS$_PRV) set_errno(EACCES);
4642 else set_errno(EVMSERR);
4646 /* If the input filespec contained any lowercase characters,
4647 * downcase the result for compatibility with Unix-minded code. */
4649 if (!decc_efs_case_preserve) {
4650 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4651 if (islower(*tbuf)) { haslower = 1; break; }
4654 /* Is a long or a short name expected */
4655 /*------------------------------------*/
4656 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4657 if (rms_nam_rsll(mynam)) {
4659 speclen = rms_nam_rsll(mynam);
4662 tbuf = esal; /* Not esa */
4663 speclen = rms_nam_esll(mynam);
4667 if (rms_nam_rsl(mynam)) {
4669 speclen = rms_nam_rsl(mynam);
4672 tbuf = esa; /* Not esal */
4673 speclen = rms_nam_esl(mynam);
4676 tbuf[speclen] = '\0';
4678 /* Trim off null fields added by $PARSE
4679 * If type > 1 char, must have been specified in original or default spec
4680 * (not true for version; $SEARCH may have added version of existing file).
4682 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4683 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4684 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4685 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4688 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4689 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4691 if (trimver || trimtype) {
4692 if (defspec && *defspec) {
4693 char *defesal = NULL;
4694 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4695 if (defesal != NULL) {
4696 struct FAB deffab = cc$rms_fab;
4697 rms_setup_nam(defnam);
4699 rms_bind_fab_nam(deffab, defnam);
4703 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4705 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4707 rms_clear_nam_nop(defnam);
4708 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4709 #ifdef NAM$M_NO_SHORT_UPCASE
4710 if (decc_efs_case_preserve)
4711 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4713 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4715 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4718 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4721 PerlMem_free(defesal);
4725 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4726 if (*(rms_nam_verl(mynam)) != '\"')
4727 speclen = rms_nam_verl(mynam) - tbuf;
4730 if (*(rms_nam_ver(mynam)) != '\"')
4731 speclen = rms_nam_ver(mynam) - tbuf;
4735 /* If we didn't already trim version, copy down */
4736 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4737 if (speclen > rms_nam_verl(mynam) - tbuf)
4739 (rms_nam_typel(mynam),
4740 rms_nam_verl(mynam),
4741 speclen - (rms_nam_verl(mynam) - tbuf));
4742 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4745 if (speclen > rms_nam_ver(mynam) - tbuf)
4747 (rms_nam_type(mynam),
4749 speclen - (rms_nam_ver(mynam) - tbuf));
4750 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4755 /* Done with these copies of the input files */
4756 /*-------------------------------------------*/
4757 if (vmsfspec != NULL)
4758 PerlMem_free(vmsfspec);
4759 if (tmpfspec != NULL)
4760 PerlMem_free(tmpfspec);
4762 /* If we just had a directory spec on input, $PARSE "helpfully"
4763 * adds an empty name and type for us */
4764 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4765 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4766 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4767 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4768 speclen = rms_nam_namel(mynam) - tbuf;
4771 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4772 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4773 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4774 speclen = rms_nam_name(mynam) - tbuf;
4777 /* Posix format specifications must have matching quotes */
4778 if (speclen < (VMS_MAXRSS - 1)) {
4779 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4780 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4781 tbuf[speclen] = '\"';
4786 tbuf[speclen] = '\0';
4787 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4789 /* Have we been working with an expanded, but not resultant, spec? */
4790 /* Also, convert back to Unix syntax if necessary. */
4792 if (!rms_nam_rsll(mynam)) {
4794 if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
4795 if (out) Safefree(out);
4798 if (outbufl != NULL)
4799 PerlMem_free(outbufl);
4803 else strcpy(outbuf,esa);
4806 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4807 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4808 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
4809 if (out) Safefree(out);
4812 PerlMem_free(tmpfspec);
4813 if (outbufl != NULL)
4814 PerlMem_free(outbufl);
4817 strcpy(outbuf,tmpfspec);
4818 PerlMem_free(tmpfspec);
4821 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4822 sts = rms_free_search_context(&myfab); /* Free search context */
4825 if (outbufl != NULL)
4826 PerlMem_free(outbufl);
4830 /* External entry points */
4831 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4832 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
4833 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4834 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
4835 char *Perl_rmsexpand_utf8
4836 (pTHX_ const char *spec, char *buf, const char *def,
4837 unsigned opt, int * fs_utf8, int * dfs_utf8)
4838 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
4839 char *Perl_rmsexpand_utf8_ts
4840 (pTHX_ const char *spec, char *buf, const char *def,
4841 unsigned opt, int * fs_utf8, int * dfs_utf8)
4842 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
4846 ** The following routines are provided to make life easier when
4847 ** converting among VMS-style and Unix-style directory specifications.
4848 ** All will take input specifications in either VMS or Unix syntax. On
4849 ** failure, all return NULL. If successful, the routines listed below
4850 ** return a pointer to a buffer containing the appropriately
4851 ** reformatted spec (and, therefore, subsequent calls to that routine
4852 ** will clobber the result), while the routines of the same names with
4853 ** a _ts suffix appended will return a pointer to a mallocd string
4854 ** containing the appropriately reformatted spec.
4855 ** In all cases, only explicit syntax is altered; no check is made that
4856 ** the resulting string is valid or that the directory in question
4859 ** fileify_dirspec() - convert a directory spec into the name of the
4860 ** directory file (i.e. what you can stat() to see if it's a dir).
4861 ** The style (VMS or Unix) of the result is the same as the style
4862 ** of the parameter passed in.
4863 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4864 ** what you prepend to a filename to indicate what directory it's in).
4865 ** The style (VMS or Unix) of the result is the same as the style
4866 ** of the parameter passed in.
4867 ** tounixpath() - convert a directory spec into a Unix-style path.
4868 ** tovmspath() - convert a directory spec into a VMS-style path.
4869 ** tounixspec() - convert any file spec into a Unix-style file spec.
4870 ** tovmsspec() - convert any file spec into a VMS-style spec.
4871 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
4873 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4874 ** Permission is given to distribute this code as part of the Perl
4875 ** standard distribution under the terms of the GNU General Public
4876 ** License or the Perl Artistic License. Copies of each may be
4877 ** found in the Perl standard distribution.
4880 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
4881 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
4883 static char __fileify_retbuf[VMS_MAXRSS];
4884 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4885 char *retspec, *cp1, *cp2, *lastdir;
4886 char *trndir, *vmsdir;
4887 unsigned short int trnlnm_iter_count;
4889 if (utf8_fl != NULL)
4892 if (!dir || !*dir) {
4893 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4895 dirlen = strlen(dir);
4896 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4897 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4898 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4905 if (dirlen > (VMS_MAXRSS - 1)) {
4906 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4909 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4910 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4911 if (!strpbrk(dir+1,"/]>:") &&
4912 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4913 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4914 trnlnm_iter_count = 0;
4915 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4916 trnlnm_iter_count++;
4917 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4919 dirlen = strlen(trndir);
4922 strncpy(trndir,dir,dirlen);
4923 trndir[dirlen] = '\0';
4926 /* At this point we are done with *dir and use *trndir which is a
4927 * copy that can be modified. *dir must not be modified.
4930 /* If we were handed a rooted logical name or spec, treat it like a
4931 * simple directory, so that
4932 * $ Define myroot dev:[dir.]
4933 * ... do_fileify_dirspec("myroot",buf,1) ...
4934 * does something useful.
4936 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4937 trndir[--dirlen] = '\0';
4938 trndir[dirlen-1] = ']';
4940 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4941 trndir[--dirlen] = '\0';
4942 trndir[dirlen-1] = '>';
4945 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4946 /* If we've got an explicit filename, we can just shuffle the string. */
4947 if (*(cp1+1)) hasfilename = 1;
4948 /* Similarly, we can just back up a level if we've got multiple levels
4949 of explicit directories in a VMS spec which ends with directories. */
4951 for (cp2 = cp1; cp2 > trndir; cp2--) {
4953 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4954 /* fix-me, can not scan EFS file specs backward like this */
4955 *cp2 = *cp1; *cp1 = '\0';
4960 if (*cp2 == '[' || *cp2 == '<') break;
4965 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4966 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4967 cp1 = strpbrk(trndir,"]:>");
4968 if (hasfilename || !cp1) { /* Unix-style path or filename */
4969 if (trndir[0] == '.') {
4970 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4971 PerlMem_free(trndir);
4972 PerlMem_free(vmsdir);
4973 return do_fileify_dirspec("[]",buf,ts,NULL);
4975 else if (trndir[1] == '.' &&
4976 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4977 PerlMem_free(trndir);
4978 PerlMem_free(vmsdir);
4979 return do_fileify_dirspec("[-]",buf,ts,NULL);
4982 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4983 dirlen -= 1; /* to last element */
4984 lastdir = strrchr(trndir,'/');
4986 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4987 /* If we have "/." or "/..", VMSify it and let the VMS code
4988 * below expand it, rather than repeating the code to handle
4989 * relative components of a filespec here */
4991 if (*(cp1+2) == '.') cp1++;
4992 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4994 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
4995 PerlMem_free(trndir);
4996 PerlMem_free(vmsdir);
4999 if (strchr(vmsdir,'/') != NULL) {
5000 /* If do_tovmsspec() returned it, it must have VMS syntax
5001 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5002 * the time to check this here only so we avoid a recursion
5003 * loop; otherwise, gigo.
5005 PerlMem_free(trndir);
5006 PerlMem_free(vmsdir);
5007 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5010 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5011 PerlMem_free(trndir);
5012 PerlMem_free(vmsdir);
5015 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5016 PerlMem_free(trndir);
5017 PerlMem_free(vmsdir);
5021 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5022 lastdir = strrchr(trndir,'/');
5024 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5026 /* Ditto for specs that end in an MFD -- let the VMS code
5027 * figure out whether it's a real device or a rooted logical. */
5029 /* This should not happen any more. Allowing the fake /000000
5030 * in a UNIX pathname causes all sorts of problems when trying
5031 * to run in UNIX emulation. So the VMS to UNIX conversions
5032 * now remove the fake /000000 directories.
5035 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5036 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5037 PerlMem_free(trndir);
5038 PerlMem_free(vmsdir);
5041 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5042 PerlMem_free(trndir);
5043 PerlMem_free(vmsdir);
5046 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5047 PerlMem_free(trndir);
5048 PerlMem_free(vmsdir);
5053 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5054 !(lastdir = cp1 = strrchr(trndir,']')) &&
5055 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5056 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5059 /* For EFS or ODS-5 look for the last dot */
5060 if (decc_efs_charset) {
5061 cp2 = strrchr(cp1,'.');
5063 if (vms_process_case_tolerant) {
5064 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5065 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5066 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5067 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5068 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5069 (ver || *cp3)))))) {
5070 PerlMem_free(trndir);
5071 PerlMem_free(vmsdir);
5073 set_vaxc_errno(RMS$_DIR);
5078 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5079 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5080 !*(cp2+3) || *(cp2+3) != 'R' ||
5081 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5082 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5083 (ver || *cp3)))))) {
5084 PerlMem_free(trndir);
5085 PerlMem_free(vmsdir);
5087 set_vaxc_errno(RMS$_DIR);
5091 dirlen = cp2 - trndir;
5095 retlen = dirlen + 6;
5096 if (buf) retspec = buf;
5097 else if (ts) Newx(retspec,retlen+1,char);
5098 else retspec = __fileify_retbuf;
5099 memcpy(retspec,trndir,dirlen);
5100 retspec[dirlen] = '\0';
5102 /* We've picked up everything up to the directory file name.
5103 Now just add the type and version, and we're set. */
5104 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5105 strcat(retspec,".dir;1");
5107 strcat(retspec,".DIR;1");
5108 PerlMem_free(trndir);
5109 PerlMem_free(vmsdir);
5112 else { /* VMS-style directory spec */
5114 char *esa, term, *cp;
5115 unsigned long int sts, cmplen, haslower = 0;
5116 unsigned int nam_fnb;
5118 struct FAB dirfab = cc$rms_fab;
5119 rms_setup_nam(savnam);
5120 rms_setup_nam(dirnam);
5122 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5123 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5124 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5125 rms_bind_fab_nam(dirfab, dirnam);
5126 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5127 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5128 #ifdef NAM$M_NO_SHORT_UPCASE
5129 if (decc_efs_case_preserve)
5130 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5133 for (cp = trndir; *cp; cp++)
5134 if (islower(*cp)) { haslower = 1; break; }
5135 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5136 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5137 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5138 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5142 PerlMem_free(trndir);
5143 PerlMem_free(vmsdir);
5145 set_vaxc_errno(dirfab.fab$l_sts);
5151 /* Does the file really exist? */
5152 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5153 /* Yes; fake the fnb bits so we'll check type below */
5154 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5156 else { /* No; just work with potential name */
5157 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5160 fab_sts = dirfab.fab$l_sts;
5161 sts = rms_free_search_context(&dirfab);
5163 PerlMem_free(trndir);
5164 PerlMem_free(vmsdir);
5165 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5170 esa[rms_nam_esll(dirnam)] = '\0';
5171 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5172 cp1 = strchr(esa,']');
5173 if (!cp1) cp1 = strchr(esa,'>');
5174 if (cp1) { /* Should always be true */
5175 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5176 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5179 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5180 /* Yep; check version while we're at it, if it's there. */
5181 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5182 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5183 /* Something other than .DIR[;1]. Bzzt. */
5184 sts = rms_free_search_context(&dirfab);
5186 PerlMem_free(trndir);
5187 PerlMem_free(vmsdir);
5189 set_vaxc_errno(RMS$_DIR);
5194 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5195 /* They provided at least the name; we added the type, if necessary, */
5196 if (buf) retspec = buf; /* in sys$parse() */
5197 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5198 else retspec = __fileify_retbuf;
5199 strcpy(retspec,esa);
5200 sts = rms_free_search_context(&dirfab);
5201 PerlMem_free(trndir);
5203 PerlMem_free(vmsdir);
5206 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5207 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5209 rms_nam_esll(dirnam) -= 9;
5211 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5212 if (cp1 == NULL) { /* should never happen */
5213 sts = rms_free_search_context(&dirfab);
5214 PerlMem_free(trndir);
5216 PerlMem_free(vmsdir);
5221 retlen = strlen(esa);
5222 cp1 = strrchr(esa,'.');
5223 /* ODS-5 directory specifications can have extra "." in them. */
5224 /* Fix-me, can not scan EFS file specifications backwards */
5225 while (cp1 != NULL) {
5226 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5230 while ((cp1 > esa) && (*cp1 != '.'))
5237 if ((cp1) != NULL) {
5238 /* There's more than one directory in the path. Just roll back. */
5240 if (buf) retspec = buf;
5241 else if (ts) Newx(retspec,retlen+7,char);
5242 else retspec = __fileify_retbuf;
5243 strcpy(retspec,esa);
5246 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5247 /* Go back and expand rooted logical name */
5248 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5249 #ifdef NAM$M_NO_SHORT_UPCASE
5250 if (decc_efs_case_preserve)
5251 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5253 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5254 sts = rms_free_search_context(&dirfab);
5256 PerlMem_free(trndir);
5257 PerlMem_free(vmsdir);
5259 set_vaxc_errno(dirfab.fab$l_sts);
5262 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5263 if (buf) retspec = buf;
5264 else if (ts) Newx(retspec,retlen+16,char);
5265 else retspec = __fileify_retbuf;
5266 cp1 = strstr(esa,"][");
5267 if (!cp1) cp1 = strstr(esa,"]<");
5269 memcpy(retspec,esa,dirlen);
5270 if (!strncmp(cp1+2,"000000]",7)) {
5271 retspec[dirlen-1] = '\0';
5272 /* fix-me Not full ODS-5, just extra dots in directories for now */
5273 cp1 = retspec + dirlen - 1;
5274 while (cp1 > retspec)
5279 if (*(cp1-1) != '^')
5284 if (*cp1 == '.') *cp1 = ']';
5286 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5287 memmove(cp1+1,"000000]",7);
5291 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5292 retspec[retlen] = '\0';
5293 /* Convert last '.' to ']' */
5294 cp1 = retspec+retlen-1;
5295 while (*cp != '[') {
5298 /* Do not trip on extra dots in ODS-5 directories */
5299 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5303 if (*cp1 == '.') *cp1 = ']';
5305 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5306 memmove(cp1+1,"000000]",7);
5310 else { /* This is a top-level dir. Add the MFD to the path. */
5311 if (buf) retspec = buf;
5312 else if (ts) Newx(retspec,retlen+16,char);
5313 else retspec = __fileify_retbuf;
5316 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5317 strcpy(cp2,":[000000]");
5322 sts = rms_free_search_context(&dirfab);
5323 /* We've set up the string up through the filename. Add the
5324 type and version, and we're done. */
5325 strcat(retspec,".DIR;1");
5327 /* $PARSE may have upcased filespec, so convert output to lower
5328 * case if input contained any lowercase characters. */
5329 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5330 PerlMem_free(trndir);
5332 PerlMem_free(vmsdir);
5335 } /* end of do_fileify_dirspec() */
5337 /* External entry points */
5338 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5339 { return do_fileify_dirspec(dir,buf,0,NULL); }
5340 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5341 { return do_fileify_dirspec(dir,buf,1,NULL); }
5342 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5343 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5344 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5345 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5347 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5348 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5350 static char __pathify_retbuf[VMS_MAXRSS];
5351 unsigned long int retlen;
5352 char *retpath, *cp1, *cp2, *trndir;
5353 unsigned short int trnlnm_iter_count;
5356 if (utf8_fl != NULL)
5359 if (!dir || !*dir) {
5360 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5363 trndir = PerlMem_malloc(VMS_MAXRSS);
5364 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5365 if (*dir) strcpy(trndir,dir);
5366 else getcwd(trndir,VMS_MAXRSS - 1);
5368 trnlnm_iter_count = 0;
5369 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5370 && my_trnlnm(trndir,trndir,0)) {
5371 trnlnm_iter_count++;
5372 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5373 trnlen = strlen(trndir);
5375 /* Trap simple rooted lnms, and return lnm:[000000] */
5376 if (!strcmp(trndir+trnlen-2,".]")) {
5377 if (buf) retpath = buf;
5378 else if (ts) Newx(retpath,strlen(dir)+10,char);
5379 else retpath = __pathify_retbuf;
5380 strcpy(retpath,dir);
5381 strcat(retpath,":[000000]");
5382 PerlMem_free(trndir);
5387 /* At this point we do not work with *dir, but the copy in
5388 * *trndir that is modifiable.
5391 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5392 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5393 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5394 retlen = 2 + (*(trndir+1) != '\0');
5396 if ( !(cp1 = strrchr(trndir,'/')) &&
5397 !(cp1 = strrchr(trndir,']')) &&
5398 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5399 if ((cp2 = strchr(cp1,'.')) != NULL &&
5400 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5401 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5402 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5403 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5406 /* For EFS or ODS-5 look for the last dot */
5407 if (decc_efs_charset) {
5408 cp2 = strrchr(cp1,'.');
5410 if (vms_process_case_tolerant) {
5411 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5412 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5413 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5414 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5415 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5416 (ver || *cp3)))))) {
5417 PerlMem_free(trndir);
5419 set_vaxc_errno(RMS$_DIR);
5424 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5425 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5426 !*(cp2+3) || *(cp2+3) != 'R' ||
5427 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5428 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5429 (ver || *cp3)))))) {
5430 PerlMem_free(trndir);
5432 set_vaxc_errno(RMS$_DIR);
5436 retlen = cp2 - trndir + 1;
5438 else { /* No file type present. Treat the filename as a directory. */
5439 retlen = strlen(trndir) + 1;
5442 if (buf) retpath = buf;
5443 else if (ts) Newx(retpath,retlen+1,char);
5444 else retpath = __pathify_retbuf;
5445 strncpy(retpath, trndir, retlen-1);
5446 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5447 retpath[retlen-1] = '/'; /* with '/', add it. */
5448 retpath[retlen] = '\0';
5450 else retpath[retlen-1] = '\0';
5452 else { /* VMS-style directory spec */
5454 unsigned long int sts, cmplen, haslower;
5455 struct FAB dirfab = cc$rms_fab;
5457 rms_setup_nam(savnam);
5458 rms_setup_nam(dirnam);
5460 /* If we've got an explicit filename, we can just shuffle the string. */
5461 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5462 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5463 if ((cp2 = strchr(cp1,'.')) != NULL) {
5465 if (vms_process_case_tolerant) {
5466 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5467 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5468 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5469 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5470 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5471 (ver || *cp3)))))) {
5472 PerlMem_free(trndir);
5474 set_vaxc_errno(RMS$_DIR);
5479 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5480 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5481 !*(cp2+3) || *(cp2+3) != 'R' ||
5482 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5483 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5484 (ver || *cp3)))))) {
5485 PerlMem_free(trndir);
5487 set_vaxc_errno(RMS$_DIR);
5492 else { /* No file type, so just draw name into directory part */
5493 for (cp2 = cp1; *cp2; cp2++) ;
5496 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5498 /* We've now got a VMS 'path'; fall through */
5501 dirlen = strlen(trndir);
5502 if (trndir[dirlen-1] == ']' ||
5503 trndir[dirlen-1] == '>' ||
5504 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5505 if (buf) retpath = buf;
5506 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5507 else retpath = __pathify_retbuf;
5508 strcpy(retpath,trndir);
5509 PerlMem_free(trndir);
5512 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5513 esa = PerlMem_malloc(VMS_MAXRSS);
5514 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5515 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5516 rms_bind_fab_nam(dirfab, dirnam);
5517 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5518 #ifdef NAM$M_NO_SHORT_UPCASE
5519 if (decc_efs_case_preserve)
5520 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5523 for (cp = trndir; *cp; cp++)
5524 if (islower(*cp)) { haslower = 1; break; }
5526 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5527 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5528 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5529 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5532 PerlMem_free(trndir);
5535 set_vaxc_errno(dirfab.fab$l_sts);
5541 /* Does the file really exist? */
5542 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5543 if (dirfab.fab$l_sts != RMS$_FNF) {
5545 sts1 = rms_free_search_context(&dirfab);
5546 PerlMem_free(trndir);
5549 set_vaxc_errno(dirfab.fab$l_sts);
5552 dirnam = savnam; /* No; just work with potential name */
5555 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5556 /* Yep; check version while we're at it, if it's there. */
5557 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5558 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5560 /* Something other than .DIR[;1]. Bzzt. */
5561 sts2 = rms_free_search_context(&dirfab);
5562 PerlMem_free(trndir);
5565 set_vaxc_errno(RMS$_DIR);
5569 /* OK, the type was fine. Now pull any file name into the
5571 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5573 cp1 = strrchr(esa,'>');
5574 *(rms_nam_typel(dirnam)) = '>';
5577 *(rms_nam_typel(dirnam) + 1) = '\0';
5578 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5579 if (buf) retpath = buf;
5580 else if (ts) Newx(retpath,retlen,char);
5581 else retpath = __pathify_retbuf;
5582 strcpy(retpath,esa);
5584 sts = rms_free_search_context(&dirfab);
5585 /* $PARSE may have upcased filespec, so convert output to lower
5586 * case if input contained any lowercase characters. */
5587 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5590 PerlMem_free(trndir);
5592 } /* end of do_pathify_dirspec() */
5594 /* External entry points */
5595 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5596 { return do_pathify_dirspec(dir,buf,0,NULL); }
5597 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5598 { return do_pathify_dirspec(dir,buf,1,NULL); }
5599 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5600 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5601 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5602 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5604 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5605 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5607 static char __tounixspec_retbuf[VMS_MAXRSS];
5608 char *dirend, *rslt, *cp1, *cp3, *tmp;
5610 int devlen, dirlen, retlen = VMS_MAXRSS;
5611 int expand = 1; /* guarantee room for leading and trailing slashes */
5612 unsigned short int trnlnm_iter_count;
5614 if (utf8_fl != NULL)
5617 if (spec == NULL) return NULL;
5618 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5619 if (buf) rslt = buf;
5621 Newx(rslt, VMS_MAXRSS, char);
5623 else rslt = __tounixspec_retbuf;
5625 /* New VMS specific format needs translation
5626 * glob passes filenames with trailing '\n' and expects this preserved.
5628 if (decc_posix_compliant_pathnames) {
5629 if (strncmp(spec, "\"^UP^", 5) == 0) {
5635 tunix = PerlMem_malloc(VMS_MAXRSS);
5636 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5637 strcpy(tunix, spec);
5638 tunix_len = strlen(tunix);
5640 if (tunix[tunix_len - 1] == '\n') {
5641 tunix[tunix_len - 1] = '\"';
5642 tunix[tunix_len] = '\0';
5646 uspec = decc$translate_vms(tunix);
5647 PerlMem_free(tunix);
5648 if ((int)uspec > 0) {
5654 /* If we can not translate it, makemaker wants as-is */
5662 cmp_rslt = 0; /* Presume VMS */
5663 cp1 = strchr(spec, '/');
5667 /* Look for EFS ^/ */
5668 if (decc_efs_charset) {
5669 while (cp1 != NULL) {
5672 /* Found illegal VMS, assume UNIX */
5677 cp1 = strchr(cp1, '/');
5681 /* Look for "." and ".." */
5682 if (decc_filename_unix_report) {
5683 if (spec[0] == '.') {
5684 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5688 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5694 /* This is already UNIX or at least nothing VMS understands */
5702 dirend = strrchr(spec,']');
5703 if (dirend == NULL) dirend = strrchr(spec,'>');
5704 if (dirend == NULL) dirend = strchr(spec,':');
5705 if (dirend == NULL) {
5710 /* Special case 1 - sys$posix_root = / */
5711 #if __CRTL_VER >= 70000000
5712 if (!decc_disable_posix_root) {
5713 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5721 /* Special case 2 - Convert NLA0: to /dev/null */
5722 #if __CRTL_VER < 70000000
5723 cmp_rslt = strncmp(spec,"NLA0:", 5);
5725 cmp_rslt = strncmp(spec,"nla0:", 5);
5727 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5729 if (cmp_rslt == 0) {
5730 strcpy(rslt, "/dev/null");
5733 if (spec[6] != '\0') {
5740 /* Also handle special case "SYS$SCRATCH:" */
5741 #if __CRTL_VER < 70000000
5742 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5744 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5746 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5748 tmp = PerlMem_malloc(VMS_MAXRSS);
5749 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5750 if (cmp_rslt == 0) {
5753 islnm = my_trnlnm(tmp, "TMP", 0);
5755 strcpy(rslt, "/tmp");
5758 if (spec[12] != '\0') {
5766 if (*cp2 != '[' && *cp2 != '<') {
5769 else { /* the VMS spec begins with directories */
5771 if (*cp2 == ']' || *cp2 == '>') {
5772 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5776 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5777 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5778 if (ts) Safefree(rslt);
5782 trnlnm_iter_count = 0;
5785 while (*cp3 != ':' && *cp3) cp3++;
5787 if (strchr(cp3,']') != NULL) break;
5788 trnlnm_iter_count++;
5789 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5790 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5792 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5793 retlen = devlen + dirlen;
5794 Renew(rslt,retlen+1+2*expand,char);
5800 *(cp1++) = *(cp3++);
5801 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5803 return NULL; /* No room */
5808 if ((*cp2 == '^')) {
5809 /* EFS file escape, pass the next character as is */
5810 /* Fix me: HEX encoding for UNICODE not implemented */
5813 else if ( *cp2 == '.') {
5814 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5815 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5822 for (; cp2 <= dirend; cp2++) {
5823 if ((*cp2 == '^')) {
5824 /* EFS file escape, pass the next character as is */
5825 /* Fix me: HEX encoding for UNICODE not implemented */
5831 if (*(cp2+1) == '[') cp2++;
5833 else if (*cp2 == ']' || *cp2 == '>') {
5834 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5836 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5838 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5839 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5840 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5841 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5842 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5844 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5845 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5849 else if (*cp2 == '-') {
5850 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5851 while (*cp2 == '-') {
5853 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5855 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5856 if (ts) Safefree(rslt); /* filespecs like */
5857 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5861 else *(cp1++) = *cp2;
5863 else *(cp1++) = *cp2;
5865 while (*cp2) *(cp1++) = *(cp2++);
5868 /* This still leaves /000000/ when working with a
5869 * VMS device root or concealed root.
5875 ulen = strlen(rslt);
5877 /* Get rid of "000000/ in rooted filespecs */
5879 zeros = strstr(rslt, "/000000/");
5880 if (zeros != NULL) {
5882 mlen = ulen - (zeros - rslt) - 7;
5883 memmove(zeros, &zeros[7], mlen);
5892 } /* end of do_tounixspec() */
5894 /* External entry points */
5895 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5896 { return do_tounixspec(spec,buf,0, NULL); }
5897 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5898 { return do_tounixspec(spec,buf,1, NULL); }
5899 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5900 { return do_tounixspec(spec,buf,0, utf8_fl); }
5901 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5902 { return do_tounixspec(spec,buf,1, utf8_fl); }
5904 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5907 This procedure is used to identify if a path is based in either
5908 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5909 it returns the OpenVMS format directory for it.
5911 It is expecting specifications of only '/' or '/xxxx/'
5913 If a posix root does not exist, or 'xxxx' is not a directory
5914 in the posix root, it returns a failure.
5916 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5918 It is used only internally by posix_to_vmsspec_hardway().
5921 static int posix_root_to_vms
5922 (char *vmspath, int vmspath_len,
5923 const char *unixpath,
5924 const int * utf8_fl) {
5926 struct FAB myfab = cc$rms_fab;
5927 struct NAML mynam = cc$rms_naml;
5928 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5929 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5936 unixlen = strlen(unixpath);
5942 #if __CRTL_VER >= 80200000
5943 /* If not a posix spec already, convert it */
5944 if (decc_posix_compliant_pathnames) {
5945 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5946 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5949 /* This is already a VMS specification, no conversion */
5951 strncpy(vmspath,unixpath, vmspath_len);
5960 /* Check to see if this is under the POSIX root */
5961 if (decc_disable_posix_root) {
5965 /* Skip leading / */
5966 if (unixpath[0] == '/') {
5972 strcpy(vmspath,"SYS$POSIX_ROOT:");
5974 /* If this is only the / , or blank, then... */
5975 if (unixpath[0] == '\0') {
5976 /* by definition, this is the answer */
5980 /* Need to look up a directory */
5984 /* Copy and add '^' escape characters as needed */
5987 while (unixpath[i] != 0) {
5990 j += copy_expand_unix_filename_escape
5991 (&vmspath[j], &unixpath[i], &k, utf8_fl);
5995 path_len = strlen(vmspath);
5996 if (vmspath[path_len - 1] == '/')
5998 vmspath[path_len] = ']';
6000 vmspath[path_len] = '\0';
6003 vmspath[vmspath_len] = 0;
6004 if (unixpath[unixlen - 1] == '/')
6006 esa = PerlMem_malloc(VMS_MAXRSS);
6007 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6008 myfab.fab$l_fna = vmspath;
6009 myfab.fab$b_fns = strlen(vmspath);
6010 myfab.fab$l_naml = &mynam;
6011 mynam.naml$l_esa = NULL;
6012 mynam.naml$b_ess = 0;
6013 mynam.naml$l_long_expand = esa;
6014 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6015 mynam.naml$l_rsa = NULL;
6016 mynam.naml$b_rss = 0;
6017 if (decc_efs_case_preserve)
6018 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6019 #ifdef NAML$M_OPEN_SPECIAL
6020 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6023 /* Set up the remaining naml fields */
6024 sts = sys$parse(&myfab);
6026 /* It failed! Try again as a UNIX filespec */
6032 /* get the Device ID and the FID */
6033 sts = sys$search(&myfab);
6034 /* on any failure, returned the POSIX ^UP^ filespec */
6039 specdsc.dsc$a_pointer = vmspath;
6040 specdsc.dsc$w_length = vmspath_len;
6042 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6043 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6044 sts = lib$fid_to_name
6045 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6047 /* on any failure, returned the POSIX ^UP^ filespec */
6049 /* This can happen if user does not have permission to read directories */
6050 if (strncmp(unixpath,"\"^UP^",5) != 0)
6051 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6053 strcpy(vmspath, unixpath);
6056 vmspath[specdsc.dsc$w_length] = 0;
6058 /* Are we expecting a directory? */
6059 if (dir_flag != 0) {
6065 i = specdsc.dsc$w_length - 1;
6069 /* Version must be '1' */
6070 if (vmspath[i--] != '1')
6072 /* Version delimiter is one of ".;" */
6073 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6076 if (vmspath[i--] != 'R')
6078 if (vmspath[i--] != 'I')
6080 if (vmspath[i--] != 'D')
6082 if (vmspath[i--] != '.')
6084 eptr = &vmspath[i+1];
6086 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6087 if (vmspath[i-1] != '^') {
6095 /* Get rid of 6 imaginary zero directory filename */
6096 vmspath[i+1] = '\0';
6100 if (vmspath[i] == '0')
6114 /* /dev/mumble needs to be handled special.
6115 /dev/null becomes NLA0:, And there is the potential for other stuff
6116 like /dev/tty which may need to be mapped to something.
6120 slash_dev_special_to_vms
6121 (const char * unixptr,
6131 nextslash = strchr(unixptr, '/');
6132 len = strlen(unixptr);
6133 if (nextslash != NULL)
6134 len = nextslash - unixptr;
6135 cmp = strncmp("null", unixptr, 5);
6137 if (vmspath_len >= 6) {
6138 strcpy(vmspath, "_NLA0:");
6145 /* The built in routines do not understand perl's special needs, so
6146 doing a manual conversion from UNIX to VMS
6148 If the utf8_fl is not null and points to a non-zero value, then
6149 treat 8 bit characters as UTF-8.
6151 The sequence starting with '$(' and ending with ')' will be passed
6152 through with out interpretation instead of being escaped.
6155 static int posix_to_vmsspec_hardway
6156 (char *vmspath, int vmspath_len,
6157 const char *unixpath,
6162 const char *unixptr;
6163 const char *unixend;
6165 const char *lastslash;
6166 const char *lastdot;
6172 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6173 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6175 if (utf8_fl != NULL)
6181 /* Ignore leading "/" characters */
6182 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6185 unixlen = strlen(unixptr);
6187 /* Do nothing with blank paths */
6194 /* This could have a "^UP^ on the front */
6195 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6201 lastslash = strrchr(unixptr,'/');
6202 lastdot = strrchr(unixptr,'.');
6203 unixend = strrchr(unixptr,'\"');
6204 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6205 unixend = unixptr + unixlen;
6208 /* last dot is last dot or past end of string */
6209 if (lastdot == NULL)
6210 lastdot = unixptr + unixlen;
6212 /* if no directories, set last slash to beginning of string */
6213 if (lastslash == NULL) {
6214 lastslash = unixptr;
6217 /* Watch out for trailing "." after last slash, still a directory */
6218 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6219 lastslash = unixptr + unixlen;
6222 /* Watch out for traiing ".." after last slash, still a directory */
6223 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6224 lastslash = unixptr + unixlen;
6227 /* dots in directories are aways escaped */
6228 if (lastdot < lastslash)
6229 lastdot = unixptr + unixlen;
6232 /* if (unixptr < lastslash) then we are in a directory */
6239 /* Start with the UNIX path */
6240 if (*unixptr != '/') {
6241 /* relative paths */
6243 /* If allowing logical names on relative pathnames, then handle here */
6244 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6245 !decc_posix_compliant_pathnames) {
6251 /* Find the next slash */
6252 nextslash = strchr(unixptr,'/');
6254 esa = PerlMem_malloc(vmspath_len);
6255 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6257 trn = PerlMem_malloc(VMS_MAXRSS);
6258 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6260 if (nextslash != NULL) {
6262 seg_len = nextslash - unixptr;
6263 strncpy(esa, unixptr, seg_len);
6267 strcpy(esa, unixptr);
6268 seg_len = strlen(unixptr);
6270 /* trnlnm(section) */
6271 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6274 /* Now fix up the directory */
6276 /* Split up the path to find the components */
6277 sts = vms_split_path
6296 /* A logical name must be a directory or the full
6297 specification. It is only a full specification if
6298 it is the only component */
6299 if ((unixptr[seg_len] == '\0') ||
6300 (unixptr[seg_len+1] == '\0')) {
6302 /* Is a directory being required? */
6303 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6304 /* Not a logical name */
6309 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6310 /* This must be a directory */
6311 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6312 strcpy(vmsptr, esa);
6313 vmslen=strlen(vmsptr);
6314 vmsptr[vmslen] = ':';
6316 vmsptr[vmslen] = '\0';
6324 /* must be dev/directory - ignore version */
6325 if ((n_len + e_len) != 0)
6328 /* transfer the volume */
6329 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6330 strncpy(vmsptr, v_spec, v_len);
6336 /* unroot the rooted directory */
6337 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6339 r_spec[r_len - 1] = ']';
6341 /* This should not be there, but nothing is perfect */
6343 cmp = strcmp(&r_spec[1], "000000.");
6353 strncpy(vmsptr, r_spec, r_len);
6359 /* Bring over the directory. */
6361 ((d_len + vmslen) < vmspath_len)) {
6363 d_spec[d_len - 1] = ']';
6365 cmp = strcmp(&d_spec[1], "000000.");
6376 /* Remove the redundant root */
6384 strncpy(vmsptr, d_spec, d_len);
6398 if (lastslash > unixptr) {
6401 /* skip leading ./ */
6403 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6409 /* Are we still in a directory? */
6410 if (unixptr <= lastslash) {
6415 /* if not backing up, then it is relative forward. */
6416 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6417 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6425 /* Perl wants an empty directory here to tell the difference
6426 * between a DCL commmand and a filename
6435 /* Handle two special files . and .. */
6436 if (unixptr[0] == '.') {
6437 if (&unixptr[1] == unixend) {
6444 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6455 else { /* Absolute PATH handling */
6459 /* Need to find out where root is */
6461 /* In theory, this procedure should never get an absolute POSIX pathname
6462 * that can not be found on the POSIX root.
6463 * In practice, that can not be relied on, and things will show up
6464 * here that are a VMS device name or concealed logical name instead.
6465 * So to make things work, this procedure must be tolerant.
6467 esa = PerlMem_malloc(vmspath_len);
6468 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6471 nextslash = strchr(&unixptr[1],'/');
6473 if (nextslash != NULL) {
6475 seg_len = nextslash - &unixptr[1];
6476 strncpy(vmspath, unixptr, seg_len + 1);
6477 vmspath[seg_len+1] = 0;
6480 cmp = strncmp(vmspath, "dev", 4);
6482 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6483 if (sts = SS$_NORMAL)
6487 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6490 if ($VMS_STATUS_SUCCESS(sts)) {
6491 /* This is verified to be a real path */
6493 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6494 if ($VMS_STATUS_SUCCESS(sts)) {
6495 strcpy(vmspath, esa);
6496 vmslen = strlen(vmspath);
6497 vmsptr = vmspath + vmslen;
6499 if (unixptr < lastslash) {
6508 cmp = strcmp(rptr,"000000.");
6513 } /* removing 6 zeros */
6514 } /* vmslen < 7, no 6 zeros possible */
6515 } /* Not in a directory */
6516 } /* Posix root found */
6518 /* No posix root, fall back to default directory */
6519 strcpy(vmspath, "SYS$DISK:[");
6520 vmsptr = &vmspath[10];
6522 if (unixptr > lastslash) {
6531 } /* end of verified real path handling */
6536 /* Ok, we have a device or a concealed root that is not in POSIX
6537 * or we have garbage. Make the best of it.
6540 /* Posix to VMS destroyed this, so copy it again */
6541 strncpy(vmspath, &unixptr[1], seg_len);
6542 vmspath[seg_len] = 0;
6544 vmsptr = &vmsptr[vmslen];
6547 /* Now do we need to add the fake 6 zero directory to it? */
6549 if ((*lastslash == '/') && (nextslash < lastslash)) {
6550 /* No there is another directory */
6557 /* now we have foo:bar or foo:[000000]bar to decide from */
6558 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6560 if (!islnm && !decc_posix_compliant_pathnames) {
6562 cmp = strncmp("bin", vmspath, 4);
6564 /* bin => SYS$SYSTEM: */
6565 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6568 /* tmp => SYS$SCRATCH: */
6569 cmp = strncmp("tmp", vmspath, 4);
6571 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6576 trnend = islnm ? islnm - 1 : 0;
6578 /* if this was a logical name, ']' or '>' must be present */
6579 /* if not a logical name, then assume a device and hope. */
6580 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6582 /* if log name and trailing '.' then rooted - treat as device */
6583 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6585 /* Fix me, if not a logical name, a device lookup should be
6586 * done to see if the device is file structured. If the device
6587 * is not file structured, the 6 zeros should not be put on.
6589 * As it is, perl is occasionally looking for dev:[000000]tty.
6590 * which looks a little strange.
6592 * Not that easy to detect as "/dev" may be file structured with
6593 * special device files.
6596 if ((add_6zero == 0) && (*nextslash == '/') &&
6597 (&nextslash[1] == unixend)) {
6598 /* No real directory present */
6603 /* Put the device delimiter on */
6606 unixptr = nextslash;
6609 /* Start directory if needed */
6610 if (!islnm || add_6zero) {
6616 /* add fake 000000] if needed */
6629 } /* non-POSIX translation */
6631 } /* End of relative/absolute path handling */
6633 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6640 if (dir_start != 0) {
6642 /* First characters in a directory are handled special */
6643 while ((*unixptr == '/') ||
6644 ((*unixptr == '.') &&
6645 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6646 (&unixptr[1]==unixend)))) {
6651 /* Skip redundant / in specification */
6652 while ((*unixptr == '/') && (dir_start != 0)) {
6655 if (unixptr == lastslash)
6658 if (unixptr == lastslash)
6661 /* Skip redundant ./ characters */
6662 while ((*unixptr == '.') &&
6663 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6666 if (unixptr == lastslash)
6668 if (*unixptr == '/')
6671 if (unixptr == lastslash)
6674 /* Skip redundant ../ characters */
6675 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6676 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6677 /* Set the backing up flag */
6683 unixptr++; /* first . */
6684 unixptr++; /* second . */
6685 if (unixptr == lastslash)
6687 if (*unixptr == '/') /* The slash */
6690 if (unixptr == lastslash)
6693 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6694 /* Not needed when VMS is pretending to be UNIX. */
6696 /* Is this loop stuck because of too many dots? */
6697 if (loop_flag == 0) {
6698 /* Exit the loop and pass the rest through */
6703 /* Are we done with directories yet? */
6704 if (unixptr >= lastslash) {
6706 /* Watch out for trailing dots */
6715 if (*unixptr == '/')
6719 /* Have we stopped backing up? */
6724 /* dir_start continues to be = 1 */
6726 if (*unixptr == '-') {
6728 *vmsptr++ = *unixptr++;
6732 /* Now are we done with directories yet? */
6733 if (unixptr >= lastslash) {
6735 /* Watch out for trailing dots */
6751 if (unixptr >= unixend)
6754 /* Normal characters - More EFS work probably needed */
6760 /* remove multiple / */
6761 while (unixptr[1] == '/') {
6764 if (unixptr == lastslash) {
6765 /* Watch out for trailing dots */
6777 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6778 /* Not needed when VMS is pretending to be UNIX. */
6782 if (unixptr != unixend)
6787 if ((unixptr < lastdot) || (unixptr < lastslash) ||
6788 (&unixptr[1] == unixend)) {
6794 /* trailing dot ==> '^..' on VMS */
6795 if (unixptr == unixend) {
6803 *vmsptr++ = *unixptr++;
6807 if (quoted && (&unixptr[1] == unixend)) {
6811 in_cnt = copy_expand_unix_filename_escape
6812 (vmsptr, unixptr, &out_cnt, utf8_fl);
6822 in_cnt = copy_expand_unix_filename_escape
6823 (vmsptr, unixptr, &out_cnt, utf8_fl);
6830 /* Make sure directory is closed */
6831 if (unixptr == lastslash) {
6833 vmsptr2 = vmsptr - 1;
6835 if (*vmsptr2 != ']') {
6838 /* directories do not end in a dot bracket */
6839 if (*vmsptr2 == '.') {
6843 if (*vmsptr2 != '^') {
6844 vmsptr--; /* back up over the dot */
6852 /* Add a trailing dot if a file with no extension */
6853 vmsptr2 = vmsptr - 1;
6855 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6856 (*vmsptr2 != ')') && (*lastdot != '.')) {
6867 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6868 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6873 /* If a UTF8 flag is being passed, honor it */
6875 if (utf8_fl != NULL) {
6876 utf8_flag = *utf8_fl;
6881 /* If there is a possibility of UTF8, then if any UTF8 characters
6882 are present, then they must be converted to VTF-7
6884 result = strcpy(rslt, path); /* FIX-ME */
6887 result = strcpy(rslt, path);
6893 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6894 static char *mp_do_tovmsspec
6895 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6896 static char __tovmsspec_retbuf[VMS_MAXRSS];
6897 char *rslt, *dirend;
6902 unsigned long int infront = 0, hasdir = 1;
6905 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6906 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6908 if (path == NULL) return NULL;
6909 rslt_len = VMS_MAXRSS-1;
6910 if (buf) rslt = buf;
6911 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6912 else rslt = __tovmsspec_retbuf;
6914 /* '.' and '..' are "[]" and "[-]" for a quick check */
6915 if (path[0] == '.') {
6916 if (path[1] == '\0') {
6918 if (utf8_flag != NULL)
6923 if (path[1] == '.' && path[2] == '\0') {
6925 if (utf8_flag != NULL)
6932 /* Posix specifications are now a native VMS format */
6933 /*--------------------------------------------------*/
6934 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6935 if (decc_posix_compliant_pathnames) {
6936 if (strncmp(path,"\"^UP^",5) == 0) {
6937 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6943 /* This is really the only way to see if this is already in VMS format */
6944 sts = vms_split_path
6959 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6960 replacement, because the above parse just took care of most of
6961 what is needed to do vmspath when the specification is already
6964 And if it is not already, it is easier to do the conversion as
6965 part of this routine than to call this routine and then work on
6969 /* If VMS punctuation was found, it is already VMS format */
6970 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6971 if (utf8_flag != NULL)
6976 /* Now, what to do with trailing "." cases where there is no
6977 extension? If this is a UNIX specification, and EFS characters
6978 are enabled, then the trailing "." should be converted to a "^.".
6979 But if this was already a VMS specification, then it should be
6982 So in the case of ambiguity, leave the specification alone.
6986 /* If there is a possibility of UTF8, then if any UTF8 characters
6987 are present, then they must be converted to VTF-7
6989 if (utf8_flag != NULL)
6995 dirend = strrchr(path,'/');
6997 if (dirend == NULL) {
6998 /* If we get here with no UNIX directory delimiters, then this is
6999 not a complete file specification, either garbage a UNIX glob
7000 specification that can not be converted to a VMS wildcard, or
7001 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7002 so apparently other programs expect this also.
7004 utf8 flag setting needs to be preserved.
7010 /* If POSIX mode active, handle the conversion */
7011 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7012 if (decc_efs_charset) {
7013 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7018 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7019 if (!*(dirend+2)) dirend +=2;
7020 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7021 if (decc_efs_charset == 0) {
7022 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7028 lastdot = strrchr(cp2,'.');
7034 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7036 if (decc_disable_posix_root) {
7037 strcpy(rslt,"sys$disk:[000000]");
7040 strcpy(rslt,"sys$posix_root:[000000]");
7042 if (utf8_flag != NULL)
7046 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7048 trndev = PerlMem_malloc(VMS_MAXRSS);
7049 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7050 islnm = my_trnlnm(rslt,trndev,0);
7052 /* DECC special handling */
7054 if (strcmp(rslt,"bin") == 0) {
7055 strcpy(rslt,"sys$system");
7058 islnm = my_trnlnm(rslt,trndev,0);
7060 else if (strcmp(rslt,"tmp") == 0) {
7061 strcpy(rslt,"sys$scratch");
7064 islnm = my_trnlnm(rslt,trndev,0);
7066 else if (!decc_disable_posix_root) {
7067 strcpy(rslt, "sys$posix_root");
7071 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7072 islnm = my_trnlnm(rslt,trndev,0);
7074 else if (strcmp(rslt,"dev") == 0) {
7075 if (strncmp(cp2,"/null", 5) == 0) {
7076 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7077 strcpy(rslt,"NLA0");
7081 islnm = my_trnlnm(rslt,trndev,0);
7087 trnend = islnm ? strlen(trndev) - 1 : 0;
7088 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7089 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7090 /* If the first element of the path is a logical name, determine
7091 * whether it has to be translated so we can add more directories. */
7092 if (!islnm || rooted) {
7095 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7099 if (cp2 != dirend) {
7100 strcpy(rslt,trndev);
7101 cp1 = rslt + trnend;
7108 if (decc_disable_posix_root) {
7114 PerlMem_free(trndev);
7119 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7120 cp2 += 2; /* skip over "./" - it's redundant */
7121 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7123 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7124 *(cp1++) = '-'; /* "../" --> "-" */
7127 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7128 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7129 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7130 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7133 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7134 /* Escape the extra dots in EFS file specifications */
7137 if (cp2 > dirend) cp2 = dirend;
7139 else *(cp1++) = '.';
7141 for (; cp2 < dirend; cp2++) {
7143 if (*(cp2-1) == '/') continue;
7144 if (*(cp1-1) != '.') *(cp1++) = '.';
7147 else if (!infront && *cp2 == '.') {
7148 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7149 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7150 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7151 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7152 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7153 else { /* back up over previous directory name */
7155 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7156 if (*(cp1-1) == '[') {
7157 memcpy(cp1,"000000.",7);
7162 if (cp2 == dirend) break;
7164 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7165 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7166 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7167 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7169 *(cp1++) = '.'; /* Simulate trailing '/' */
7170 cp2 += 2; /* for loop will incr this to == dirend */
7172 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7175 if (decc_efs_charset == 0)
7176 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7178 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7184 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7186 if (decc_efs_charset == 0)
7193 else *(cp1++) = *cp2;
7197 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7198 if (hasdir) *(cp1++) = ']';
7199 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7200 /* fixme for ODS5 */
7207 if (decc_efs_charset == 0)
7218 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7219 decc_readdir_dropdotnotype) {
7224 /* trailing dot ==> '^..' on VMS */
7231 *(cp1++) = *(cp2++);
7236 /* This could be a macro to be passed through */
7237 *(cp1++) = *(cp2++);
7239 const char * save_cp2;
7243 /* paranoid check */
7249 *(cp1++) = *(cp2++);
7250 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7251 *(cp1++) = *(cp2++);
7252 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7253 *(cp1++) = *(cp2++);
7256 *(cp1++) = *(cp2++);
7260 if (is_macro == 0) {
7261 /* Not really a macro - never mind */
7291 *(cp1++) = *(cp2++);
7294 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7295 * which is wrong. UNIX notation should be ".dir." unless
7296 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7297 * changing this behavior could break more things at this time.
7298 * efs character set effectively does not allow "." to be a version
7299 * delimiter as a further complication about changing this.
7301 if (decc_filename_unix_report != 0) {
7304 *(cp1++) = *(cp2++);
7307 *(cp1++) = *(cp2++);
7310 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7314 /* Fix me for "^]", but that requires making sure that you do
7315 * not back up past the start of the filename
7317 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7322 if (utf8_flag != NULL)
7326 } /* end of do_tovmsspec() */
7328 /* External entry points */
7329 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7330 { return do_tovmsspec(path,buf,0,NULL); }
7331 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7332 { return do_tovmsspec(path,buf,1,NULL); }
7333 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7334 { return do_tovmsspec(path,buf,0,utf8_fl); }
7335 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7336 { return do_tovmsspec(path,buf,1,utf8_fl); }
7338 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7339 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7340 static char __tovmspath_retbuf[VMS_MAXRSS];
7342 char *pathified, *vmsified, *cp;
7344 if (path == NULL) return NULL;
7345 pathified = PerlMem_malloc(VMS_MAXRSS);
7346 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7347 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7348 PerlMem_free(pathified);
7354 Newx(vmsified, VMS_MAXRSS, char);
7355 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7356 PerlMem_free(pathified);
7357 if (vmsified) Safefree(vmsified);
7360 PerlMem_free(pathified);
7365 vmslen = strlen(vmsified);
7366 Newx(cp,vmslen+1,char);
7367 memcpy(cp,vmsified,vmslen);
7373 strcpy(__tovmspath_retbuf,vmsified);
7375 return __tovmspath_retbuf;
7378 } /* end of do_tovmspath() */
7380 /* External entry points */
7381 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7382 { return do_tovmspath(path,buf,0, NULL); }
7383 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7384 { return do_tovmspath(path,buf,1, NULL); }
7385 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7386 { return do_tovmspath(path,buf,0,utf8_fl); }
7387 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7388 { return do_tovmspath(path,buf,1,utf8_fl); }
7391 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7392 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7393 static char __tounixpath_retbuf[VMS_MAXRSS];
7395 char *pathified, *unixified, *cp;
7397 if (path == NULL) return NULL;
7398 pathified = PerlMem_malloc(VMS_MAXRSS);
7399 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7400 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7401 PerlMem_free(pathified);
7407 Newx(unixified, VMS_MAXRSS, char);
7409 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7410 PerlMem_free(pathified);
7411 if (unixified) Safefree(unixified);
7414 PerlMem_free(pathified);
7419 unixlen = strlen(unixified);
7420 Newx(cp,unixlen+1,char);
7421 memcpy(cp,unixified,unixlen);
7423 Safefree(unixified);
7427 strcpy(__tounixpath_retbuf,unixified);
7428 Safefree(unixified);
7429 return __tounixpath_retbuf;
7432 } /* end of do_tounixpath() */
7434 /* External entry points */
7435 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7436 { return do_tounixpath(path,buf,0,NULL); }
7437 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7438 { return do_tounixpath(path,buf,1,NULL); }
7439 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7440 { return do_tounixpath(path,buf,0,utf8_fl); }
7441 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7442 { return do_tounixpath(path,buf,1,utf8_fl); }
7445 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
7447 *****************************************************************************
7449 * Copyright (C) 1989-1994 by *
7450 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7452 * Permission is hereby granted for the reproduction of this software, *
7453 * on condition that this copyright notice is included in the reproduction, *
7454 * and that such reproduction is not for purposes of profit or material *
7457 * 27-Aug-1994 Modified for inclusion in perl5 *
7458 * by Charles Bailey bailey@newman.upenn.edu *
7459 *****************************************************************************
7463 * getredirection() is intended to aid in porting C programs
7464 * to VMS (Vax-11 C). The native VMS environment does not support
7465 * '>' and '<' I/O redirection, or command line wild card expansion,
7466 * or a command line pipe mechanism using the '|' AND background
7467 * command execution '&'. All of these capabilities are provided to any
7468 * C program which calls this procedure as the first thing in the
7470 * The piping mechanism will probably work with almost any 'filter' type
7471 * of program. With suitable modification, it may useful for other
7472 * portability problems as well.
7474 * Author: Mark Pizzolato mark@infocomm.com
7478 struct list_item *next;
7482 static void add_item(struct list_item **head,
7483 struct list_item **tail,
7487 static void mp_expand_wild_cards(pTHX_ char *item,
7488 struct list_item **head,
7489 struct list_item **tail,
7492 static int background_process(pTHX_ int argc, char **argv);
7494 static void pipe_and_fork(pTHX_ char **cmargv);
7496 /*{{{ void getredirection(int *ac, char ***av)*/
7498 mp_getredirection(pTHX_ int *ac, char ***av)
7500 * Process vms redirection arg's. Exit if any error is seen.
7501 * If getredirection() processes an argument, it is erased
7502 * from the vector. getredirection() returns a new argc and argv value.
7503 * In the event that a background command is requested (by a trailing "&"),
7504 * this routine creates a background subprocess, and simply exits the program.
7506 * Warning: do not try to simplify the code for vms. The code
7507 * presupposes that getredirection() is called before any data is
7508 * read from stdin or written to stdout.
7510 * Normal usage is as follows:
7516 * getredirection(&argc, &argv);
7520 int argc = *ac; /* Argument Count */
7521 char **argv = *av; /* Argument Vector */
7522 char *ap; /* Argument pointer */
7523 int j; /* argv[] index */
7524 int item_count = 0; /* Count of Items in List */
7525 struct list_item *list_head = 0; /* First Item in List */
7526 struct list_item *list_tail; /* Last Item in List */
7527 char *in = NULL; /* Input File Name */
7528 char *out = NULL; /* Output File Name */
7529 char *outmode = "w"; /* Mode to Open Output File */
7530 char *err = NULL; /* Error File Name */
7531 char *errmode = "w"; /* Mode to Open Error File */
7532 int cmargc = 0; /* Piped Command Arg Count */
7533 char **cmargv = NULL;/* Piped Command Arg Vector */
7536 * First handle the case where the last thing on the line ends with
7537 * a '&'. This indicates the desire for the command to be run in a
7538 * subprocess, so we satisfy that desire.
7541 if (0 == strcmp("&", ap))
7542 exit(background_process(aTHX_ --argc, argv));
7543 if (*ap && '&' == ap[strlen(ap)-1])
7545 ap[strlen(ap)-1] = '\0';
7546 exit(background_process(aTHX_ argc, argv));
7549 * Now we handle the general redirection cases that involve '>', '>>',
7550 * '<', and pipes '|'.
7552 for (j = 0; j < argc; ++j)
7554 if (0 == strcmp("<", argv[j]))
7558 fprintf(stderr,"No input file after < on command line");
7559 exit(LIB$_WRONUMARG);
7564 if ('<' == *(ap = argv[j]))
7569 if (0 == strcmp(">", ap))
7573 fprintf(stderr,"No output file after > on command line");
7574 exit(LIB$_WRONUMARG);
7593 fprintf(stderr,"No output file after > or >> on command line");
7594 exit(LIB$_WRONUMARG);
7598 if (('2' == *ap) && ('>' == ap[1]))
7615 fprintf(stderr,"No output file after 2> or 2>> on command line");
7616 exit(LIB$_WRONUMARG);
7620 if (0 == strcmp("|", argv[j]))
7624 fprintf(stderr,"No command into which to pipe on command line");
7625 exit(LIB$_WRONUMARG);
7627 cmargc = argc-(j+1);
7628 cmargv = &argv[j+1];
7632 if ('|' == *(ap = argv[j]))
7640 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7643 * Allocate and fill in the new argument vector, Some Unix's terminate
7644 * the list with an extra null pointer.
7646 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7647 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7649 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7650 argv[j] = list_head->value;
7656 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7657 exit(LIB$_INVARGORD);
7659 pipe_and_fork(aTHX_ cmargv);
7662 /* Check for input from a pipe (mailbox) */
7664 if (in == NULL && 1 == isapipe(0))
7666 char mbxname[L_tmpnam];
7668 long int dvi_item = DVI$_DEVBUFSIZ;
7669 $DESCRIPTOR(mbxnam, "");
7670 $DESCRIPTOR(mbxdevnam, "");
7672 /* Input from a pipe, reopen it in binary mode to disable */
7673 /* carriage control processing. */
7675 fgetname(stdin, mbxname);
7676 mbxnam.dsc$a_pointer = mbxname;
7677 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7678 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7679 mbxdevnam.dsc$a_pointer = mbxname;
7680 mbxdevnam.dsc$w_length = sizeof(mbxname);
7681 dvi_item = DVI$_DEVNAM;
7682 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7683 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7686 freopen(mbxname, "rb", stdin);
7689 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7693 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7695 fprintf(stderr,"Can't open input file %s as stdin",in);
7698 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7700 fprintf(stderr,"Can't open output file %s as stdout",out);
7703 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7706 if (strcmp(err,"&1") == 0) {
7707 dup2(fileno(stdout), fileno(stderr));
7708 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7711 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7713 fprintf(stderr,"Can't open error file %s as stderr",err);
7717 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7721 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7724 #ifdef ARGPROC_DEBUG
7725 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7726 for (j = 0; j < *ac; ++j)
7727 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7729 /* Clear errors we may have hit expanding wildcards, so they don't
7730 show up in Perl's $! later */
7731 set_errno(0); set_vaxc_errno(1);
7732 } /* end of getredirection() */
7735 static void add_item(struct list_item **head,
7736 struct list_item **tail,
7742 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7743 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7747 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7748 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7749 *tail = (*tail)->next;
7751 (*tail)->value = value;
7755 static void mp_expand_wild_cards(pTHX_ char *item,
7756 struct list_item **head,
7757 struct list_item **tail,
7761 unsigned long int context = 0;
7769 $DESCRIPTOR(filespec, "");
7770 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7771 $DESCRIPTOR(resultspec, "");
7772 unsigned long int lff_flags = 0;
7776 #ifdef VMS_LONGNAME_SUPPORT
7777 lff_flags = LIB$M_FIL_LONG_NAMES;
7780 for (cp = item; *cp; cp++) {
7781 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7782 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7784 if (!*cp || isspace(*cp))
7786 add_item(head, tail, item, count);
7791 /* "double quoted" wild card expressions pass as is */
7792 /* From DCL that means using e.g.: */
7793 /* perl program """perl.*""" */
7794 item_len = strlen(item);
7795 if ( '"' == *item && '"' == item[item_len-1] )
7798 item[item_len-2] = '\0';
7799 add_item(head, tail, item, count);
7803 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7804 resultspec.dsc$b_class = DSC$K_CLASS_D;
7805 resultspec.dsc$a_pointer = NULL;
7806 vmsspec = PerlMem_malloc(VMS_MAXRSS);
7807 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7808 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7809 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7810 if (!isunix || !filespec.dsc$a_pointer)
7811 filespec.dsc$a_pointer = item;
7812 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7814 * Only return version specs, if the caller specified a version
7816 had_version = strchr(item, ';');
7818 * Only return device and directory specs, if the caller specifed either.
7820 had_device = strchr(item, ':');
7821 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7823 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7824 (&filespec, &resultspec, &context,
7825 &defaultspec, 0, &rms_sts, &lff_flags)))
7830 string = PerlMem_malloc(resultspec.dsc$w_length+1);
7831 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7832 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7833 string[resultspec.dsc$w_length] = '\0';
7834 if (NULL == had_version)
7835 *(strrchr(string, ';')) = '\0';
7836 if ((!had_directory) && (had_device == NULL))
7838 if (NULL == (devdir = strrchr(string, ']')))
7839 devdir = strrchr(string, '>');
7840 strcpy(string, devdir + 1);
7843 * Be consistent with what the C RTL has already done to the rest of
7844 * the argv items and lowercase all of these names.
7846 if (!decc_efs_case_preserve) {
7847 for (c = string; *c; ++c)
7851 if (isunix) trim_unixpath(string,item,1);
7852 add_item(head, tail, string, count);
7855 PerlMem_free(vmsspec);
7856 if (sts != RMS$_NMF)
7858 set_vaxc_errno(sts);
7861 case RMS$_FNF: case RMS$_DNF:
7862 set_errno(ENOENT); break;
7864 set_errno(ENOTDIR); break;
7866 set_errno(ENODEV); break;
7867 case RMS$_FNM: case RMS$_SYN:
7868 set_errno(EINVAL); break;
7870 set_errno(EACCES); break;
7872 _ckvmssts_noperl(sts);
7876 add_item(head, tail, item, count);
7877 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7878 _ckvmssts_noperl(lib$find_file_end(&context));
7881 static int child_st[2];/* Event Flag set when child process completes */
7883 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
7885 static unsigned long int exit_handler(int *status)
7889 if (0 == child_st[0])
7891 #ifdef ARGPROC_DEBUG
7892 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7894 fflush(stdout); /* Have to flush pipe for binary data to */
7895 /* terminate properly -- <tp@mccall.com> */
7896 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7897 sys$dassgn(child_chan);
7899 sys$synch(0, child_st);
7904 static void sig_child(int chan)
7906 #ifdef ARGPROC_DEBUG
7907 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7909 if (child_st[0] == 0)
7913 static struct exit_control_block exit_block =
7918 &exit_block.exit_status,
7923 pipe_and_fork(pTHX_ char **cmargv)
7926 struct dsc$descriptor_s *vmscmd;
7927 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7928 int sts, j, l, ismcr, quote, tquote = 0;
7930 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
7931 vms_execfree(vmscmd);
7936 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7937 && toupper(*(q+2)) == 'R' && !*(q+3);
7939 while (q && l < MAX_DCL_LINE_LENGTH) {
7941 if (j > 0 && quote) {
7947 if (ismcr && j > 1) quote = 1;
7948 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7951 if (quote || tquote) {
7957 if ((quote||tquote) && *q == '"') {
7967 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7969 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7973 static int background_process(pTHX_ int argc, char **argv)
7975 char command[MAX_DCL_SYMBOL + 1] = "$";
7976 $DESCRIPTOR(value, "");
7977 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7978 static $DESCRIPTOR(null, "NLA0:");
7979 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7981 $DESCRIPTOR(pidstr, "");
7983 unsigned long int flags = 17, one = 1, retsts;
7986 strcat(command, argv[0]);
7987 len = strlen(command);
7988 while (--argc && (len < MAX_DCL_SYMBOL))
7990 strcat(command, " \"");
7991 strcat(command, *(++argv));
7992 strcat(command, "\"");
7993 len = strlen(command);
7995 value.dsc$a_pointer = command;
7996 value.dsc$w_length = strlen(value.dsc$a_pointer);
7997 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7998 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7999 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8000 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8003 _ckvmssts_noperl(retsts);
8005 #ifdef ARGPROC_DEBUG
8006 PerlIO_printf(Perl_debug_log, "%s\n", command);
8008 sprintf(pidstring, "%08X", pid);
8009 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8010 pidstr.dsc$a_pointer = pidstring;
8011 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8012 lib$set_symbol(&pidsymbol, &pidstr);
8016 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8019 /* OS-specific initialization at image activation (not thread startup) */
8020 /* Older VAXC header files lack these constants */
8021 #ifndef JPI$_RIGHTS_SIZE
8022 # define JPI$_RIGHTS_SIZE 817
8024 #ifndef KGB$M_SUBSYSTEM
8025 # define KGB$M_SUBSYSTEM 0x8
8028 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8030 /*{{{void vms_image_init(int *, char ***)*/
8032 vms_image_init(int *argcp, char ***argvp)
8034 char eqv[LNM$C_NAMLENGTH+1] = "";
8035 unsigned int len, tabct = 8, tabidx = 0;
8036 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8037 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8038 unsigned short int dummy, rlen;
8039 struct dsc$descriptor_s **tabvec;
8040 #if defined(PERL_IMPLICIT_CONTEXT)
8043 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8044 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8045 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8048 #ifdef KILL_BY_SIGPRC
8049 Perl_csighandler_init();
8052 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8053 _ckvmssts_noperl(iosb[0]);
8054 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8055 if (iprv[i]) { /* Running image installed with privs? */
8056 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8061 /* Rights identifiers might trigger tainting as well. */
8062 if (!will_taint && (rlen || rsz)) {
8063 while (rlen < rsz) {
8064 /* We didn't get all the identifiers on the first pass. Allocate a
8065 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8066 * were needed to hold all identifiers at time of last call; we'll
8067 * allocate that many unsigned long ints), and go back and get 'em.
8068 * If it gave us less than it wanted to despite ample buffer space,
8069 * something's broken. Is your system missing a system identifier?
8071 if (rsz <= jpilist[1].buflen) {
8072 /* Perl_croak accvios when used this early in startup. */
8073 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8074 rsz, (unsigned long) jpilist[1].buflen,
8075 "Check your rights database for corruption.\n");
8078 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8079 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8080 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8081 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8082 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8083 _ckvmssts_noperl(iosb[0]);
8085 mask = jpilist[1].bufadr;
8086 /* Check attribute flags for each identifier (2nd longword); protected
8087 * subsystem identifiers trigger tainting.
8089 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8090 if (mask[i] & KGB$M_SUBSYSTEM) {
8095 if (mask != rlst) PerlMem_free(mask);
8098 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8099 * logical, some versions of the CRTL will add a phanthom /000000/
8100 * directory. This needs to be removed.
8102 if (decc_filename_unix_report) {
8105 ulen = strlen(argvp[0][0]);
8107 zeros = strstr(argvp[0][0], "/000000/");
8108 if (zeros != NULL) {
8110 mlen = ulen - (zeros - argvp[0][0]) - 7;
8111 memmove(zeros, &zeros[7], mlen);
8113 argvp[0][0][ulen] = '\0';
8116 /* It also may have a trailing dot that needs to be removed otherwise
8117 * it will be converted to VMS mode incorrectly.
8120 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8121 argvp[0][0][ulen] = '\0';
8124 /* We need to use this hack to tell Perl it should run with tainting,
8125 * since its tainting flag may be part of the PL_curinterp struct, which
8126 * hasn't been allocated when vms_image_init() is called.
8129 char **newargv, **oldargv;
8131 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8132 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8133 newargv[0] = oldargv[0];
8134 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8135 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8136 strcpy(newargv[1], "-T");
8137 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8139 newargv[*argcp] = NULL;
8140 /* We orphan the old argv, since we don't know where it's come from,
8141 * so we don't know how to free it.
8145 else { /* Did user explicitly request tainting? */
8147 char *cp, **av = *argvp;
8148 for (i = 1; i < *argcp; i++) {
8149 if (*av[i] != '-') break;
8150 for (cp = av[i]+1; *cp; cp++) {
8151 if (*cp == 'T') { will_taint = 1; break; }
8152 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8153 strchr("DFIiMmx",*cp)) break;
8155 if (will_taint) break;
8160 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8163 tabvec = (struct dsc$descriptor_s **)
8164 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8165 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8167 else if (tabidx >= tabct) {
8169 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8170 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8172 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8173 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8174 tabvec[tabidx]->dsc$w_length = 0;
8175 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8176 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8177 tabvec[tabidx]->dsc$a_pointer = NULL;
8178 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8180 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8182 getredirection(argcp,argvp);
8183 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8185 # include <reentrancy.h>
8186 decc$set_reentrancy(C$C_MULTITHREAD);
8195 * Trim Unix-style prefix off filespec, so it looks like what a shell
8196 * glob expansion would return (i.e. from specified prefix on, not
8197 * full path). Note that returned filespec is Unix-style, regardless
8198 * of whether input filespec was VMS-style or Unix-style.
8200 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8201 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8202 * vector of options; at present, only bit 0 is used, and if set tells
8203 * trim unixpath to try the current default directory as a prefix when
8204 * presented with a possibly ambiguous ... wildcard.
8206 * Returns !=0 on success, with trimmed filespec replacing contents of
8207 * fspec, and 0 on failure, with contents of fpsec unchanged.
8209 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8211 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8213 char *unixified, *unixwild,
8214 *template, *base, *end, *cp1, *cp2;
8215 register int tmplen, reslen = 0, dirs = 0;
8217 unixwild = PerlMem_malloc(VMS_MAXRSS);
8218 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8219 if (!wildspec || !fspec) return 0;
8220 template = unixwild;
8221 if (strpbrk(wildspec,"]>:") != NULL) {
8222 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8223 PerlMem_free(unixwild);
8228 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8229 unixwild[VMS_MAXRSS-1] = 0;
8231 unixified = PerlMem_malloc(VMS_MAXRSS);
8232 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8233 if (strpbrk(fspec,"]>:") != NULL) {
8234 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8235 PerlMem_free(unixwild);
8236 PerlMem_free(unixified);
8239 else base = unixified;
8240 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8241 * check to see that final result fits into (isn't longer than) fspec */
8242 reslen = strlen(fspec);
8246 /* No prefix or absolute path on wildcard, so nothing to remove */
8247 if (!*template || *template == '/') {
8248 PerlMem_free(unixwild);
8249 if (base == fspec) {
8250 PerlMem_free(unixified);
8253 tmplen = strlen(unixified);
8254 if (tmplen > reslen) {
8255 PerlMem_free(unixified);
8256 return 0; /* not enough space */
8258 /* Copy unixified resultant, including trailing NUL */
8259 memmove(fspec,unixified,tmplen+1);
8260 PerlMem_free(unixified);
8264 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8265 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8266 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8267 for (cp1 = end ;cp1 >= base; cp1--)
8268 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8270 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8271 PerlMem_free(unixified);
8272 PerlMem_free(unixwild);
8277 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8278 int ells = 1, totells, segdirs, match;
8279 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8280 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8282 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8284 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8285 tpl = PerlMem_malloc(VMS_MAXRSS);
8286 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8287 if (ellipsis == template && opts & 1) {
8288 /* Template begins with an ellipsis. Since we can't tell how many
8289 * directory names at the front of the resultant to keep for an
8290 * arbitrary starting point, we arbitrarily choose the current
8291 * default directory as a starting point. If it's there as a prefix,
8292 * clip it off. If not, fall through and act as if the leading
8293 * ellipsis weren't there (i.e. return shortest possible path that
8294 * could match template).
8296 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8298 PerlMem_free(unixified);
8299 PerlMem_free(unixwild);
8302 if (!decc_efs_case_preserve) {
8303 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8304 if (_tolower(*cp1) != _tolower(*cp2)) break;
8306 segdirs = dirs - totells; /* Min # of dirs we must have left */
8307 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8308 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8309 memmove(fspec,cp2+1,end - cp2);
8311 PerlMem_free(unixified);
8312 PerlMem_free(unixwild);
8316 /* First off, back up over constant elements at end of path */
8318 for (front = end ; front >= base; front--)
8319 if (*front == '/' && !dirs--) { front++; break; }
8321 lcres = PerlMem_malloc(VMS_MAXRSS);
8322 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8323 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8325 if (!decc_efs_case_preserve) {
8326 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8334 PerlMem_free(unixified);
8335 PerlMem_free(unixwild);
8336 PerlMem_free(lcres);
8337 return 0; /* Path too long. */
8340 *cp2 = '\0'; /* Pick up with memcpy later */
8341 lcfront = lcres + (front - base);
8342 /* Now skip over each ellipsis and try to match the path in front of it. */
8344 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8345 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8346 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8347 if (cp1 < template) break; /* template started with an ellipsis */
8348 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8349 ellipsis = cp1; continue;
8351 wilddsc.dsc$a_pointer = tpl;
8352 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8354 for (segdirs = 0, cp2 = tpl;
8355 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8357 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8359 if (!decc_efs_case_preserve) {
8360 *cp2 = _tolower(*cp1); /* else lowercase for match */
8363 *cp2 = *cp1; /* else preserve case for match */
8366 if (*cp2 == '/') segdirs++;
8368 if (cp1 != ellipsis - 1) {
8370 PerlMem_free(unixified);
8371 PerlMem_free(unixwild);
8372 PerlMem_free(lcres);
8373 return 0; /* Path too long */
8375 /* Back up at least as many dirs as in template before matching */
8376 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8377 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8378 for (match = 0; cp1 > lcres;) {
8379 resdsc.dsc$a_pointer = cp1;
8380 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8382 if (match == 1) lcfront = cp1;
8384 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8388 PerlMem_free(unixified);
8389 PerlMem_free(unixwild);
8390 PerlMem_free(lcres);
8391 return 0; /* Can't find prefix ??? */
8393 if (match > 1 && opts & 1) {
8394 /* This ... wildcard could cover more than one set of dirs (i.e.
8395 * a set of similar dir names is repeated). If the template
8396 * contains more than 1 ..., upstream elements could resolve the
8397 * ambiguity, but it's not worth a full backtracking setup here.
8398 * As a quick heuristic, clip off the current default directory
8399 * if it's present to find the trimmed spec, else use the
8400 * shortest string that this ... could cover.
8402 char def[NAM$C_MAXRSS+1], *st;
8404 if (getcwd(def, sizeof def,0) == NULL) {
8405 Safefree(unixified);
8411 if (!decc_efs_case_preserve) {
8412 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8413 if (_tolower(*cp1) != _tolower(*cp2)) break;
8415 segdirs = dirs - totells; /* Min # of dirs we must have left */
8416 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8417 if (*cp1 == '\0' && *cp2 == '/') {
8418 memmove(fspec,cp2+1,end - cp2);
8420 PerlMem_free(unixified);
8421 PerlMem_free(unixwild);
8422 PerlMem_free(lcres);
8425 /* Nope -- stick with lcfront from above and keep going. */
8428 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8430 PerlMem_free(unixified);
8431 PerlMem_free(unixwild);
8432 PerlMem_free(lcres);
8437 } /* end of trim_unixpath() */
8442 * VMS readdir() routines.
8443 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8445 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8446 * Minor modifications to original routines.
8449 /* readdir may have been redefined by reentr.h, so make sure we get
8450 * the local version for what we do here.
8455 #if !defined(PERL_IMPLICIT_CONTEXT)
8456 # define readdir Perl_readdir
8458 # define readdir(a) Perl_readdir(aTHX_ a)
8461 /* Number of elements in vms_versions array */
8462 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8465 * Open a directory, return a handle for later use.
8467 /*{{{ DIR *opendir(char*name) */
8469 Perl_opendir(pTHX_ const char *name)
8477 if (decc_efs_charset) {
8478 unix_flag = is_unix_filespec(name);
8481 Newx(dir, VMS_MAXRSS, char);
8482 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8486 /* Check access before stat; otherwise stat does not
8487 * accurately report whether it's a directory.
8489 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8490 /* cando_by_name has already set errno */
8494 if (flex_stat(dir,&sb) == -1) return NULL;
8495 if (!S_ISDIR(sb.st_mode)) {
8497 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8500 /* Get memory for the handle, and the pattern. */
8502 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8504 /* Fill in the fields; mainly playing with the descriptor. */
8505 sprintf(dd->pattern, "%s*.*",dir);
8511 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8512 dd->pat.dsc$a_pointer = dd->pattern;
8513 dd->pat.dsc$w_length = strlen(dd->pattern);
8514 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8515 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8516 #if defined(USE_ITHREADS)
8517 Newx(dd->mutex,1,perl_mutex);
8518 MUTEX_INIT( (perl_mutex *) dd->mutex );
8524 } /* end of opendir() */
8528 * Set the flag to indicate we want versions or not.
8530 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8532 vmsreaddirversions(DIR *dd, int flag)
8535 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8537 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8542 * Free up an opened directory.
8544 /*{{{ void closedir(DIR *dd)*/
8546 Perl_closedir(DIR *dd)
8550 sts = lib$find_file_end(&dd->context);
8551 Safefree(dd->pattern);
8552 #if defined(USE_ITHREADS)
8553 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8554 Safefree(dd->mutex);
8561 * Collect all the version numbers for the current file.
8564 collectversions(pTHX_ DIR *dd)
8566 struct dsc$descriptor_s pat;
8567 struct dsc$descriptor_s res;
8569 char *p, *text, *buff;
8571 unsigned long context, tmpsts;
8573 /* Convenient shorthand. */
8576 /* Add the version wildcard, ignoring the "*.*" put on before */
8577 i = strlen(dd->pattern);
8578 Newx(text,i + e->d_namlen + 3,char);
8579 strcpy(text, dd->pattern);
8580 sprintf(&text[i - 3], "%s;*", e->d_name);
8582 /* Set up the pattern descriptor. */
8583 pat.dsc$a_pointer = text;
8584 pat.dsc$w_length = i + e->d_namlen - 1;
8585 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8586 pat.dsc$b_class = DSC$K_CLASS_S;
8588 /* Set up result descriptor. */
8589 Newx(buff, VMS_MAXRSS, char);
8590 res.dsc$a_pointer = buff;
8591 res.dsc$w_length = VMS_MAXRSS - 1;
8592 res.dsc$b_dtype = DSC$K_DTYPE_T;
8593 res.dsc$b_class = DSC$K_CLASS_S;
8595 /* Read files, collecting versions. */
8596 for (context = 0, e->vms_verscount = 0;
8597 e->vms_verscount < VERSIZE(e);
8598 e->vms_verscount++) {
8600 unsigned long flags = 0;
8602 #ifdef VMS_LONGNAME_SUPPORT
8603 flags = LIB$M_FIL_LONG_NAMES;
8605 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8606 if (tmpsts == RMS$_NMF || context == 0) break;
8608 buff[VMS_MAXRSS - 1] = '\0';
8609 if ((p = strchr(buff, ';')))
8610 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8612 e->vms_versions[e->vms_verscount] = -1;
8615 _ckvmssts(lib$find_file_end(&context));
8619 } /* end of collectversions() */
8622 * Read the next entry from the directory.
8624 /*{{{ struct dirent *readdir(DIR *dd)*/
8626 Perl_readdir(pTHX_ DIR *dd)
8628 struct dsc$descriptor_s res;
8630 unsigned long int tmpsts;
8632 unsigned long flags = 0;
8633 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8634 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8636 /* Set up result descriptor, and get next file. */
8637 Newx(buff, VMS_MAXRSS, char);
8638 res.dsc$a_pointer = buff;
8639 res.dsc$w_length = VMS_MAXRSS - 1;
8640 res.dsc$b_dtype = DSC$K_DTYPE_T;
8641 res.dsc$b_class = DSC$K_CLASS_S;
8643 #ifdef VMS_LONGNAME_SUPPORT
8644 flags = LIB$M_FIL_LONG_NAMES;
8647 tmpsts = lib$find_file
8648 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8649 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8650 if (!(tmpsts & 1)) {
8651 set_vaxc_errno(tmpsts);
8654 set_errno(EACCES); break;
8656 set_errno(ENODEV); break;
8658 set_errno(ENOTDIR); break;
8659 case RMS$_FNF: case RMS$_DNF:
8660 set_errno(ENOENT); break;
8668 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8669 if (!decc_efs_case_preserve) {
8670 buff[VMS_MAXRSS - 1] = '\0';
8671 for (p = buff; *p; p++) *p = _tolower(*p);
8674 /* we don't want to force to lowercase, just null terminate */
8675 buff[res.dsc$w_length] = '\0';
8677 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8680 /* Skip any directory component and just copy the name. */
8681 sts = vms_split_path
8696 /* Drop NULL extensions on UNIX file specification */
8697 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8698 (e_len == 1) && decc_readdir_dropdotnotype)) {
8703 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8704 dd->entry.d_name[n_len + e_len] = '\0';
8705 dd->entry.d_namlen = strlen(dd->entry.d_name);
8707 /* Convert the filename to UNIX format if needed */
8708 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8710 /* Translate the encoded characters. */
8711 /* Fixme: unicode handling could result in embedded 0 characters */
8712 if (strchr(dd->entry.d_name, '^') != NULL) {
8716 p = dd->entry.d_name;
8720 x = copy_expand_vms_filename_escape(q, p, &y);
8724 /* if y > 1, then this is a wide file specification */
8725 /* Wide file specifications need to be passed in Perl */
8726 /* counted strings apparently with a unicode flag */
8729 strcpy(dd->entry.d_name, new_name);
8733 dd->entry.vms_verscount = 0;
8734 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8738 } /* end of readdir() */
8742 * Read the next entry from the directory -- thread-safe version.
8744 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8746 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8750 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8752 entry = readdir(dd);
8754 retval = ( *result == NULL ? errno : 0 );
8756 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8760 } /* end of readdir_r() */
8764 * Return something that can be used in a seekdir later.
8766 /*{{{ long telldir(DIR *dd)*/
8768 Perl_telldir(DIR *dd)
8775 * Return to a spot where we used to be. Brute force.
8777 /*{{{ void seekdir(DIR *dd,long count)*/
8779 Perl_seekdir(pTHX_ DIR *dd, long count)
8783 /* If we haven't done anything yet... */
8787 /* Remember some state, and clear it. */
8788 old_flags = dd->flags;
8789 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8790 _ckvmssts(lib$find_file_end(&dd->context));
8793 /* The increment is in readdir(). */
8794 for (dd->count = 0; dd->count < count; )
8797 dd->flags = old_flags;
8799 } /* end of seekdir() */
8802 /* VMS subprocess management
8804 * my_vfork() - just a vfork(), after setting a flag to record that
8805 * the current script is trying a Unix-style fork/exec.
8807 * vms_do_aexec() and vms_do_exec() are called in response to the
8808 * perl 'exec' function. If this follows a vfork call, then they
8809 * call out the regular perl routines in doio.c which do an
8810 * execvp (for those who really want to try this under VMS).
8811 * Otherwise, they do exactly what the perl docs say exec should
8812 * do - terminate the current script and invoke a new command
8813 * (See below for notes on command syntax.)
8815 * do_aspawn() and do_spawn() implement the VMS side of the perl
8816 * 'system' function.
8818 * Note on command arguments to perl 'exec' and 'system': When handled
8819 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8820 * are concatenated to form a DCL command string. If the first arg
8821 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8822 * the command string is handed off to DCL directly. Otherwise,
8823 * the first token of the command is taken as the filespec of an image
8824 * to run. The filespec is expanded using a default type of '.EXE' and
8825 * the process defaults for device, directory, etc., and if found, the resultant
8826 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8827 * the command string as parameters. This is perhaps a bit complicated,
8828 * but I hope it will form a happy medium between what VMS folks expect
8829 * from lib$spawn and what Unix folks expect from exec.
8832 static int vfork_called;
8834 /*{{{int my_vfork()*/
8845 vms_execfree(struct dsc$descriptor_s *vmscmd)
8848 if (vmscmd->dsc$a_pointer) {
8849 PerlMem_free(vmscmd->dsc$a_pointer);
8851 PerlMem_free(vmscmd);
8856 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8858 char *junk, *tmps = Nullch;
8859 register size_t cmdlen = 0;
8866 tmps = SvPV(really,rlen);
8873 for (idx++; idx <= sp; idx++) {
8875 junk = SvPVx(*idx,rlen);
8876 cmdlen += rlen ? rlen + 1 : 0;
8879 Newx(PL_Cmd, cmdlen+1, char);
8881 if (tmps && *tmps) {
8882 strcpy(PL_Cmd,tmps);
8885 else *PL_Cmd = '\0';
8886 while (++mark <= sp) {
8888 char *s = SvPVx(*mark,n_a);
8890 if (*PL_Cmd) strcat(PL_Cmd," ");
8896 } /* end of setup_argstr() */
8899 static unsigned long int
8900 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8901 struct dsc$descriptor_s **pvmscmd)
8903 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8904 char image_name[NAM$C_MAXRSS+1];
8905 char image_argv[NAM$C_MAXRSS+1];
8906 $DESCRIPTOR(defdsc,".EXE");
8907 $DESCRIPTOR(defdsc2,".");
8908 $DESCRIPTOR(resdsc,resspec);
8909 struct dsc$descriptor_s *vmscmd;
8910 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8911 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8912 register char *s, *rest, *cp, *wordbreak;
8917 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8918 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8920 /* Make a copy for modification */
8921 cmdlen = strlen(incmd);
8922 cmd = PerlMem_malloc(cmdlen+1);
8923 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8924 strncpy(cmd, incmd, cmdlen);
8929 vmscmd->dsc$a_pointer = NULL;
8930 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8931 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8932 vmscmd->dsc$w_length = 0;
8933 if (pvmscmd) *pvmscmd = vmscmd;
8935 if (suggest_quote) *suggest_quote = 0;
8937 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8939 return CLI$_BUFOVF; /* continuation lines currently unsupported */
8944 while (*s && isspace(*s)) s++;
8946 if (*s == '@' || *s == '$') {
8947 vmsspec[0] = *s; rest = s + 1;
8948 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8950 else { cp = vmsspec; rest = s; }
8951 if (*rest == '.' || *rest == '/') {
8954 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8955 rest++, cp2++) *cp2 = *rest;
8957 if (do_tovmsspec(resspec,cp,0,NULL)) {
8960 for (cp2 = vmsspec + strlen(vmsspec);
8961 *rest && cp2 - vmsspec < sizeof vmsspec;
8962 rest++, cp2++) *cp2 = *rest;
8967 /* Intuit whether verb (first word of cmd) is a DCL command:
8968 * - if first nonspace char is '@', it's a DCL indirection
8970 * - if verb contains a filespec separator, it's not a DCL command
8971 * - if it doesn't, caller tells us whether to default to a DCL
8972 * command, or to a local image unless told it's DCL (by leading '$')
8976 if (suggest_quote) *suggest_quote = 1;
8978 register char *filespec = strpbrk(s,":<[.;");
8979 rest = wordbreak = strpbrk(s," \"\t/");
8980 if (!wordbreak) wordbreak = s + strlen(s);
8981 if (*s == '$') check_img = 0;
8982 if (filespec && (filespec < wordbreak)) isdcl = 0;
8983 else isdcl = !check_img;
8988 imgdsc.dsc$a_pointer = s;
8989 imgdsc.dsc$w_length = wordbreak - s;
8990 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8992 _ckvmssts(lib$find_file_end(&cxt));
8993 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8994 if (!(retsts & 1) && *s == '$') {
8995 _ckvmssts(lib$find_file_end(&cxt));
8996 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8997 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8999 _ckvmssts(lib$find_file_end(&cxt));
9000 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9004 _ckvmssts(lib$find_file_end(&cxt));
9009 while (*s && !isspace(*s)) s++;
9012 /* check that it's really not DCL with no file extension */
9013 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9015 char b[256] = {0,0,0,0};
9016 read(fileno(fp), b, 256);
9017 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9021 /* Check for script */
9023 if ((b[0] == '#') && (b[1] == '!'))
9025 #ifdef ALTERNATE_SHEBANG
9027 shebang_len = strlen(ALTERNATE_SHEBANG);
9028 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9030 perlstr = strstr("perl",b);
9031 if (perlstr == NULL)
9039 if (shebang_len > 0) {
9042 char tmpspec[NAM$C_MAXRSS + 1];
9045 /* Image is following after white space */
9046 /*--------------------------------------*/
9047 while (isprint(b[i]) && isspace(b[i]))
9051 while (isprint(b[i]) && !isspace(b[i])) {
9052 tmpspec[j++] = b[i++];
9053 if (j >= NAM$C_MAXRSS)
9058 /* There may be some default parameters to the image */
9059 /*---------------------------------------------------*/
9061 while (isprint(b[i])) {
9062 image_argv[j++] = b[i++];
9063 if (j >= NAM$C_MAXRSS)
9066 while ((j > 0) && !isprint(image_argv[j-1]))
9070 /* It will need to be converted to VMS format and validated */
9071 if (tmpspec[0] != '\0') {
9074 /* Try to find the exact program requested to be run */
9075 /*---------------------------------------------------*/
9076 iname = do_rmsexpand
9077 (tmpspec, image_name, 0, ".exe",
9078 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9079 if (iname != NULL) {
9080 if (cando_by_name_int
9081 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9082 /* MCR prefix needed */
9086 /* Try again with a null type */
9087 /*----------------------------*/
9088 iname = do_rmsexpand
9089 (tmpspec, image_name, 0, ".",
9090 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9091 if (iname != NULL) {
9092 if (cando_by_name_int
9093 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9094 /* MCR prefix needed */
9100 /* Did we find the image to run the script? */
9101 /*------------------------------------------*/
9105 /* Assume DCL or foreign command exists */
9106 /*--------------------------------------*/
9107 tchr = strrchr(tmpspec, '/');
9114 strcpy(image_name, tchr);
9122 if (check_img && isdcl) return RMS$_FNF;
9124 if (cando_by_name(S_IXUSR,0,resspec)) {
9125 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9126 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9128 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9129 if (image_name[0] != 0) {
9130 strcat(vmscmd->dsc$a_pointer, image_name);
9131 strcat(vmscmd->dsc$a_pointer, " ");
9133 } else if (image_name[0] != 0) {
9134 strcpy(vmscmd->dsc$a_pointer, image_name);
9135 strcat(vmscmd->dsc$a_pointer, " ");
9137 strcpy(vmscmd->dsc$a_pointer,"@");
9139 if (suggest_quote) *suggest_quote = 1;
9141 /* If there is an image name, use original command */
9142 if (image_name[0] == 0)
9143 strcat(vmscmd->dsc$a_pointer,resspec);
9146 while (*rest && isspace(*rest)) rest++;
9149 if (image_argv[0] != 0) {
9150 strcat(vmscmd->dsc$a_pointer,image_argv);
9151 strcat(vmscmd->dsc$a_pointer, " ");
9157 rest_len = strlen(rest);
9158 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9159 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9160 strcat(vmscmd->dsc$a_pointer,rest);
9162 retsts = CLI$_BUFOVF;
9164 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9166 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9172 /* It's either a DCL command or we couldn't find a suitable image */
9173 vmscmd->dsc$w_length = strlen(cmd);
9175 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9176 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9177 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9181 /* check if it's a symbol (for quoting purposes) */
9182 if (suggest_quote && !*suggest_quote) {
9184 char equiv[LNM$C_NAMLENGTH];
9185 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9186 eqvdsc.dsc$a_pointer = equiv;
9188 iss = lib$get_symbol(vmscmd,&eqvdsc);
9189 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9191 if (!(retsts & 1)) {
9192 /* just hand off status values likely to be due to user error */
9193 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9194 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9195 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9196 else { _ckvmssts(retsts); }
9199 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9201 } /* end of setup_cmddsc() */
9204 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9206 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9212 if (vfork_called) { /* this follows a vfork - act Unixish */
9214 if (vfork_called < 0) {
9215 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9218 else return do_aexec(really,mark,sp);
9220 /* no vfork - act VMSish */
9221 cmd = setup_argstr(aTHX_ really,mark,sp);
9222 exec_sts = vms_do_exec(cmd);
9223 Safefree(cmd); /* Clean up from setup_argstr() */
9228 } /* end of vms_do_aexec() */
9231 /* {{{bool vms_do_exec(char *cmd) */
9233 Perl_vms_do_exec(pTHX_ const char *cmd)
9235 struct dsc$descriptor_s *vmscmd;
9237 if (vfork_called) { /* this follows a vfork - act Unixish */
9239 if (vfork_called < 0) {
9240 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9243 else return do_exec(cmd);
9246 { /* no vfork - act VMSish */
9247 unsigned long int retsts;
9250 TAINT_PROPER("exec");
9251 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9252 retsts = lib$do_command(vmscmd);
9255 case RMS$_FNF: case RMS$_DNF:
9256 set_errno(ENOENT); break;
9258 set_errno(ENOTDIR); break;
9260 set_errno(ENODEV); break;
9262 set_errno(EACCES); break;
9264 set_errno(EINVAL); break;
9265 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9266 set_errno(E2BIG); break;
9267 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9268 _ckvmssts(retsts); /* fall through */
9269 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9272 set_vaxc_errno(retsts);
9273 if (ckWARN(WARN_EXEC)) {
9274 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9275 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9277 vms_execfree(vmscmd);
9282 } /* end of vms_do_exec() */
9285 unsigned long int Perl_do_spawn(pTHX_ const char *);
9287 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9289 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9291 unsigned long int sts;
9295 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9296 sts = do_spawn(cmd);
9297 /* pp_sys will clean up cmd */
9301 } /* end of do_aspawn() */
9304 /* {{{unsigned long int do_spawn(char *cmd) */
9306 Perl_do_spawn(pTHX_ const char *cmd)
9308 unsigned long int sts, substs;
9310 /* The caller of this routine expects to Safefree(PL_Cmd) */
9311 Newx(PL_Cmd,10,char);
9314 TAINT_PROPER("spawn");
9315 if (!cmd || !*cmd) {
9316 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9319 case RMS$_FNF: case RMS$_DNF:
9320 set_errno(ENOENT); break;
9322 set_errno(ENOTDIR); break;
9324 set_errno(ENODEV); break;
9326 set_errno(EACCES); break;
9328 set_errno(EINVAL); break;
9329 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9330 set_errno(E2BIG); break;
9331 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9332 _ckvmssts(sts); /* fall through */
9333 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9336 set_vaxc_errno(sts);
9337 if (ckWARN(WARN_EXEC)) {
9338 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9346 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9351 } /* end of do_spawn() */
9355 static unsigned int *sockflags, sockflagsize;
9358 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9359 * routines found in some versions of the CRTL can't deal with sockets.
9360 * We don't shim the other file open routines since a socket isn't
9361 * likely to be opened by a name.
9363 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9364 FILE *my_fdopen(int fd, const char *mode)
9366 FILE *fp = fdopen(fd, mode);
9369 unsigned int fdoff = fd / sizeof(unsigned int);
9370 Stat_t sbuf; /* native stat; we don't need flex_stat */
9371 if (!sockflagsize || fdoff > sockflagsize) {
9372 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9373 else Newx (sockflags,fdoff+2,unsigned int);
9374 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9375 sockflagsize = fdoff + 2;
9377 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9378 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9387 * Clear the corresponding bit when the (possibly) socket stream is closed.
9388 * There still a small hole: we miss an implicit close which might occur
9389 * via freopen(). >> Todo
9391 /*{{{ int my_fclose(FILE *fp)*/
9392 int my_fclose(FILE *fp) {
9394 unsigned int fd = fileno(fp);
9395 unsigned int fdoff = fd / sizeof(unsigned int);
9397 if (sockflagsize && fdoff <= sockflagsize)
9398 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9406 * A simple fwrite replacement which outputs itmsz*nitm chars without
9407 * introducing record boundaries every itmsz chars.
9408 * We are using fputs, which depends on a terminating null. We may
9409 * well be writing binary data, so we need to accommodate not only
9410 * data with nulls sprinkled in the middle but also data with no null
9413 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9415 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9417 register char *cp, *end, *cpd, *data;
9418 register unsigned int fd = fileno(dest);
9419 register unsigned int fdoff = fd / sizeof(unsigned int);
9421 int bufsize = itmsz * nitm + 1;
9423 if (fdoff < sockflagsize &&
9424 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9425 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9429 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9430 memcpy( data, src, itmsz*nitm );
9431 data[itmsz*nitm] = '\0';
9433 end = data + itmsz * nitm;
9434 retval = (int) nitm; /* on success return # items written */
9437 while (cpd <= end) {
9438 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9439 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9441 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9445 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9448 } /* end of my_fwrite() */
9451 /*{{{ int my_flush(FILE *fp)*/
9453 Perl_my_flush(pTHX_ FILE *fp)
9456 if ((res = fflush(fp)) == 0 && fp) {
9457 #ifdef VMS_DO_SOCKETS
9459 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9461 res = fsync(fileno(fp));
9464 * If the flush succeeded but set end-of-file, we need to clear
9465 * the error because our caller may check ferror(). BTW, this
9466 * probably means we just flushed an empty file.
9468 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9475 * Here are replacements for the following Unix routines in the VMS environment:
9476 * getpwuid Get information for a particular UIC or UID
9477 * getpwnam Get information for a named user
9478 * getpwent Get information for each user in the rights database
9479 * setpwent Reset search to the start of the rights database
9480 * endpwent Finish searching for users in the rights database
9482 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9483 * (defined in pwd.h), which contains the following fields:-
9485 * char *pw_name; Username (in lower case)
9486 * char *pw_passwd; Hashed password
9487 * unsigned int pw_uid; UIC
9488 * unsigned int pw_gid; UIC group number
9489 * char *pw_unixdir; Default device/directory (VMS-style)
9490 * char *pw_gecos; Owner name
9491 * char *pw_dir; Default device/directory (Unix-style)
9492 * char *pw_shell; Default CLI name (eg. DCL)
9494 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9496 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9497 * not the UIC member number (eg. what's returned by getuid()),
9498 * getpwuid() can accept either as input (if uid is specified, the caller's
9499 * UIC group is used), though it won't recognise gid=0.
9501 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9502 * information about other users in your group or in other groups, respectively.
9503 * If the required privilege is not available, then these routines fill only
9504 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9507 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9510 /* sizes of various UAF record fields */
9511 #define UAI$S_USERNAME 12
9512 #define UAI$S_IDENT 31
9513 #define UAI$S_OWNER 31
9514 #define UAI$S_DEFDEV 31
9515 #define UAI$S_DEFDIR 63
9516 #define UAI$S_DEFCLI 31
9519 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9520 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9521 (uic).uic$v_group != UIC$K_WILD_GROUP)
9523 static char __empty[]= "";
9524 static struct passwd __passwd_empty=
9525 {(char *) __empty, (char *) __empty, 0, 0,
9526 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9527 static int contxt= 0;
9528 static struct passwd __pwdcache;
9529 static char __pw_namecache[UAI$S_IDENT+1];
9532 * This routine does most of the work extracting the user information.
9534 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9537 unsigned char length;
9538 char pw_gecos[UAI$S_OWNER+1];
9540 static union uicdef uic;
9542 unsigned char length;
9543 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9546 unsigned char length;
9547 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9550 unsigned char length;
9551 char pw_shell[UAI$S_DEFCLI+1];
9553 static char pw_passwd[UAI$S_PWD+1];
9555 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9556 struct dsc$descriptor_s name_desc;
9557 unsigned long int sts;
9559 static struct itmlst_3 itmlst[]= {
9560 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9561 {sizeof(uic), UAI$_UIC, &uic, &luic},
9562 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9563 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9564 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9565 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9566 {0, 0, NULL, NULL}};
9568 name_desc.dsc$w_length= strlen(name);
9569 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9570 name_desc.dsc$b_class= DSC$K_CLASS_S;
9571 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9573 /* Note that sys$getuai returns many fields as counted strings. */
9574 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9575 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9576 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9578 else { _ckvmssts(sts); }
9579 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9581 if ((int) owner.length < lowner) lowner= (int) owner.length;
9582 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9583 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9584 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9585 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9586 owner.pw_gecos[lowner]= '\0';
9587 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9588 defcli.pw_shell[ldefcli]= '\0';
9589 if (valid_uic(uic)) {
9590 pwd->pw_uid= uic.uic$l_uic;
9591 pwd->pw_gid= uic.uic$v_group;
9594 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9595 pwd->pw_passwd= pw_passwd;
9596 pwd->pw_gecos= owner.pw_gecos;
9597 pwd->pw_dir= defdev.pw_dir;
9598 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9599 pwd->pw_shell= defcli.pw_shell;
9600 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9602 ldir= strlen(pwd->pw_unixdir) - 1;
9603 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9606 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9607 if (!decc_efs_case_preserve)
9608 __mystrtolower(pwd->pw_unixdir);
9613 * Get information for a named user.
9615 /*{{{struct passwd *getpwnam(char *name)*/
9616 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9618 struct dsc$descriptor_s name_desc;
9620 unsigned long int status, sts;
9622 __pwdcache = __passwd_empty;
9623 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9624 /* We still may be able to determine pw_uid and pw_gid */
9625 name_desc.dsc$w_length= strlen(name);
9626 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9627 name_desc.dsc$b_class= DSC$K_CLASS_S;
9628 name_desc.dsc$a_pointer= (char *) name;
9629 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9630 __pwdcache.pw_uid= uic.uic$l_uic;
9631 __pwdcache.pw_gid= uic.uic$v_group;
9634 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9635 set_vaxc_errno(sts);
9636 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9639 else { _ckvmssts(sts); }
9642 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9643 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9644 __pwdcache.pw_name= __pw_namecache;
9646 } /* end of my_getpwnam() */
9650 * Get information for a particular UIC or UID.
9651 * Called by my_getpwent with uid=-1 to list all users.
9653 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9654 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9656 const $DESCRIPTOR(name_desc,__pw_namecache);
9657 unsigned short lname;
9659 unsigned long int status;
9661 if (uid == (unsigned int) -1) {
9663 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9664 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9665 set_vaxc_errno(status);
9666 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9670 else { _ckvmssts(status); }
9671 } while (!valid_uic (uic));
9675 if (!uic.uic$v_group)
9676 uic.uic$v_group= PerlProc_getgid();
9678 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9679 else status = SS$_IVIDENT;
9680 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9681 status == RMS$_PRV) {
9682 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9685 else { _ckvmssts(status); }
9687 __pw_namecache[lname]= '\0';
9688 __mystrtolower(__pw_namecache);
9690 __pwdcache = __passwd_empty;
9691 __pwdcache.pw_name = __pw_namecache;
9693 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9694 The identifier's value is usually the UIC, but it doesn't have to be,
9695 so if we can, we let fillpasswd update this. */
9696 __pwdcache.pw_uid = uic.uic$l_uic;
9697 __pwdcache.pw_gid = uic.uic$v_group;
9699 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9702 } /* end of my_getpwuid() */
9706 * Get information for next user.
9708 /*{{{struct passwd *my_getpwent()*/
9709 struct passwd *Perl_my_getpwent(pTHX)
9711 return (my_getpwuid((unsigned int) -1));
9716 * Finish searching rights database for users.
9718 /*{{{void my_endpwent()*/
9719 void Perl_my_endpwent(pTHX)
9722 _ckvmssts(sys$finish_rdb(&contxt));
9728 #ifdef HOMEGROWN_POSIX_SIGNALS
9729 /* Signal handling routines, pulled into the core from POSIX.xs.
9731 * We need these for threads, so they've been rolled into the core,
9732 * rather than left in POSIX.xs.
9734 * (DRS, Oct 23, 1997)
9737 /* sigset_t is atomic under VMS, so these routines are easy */
9738 /*{{{int my_sigemptyset(sigset_t *) */
9739 int my_sigemptyset(sigset_t *set) {
9740 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9746 /*{{{int my_sigfillset(sigset_t *)*/
9747 int my_sigfillset(sigset_t *set) {
9749 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9750 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9756 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9757 int my_sigaddset(sigset_t *set, int sig) {
9758 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9759 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9760 *set |= (1 << (sig - 1));
9766 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9767 int my_sigdelset(sigset_t *set, int sig) {
9768 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9769 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9770 *set &= ~(1 << (sig - 1));
9776 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9777 int my_sigismember(sigset_t *set, int sig) {
9778 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9779 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9780 return *set & (1 << (sig - 1));
9785 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9786 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9789 /* If set and oset are both null, then things are badly wrong. Bail out. */
9790 if ((oset == NULL) && (set == NULL)) {
9791 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9795 /* If set's null, then we're just handling a fetch. */
9797 tempmask = sigblock(0);
9802 tempmask = sigsetmask(*set);
9805 tempmask = sigblock(*set);
9808 tempmask = sigblock(0);
9809 sigsetmask(*oset & ~tempmask);
9812 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9817 /* Did they pass us an oset? If so, stick our holding mask into it */
9824 #endif /* HOMEGROWN_POSIX_SIGNALS */
9827 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9828 * my_utime(), and flex_stat(), all of which operate on UTC unless
9829 * VMSISH_TIMES is true.
9831 /* method used to handle UTC conversions:
9832 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
9834 static int gmtime_emulation_type;
9835 /* number of secs to add to UTC POSIX-style time to get local time */
9836 static long int utc_offset_secs;
9838 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9839 * in vmsish.h. #undef them here so we can call the CRTL routines
9848 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9849 * qualifier with the extern prefix pragma. This provisional
9850 * hack circumvents this prefix pragma problem in previous
9853 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9854 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9855 # pragma __extern_prefix save
9856 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
9857 # define gmtime decc$__utctz_gmtime
9858 # define localtime decc$__utctz_localtime
9859 # define time decc$__utc_time
9860 # pragma __extern_prefix restore
9862 struct tm *gmtime(), *localtime();
9868 static time_t toutc_dst(time_t loc) {
9871 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9872 loc -= utc_offset_secs;
9873 if (rsltmp->tm_isdst) loc -= 3600;
9876 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9877 ((gmtime_emulation_type || my_time(NULL)), \
9878 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9879 ((secs) - utc_offset_secs))))
9881 static time_t toloc_dst(time_t utc) {
9884 utc += utc_offset_secs;
9885 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9886 if (rsltmp->tm_isdst) utc += 3600;
9889 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9890 ((gmtime_emulation_type || my_time(NULL)), \
9891 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9892 ((secs) + utc_offset_secs))))
9894 #ifndef RTL_USES_UTC
9897 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9898 DST starts on 1st sun of april at 02:00 std time
9899 ends on last sun of october at 02:00 dst time
9900 see the UCX management command reference, SET CONFIG TIMEZONE
9901 for formatting info.
9903 No, it's not as general as it should be, but then again, NOTHING
9904 will handle UK times in a sensible way.
9909 parse the DST start/end info:
9910 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9914 tz_parse_startend(char *s, struct tm *w, int *past)
9916 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9917 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9922 if (!past) return 0;
9925 if (w->tm_year % 4 == 0) ly = 1;
9926 if (w->tm_year % 100 == 0) ly = 0;
9927 if (w->tm_year+1900 % 400 == 0) ly = 1;
9930 dozjd = isdigit(*s);
9931 if (*s == 'J' || *s == 'j' || dozjd) {
9932 if (!dozjd && !isdigit(*++s)) return 0;
9935 d = d*10 + *s++ - '0';
9937 d = d*10 + *s++ - '0';
9940 if (d == 0) return 0;
9941 if (d > 366) return 0;
9943 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9946 } else if (*s == 'M' || *s == 'm') {
9947 if (!isdigit(*++s)) return 0;
9949 if (isdigit(*s)) m = 10*m + *s++ - '0';
9950 if (*s != '.') return 0;
9951 if (!isdigit(*++s)) return 0;
9953 if (n < 1 || n > 5) return 0;
9954 if (*s != '.') return 0;
9955 if (!isdigit(*++s)) return 0;
9957 if (d > 6) return 0;
9961 if (!isdigit(*++s)) return 0;
9963 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9965 if (!isdigit(*++s)) return 0;
9967 if (isdigit(*s)) min = 10*min + *s++ - '0';
9969 if (!isdigit(*++s)) return 0;
9971 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9981 if (w->tm_yday < d) goto before;
9982 if (w->tm_yday > d) goto after;
9984 if (w->tm_mon+1 < m) goto before;
9985 if (w->tm_mon+1 > m) goto after;
9987 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9988 k = d - j; /* mday of first d */
9990 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9991 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9992 if (w->tm_mday < k) goto before;
9993 if (w->tm_mday > k) goto after;
9996 if (w->tm_hour < hour) goto before;
9997 if (w->tm_hour > hour) goto after;
9998 if (w->tm_min < min) goto before;
9999 if (w->tm_min > min) goto after;
10000 if (w->tm_sec < sec) goto before;
10014 /* parse the offset: (+|-)hh[:mm[:ss]] */
10017 tz_parse_offset(char *s, int *offset)
10019 int hour = 0, min = 0, sec = 0;
10022 if (!offset) return 0;
10024 if (*s == '-') {neg++; s++;}
10025 if (*s == '+') s++;
10026 if (!isdigit(*s)) return 0;
10028 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10029 if (hour > 24) return 0;
10031 if (!isdigit(*++s)) return 0;
10033 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10034 if (min > 59) return 0;
10036 if (!isdigit(*++s)) return 0;
10038 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10039 if (sec > 59) return 0;
10043 *offset = (hour*60+min)*60 + sec;
10044 if (neg) *offset = -*offset;
10049 input time is w, whatever type of time the CRTL localtime() uses.
10050 sets dst, the zone, and the gmtoff (seconds)
10052 caches the value of TZ and UCX$TZ env variables; note that
10053 my_setenv looks for these and sets a flag if they're changed
10056 We have to watch out for the "australian" case (dst starts in
10057 october, ends in april)...flagged by "reverse" and checked by
10058 scanning through the months of the previous year.
10063 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10068 char *dstzone, *tz, *s_start, *s_end;
10069 int std_off, dst_off, isdst;
10070 int y, dststart, dstend;
10071 static char envtz[1025]; /* longer than any logical, symbol, ... */
10072 static char ucxtz[1025];
10073 static char reversed = 0;
10079 reversed = -1; /* flag need to check */
10080 envtz[0] = ucxtz[0] = '\0';
10081 tz = my_getenv("TZ",0);
10082 if (tz) strcpy(envtz, tz);
10083 tz = my_getenv("UCX$TZ",0);
10084 if (tz) strcpy(ucxtz, tz);
10085 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10088 if (!*tz) tz = ucxtz;
10091 while (isalpha(*s)) s++;
10092 s = tz_parse_offset(s, &std_off);
10094 if (!*s) { /* no DST, hurray we're done! */
10100 while (isalpha(*s)) s++;
10101 s2 = tz_parse_offset(s, &dst_off);
10105 dst_off = std_off - 3600;
10108 if (!*s) { /* default dst start/end?? */
10109 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10110 s = strchr(ucxtz,',');
10112 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10114 if (*s != ',') return 0;
10117 when = _toutc(when); /* convert to utc */
10118 when = when - std_off; /* convert to pseudolocal time*/
10120 w2 = localtime(&when);
10123 s = tz_parse_startend(s_start,w2,&dststart);
10125 if (*s != ',') return 0;
10128 when = _toutc(when); /* convert to utc */
10129 when = when - dst_off; /* convert to pseudolocal time*/
10130 w2 = localtime(&when);
10131 if (w2->tm_year != y) { /* spans a year, just check one time */
10132 when += dst_off - std_off;
10133 w2 = localtime(&when);
10136 s = tz_parse_startend(s_end,w2,&dstend);
10139 if (reversed == -1) { /* need to check if start later than end */
10143 if (when < 2*365*86400) {
10144 when += 2*365*86400;
10148 w2 =localtime(&when);
10149 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10151 for (j = 0; j < 12; j++) {
10152 w2 =localtime(&when);
10153 tz_parse_startend(s_start,w2,&ds);
10154 tz_parse_startend(s_end,w2,&de);
10155 if (ds != de) break;
10159 if (de && !ds) reversed = 1;
10162 isdst = dststart && !dstend;
10163 if (reversed) isdst = dststart || !dstend;
10166 if (dst) *dst = isdst;
10167 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10168 if (isdst) tz = dstzone;
10170 while(isalpha(*tz)) *zone++ = *tz++;
10176 #endif /* !RTL_USES_UTC */
10178 /* my_time(), my_localtime(), my_gmtime()
10179 * By default traffic in UTC time values, using CRTL gmtime() or
10180 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10181 * Note: We need to use these functions even when the CRTL has working
10182 * UTC support, since they also handle C<use vmsish qw(times);>
10184 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10185 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10188 /*{{{time_t my_time(time_t *timep)*/
10189 time_t Perl_my_time(pTHX_ time_t *timep)
10194 if (gmtime_emulation_type == 0) {
10196 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10197 /* results of calls to gmtime() and localtime() */
10198 /* for same &base */
10200 gmtime_emulation_type++;
10201 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10202 char off[LNM$C_NAMLENGTH+1];;
10204 gmtime_emulation_type++;
10205 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10206 gmtime_emulation_type++;
10207 utc_offset_secs = 0;
10208 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10210 else { utc_offset_secs = atol(off); }
10212 else { /* We've got a working gmtime() */
10213 struct tm gmt, local;
10216 tm_p = localtime(&base);
10218 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10219 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10220 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10221 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10226 # ifdef VMSISH_TIME
10227 # ifdef RTL_USES_UTC
10228 if (VMSISH_TIME) when = _toloc(when);
10230 if (!VMSISH_TIME) when = _toutc(when);
10233 if (timep != NULL) *timep = when;
10236 } /* end of my_time() */
10240 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10242 Perl_my_gmtime(pTHX_ const time_t *timep)
10248 if (timep == NULL) {
10249 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10252 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10255 # ifdef VMSISH_TIME
10256 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10258 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10259 return gmtime(&when);
10261 /* CRTL localtime() wants local time as input, so does no tz correction */
10262 rsltmp = localtime(&when);
10263 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10266 } /* end of my_gmtime() */
10270 /*{{{struct tm *my_localtime(const time_t *timep)*/
10272 Perl_my_localtime(pTHX_ const time_t *timep)
10274 time_t when, whenutc;
10278 if (timep == NULL) {
10279 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10282 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10283 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10286 # ifdef RTL_USES_UTC
10287 # ifdef VMSISH_TIME
10288 if (VMSISH_TIME) when = _toutc(when);
10290 /* CRTL localtime() wants UTC as input, does tz correction itself */
10291 return localtime(&when);
10293 # else /* !RTL_USES_UTC */
10295 # ifdef VMSISH_TIME
10296 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10297 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10300 #ifndef RTL_USES_UTC
10301 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10302 when = whenutc - offset; /* pseudolocal time*/
10305 /* CRTL localtime() wants local time as input, so does no tz correction */
10306 rsltmp = localtime(&when);
10307 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10311 } /* end of my_localtime() */
10314 /* Reset definitions for later calls */
10315 #define gmtime(t) my_gmtime(t)
10316 #define localtime(t) my_localtime(t)
10317 #define time(t) my_time(t)
10320 /* my_utime - update modification/access time of a file
10322 * VMS 7.3 and later implementation
10323 * Only the UTC translation is home-grown. The rest is handled by the
10324 * CRTL utime(), which will take into account the relevant feature
10325 * logicals and ODS-5 volume characteristics for true access times.
10327 * pre VMS 7.3 implementation:
10328 * The calling sequence is identical to POSIX utime(), but under
10329 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10330 * not maintain access times. Restrictions differ from the POSIX
10331 * definition in that the time can be changed as long as the
10332 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10333 * no separate checks are made to insure that the caller is the
10334 * owner of the file or has special privs enabled.
10335 * Code here is based on Joe Meadows' FILE utility.
10339 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10340 * to VMS epoch (01-JAN-1858 00:00:00.00)
10341 * in 100 ns intervals.
10343 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10345 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10346 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10348 #if __CRTL_VER >= 70300000
10349 struct utimbuf utc_utimes, *utc_utimesp;
10351 if (utimes != NULL) {
10352 utc_utimes.actime = utimes->actime;
10353 utc_utimes.modtime = utimes->modtime;
10354 # ifdef VMSISH_TIME
10355 /* If input was local; convert to UTC for sys svc */
10357 utc_utimes.actime = _toutc(utimes->actime);
10358 utc_utimes.modtime = _toutc(utimes->modtime);
10361 utc_utimesp = &utc_utimes;
10364 utc_utimesp = NULL;
10367 return utime(file, utc_utimesp);
10369 #else /* __CRTL_VER < 70300000 */
10373 long int bintime[2], len = 2, lowbit, unixtime,
10374 secscale = 10000000; /* seconds --> 100 ns intervals */
10375 unsigned long int chan, iosb[2], retsts;
10376 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10377 struct FAB myfab = cc$rms_fab;
10378 struct NAM mynam = cc$rms_nam;
10379 #if defined (__DECC) && defined (__VAX)
10380 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10381 * at least through VMS V6.1, which causes a type-conversion warning.
10383 # pragma message save
10384 # pragma message disable cvtdiftypes
10386 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10387 struct fibdef myfib;
10388 #if defined (__DECC) && defined (__VAX)
10389 /* This should be right after the declaration of myatr, but due
10390 * to a bug in VAX DEC C, this takes effect a statement early.
10392 # pragma message restore
10394 /* cast ok for read only parameter */
10395 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10396 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10397 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10399 if (file == NULL || *file == '\0') {
10400 SETERRNO(ENOENT, LIB$_INVARG);
10404 /* Convert to VMS format ensuring that it will fit in 255 characters */
10405 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10406 SETERRNO(ENOENT, LIB$_INVARG);
10409 if (utimes != NULL) {
10410 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10411 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10412 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10413 * as input, we force the sign bit to be clear by shifting unixtime right
10414 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10416 lowbit = (utimes->modtime & 1) ? secscale : 0;
10417 unixtime = (long int) utimes->modtime;
10418 # ifdef VMSISH_TIME
10419 /* If input was UTC; convert to local for sys svc */
10420 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10422 unixtime >>= 1; secscale <<= 1;
10423 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10424 if (!(retsts & 1)) {
10425 SETERRNO(EVMSERR, retsts);
10428 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10429 if (!(retsts & 1)) {
10430 SETERRNO(EVMSERR, retsts);
10435 /* Just get the current time in VMS format directly */
10436 retsts = sys$gettim(bintime);
10437 if (!(retsts & 1)) {
10438 SETERRNO(EVMSERR, retsts);
10443 myfab.fab$l_fna = vmsspec;
10444 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10445 myfab.fab$l_nam = &mynam;
10446 mynam.nam$l_esa = esa;
10447 mynam.nam$b_ess = (unsigned char) sizeof esa;
10448 mynam.nam$l_rsa = rsa;
10449 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10450 if (decc_efs_case_preserve)
10451 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10453 /* Look for the file to be affected, letting RMS parse the file
10454 * specification for us as well. I have set errno using only
10455 * values documented in the utime() man page for VMS POSIX.
10457 retsts = sys$parse(&myfab,0,0);
10458 if (!(retsts & 1)) {
10459 set_vaxc_errno(retsts);
10460 if (retsts == RMS$_PRV) set_errno(EACCES);
10461 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10462 else set_errno(EVMSERR);
10465 retsts = sys$search(&myfab,0,0);
10466 if (!(retsts & 1)) {
10467 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10468 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10469 set_vaxc_errno(retsts);
10470 if (retsts == RMS$_PRV) set_errno(EACCES);
10471 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10472 else set_errno(EVMSERR);
10476 devdsc.dsc$w_length = mynam.nam$b_dev;
10477 /* cast ok for read only parameter */
10478 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10480 retsts = sys$assign(&devdsc,&chan,0,0);
10481 if (!(retsts & 1)) {
10482 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10483 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10484 set_vaxc_errno(retsts);
10485 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10486 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10487 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10488 else set_errno(EVMSERR);
10492 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10493 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10495 memset((void *) &myfib, 0, sizeof myfib);
10496 #if defined(__DECC) || defined(__DECCXX)
10497 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10498 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10499 /* This prevents the revision time of the file being reset to the current
10500 * time as a result of our IO$_MODIFY $QIO. */
10501 myfib.fib$l_acctl = FIB$M_NORECORD;
10503 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10504 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10505 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10507 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10508 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10509 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10510 _ckvmssts(sys$dassgn(chan));
10511 if (retsts & 1) retsts = iosb[0];
10512 if (!(retsts & 1)) {
10513 set_vaxc_errno(retsts);
10514 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10515 else set_errno(EVMSERR);
10521 #endif /* #if __CRTL_VER >= 70300000 */
10523 } /* end of my_utime() */
10527 * flex_stat, flex_lstat, flex_fstat
10528 * basic stat, but gets it right when asked to stat
10529 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10532 #ifndef _USE_STD_STAT
10533 /* encode_dev packs a VMS device name string into an integer to allow
10534 * simple comparisons. This can be used, for example, to check whether two
10535 * files are located on the same device, by comparing their encoded device
10536 * names. Even a string comparison would not do, because stat() reuses the
10537 * device name buffer for each call; so without encode_dev, it would be
10538 * necessary to save the buffer and use strcmp (this would mean a number of
10539 * changes to the standard Perl code, to say nothing of what a Perl script
10540 * would have to do.
10542 * The device lock id, if it exists, should be unique (unless perhaps compared
10543 * with lock ids transferred from other nodes). We have a lock id if the disk is
10544 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10545 * device names. Thus we use the lock id in preference, and only if that isn't
10546 * available, do we try to pack the device name into an integer (flagged by
10547 * the sign bit (LOCKID_MASK) being set).
10549 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10550 * name and its encoded form, but it seems very unlikely that we will find
10551 * two files on different disks that share the same encoded device names,
10552 * and even more remote that they will share the same file id (if the test
10553 * is to check for the same file).
10555 * A better method might be to use sys$device_scan on the first call, and to
10556 * search for the device, returning an index into the cached array.
10557 * The number returned would be more intelligible.
10558 * This is probably not worth it, and anyway would take quite a bit longer
10559 * on the first call.
10561 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10562 static mydev_t encode_dev (pTHX_ const char *dev)
10565 unsigned long int f;
10570 if (!dev || !dev[0]) return 0;
10574 struct dsc$descriptor_s dev_desc;
10575 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10577 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10578 can try that first. */
10579 dev_desc.dsc$w_length = strlen (dev);
10580 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10581 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10582 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10583 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10584 if (!$VMS_STATUS_SUCCESS(status)) {
10586 case SS$_NOSUCHDEV:
10587 SETERRNO(ENODEV, status);
10593 if (lockid) return (lockid & ~LOCKID_MASK);
10597 /* Otherwise we try to encode the device name */
10601 for (q = dev + strlen(dev); q--; q >= dev) {
10606 else if (isalpha (toupper (*q)))
10607 c= toupper (*q) - 'A' + (char)10;
10609 continue; /* Skip '$'s */
10611 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10613 enc += f * (unsigned long int) c;
10615 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10617 } /* end of encode_dev() */
10618 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10619 device_no = encode_dev(aTHX_ devname)
10621 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10622 device_no = new_dev_no
10626 is_null_device(name)
10629 if (decc_bug_devnull != 0) {
10630 if (strncmp("/dev/null", name, 9) == 0)
10633 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10634 The underscore prefix, controller letter, and unit number are
10635 independently optional; for our purposes, the colon punctuation
10636 is not. The colon can be trailed by optional directory and/or
10637 filename, but two consecutive colons indicates a nodename rather
10638 than a device. [pr] */
10639 if (*name == '_') ++name;
10640 if (tolower(*name++) != 'n') return 0;
10641 if (tolower(*name++) != 'l') return 0;
10642 if (tolower(*name) == 'a') ++name;
10643 if (*name == '0') ++name;
10644 return (*name++ == ':') && (*name != ':');
10649 Perl_cando_by_name_int
10650 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10652 static char usrname[L_cuserid];
10653 static struct dsc$descriptor_s usrdsc =
10654 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10655 char vmsname[NAM$C_MAXRSS+1];
10657 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10658 unsigned short int retlen, trnlnm_iter_count;
10659 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10660 union prvdef curprv;
10661 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10662 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10663 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10664 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10665 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10667 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10669 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10671 if (!fname || !*fname) return FALSE;
10672 /* Make sure we expand logical names, since sys$check_access doesn't */
10675 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10676 fileified = PerlMem_malloc(VMS_MAXRSS);
10677 if (!strpbrk(fname,"/]>:")) {
10678 strcpy(fileified,fname);
10679 trnlnm_iter_count = 0;
10680 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10681 trnlnm_iter_count++;
10682 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10686 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10687 PerlMem_free(fileified);
10690 retlen = namdsc.dsc$w_length = strlen(vmsname);
10691 namdsc.dsc$a_pointer = vmsname;
10692 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10693 vmsname[retlen-1] == ':') {
10694 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10695 namdsc.dsc$w_length = strlen(fileified);
10696 namdsc.dsc$a_pointer = fileified;
10700 retlen = namdsc.dsc$w_length = strlen(fname);
10701 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10705 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10706 access = ARM$M_EXECUTE;
10707 flags = CHP$M_READ;
10709 case S_IRUSR: case S_IRGRP: case S_IROTH:
10710 access = ARM$M_READ;
10711 flags = CHP$M_READ | CHP$M_USEREADALL;
10713 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10714 access = ARM$M_WRITE;
10715 flags = CHP$M_READ | CHP$M_WRITE;
10717 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10718 access = ARM$M_DELETE;
10719 flags = CHP$M_READ | CHP$M_WRITE;
10722 if (fileified != NULL)
10723 PerlMem_free(fileified);
10727 /* Before we call $check_access, create a user profile with the current
10728 * process privs since otherwise it just uses the default privs from the
10729 * UAF and might give false positives or negatives. This only works on
10730 * VMS versions v6.0 and later since that's when sys$create_user_profile
10731 * became available.
10734 /* get current process privs and username */
10735 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10736 _ckvmssts(iosb[0]);
10738 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10740 /* find out the space required for the profile */
10741 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10742 &usrprodsc.dsc$w_length,0));
10744 /* allocate space for the profile and get it filled in */
10745 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10746 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10747 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10748 &usrprodsc.dsc$w_length,0));
10750 /* use the profile to check access to the file; free profile & analyze results */
10751 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10752 PerlMem_free(usrprodsc.dsc$a_pointer);
10753 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10757 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10761 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
10762 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10763 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10764 set_vaxc_errno(retsts);
10765 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10766 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10767 else set_errno(ENOENT);
10768 if (fileified != NULL)
10769 PerlMem_free(fileified);
10772 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10773 if (fileified != NULL)
10774 PerlMem_free(fileified);
10779 if (fileified != NULL)
10780 PerlMem_free(fileified);
10781 return FALSE; /* Should never get here */
10785 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
10786 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10787 * subset of the applicable information.
10790 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10792 return cando_by_name_int
10793 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10794 } /* end of cando() */
10798 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10800 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10802 return cando_by_name_int(bit, effective, fname, 0);
10804 } /* end of cando_by_name() */
10808 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10810 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10812 if (!fstat(fd,(stat_t *) statbufp)) {
10814 char *vms_filename;
10815 vms_filename = PerlMem_malloc(VMS_MAXRSS);
10816 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10818 /* Save name for cando by name in VMS format */
10819 cptr = getname(fd, vms_filename, 1);
10821 /* This should not happen, but just in case */
10822 if (cptr == NULL) {
10823 statbufp->st_devnam[0] = 0;
10826 /* Make sure that the saved name fits in 255 characters */
10827 cptr = do_rmsexpand
10829 statbufp->st_devnam,
10832 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10836 statbufp->st_devnam[0] = 0;
10838 PerlMem_free(vms_filename);
10840 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10842 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10844 # ifdef RTL_USES_UTC
10845 # ifdef VMSISH_TIME
10847 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10848 statbufp->st_atime = _toloc(statbufp->st_atime);
10849 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10853 # ifdef VMSISH_TIME
10854 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10858 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10859 statbufp->st_atime = _toutc(statbufp->st_atime);
10860 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10867 } /* end of flex_fstat() */
10870 #if !defined(__VAX) && __CRTL_VER >= 80200000
10878 #define lstat(_x, _y) stat(_x, _y)
10881 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10884 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10886 char fileified[VMS_MAXRSS];
10887 char temp_fspec[VMS_MAXRSS];
10890 int saved_errno, saved_vaxc_errno;
10892 if (!fspec) return retval;
10893 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10894 strcpy(temp_fspec, fspec);
10896 if (decc_bug_devnull != 0) {
10897 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10898 memset(statbufp,0,sizeof *statbufp);
10899 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10900 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10901 statbufp->st_uid = 0x00010001;
10902 statbufp->st_gid = 0x0001;
10903 time((time_t *)&statbufp->st_mtime);
10904 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10909 /* Try for a directory name first. If fspec contains a filename without
10910 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10911 * and sea:[wine.dark]water. exist, we prefer the directory here.
10912 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10913 * not sea:[wine.dark]., if the latter exists. If the intended target is
10914 * the file with null type, specify this by calling flex_stat() with
10915 * a '.' at the end of fspec.
10917 * If we are in Posix filespec mode, accept the filename as is.
10919 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10920 if (decc_posix_compliant_pathnames == 0) {
10922 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10923 if (lstat_flag == 0)
10924 retval = stat(fileified,(stat_t *) statbufp);
10926 retval = lstat(fileified,(stat_t *) statbufp);
10927 save_spec = fileified;
10930 if (lstat_flag == 0)
10931 retval = stat(temp_fspec,(stat_t *) statbufp);
10933 retval = lstat(temp_fspec,(stat_t *) statbufp);
10934 save_spec = temp_fspec;
10936 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10938 if (lstat_flag == 0)
10939 retval = stat(temp_fspec,(stat_t *) statbufp);
10941 retval = lstat(temp_fspec,(stat_t *) statbufp);
10942 save_spec = temp_fspec;
10947 cptr = do_rmsexpand
10948 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10950 statbufp->st_devnam[0] = 0;
10952 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10954 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10955 # ifdef RTL_USES_UTC
10956 # ifdef VMSISH_TIME
10958 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10959 statbufp->st_atime = _toloc(statbufp->st_atime);
10960 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10964 # ifdef VMSISH_TIME
10965 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10969 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10970 statbufp->st_atime = _toutc(statbufp->st_atime);
10971 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10975 /* If we were successful, leave errno where we found it */
10976 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10979 } /* end of flex_stat_int() */
10982 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10984 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10986 return flex_stat_int(fspec, statbufp, 0);
10990 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10992 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10994 return flex_stat_int(fspec, statbufp, 1);
10999 /*{{{char *my_getlogin()*/
11000 /* VMS cuserid == Unix getlogin, except calling sequence */
11004 static char user[L_cuserid];
11005 return cuserid(user);
11010 /* rmscopy - copy a file using VMS RMS routines
11012 * Copies contents and attributes of spec_in to spec_out, except owner
11013 * and protection information. Name and type of spec_in are used as
11014 * defaults for spec_out. The third parameter specifies whether rmscopy()
11015 * should try to propagate timestamps from the input file to the output file.
11016 * If it is less than 0, no timestamps are preserved. If it is 0, then
11017 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11018 * propagated to the output file at creation iff the output file specification
11019 * did not contain an explicit name or type, and the revision date is always
11020 * updated at the end of the copy operation. If it is greater than 0, then
11021 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11022 * other than the revision date should be propagated, and bit 1 indicates
11023 * that the revision date should be propagated.
11025 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11027 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11028 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11029 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11030 * as part of the Perl standard distribution under the terms of the
11031 * GNU General Public License or the Perl Artistic License. Copies
11032 * of each may be found in the Perl standard distribution.
11034 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11036 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11038 char *vmsin, * vmsout, *esa, *esa_out,
11040 unsigned long int i, sts, sts2;
11042 struct FAB fab_in, fab_out;
11043 struct RAB rab_in, rab_out;
11044 rms_setup_nam(nam);
11045 rms_setup_nam(nam_out);
11046 struct XABDAT xabdat;
11047 struct XABFHC xabfhc;
11048 struct XABRDT xabrdt;
11049 struct XABSUM xabsum;
11051 vmsin = PerlMem_malloc(VMS_MAXRSS);
11052 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11053 vmsout = PerlMem_malloc(VMS_MAXRSS);
11054 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11055 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11056 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11057 PerlMem_free(vmsin);
11058 PerlMem_free(vmsout);
11059 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11063 esa = PerlMem_malloc(VMS_MAXRSS);
11064 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11065 fab_in = cc$rms_fab;
11066 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11067 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11068 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11069 fab_in.fab$l_fop = FAB$M_SQO;
11070 rms_bind_fab_nam(fab_in, nam);
11071 fab_in.fab$l_xab = (void *) &xabdat;
11073 rsa = PerlMem_malloc(VMS_MAXRSS);
11074 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11075 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11076 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11077 rms_nam_esl(nam) = 0;
11078 rms_nam_rsl(nam) = 0;
11079 rms_nam_esll(nam) = 0;
11080 rms_nam_rsll(nam) = 0;
11081 #ifdef NAM$M_NO_SHORT_UPCASE
11082 if (decc_efs_case_preserve)
11083 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11086 xabdat = cc$rms_xabdat; /* To get creation date */
11087 xabdat.xab$l_nxt = (void *) &xabfhc;
11089 xabfhc = cc$rms_xabfhc; /* To get record length */
11090 xabfhc.xab$l_nxt = (void *) &xabsum;
11092 xabsum = cc$rms_xabsum; /* To get key and area information */
11094 if (!((sts = sys$open(&fab_in)) & 1)) {
11095 PerlMem_free(vmsin);
11096 PerlMem_free(vmsout);
11099 set_vaxc_errno(sts);
11101 case RMS$_FNF: case RMS$_DNF:
11102 set_errno(ENOENT); break;
11104 set_errno(ENOTDIR); break;
11106 set_errno(ENODEV); break;
11108 set_errno(EINVAL); break;
11110 set_errno(EACCES); break;
11112 set_errno(EVMSERR);
11119 fab_out.fab$w_ifi = 0;
11120 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11121 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11122 fab_out.fab$l_fop = FAB$M_SQO;
11123 rms_bind_fab_nam(fab_out, nam_out);
11124 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11125 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11126 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11127 esa_out = PerlMem_malloc(VMS_MAXRSS);
11128 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11129 rms_set_rsa(nam_out, NULL, 0);
11130 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11132 if (preserve_dates == 0) { /* Act like DCL COPY */
11133 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11134 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11135 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11136 PerlMem_free(vmsin);
11137 PerlMem_free(vmsout);
11140 PerlMem_free(esa_out);
11141 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11142 set_vaxc_errno(sts);
11145 fab_out.fab$l_xab = (void *) &xabdat;
11146 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11147 preserve_dates = 1;
11149 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11150 preserve_dates =0; /* bitmask from this point forward */
11152 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11153 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11154 PerlMem_free(vmsin);
11155 PerlMem_free(vmsout);
11158 PerlMem_free(esa_out);
11159 set_vaxc_errno(sts);
11162 set_errno(ENOENT); break;
11164 set_errno(ENOTDIR); break;
11166 set_errno(ENODEV); break;
11168 set_errno(EINVAL); break;
11170 set_errno(EACCES); break;
11172 set_errno(EVMSERR);
11176 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11177 if (preserve_dates & 2) {
11178 /* sys$close() will process xabrdt, not xabdat */
11179 xabrdt = cc$rms_xabrdt;
11181 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11183 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11184 * is unsigned long[2], while DECC & VAXC use a struct */
11185 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11187 fab_out.fab$l_xab = (void *) &xabrdt;
11190 ubf = PerlMem_malloc(32256);
11191 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11192 rab_in = cc$rms_rab;
11193 rab_in.rab$l_fab = &fab_in;
11194 rab_in.rab$l_rop = RAB$M_BIO;
11195 rab_in.rab$l_ubf = ubf;
11196 rab_in.rab$w_usz = 32256;
11197 if (!((sts = sys$connect(&rab_in)) & 1)) {
11198 sys$close(&fab_in); sys$close(&fab_out);
11199 PerlMem_free(vmsin);
11200 PerlMem_free(vmsout);
11204 PerlMem_free(esa_out);
11205 set_errno(EVMSERR); set_vaxc_errno(sts);
11209 rab_out = cc$rms_rab;
11210 rab_out.rab$l_fab = &fab_out;
11211 rab_out.rab$l_rbf = ubf;
11212 if (!((sts = sys$connect(&rab_out)) & 1)) {
11213 sys$close(&fab_in); sys$close(&fab_out);
11214 PerlMem_free(vmsin);
11215 PerlMem_free(vmsout);
11219 PerlMem_free(esa_out);
11220 set_errno(EVMSERR); set_vaxc_errno(sts);
11224 while ((sts = sys$read(&rab_in))) { /* always true */
11225 if (sts == RMS$_EOF) break;
11226 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11227 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11228 sys$close(&fab_in); sys$close(&fab_out);
11229 PerlMem_free(vmsin);
11230 PerlMem_free(vmsout);
11234 PerlMem_free(esa_out);
11235 set_errno(EVMSERR); set_vaxc_errno(sts);
11241 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11242 sys$close(&fab_in); sys$close(&fab_out);
11243 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11245 PerlMem_free(vmsin);
11246 PerlMem_free(vmsout);
11250 PerlMem_free(esa_out);
11251 set_errno(EVMSERR); set_vaxc_errno(sts);
11255 PerlMem_free(vmsin);
11256 PerlMem_free(vmsout);
11260 PerlMem_free(esa_out);
11263 } /* end of rmscopy() */
11267 /*** The following glue provides 'hooks' to make some of the routines
11268 * from this file available from Perl. These routines are sufficiently
11269 * basic, and are required sufficiently early in the build process,
11270 * that's it's nice to have them available to miniperl as well as the
11271 * full Perl, so they're set up here instead of in an extension. The
11272 * Perl code which handles importation of these names into a given
11273 * package lives in [.VMS]Filespec.pm in @INC.
11277 rmsexpand_fromperl(pTHX_ CV *cv)
11280 char *fspec, *defspec = NULL, *rslt;
11282 int fs_utf8, dfs_utf8;
11286 if (!items || items > 2)
11287 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11288 fspec = SvPV(ST(0),n_a);
11289 fs_utf8 = SvUTF8(ST(0));
11290 if (!fspec || !*fspec) XSRETURN_UNDEF;
11292 defspec = SvPV(ST(1),n_a);
11293 dfs_utf8 = SvUTF8(ST(1));
11295 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11296 ST(0) = sv_newmortal();
11297 if (rslt != NULL) {
11298 sv_usepvn(ST(0),rslt,strlen(rslt));
11307 vmsify_fromperl(pTHX_ CV *cv)
11314 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11315 utf8_fl = SvUTF8(ST(0));
11316 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11317 ST(0) = sv_newmortal();
11318 if (vmsified != NULL) {
11319 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11328 unixify_fromperl(pTHX_ CV *cv)
11335 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11336 utf8_fl = SvUTF8(ST(0));
11337 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11338 ST(0) = sv_newmortal();
11339 if (unixified != NULL) {
11340 sv_usepvn(ST(0),unixified,strlen(unixified));
11349 fileify_fromperl(pTHX_ CV *cv)
11356 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11357 utf8_fl = SvUTF8(ST(0));
11358 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11359 ST(0) = sv_newmortal();
11360 if (fileified != NULL) {
11361 sv_usepvn(ST(0),fileified,strlen(fileified));
11370 pathify_fromperl(pTHX_ CV *cv)
11377 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11378 utf8_fl = SvUTF8(ST(0));
11379 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11380 ST(0) = sv_newmortal();
11381 if (pathified != NULL) {
11382 sv_usepvn(ST(0),pathified,strlen(pathified));
11391 vmspath_fromperl(pTHX_ CV *cv)
11398 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11399 utf8_fl = SvUTF8(ST(0));
11400 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11401 ST(0) = sv_newmortal();
11402 if (vmspath != NULL) {
11403 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11412 unixpath_fromperl(pTHX_ CV *cv)
11419 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11420 utf8_fl = SvUTF8(ST(0));
11421 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11422 ST(0) = sv_newmortal();
11423 if (unixpath != NULL) {
11424 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11433 candelete_fromperl(pTHX_ CV *cv)
11441 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11443 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11444 Newx(fspec, VMS_MAXRSS, char);
11445 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11446 if (SvTYPE(mysv) == SVt_PVGV) {
11447 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11448 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11456 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11457 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11464 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11470 rmscopy_fromperl(pTHX_ CV *cv)
11473 char *inspec, *outspec, *inp, *outp;
11475 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11476 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11477 unsigned long int sts;
11482 if (items < 2 || items > 3)
11483 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11485 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11486 Newx(inspec, VMS_MAXRSS, char);
11487 if (SvTYPE(mysv) == SVt_PVGV) {
11488 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11489 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11497 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11498 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11504 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11505 Newx(outspec, VMS_MAXRSS, char);
11506 if (SvTYPE(mysv) == SVt_PVGV) {
11507 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11508 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11517 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11518 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11525 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11527 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11533 /* The mod2fname is limited to shorter filenames by design, so it should
11534 * not be modified to support longer EFS pathnames
11537 mod2fname(pTHX_ CV *cv)
11540 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11541 workbuff[NAM$C_MAXRSS*1 + 1];
11542 int total_namelen = 3, counter, num_entries;
11543 /* ODS-5 ups this, but we want to be consistent, so... */
11544 int max_name_len = 39;
11545 AV *in_array = (AV *)SvRV(ST(0));
11547 num_entries = av_len(in_array);
11549 /* All the names start with PL_. */
11550 strcpy(ultimate_name, "PL_");
11552 /* Clean up our working buffer */
11553 Zero(work_name, sizeof(work_name), char);
11555 /* Run through the entries and build up a working name */
11556 for(counter = 0; counter <= num_entries; counter++) {
11557 /* If it's not the first name then tack on a __ */
11559 strcat(work_name, "__");
11561 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11565 /* Check to see if we actually have to bother...*/
11566 if (strlen(work_name) + 3 <= max_name_len) {
11567 strcat(ultimate_name, work_name);
11569 /* It's too darned big, so we need to go strip. We use the same */
11570 /* algorithm as xsubpp does. First, strip out doubled __ */
11571 char *source, *dest, last;
11574 for (source = work_name; *source; source++) {
11575 if (last == *source && last == '_') {
11581 /* Go put it back */
11582 strcpy(work_name, workbuff);
11583 /* Is it still too big? */
11584 if (strlen(work_name) + 3 > max_name_len) {
11585 /* Strip duplicate letters */
11588 for (source = work_name; *source; source++) {
11589 if (last == toupper(*source)) {
11593 last = toupper(*source);
11595 strcpy(work_name, workbuff);
11598 /* Is it *still* too big? */
11599 if (strlen(work_name) + 3 > max_name_len) {
11600 /* Too bad, we truncate */
11601 work_name[max_name_len - 2] = 0;
11603 strcat(ultimate_name, work_name);
11606 /* Okay, return it */
11607 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11612 hushexit_fromperl(pTHX_ CV *cv)
11617 VMSISH_HUSHED = SvTRUE(ST(0));
11619 ST(0) = boolSV(VMSISH_HUSHED);
11625 Perl_vms_start_glob
11626 (pTHX_ SV *tmpglob,
11630 struct vs_str_st *rslt;
11634 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11637 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11638 struct dsc$descriptor_vs rsdsc;
11639 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11640 unsigned long hasver = 0, isunix = 0;
11641 unsigned long int lff_flags = 0;
11644 #ifdef VMS_LONGNAME_SUPPORT
11645 lff_flags = LIB$M_FIL_LONG_NAMES;
11647 /* The Newx macro will not allow me to assign a smaller array
11648 * to the rslt pointer, so we will assign it to the begin char pointer
11649 * and then copy the value into the rslt pointer.
11651 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11652 rslt = (struct vs_str_st *)begin;
11654 rstr = &rslt->str[0];
11655 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11656 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11657 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11658 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11660 Newx(vmsspec, VMS_MAXRSS, char);
11662 /* We could find out if there's an explicit dev/dir or version
11663 by peeking into lib$find_file's internal context at
11664 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11665 but that's unsupported, so I don't want to do it now and
11666 have it bite someone in the future. */
11667 /* Fix-me: vms_split_path() is the only way to do this, the
11668 existing method will fail with many legal EFS or UNIX specifications
11671 cp = SvPV(tmpglob,i);
11674 if (cp[i] == ';') hasver = 1;
11675 if (cp[i] == '.') {
11676 if (sts) hasver = 1;
11679 if (cp[i] == '/') {
11680 hasdir = isunix = 1;
11683 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11688 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11691 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11692 if (!stat_sts && S_ISDIR(st.st_mode)) {
11693 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11694 ok = (wilddsc.dsc$a_pointer != NULL);
11697 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11698 ok = (wilddsc.dsc$a_pointer != NULL);
11701 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11703 /* If not extended character set, replace ? with % */
11704 /* With extended character set, ? is a wildcard single character */
11705 if (!decc_efs_case_preserve) {
11706 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11707 if (*cp == '?') *cp = '%';
11710 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11711 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11712 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11714 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11715 &dfltdsc,NULL,&rms_sts,&lff_flags);
11716 if (!$VMS_STATUS_SUCCESS(sts))
11719 /* with varying string, 1st word of buffer contains result length */
11720 rstr[rslt->length] = '\0';
11722 /* Find where all the components are */
11723 v_sts = vms_split_path
11738 /* If no version on input, truncate the version on output */
11739 if (!hasver && (vs_len > 0)) {
11743 /* No version & a null extension on UNIX handling */
11744 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11750 if (!decc_efs_case_preserve) {
11751 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11755 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11759 /* Start with the name */
11762 strcat(begin,"\n");
11763 ok = (PerlIO_puts(tmpfp,begin) != EOF);
11765 if (cxt) (void)lib$find_file_end(&cxt);
11766 if (ok && sts != RMS$_NMF &&
11767 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11770 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11772 PerlIO_close(tmpfp);
11776 PerlIO_rewind(tmpfp);
11777 IoTYPE(io) = IoTYPE_RDONLY;
11778 IoIFP(io) = fp = tmpfp;
11779 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
11789 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11792 vms_realpath_fromperl(pTHX_ CV *cv)
11795 char *fspec, *rslt_spec, *rslt;
11798 if (!items || items != 1)
11799 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11801 fspec = SvPV(ST(0),n_a);
11802 if (!fspec || !*fspec) XSRETURN_UNDEF;
11804 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11805 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11806 ST(0) = sv_newmortal();
11808 sv_usepvn(ST(0),rslt,strlen(rslt));
11810 Safefree(rslt_spec);
11815 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11816 int do_vms_case_tolerant(void);
11819 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11822 ST(0) = boolSV(do_vms_case_tolerant());
11828 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11829 struct interp_intern *dst)
11831 memcpy(dst,src,sizeof(struct interp_intern));
11835 Perl_sys_intern_clear(pTHX)
11840 Perl_sys_intern_init(pTHX)
11842 unsigned int ix = RAND_MAX;
11847 /* fix me later to track running under GNV */
11848 /* this allows some limited testing */
11849 MY_POSIX_EXIT = decc_filename_unix_report;
11852 MY_INV_RAND_MAX = 1./x;
11856 init_os_extras(void)
11859 char* file = __FILE__;
11860 if (decc_disable_to_vms_logname_translation) {
11861 no_translate_barewords = TRUE;
11863 no_translate_barewords = FALSE;
11866 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11867 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11868 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11869 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11870 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11871 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11872 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11873 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11874 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11875 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11876 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11878 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11880 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11881 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11884 store_pipelocs(aTHX); /* will redo any earlier attempts */
11891 #if __CRTL_VER == 80200000
11892 /* This missed getting in to the DECC SDK for 8.2 */
11893 char *realpath(const char *file_name, char * resolved_name, ...);
11896 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11897 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11898 * The perl fallback routine to provide realpath() is not as efficient
11902 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11904 return realpath(filespec, outbuf);
11908 /* External entry points */
11909 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11910 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11912 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11917 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11918 /* case_tolerant */
11920 /*{{{int do_vms_case_tolerant(void)*/
11921 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11922 * controlled by a process setting.
11924 int do_vms_case_tolerant(void)
11926 return vms_process_case_tolerant;
11929 /* External entry points */
11930 int Perl_vms_case_tolerant(void)
11931 { return do_vms_case_tolerant(); }
11933 int Perl_vms_case_tolerant(void)
11934 { return vms_process_case_tolerant; }
11938 /* Start of DECC RTL Feature handling */
11940 static int sys_trnlnm
11941 (const char * logname,
11945 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11946 const unsigned long attr = LNM$M_CASE_BLIND;
11947 struct dsc$descriptor_s name_dsc;
11949 unsigned short result;
11950 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11953 name_dsc.dsc$w_length = strlen(logname);
11954 name_dsc.dsc$a_pointer = (char *)logname;
11955 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11956 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11958 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11960 if ($VMS_STATUS_SUCCESS(status)) {
11962 /* Null terminate and return the string */
11963 /*--------------------------------------*/
11970 static int sys_crelnm
11971 (const char * logname,
11972 const char * value)
11975 const char * proc_table = "LNM$PROCESS_TABLE";
11976 struct dsc$descriptor_s proc_table_dsc;
11977 struct dsc$descriptor_s logname_dsc;
11978 struct itmlst_3 item_list[2];
11980 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11981 proc_table_dsc.dsc$w_length = strlen(proc_table);
11982 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11983 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11985 logname_dsc.dsc$a_pointer = (char *) logname;
11986 logname_dsc.dsc$w_length = strlen(logname);
11987 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11988 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11990 item_list[0].buflen = strlen(value);
11991 item_list[0].itmcode = LNM$_STRING;
11992 item_list[0].bufadr = (char *)value;
11993 item_list[0].retlen = NULL;
11995 item_list[1].buflen = 0;
11996 item_list[1].itmcode = 0;
11998 ret_val = sys$crelnm
12000 (const struct dsc$descriptor_s *)&proc_table_dsc,
12001 (const struct dsc$descriptor_s *)&logname_dsc,
12003 (const struct item_list_3 *) item_list);
12008 /* C RTL Feature settings */
12010 static int set_features
12011 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12012 int (* cli_routine)(void), /* Not documented */
12013 void *image_info) /* Not documented */
12020 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12021 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12022 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12023 unsigned long case_perm;
12024 unsigned long case_image;
12027 /* Allow an exception to bring Perl into the VMS debugger */
12028 vms_debug_on_exception = 0;
12029 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12030 if ($VMS_STATUS_SUCCESS(status)) {
12031 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12032 vms_debug_on_exception = 1;
12034 vms_debug_on_exception = 0;
12037 /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12038 vms_vtf7_filenames = 0;
12039 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12040 if ($VMS_STATUS_SUCCESS(status)) {
12041 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12042 vms_vtf7_filenames = 1;
12044 vms_vtf7_filenames = 0;
12047 /* Dectect running under GNV Bash or other UNIX like shell */
12048 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12049 gnv_unix_shell = 0;
12050 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12051 if ($VMS_STATUS_SUCCESS(status)) {
12052 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12053 gnv_unix_shell = 1;
12054 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12055 set_feature_default("DECC$EFS_CHARSET", 1);
12056 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12057 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12058 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12059 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12062 gnv_unix_shell = 0;
12066 /* hacks to see if known bugs are still present for testing */
12068 /* Readdir is returning filenames in VMS syntax always */
12069 decc_bug_readdir_efs1 = 1;
12070 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12071 if ($VMS_STATUS_SUCCESS(status)) {
12072 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12073 decc_bug_readdir_efs1 = 1;
12075 decc_bug_readdir_efs1 = 0;
12078 /* PCP mode requires creating /dev/null special device file */
12079 decc_bug_devnull = 0;
12080 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12081 if ($VMS_STATUS_SUCCESS(status)) {
12082 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12083 decc_bug_devnull = 1;
12085 decc_bug_devnull = 0;
12088 /* fgetname returning a VMS name in UNIX mode */
12089 decc_bug_fgetname = 1;
12090 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12091 if ($VMS_STATUS_SUCCESS(status)) {
12092 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12093 decc_bug_fgetname = 1;
12095 decc_bug_fgetname = 0;
12098 /* UNIX directory names with no paths are broken in a lot of places */
12099 decc_dir_barename = 1;
12100 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12101 if ($VMS_STATUS_SUCCESS(status)) {
12102 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12103 decc_dir_barename = 1;
12105 decc_dir_barename = 0;
12108 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12109 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12111 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12112 if (decc_disable_to_vms_logname_translation < 0)
12113 decc_disable_to_vms_logname_translation = 0;
12116 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12118 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12119 if (decc_efs_case_preserve < 0)
12120 decc_efs_case_preserve = 0;
12123 s = decc$feature_get_index("DECC$EFS_CHARSET");
12125 decc_efs_charset = decc$feature_get_value(s, 1);
12126 if (decc_efs_charset < 0)
12127 decc_efs_charset = 0;
12130 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12132 decc_filename_unix_report = decc$feature_get_value(s, 1);
12133 if (decc_filename_unix_report > 0)
12134 decc_filename_unix_report = 1;
12136 decc_filename_unix_report = 0;
12139 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12141 decc_filename_unix_only = decc$feature_get_value(s, 1);
12142 if (decc_filename_unix_only > 0) {
12143 decc_filename_unix_only = 1;
12146 decc_filename_unix_only = 0;
12150 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12152 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12153 if (decc_filename_unix_no_version < 0)
12154 decc_filename_unix_no_version = 0;
12157 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12159 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12160 if (decc_readdir_dropdotnotype < 0)
12161 decc_readdir_dropdotnotype = 0;
12164 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12165 if ($VMS_STATUS_SUCCESS(status)) {
12166 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12168 dflt = decc$feature_get_value(s, 4);
12170 decc_disable_posix_root = decc$feature_get_value(s, 1);
12171 if (decc_disable_posix_root <= 0) {
12172 decc$feature_set_value(s, 1, 1);
12173 decc_disable_posix_root = 1;
12177 /* Traditionally Perl assumes this is off */
12178 decc_disable_posix_root = 1;
12179 decc$feature_set_value(s, 1, 1);
12184 #if __CRTL_VER >= 80200000
12185 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12187 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12188 if (decc_posix_compliant_pathnames < 0)
12189 decc_posix_compliant_pathnames = 0;
12190 if (decc_posix_compliant_pathnames > 4)
12191 decc_posix_compliant_pathnames = 0;
12196 status = sys_trnlnm
12197 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12198 if ($VMS_STATUS_SUCCESS(status)) {
12199 val_str[0] = _toupper(val_str[0]);
12200 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12201 decc_disable_to_vms_logname_translation = 1;
12206 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12207 if ($VMS_STATUS_SUCCESS(status)) {
12208 val_str[0] = _toupper(val_str[0]);
12209 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12210 decc_efs_case_preserve = 1;
12215 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12216 if ($VMS_STATUS_SUCCESS(status)) {
12217 val_str[0] = _toupper(val_str[0]);
12218 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12219 decc_filename_unix_report = 1;
12222 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12223 if ($VMS_STATUS_SUCCESS(status)) {
12224 val_str[0] = _toupper(val_str[0]);
12225 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12226 decc_filename_unix_only = 1;
12227 decc_filename_unix_report = 1;
12230 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12231 if ($VMS_STATUS_SUCCESS(status)) {
12232 val_str[0] = _toupper(val_str[0]);
12233 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12234 decc_filename_unix_no_version = 1;
12237 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12238 if ($VMS_STATUS_SUCCESS(status)) {
12239 val_str[0] = _toupper(val_str[0]);
12240 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12241 decc_readdir_dropdotnotype = 1;
12246 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12248 /* Report true case tolerance */
12249 /*----------------------------*/
12250 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12251 if (!$VMS_STATUS_SUCCESS(status))
12252 case_perm = PPROP$K_CASE_BLIND;
12253 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12254 if (!$VMS_STATUS_SUCCESS(status))
12255 case_image = PPROP$K_CASE_BLIND;
12256 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12257 (case_image == PPROP$K_CASE_SENSITIVE))
12258 vms_process_case_tolerant = 0;
12263 /* CRTL can be initialized past this point, but not before. */
12264 /* DECC$CRTL_INIT(); */
12270 /* DECC dependent attributes */
12271 #if __DECC_VER < 60560002
12273 #define not_executable
12275 #define relative ,rel
12276 #define not_executable ,noexe
12279 #pragma extern_model save
12280 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12282 const __align (LONGWORD) int spare[8] = {0};
12283 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12286 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12287 nowrt,noshr relative not_executable
12289 const long vms_cc_features = (const long)set_features;
12292 ** Force a reference to LIB$INITIALIZE to ensure it
12293 ** exists in the image.
12295 int lib$initialize(void);
12297 #pragma extern_model strict_refdef
12299 int lib_init_ref = (int) lib$initialize;
12302 #pragma extern_model restore