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];
1360 strncpy(lnm, key, keylen);
1361 int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1362 sv = newSVpvn(eqv, strlen(eqv));
1365 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1369 hv_store(envhv,key,keylen,sv,hash);
1370 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1372 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1373 /* get the PPFs for this process, not the subprocess */
1374 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1375 char eqv[LNM$C_NAMLENGTH+1];
1377 for (i = 0; ppfs[i]; i++) {
1378 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1379 sv = newSVpv(eqv,trnlen);
1381 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1386 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1387 if (buf) Safefree(buf);
1388 if (seenhv) SvREFCNT_dec(seenhv);
1389 MUTEX_UNLOCK(&primenv_mutex);
1392 } /* end of prime_env_iter */
1396 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1397 /* Define or delete an element in the same "environment" as
1398 * vmstrnenv(). If an element is to be deleted, it's removed from
1399 * the first place it's found. If it's to be set, it's set in the
1400 * place designated by the first element of the table vector.
1401 * Like setenv() returns 0 for success, non-zero on error.
1404 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1407 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1408 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1410 unsigned long int retsts, usermode = PSL$C_USER;
1411 struct itmlst_3 *ile, *ilist;
1412 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1413 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1414 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1415 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1416 $DESCRIPTOR(local,"_LOCAL");
1419 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1420 return SS$_IVLOGNAM;
1423 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1424 *cp2 = _toupper(*cp1);
1425 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1426 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1427 return SS$_IVLOGNAM;
1430 lnmdsc.dsc$w_length = cp1 - lnm;
1431 if (!tabvec || !*tabvec) tabvec = env_tables;
1433 if (!eqv) { /* we're deleting n element */
1434 for (curtab = 0; tabvec[curtab]; curtab++) {
1435 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1437 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1438 if ((cp1 = strchr(environ[i],'=')) &&
1439 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1440 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1442 return setenv(lnm,"",1) ? vaxc$errno : 0;
1445 ivenv = 1; retsts = SS$_NOLOGNAM;
1447 if (ckWARN(WARN_INTERNAL))
1448 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1449 ivenv = 1; retsts = SS$_NOSUCHPGM;
1455 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1456 !str$case_blind_compare(&tmpdsc,&clisym)) {
1457 unsigned int symtype;
1458 if (tabvec[curtab]->dsc$w_length == 12 &&
1459 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1460 !str$case_blind_compare(&tmpdsc,&local))
1461 symtype = LIB$K_CLI_LOCAL_SYM;
1462 else symtype = LIB$K_CLI_GLOBAL_SYM;
1463 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1464 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1465 if (retsts == LIB$_NOSUCHSYM) continue;
1469 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1470 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1471 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1472 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1473 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1477 else { /* we're defining a value */
1478 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1480 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1482 if (ckWARN(WARN_INTERNAL))
1483 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1484 retsts = SS$_NOSUCHPGM;
1488 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1489 eqvdsc.dsc$w_length = strlen(eqv);
1490 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1491 !str$case_blind_compare(&tmpdsc,&clisym)) {
1492 unsigned int symtype;
1493 if (tabvec[0]->dsc$w_length == 12 &&
1494 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1495 !str$case_blind_compare(&tmpdsc,&local))
1496 symtype = LIB$K_CLI_LOCAL_SYM;
1497 else symtype = LIB$K_CLI_GLOBAL_SYM;
1498 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1501 if (!*eqv) eqvdsc.dsc$w_length = 1;
1502 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1504 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1505 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1506 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1507 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1508 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1509 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1512 Newx(ilist,nseg+1,struct itmlst_3);
1515 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1518 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1520 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1521 ile->itmcode = LNM$_STRING;
1523 if ((j+1) == nseg) {
1524 ile->buflen = strlen(c);
1525 /* in case we are truncating one that's too long */
1526 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1529 ile->buflen = LNM$C_NAMLENGTH;
1533 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1537 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1542 if (!(retsts & 1)) {
1544 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1545 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1546 set_errno(EVMSERR); break;
1547 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1548 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1549 set_errno(EINVAL); break;
1551 set_errno(EACCES); break;
1556 set_vaxc_errno(retsts);
1557 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1560 /* We reset error values on success because Perl does an hv_fetch()
1561 * before each hv_store(), and if the thing we're setting didn't
1562 * previously exist, we've got a leftover error message. (Of course,
1563 * this fails in the face of
1564 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1565 * in that the error reported in $! isn't spurious,
1566 * but it's right more often than not.)
1568 set_errno(0); set_vaxc_errno(retsts);
1572 } /* end of vmssetenv() */
1575 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1576 /* This has to be a function since there's a prototype for it in proto.h */
1578 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1581 int len = strlen(lnm);
1585 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1586 if (!strcmp(uplnm,"DEFAULT")) {
1587 if (eqv && *eqv) my_chdir(eqv);
1591 #ifndef RTL_USES_UTC
1592 if (len == 6 || len == 2) {
1595 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1597 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1598 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1602 (void) vmssetenv(lnm,eqv,NULL);
1606 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1608 * sets a user-mode logical in the process logical name table
1609 * used for redirection of sys$error
1612 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1614 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1615 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1616 unsigned long int iss, attr = LNM$M_CONFINE;
1617 unsigned char acmode = PSL$C_USER;
1618 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1620 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1621 d_name.dsc$w_length = strlen(name);
1623 lnmlst[0].buflen = strlen(eqv);
1624 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1626 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1627 if (!(iss&1)) lib$signal(iss);
1632 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1633 /* my_crypt - VMS password hashing
1634 * my_crypt() provides an interface compatible with the Unix crypt()
1635 * C library function, and uses sys$hash_password() to perform VMS
1636 * password hashing. The quadword hashed password value is returned
1637 * as a NUL-terminated 8 character string. my_crypt() does not change
1638 * the case of its string arguments; in order to match the behavior
1639 * of LOGINOUT et al., alphabetic characters in both arguments must
1640 * be upcased by the caller.
1642 * - fix me to call ACM services when available
1645 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1647 # ifndef UAI$C_PREFERRED_ALGORITHM
1648 # define UAI$C_PREFERRED_ALGORITHM 127
1650 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1651 unsigned short int salt = 0;
1652 unsigned long int sts;
1654 unsigned short int dsc$w_length;
1655 unsigned char dsc$b_type;
1656 unsigned char dsc$b_class;
1657 const char * dsc$a_pointer;
1658 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1659 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1660 struct itmlst_3 uailst[3] = {
1661 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1662 { sizeof salt, UAI$_SALT, &salt, 0},
1663 { 0, 0, NULL, NULL}};
1664 static char hash[9];
1666 usrdsc.dsc$w_length = strlen(usrname);
1667 usrdsc.dsc$a_pointer = usrname;
1668 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1670 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1674 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1679 set_vaxc_errno(sts);
1680 if (sts != RMS$_RNF) return NULL;
1683 txtdsc.dsc$w_length = strlen(textpasswd);
1684 txtdsc.dsc$a_pointer = textpasswd;
1685 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1686 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1689 return (char *) hash;
1691 } /* end of my_crypt() */
1695 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1696 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1697 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1699 /* fixup barenames that are directories for internal use.
1700 * There have been problems with the consistent handling of UNIX
1701 * style directory names when routines are presented with a name that
1702 * has no directory delimitors at all. So this routine will eventually
1705 static char * fixup_bare_dirnames(const char * name)
1707 if (decc_disable_to_vms_logname_translation) {
1714 * A little hack to get around a bug in some implemenation of remove()
1715 * that do not know how to delete a directory
1717 * Delete any file to which user has control access, regardless of whether
1718 * delete access is explicitly allowed.
1719 * Limitations: User must have write access to parent directory.
1720 * Does not block signals or ASTs; if interrupted in midstream
1721 * may leave file with an altered ACL.
1724 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1726 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1728 char *vmsname, *rspec;
1730 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1731 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1732 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1734 unsigned char myace$b_length;
1735 unsigned char myace$b_type;
1736 unsigned short int myace$w_flags;
1737 unsigned long int myace$l_access;
1738 unsigned long int myace$l_ident;
1739 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1740 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1741 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1743 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1744 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1745 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1746 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1747 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1748 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1750 /* Expand the input spec using RMS, since the CRTL remove() and
1751 * system services won't do this by themselves, so we may miss
1752 * a file "hiding" behind a logical name or search list. */
1753 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1754 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1756 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1757 PerlMem_free(vmsname);
1761 if (decc_posix_compliant_pathnames) {
1762 /* In POSIX mode, we prefer to remove the UNIX name */
1764 remove_name = (char *)name;
1767 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1768 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1769 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1770 PerlMem_free(rspec);
1771 PerlMem_free(vmsname);
1774 PerlMem_free(vmsname);
1775 remove_name = rspec;
1778 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1780 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1781 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1782 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1784 do_pathify_dirspec(name, remove_name, 0, NULL);
1785 if (!rmdir(remove_name)) {
1787 PerlMem_free(remove_name);
1788 PerlMem_free(rspec);
1789 return 0; /* Can we just get rid of it? */
1793 if (!rmdir(remove_name)) {
1794 PerlMem_free(rspec);
1795 return 0; /* Can we just get rid of it? */
1801 if (!remove(remove_name)) {
1802 PerlMem_free(rspec);
1803 return 0; /* Can we just get rid of it? */
1806 /* If not, can changing protections help? */
1807 if (vaxc$errno != RMS$_PRV) {
1808 PerlMem_free(rspec);
1812 /* No, so we get our own UIC to use as a rights identifier,
1813 * and the insert an ACE at the head of the ACL which allows us
1814 * to delete the file.
1816 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1817 fildsc.dsc$w_length = strlen(rspec);
1818 fildsc.dsc$a_pointer = rspec;
1820 newace.myace$l_ident = oldace.myace$l_ident;
1821 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1823 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1824 set_errno(ENOENT); break;
1826 set_errno(ENOTDIR); break;
1828 set_errno(ENODEV); break;
1829 case RMS$_SYN: case SS$_INVFILFOROP:
1830 set_errno(EINVAL); break;
1832 set_errno(EACCES); break;
1836 set_vaxc_errno(aclsts);
1837 PerlMem_free(rspec);
1840 /* Grab any existing ACEs with this identifier in case we fail */
1841 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1842 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1843 || fndsts == SS$_NOMOREACE ) {
1844 /* Add the new ACE . . . */
1845 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1848 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1850 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1851 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1852 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1854 do_pathify_dirspec(name, remove_name, 0, NULL);
1855 rmsts = rmdir(remove_name);
1856 PerlMem_free(remove_name);
1859 rmsts = rmdir(remove_name);
1863 rmsts = remove(remove_name);
1865 /* We blew it - dir with files in it, no write priv for
1866 * parent directory, etc. Put things back the way they were. */
1867 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1870 addlst[0].bufadr = &oldace;
1871 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1878 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1879 /* We just deleted it, so of course it's not there. Some versions of
1880 * VMS seem to return success on the unlock operation anyhow (after all
1881 * the unlock is successful), but others don't.
1883 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1884 if (aclsts & 1) aclsts = fndsts;
1885 if (!(aclsts & 1)) {
1887 set_vaxc_errno(aclsts);
1888 PerlMem_free(rspec);
1892 PerlMem_free(rspec);
1895 } /* end of kill_file() */
1899 /*{{{int do_rmdir(char *name)*/
1901 Perl_do_rmdir(pTHX_ const char *name)
1903 char dirfile[NAM$C_MAXRSS+1];
1907 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1908 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1909 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1912 } /* end of do_rmdir */
1916 * Delete any file to which user has control access, regardless of whether
1917 * delete access is explicitly allowed.
1918 * Limitations: User must have write access to parent directory.
1919 * Does not block signals or ASTs; if interrupted in midstream
1920 * may leave file with an altered ACL.
1923 /*{{{int kill_file(char *name)*/
1925 Perl_kill_file(pTHX_ const char *name)
1927 char rspec[NAM$C_MAXRSS+1];
1929 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1930 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1931 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1933 unsigned char myace$b_length;
1934 unsigned char myace$b_type;
1935 unsigned short int myace$w_flags;
1936 unsigned long int myace$l_access;
1937 unsigned long int myace$l_ident;
1938 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1939 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1940 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1942 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1943 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1944 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1945 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1946 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1947 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1949 /* Expand the input spec using RMS, since the CRTL remove() and
1950 * system services won't do this by themselves, so we may miss
1951 * a file "hiding" behind a logical name or search list. */
1952 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1953 if (tspec == NULL) return -1;
1954 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1955 /* If not, can changing protections help? */
1956 if (vaxc$errno != RMS$_PRV) return -1;
1958 /* No, so we get our own UIC to use as a rights identifier,
1959 * and the insert an ACE at the head of the ACL which allows us
1960 * to delete the file.
1962 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1963 fildsc.dsc$w_length = strlen(rspec);
1964 fildsc.dsc$a_pointer = rspec;
1966 newace.myace$l_ident = oldace.myace$l_ident;
1967 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1969 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1970 set_errno(ENOENT); break;
1972 set_errno(ENOTDIR); break;
1974 set_errno(ENODEV); break;
1975 case RMS$_SYN: case SS$_INVFILFOROP:
1976 set_errno(EINVAL); break;
1978 set_errno(EACCES); break;
1982 set_vaxc_errno(aclsts);
1985 /* Grab any existing ACEs with this identifier in case we fail */
1986 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1987 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1988 || fndsts == SS$_NOMOREACE ) {
1989 /* Add the new ACE . . . */
1990 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1992 if ((rmsts = remove(name))) {
1993 /* We blew it - dir with files in it, no write priv for
1994 * parent directory, etc. Put things back the way they were. */
1995 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1998 addlst[0].bufadr = &oldace;
1999 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2006 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2007 /* We just deleted it, so of course it's not there. Some versions of
2008 * VMS seem to return success on the unlock operation anyhow (after all
2009 * the unlock is successful), but others don't.
2011 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2012 if (aclsts & 1) aclsts = fndsts;
2013 if (!(aclsts & 1)) {
2015 set_vaxc_errno(aclsts);
2021 } /* end of kill_file() */
2025 /*{{{int my_mkdir(char *,Mode_t)*/
2027 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2029 STRLEN dirlen = strlen(dir);
2031 /* zero length string sometimes gives ACCVIO */
2032 if (dirlen == 0) return -1;
2034 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2035 * null file name/type. However, it's commonplace under Unix,
2036 * so we'll allow it for a gain in portability.
2038 if (dir[dirlen-1] == '/') {
2039 char *newdir = savepvn(dir,dirlen-1);
2040 int ret = mkdir(newdir,mode);
2044 else return mkdir(dir,mode);
2045 } /* end of my_mkdir */
2048 /*{{{int my_chdir(char *)*/
2050 Perl_my_chdir(pTHX_ const char *dir)
2052 STRLEN dirlen = strlen(dir);
2054 /* zero length string sometimes gives ACCVIO */
2055 if (dirlen == 0) return -1;
2058 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2059 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2060 * so that existing scripts do not need to be changed.
2063 while ((dirlen > 0) && (*dir1 == ' ')) {
2068 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2070 * null file name/type. However, it's commonplace under Unix,
2071 * so we'll allow it for a gain in portability.
2073 * - Preview- '/' will be valid soon on VMS
2075 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2076 char *newdir = savepvn(dir1,dirlen-1);
2077 int ret = chdir(newdir);
2081 else return chdir(dir1);
2082 } /* end of my_chdir */
2086 /*{{{FILE *my_tmpfile()*/
2093 if ((fp = tmpfile())) return fp;
2095 cp = PerlMem_malloc(L_tmpnam+24);
2096 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2098 if (decc_filename_unix_only == 0)
2099 strcpy(cp,"Sys$Scratch:");
2102 tmpnam(cp+strlen(cp));
2103 strcat(cp,".Perltmp");
2104 fp = fopen(cp,"w+","fop=dlt");
2111 #ifndef HOMEGROWN_POSIX_SIGNALS
2113 * The C RTL's sigaction fails to check for invalid signal numbers so we
2114 * help it out a bit. The docs are correct, but the actual routine doesn't
2115 * do what the docs say it will.
2117 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2119 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2120 struct sigaction* oact)
2122 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2123 SETERRNO(EINVAL, SS$_INVARG);
2126 return sigaction(sig, act, oact);
2131 #ifdef KILL_BY_SIGPRC
2132 #include <errnodef.h>
2134 /* We implement our own kill() using the undocumented system service
2135 sys$sigprc for one of two reasons:
2137 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2138 target process to do a sys$exit, which usually can't be handled
2139 gracefully...certainly not by Perl and the %SIG{} mechanism.
2141 2.) If the kill() in the CRTL can't be called from a signal
2142 handler without disappearing into the ether, i.e., the signal
2143 it purportedly sends is never trapped. Still true as of VMS 7.3.
2145 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2146 in the target process rather than calling sys$exit.
2148 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2149 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2150 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2151 with condition codes C$_SIG0+nsig*8, catching the exception on the
2152 target process and resignaling with appropriate arguments.
2154 But we don't have that VMS 7.0+ exception handler, so if you
2155 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2157 Also note that SIGTERM is listed in the docs as being "unimplemented",
2158 yet always seems to be signaled with a VMS condition code of 4 (and
2159 correctly handled for that code). So we hardwire it in.
2161 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2162 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2163 than signalling with an unrecognized (and unhandled by CRTL) code.
2166 #define _MY_SIG_MAX 28
2169 Perl_sig_to_vmscondition_int(int sig)
2171 static unsigned int sig_code[_MY_SIG_MAX+1] =
2174 SS$_HANGUP, /* 1 SIGHUP */
2175 SS$_CONTROLC, /* 2 SIGINT */
2176 SS$_CONTROLY, /* 3 SIGQUIT */
2177 SS$_RADRMOD, /* 4 SIGILL */
2178 SS$_BREAK, /* 5 SIGTRAP */
2179 SS$_OPCCUS, /* 6 SIGABRT */
2180 SS$_COMPAT, /* 7 SIGEMT */
2182 SS$_FLTOVF, /* 8 SIGFPE VAX */
2184 SS$_HPARITH, /* 8 SIGFPE AXP */
2186 SS$_ABORT, /* 9 SIGKILL */
2187 SS$_ACCVIO, /* 10 SIGBUS */
2188 SS$_ACCVIO, /* 11 SIGSEGV */
2189 SS$_BADPARAM, /* 12 SIGSYS */
2190 SS$_NOMBX, /* 13 SIGPIPE */
2191 SS$_ASTFLT, /* 14 SIGALRM */
2208 #if __VMS_VER >= 60200000
2209 static int initted = 0;
2212 sig_code[16] = C$_SIGUSR1;
2213 sig_code[17] = C$_SIGUSR2;
2214 #if __CRTL_VER >= 70000000
2215 sig_code[20] = C$_SIGCHLD;
2217 #if __CRTL_VER >= 70300000
2218 sig_code[28] = C$_SIGWINCH;
2223 if (sig < _SIG_MIN) return 0;
2224 if (sig > _MY_SIG_MAX) return 0;
2225 return sig_code[sig];
2229 Perl_sig_to_vmscondition(int sig)
2232 if (vms_debug_on_exception != 0)
2233 lib$signal(SS$_DEBUG);
2235 return Perl_sig_to_vmscondition_int(sig);
2240 Perl_my_kill(int pid, int sig)
2245 int sys$sigprc(unsigned int *pidadr,
2246 struct dsc$descriptor_s *prcname,
2249 /* sig 0 means validate the PID */
2250 /*------------------------------*/
2252 const unsigned long int jpicode = JPI$_PID;
2255 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2256 if ($VMS_STATUS_SUCCESS(status))
2259 case SS$_NOSUCHNODE:
2260 case SS$_UNREACHABLE:
2274 code = Perl_sig_to_vmscondition_int(sig);
2277 SETERRNO(EINVAL, SS$_BADPARAM);
2281 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2282 * signals are to be sent to multiple processes.
2283 * pid = 0 - all processes in group except ones that the system exempts
2284 * pid = -1 - all processes except ones that the system exempts
2285 * pid = -n - all processes in group (abs(n)) except ...
2286 * For now, just report as not supported.
2290 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2294 iss = sys$sigprc((unsigned int *)&pid,0,code);
2295 if (iss&1) return 0;
2299 set_errno(EPERM); break;
2301 case SS$_NOSUCHNODE:
2302 case SS$_UNREACHABLE:
2303 set_errno(ESRCH); break;
2305 set_errno(ENOMEM); break;
2310 set_vaxc_errno(iss);
2316 /* Routine to convert a VMS status code to a UNIX status code.
2317 ** More tricky than it appears because of conflicting conventions with
2320 ** VMS status codes are a bit mask, with the least significant bit set for
2323 ** Special UNIX status of EVMSERR indicates that no translation is currently
2324 ** available, and programs should check the VMS status code.
2326 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2330 #ifndef C_FACILITY_NO
2331 #define C_FACILITY_NO 0x350000
2334 #define DCL_IVVERB 0x38090
2337 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2345 /* Assume the best or the worst */
2346 if (vms_status & STS$M_SUCCESS)
2349 unix_status = EVMSERR;
2351 msg_status = vms_status & ~STS$M_CONTROL;
2353 facility = vms_status & STS$M_FAC_NO;
2354 fac_sp = vms_status & STS$M_FAC_SP;
2355 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2357 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2363 unix_status = EFAULT;
2365 case SS$_DEVOFFLINE:
2366 unix_status = EBUSY;
2369 unix_status = ENOTCONN;
2377 case SS$_INVFILFOROP:
2381 unix_status = EINVAL;
2383 case SS$_UNSUPPORTED:
2384 unix_status = ENOTSUP;
2389 unix_status = EACCES;
2391 case SS$_DEVICEFULL:
2392 unix_status = ENOSPC;
2395 unix_status = ENODEV;
2397 case SS$_NOSUCHFILE:
2398 case SS$_NOSUCHOBJECT:
2399 unix_status = ENOENT;
2401 case SS$_ABORT: /* Fatal case */
2402 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2403 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2404 unix_status = EINTR;
2407 unix_status = E2BIG;
2410 unix_status = ENOMEM;
2413 unix_status = EPERM;
2415 case SS$_NOSUCHNODE:
2416 case SS$_UNREACHABLE:
2417 unix_status = ESRCH;
2420 unix_status = ECHILD;
2423 if ((facility == 0) && (msg_no < 8)) {
2424 /* These are not real VMS status codes so assume that they are
2425 ** already UNIX status codes
2427 unix_status = msg_no;
2433 /* Translate a POSIX exit code to a UNIX exit code */
2434 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2435 unix_status = (msg_no & 0x07F8) >> 3;
2439 /* Documented traditional behavior for handling VMS child exits */
2440 /*--------------------------------------------------------------*/
2441 if (child_flag != 0) {
2443 /* Success / Informational return 0 */
2444 /*----------------------------------*/
2445 if (msg_no & STS$K_SUCCESS)
2448 /* Warning returns 1 */
2449 /*-------------------*/
2450 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2453 /* Everything else pass through the severity bits */
2454 /*------------------------------------------------*/
2455 return (msg_no & STS$M_SEVERITY);
2458 /* Normal VMS status to ERRNO mapping attempt */
2459 /*--------------------------------------------*/
2460 switch(msg_status) {
2461 /* case RMS$_EOF: */ /* End of File */
2462 case RMS$_FNF: /* File Not Found */
2463 case RMS$_DNF: /* Dir Not Found */
2464 unix_status = ENOENT;
2466 case RMS$_RNF: /* Record Not Found */
2467 unix_status = ESRCH;
2470 unix_status = ENOTDIR;
2473 unix_status = ENODEV;
2478 unix_status = EBADF;
2481 unix_status = EEXIST;
2485 case LIB$_INVSTRDES:
2487 case LIB$_NOSUCHSYM:
2488 case LIB$_INVSYMNAM:
2490 unix_status = EINVAL;
2496 unix_status = E2BIG;
2498 case RMS$_PRV: /* No privilege */
2499 case RMS$_ACC: /* ACP file access failed */
2500 case RMS$_WLK: /* Device write locked */
2501 unix_status = EACCES;
2503 /* case RMS$_NMF: */ /* No more files */
2511 /* Try to guess at what VMS error status should go with a UNIX errno
2512 * value. This is hard to do as there could be many possible VMS
2513 * error statuses that caused the errno value to be set.
2516 int Perl_unix_status_to_vms(int unix_status)
2518 int test_unix_status;
2520 /* Trivial cases first */
2521 /*---------------------*/
2522 if (unix_status == EVMSERR)
2525 /* Is vaxc$errno sane? */
2526 /*---------------------*/
2527 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2528 if (test_unix_status == unix_status)
2531 /* If way out of range, must be VMS code already */
2532 /*-----------------------------------------------*/
2533 if (unix_status > EVMSERR)
2536 /* If out of range, punt */
2537 /*-----------------------*/
2538 if (unix_status > __ERRNO_MAX)
2542 /* Ok, now we have to do it the hard way. */
2543 /*----------------------------------------*/
2544 switch(unix_status) {
2545 case 0: return SS$_NORMAL;
2546 case EPERM: return SS$_NOPRIV;
2547 case ENOENT: return SS$_NOSUCHOBJECT;
2548 case ESRCH: return SS$_UNREACHABLE;
2549 case EINTR: return SS$_ABORT;
2552 case E2BIG: return SS$_BUFFEROVF;
2554 case EBADF: return RMS$_IFI;
2555 case ECHILD: return SS$_NONEXPR;
2557 case ENOMEM: return SS$_INSFMEM;
2558 case EACCES: return SS$_FILACCERR;
2559 case EFAULT: return SS$_ACCVIO;
2561 case EBUSY: return SS$_DEVOFFLINE;
2562 case EEXIST: return RMS$_FEX;
2564 case ENODEV: return SS$_NOSUCHDEV;
2565 case ENOTDIR: return RMS$_DIR;
2567 case EINVAL: return SS$_INVARG;
2573 case ENOSPC: return SS$_DEVICEFULL;
2574 case ESPIPE: return LIB$_INVARG;
2579 case ERANGE: return LIB$_INVARG;
2580 /* case EWOULDBLOCK */
2581 /* case EINPROGRESS */
2584 /* case EDESTADDRREQ */
2586 /* case EPROTOTYPE */
2587 /* case ENOPROTOOPT */
2588 /* case EPROTONOSUPPORT */
2589 /* case ESOCKTNOSUPPORT */
2590 /* case EOPNOTSUPP */
2591 /* case EPFNOSUPPORT */
2592 /* case EAFNOSUPPORT */
2593 /* case EADDRINUSE */
2594 /* case EADDRNOTAVAIL */
2596 /* case ENETUNREACH */
2597 /* case ENETRESET */
2598 /* case ECONNABORTED */
2599 /* case ECONNRESET */
2602 case ENOTCONN: return SS$_CLEARED;
2603 /* case ESHUTDOWN */
2604 /* case ETOOMANYREFS */
2605 /* case ETIMEDOUT */
2606 /* case ECONNREFUSED */
2608 /* case ENAMETOOLONG */
2609 /* case EHOSTDOWN */
2610 /* case EHOSTUNREACH */
2611 /* case ENOTEMPTY */
2623 /* case ECANCELED */
2627 return SS$_UNSUPPORTED;
2633 /* case EABANDONED */
2635 return SS$_ABORT; /* punt */
2638 return SS$_ABORT; /* Should not get here */
2642 /* default piping mailbox size */
2643 #define PERL_BUFSIZ 512
2647 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2649 unsigned long int mbxbufsiz;
2650 static unsigned long int syssize = 0;
2651 unsigned long int dviitm = DVI$_DEVNAM;
2652 char csize[LNM$C_NAMLENGTH+1];
2656 unsigned long syiitm = SYI$_MAXBUF;
2658 * Get the SYSGEN parameter MAXBUF
2660 * If the logical 'PERL_MBX_SIZE' is defined
2661 * use the value of the logical instead of PERL_BUFSIZ, but
2662 * keep the size between 128 and MAXBUF.
2665 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2668 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2669 mbxbufsiz = atoi(csize);
2671 mbxbufsiz = PERL_BUFSIZ;
2673 if (mbxbufsiz < 128) mbxbufsiz = 128;
2674 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2676 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2678 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2679 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2681 } /* end of create_mbx() */
2684 /*{{{ my_popen and my_pclose*/
2686 typedef struct _iosb IOSB;
2687 typedef struct _iosb* pIOSB;
2688 typedef struct _pipe Pipe;
2689 typedef struct _pipe* pPipe;
2690 typedef struct pipe_details Info;
2691 typedef struct pipe_details* pInfo;
2692 typedef struct _srqp RQE;
2693 typedef struct _srqp* pRQE;
2694 typedef struct _tochildbuf CBuf;
2695 typedef struct _tochildbuf* pCBuf;
2698 unsigned short status;
2699 unsigned short count;
2700 unsigned long dvispec;
2703 #pragma member_alignment save
2704 #pragma nomember_alignment quadword
2705 struct _srqp { /* VMS self-relative queue entry */
2706 unsigned long qptr[2];
2708 #pragma member_alignment restore
2709 static RQE RQE_ZERO = {0,0};
2711 struct _tochildbuf {
2714 unsigned short size;
2722 unsigned short chan_in;
2723 unsigned short chan_out;
2725 unsigned int bufsize;
2737 #if defined(PERL_IMPLICIT_CONTEXT)
2738 void *thx; /* Either a thread or an interpreter */
2739 /* pointer, depending on how we're built */
2747 PerlIO *fp; /* file pointer to pipe mailbox */
2748 int useFILE; /* using stdio, not perlio */
2749 int pid; /* PID of subprocess */
2750 int mode; /* == 'r' if pipe open for reading */
2751 int done; /* subprocess has completed */
2752 int waiting; /* waiting for completion/closure */
2753 int closing; /* my_pclose is closing this pipe */
2754 unsigned long completion; /* termination status of subprocess */
2755 pPipe in; /* pipe in to sub */
2756 pPipe out; /* pipe out of sub */
2757 pPipe err; /* pipe of sub's sys$error */
2758 int in_done; /* true when in pipe finished */
2763 struct exit_control_block
2765 struct exit_control_block *flink;
2766 unsigned long int (*exit_routine)();
2767 unsigned long int arg_count;
2768 unsigned long int *status_address;
2769 unsigned long int exit_status;
2772 typedef struct _closed_pipes Xpipe;
2773 typedef struct _closed_pipes* pXpipe;
2775 struct _closed_pipes {
2776 int pid; /* PID of subprocess */
2777 unsigned long completion; /* termination status of subprocess */
2779 #define NKEEPCLOSED 50
2780 static Xpipe closed_list[NKEEPCLOSED];
2781 static int closed_index = 0;
2782 static int closed_num = 0;
2784 #define RETRY_DELAY "0 ::0.20"
2785 #define MAX_RETRY 50
2787 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2788 static unsigned long mypid;
2789 static unsigned long delaytime[2];
2791 static pInfo open_pipes = NULL;
2792 static $DESCRIPTOR(nl_desc, "NL:");
2794 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2798 static unsigned long int
2799 pipe_exit_routine(pTHX)
2802 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2803 int sts, did_stuff, need_eof, j;
2806 flush any pending i/o
2812 PerlIO_flush(info->fp); /* first, flush data */
2814 fflush((FILE *)info->fp);
2820 next we try sending an EOF...ignore if doesn't work, make sure we
2828 _ckvmssts_noperl(sys$setast(0));
2829 if (info->in && !info->in->shut_on_empty) {
2830 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2835 _ckvmssts_noperl(sys$setast(1));
2839 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2841 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2846 _ckvmssts_noperl(sys$setast(0));
2847 if (info->waiting && info->done)
2849 nwait += info->waiting;
2850 _ckvmssts_noperl(sys$setast(1));
2860 _ckvmssts_noperl(sys$setast(0));
2861 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2862 sts = sys$forcex(&info->pid,0,&abort);
2863 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2866 _ckvmssts_noperl(sys$setast(1));
2870 /* again, wait for effect */
2872 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2877 _ckvmssts_noperl(sys$setast(0));
2878 if (info->waiting && info->done)
2880 nwait += info->waiting;
2881 _ckvmssts_noperl(sys$setast(1));
2890 _ckvmssts_noperl(sys$setast(0));
2891 if (!info->done) { /* We tried to be nice . . . */
2892 sts = sys$delprc(&info->pid,0);
2893 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2895 _ckvmssts_noperl(sys$setast(1));
2900 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2901 else if (!(sts & 1)) retsts = sts;
2906 static struct exit_control_block pipe_exitblock =
2907 {(struct exit_control_block *) 0,
2908 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2910 static void pipe_mbxtofd_ast(pPipe p);
2911 static void pipe_tochild1_ast(pPipe p);
2912 static void pipe_tochild2_ast(pPipe p);
2915 popen_completion_ast(pInfo info)
2917 pInfo i = open_pipes;
2922 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2923 closed_list[closed_index].pid = info->pid;
2924 closed_list[closed_index].completion = info->completion;
2926 if (closed_index == NKEEPCLOSED)
2931 if (i == info) break;
2934 if (!i) return; /* unlinked, probably freed too */
2939 Writing to subprocess ...
2940 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2942 chan_out may be waiting for "done" flag, or hung waiting
2943 for i/o completion to child...cancel the i/o. This will
2944 put it into "snarf mode" (done but no EOF yet) that discards
2947 Output from subprocess (stdout, stderr) needs to be flushed and
2948 shut down. We try sending an EOF, but if the mbx is full the pipe
2949 routine should still catch the "shut_on_empty" flag, telling it to
2950 use immediate-style reads so that "mbx empty" -> EOF.
2954 if (info->in && !info->in_done) { /* only for mode=w */
2955 if (info->in->shut_on_empty && info->in->need_wake) {
2956 info->in->need_wake = FALSE;
2957 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2959 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2963 if (info->out && !info->out_done) { /* were we also piping output? */
2964 info->out->shut_on_empty = TRUE;
2965 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2966 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2967 _ckvmssts_noperl(iss);
2970 if (info->err && !info->err_done) { /* we were piping stderr */
2971 info->err->shut_on_empty = TRUE;
2972 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2973 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2974 _ckvmssts_noperl(iss);
2976 _ckvmssts_noperl(sys$setef(pipe_ef));
2980 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2981 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2984 we actually differ from vmstrnenv since we use this to
2985 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2986 are pointing to the same thing
2989 static unsigned short
2990 popen_translate(pTHX_ char *logical, char *result)
2993 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2994 $DESCRIPTOR(d_log,"");
2996 unsigned short length;
2997 unsigned short code;
2999 unsigned short *retlenaddr;
3001 unsigned short l, ifi;
3003 d_log.dsc$a_pointer = logical;
3004 d_log.dsc$w_length = strlen(logical);
3006 itmlst[0].code = LNM$_STRING;
3007 itmlst[0].length = 255;
3008 itmlst[0].buffer_addr = result;
3009 itmlst[0].retlenaddr = &l;
3012 itmlst[1].length = 0;
3013 itmlst[1].buffer_addr = 0;
3014 itmlst[1].retlenaddr = 0;
3016 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3017 if (iss == SS$_NOLOGNAM) {
3021 if (!(iss&1)) lib$signal(iss);
3024 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3025 strip it off and return the ifi, if any
3028 if (result[0] == 0x1b && result[1] == 0x00) {
3029 memmove(&ifi,result+2,2);
3030 strcpy(result,result+4);
3032 return ifi; /* this is the RMS internal file id */
3035 static void pipe_infromchild_ast(pPipe p);
3038 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3039 inside an AST routine without worrying about reentrancy and which Perl
3040 memory allocator is being used.
3042 We read data and queue up the buffers, then spit them out one at a
3043 time to the output mailbox when the output mailbox is ready for one.
3046 #define INITIAL_TOCHILDQUEUE 2
3049 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3053 char mbx1[64], mbx2[64];
3054 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3055 DSC$K_CLASS_S, mbx1},
3056 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3057 DSC$K_CLASS_S, mbx2};
3058 unsigned int dviitm = DVI$_DEVBUFSIZ;
3062 _ckvmssts(lib$get_vm(&n, &p));
3064 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3065 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3066 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3069 p->shut_on_empty = FALSE;
3070 p->need_wake = FALSE;
3073 p->iosb.status = SS$_NORMAL;
3074 p->iosb2.status = SS$_NORMAL;
3080 #ifdef PERL_IMPLICIT_CONTEXT
3084 n = sizeof(CBuf) + p->bufsize;
3086 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3087 _ckvmssts(lib$get_vm(&n, &b));
3088 b->buf = (char *) b + sizeof(CBuf);
3089 _ckvmssts(lib$insqhi(b, &p->free));
3092 pipe_tochild2_ast(p);
3093 pipe_tochild1_ast(p);
3099 /* reads the MBX Perl is writing, and queues */
3102 pipe_tochild1_ast(pPipe p)
3105 int iss = p->iosb.status;
3106 int eof = (iss == SS$_ENDOFFILE);
3108 #ifdef PERL_IMPLICIT_CONTEXT
3114 p->shut_on_empty = TRUE;
3116 _ckvmssts(sys$dassgn(p->chan_in));
3122 b->size = p->iosb.count;
3123 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3125 p->need_wake = FALSE;
3126 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3129 p->retry = 1; /* initial call */
3132 if (eof) { /* flush the free queue, return when done */
3133 int n = sizeof(CBuf) + p->bufsize;
3135 iss = lib$remqti(&p->free, &b);
3136 if (iss == LIB$_QUEWASEMP) return;
3138 _ckvmssts(lib$free_vm(&n, &b));
3142 iss = lib$remqti(&p->free, &b);
3143 if (iss == LIB$_QUEWASEMP) {
3144 int n = sizeof(CBuf) + p->bufsize;
3145 _ckvmssts(lib$get_vm(&n, &b));
3146 b->buf = (char *) b + sizeof(CBuf);
3152 iss = sys$qio(0,p->chan_in,
3153 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3155 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3156 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3161 /* writes queued buffers to output, waits for each to complete before
3165 pipe_tochild2_ast(pPipe p)
3168 int iss = p->iosb2.status;
3169 int n = sizeof(CBuf) + p->bufsize;
3170 int done = (p->info && p->info->done) ||
3171 iss == SS$_CANCEL || iss == SS$_ABORT;
3172 #if defined(PERL_IMPLICIT_CONTEXT)
3177 if (p->type) { /* type=1 has old buffer, dispose */
3178 if (p->shut_on_empty) {
3179 _ckvmssts(lib$free_vm(&n, &b));
3181 _ckvmssts(lib$insqhi(b, &p->free));
3186 iss = lib$remqti(&p->wait, &b);
3187 if (iss == LIB$_QUEWASEMP) {
3188 if (p->shut_on_empty) {
3190 _ckvmssts(sys$dassgn(p->chan_out));
3191 *p->pipe_done = TRUE;
3192 _ckvmssts(sys$setef(pipe_ef));
3194 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3195 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3199 p->need_wake = TRUE;
3209 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3210 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3212 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3213 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3222 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3225 char mbx1[64], mbx2[64];
3226 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3227 DSC$K_CLASS_S, mbx1},
3228 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3229 DSC$K_CLASS_S, mbx2};
3230 unsigned int dviitm = DVI$_DEVBUFSIZ;
3232 int n = sizeof(Pipe);
3233 _ckvmssts(lib$get_vm(&n, &p));
3234 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3235 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3237 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3238 n = p->bufsize * sizeof(char);
3239 _ckvmssts(lib$get_vm(&n, &p->buf));
3240 p->shut_on_empty = FALSE;
3243 p->iosb.status = SS$_NORMAL;
3244 #if defined(PERL_IMPLICIT_CONTEXT)
3247 pipe_infromchild_ast(p);
3255 pipe_infromchild_ast(pPipe p)
3257 int iss = p->iosb.status;
3258 int eof = (iss == SS$_ENDOFFILE);
3259 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3260 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3261 #if defined(PERL_IMPLICIT_CONTEXT)
3265 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3266 _ckvmssts(sys$dassgn(p->chan_out));
3271 input shutdown if EOF from self (done or shut_on_empty)
3272 output shutdown if closing flag set (my_pclose)
3273 send data/eof from child or eof from self
3274 otherwise, re-read (snarf of data from child)
3279 if (myeof && p->chan_in) { /* input shutdown */
3280 _ckvmssts(sys$dassgn(p->chan_in));
3285 if (myeof || kideof) { /* pass EOF to parent */
3286 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3287 pipe_infromchild_ast, p,
3290 } else if (eof) { /* eat EOF --- fall through to read*/
3292 } else { /* transmit data */
3293 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3294 pipe_infromchild_ast,p,
3295 p->buf, p->iosb.count, 0, 0, 0, 0));
3301 /* everything shut? flag as done */
3303 if (!p->chan_in && !p->chan_out) {
3304 *p->pipe_done = TRUE;
3305 _ckvmssts(sys$setef(pipe_ef));
3309 /* write completed (or read, if snarfing from child)
3310 if still have input active,
3311 queue read...immediate mode if shut_on_empty so we get EOF if empty
3313 check if Perl reading, generate EOFs as needed
3319 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3320 pipe_infromchild_ast,p,
3321 p->buf, p->bufsize, 0, 0, 0, 0);
3322 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3324 } else { /* send EOFs for extra reads */
3325 p->iosb.status = SS$_ENDOFFILE;
3326 p->iosb.dvispec = 0;
3327 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3329 pipe_infromchild_ast, p, 0, 0, 0, 0));
3335 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3339 unsigned long dviitm = DVI$_DEVBUFSIZ;
3341 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3342 DSC$K_CLASS_S, mbx};
3343 int n = sizeof(Pipe);
3345 /* things like terminals and mbx's don't need this filter */
3346 if (fd && fstat(fd,&s) == 0) {
3347 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3349 unsigned short dev_len;
3350 struct dsc$descriptor_s d_dev;
3352 struct item_list_3 items[3];
3354 unsigned short dvi_iosb[4];
3356 cptr = getname(fd, out, 1);
3357 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3358 d_dev.dsc$a_pointer = out;
3359 d_dev.dsc$w_length = strlen(out);
3360 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3361 d_dev.dsc$b_class = DSC$K_CLASS_S;
3364 items[0].code = DVI$_DEVCHAR;
3365 items[0].bufadr = &devchar;
3366 items[0].retadr = NULL;
3368 items[1].code = DVI$_FULLDEVNAM;
3369 items[1].bufadr = device;
3370 items[1].retadr = &dev_len;
3374 status = sys$getdviw
3375 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3377 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3378 device[dev_len] = 0;
3380 if (!(devchar & DEV$M_DIR)) {
3381 strcpy(out, device);
3387 _ckvmssts(lib$get_vm(&n, &p));
3388 p->fd_out = dup(fd);
3389 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3390 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3391 n = (p->bufsize+1) * sizeof(char);
3392 _ckvmssts(lib$get_vm(&n, &p->buf));
3393 p->shut_on_empty = FALSE;
3398 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3399 pipe_mbxtofd_ast, p,
3400 p->buf, p->bufsize, 0, 0, 0, 0));
3406 pipe_mbxtofd_ast(pPipe p)
3408 int iss = p->iosb.status;
3409 int done = p->info->done;
3411 int eof = (iss == SS$_ENDOFFILE);
3412 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3413 int err = !(iss&1) && !eof;
3414 #if defined(PERL_IMPLICIT_CONTEXT)
3418 if (done && myeof) { /* end piping */
3420 sys$dassgn(p->chan_in);
3421 *p->pipe_done = TRUE;
3422 _ckvmssts(sys$setef(pipe_ef));
3426 if (!err && !eof) { /* good data to send to file */
3427 p->buf[p->iosb.count] = '\n';
3428 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3431 if (p->retry < MAX_RETRY) {
3432 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3442 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3443 pipe_mbxtofd_ast, p,
3444 p->buf, p->bufsize, 0, 0, 0, 0);
3445 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3450 typedef struct _pipeloc PLOC;
3451 typedef struct _pipeloc* pPLOC;
3455 char dir[NAM$C_MAXRSS+1];
3457 static pPLOC head_PLOC = 0;
3460 free_pipelocs(pTHX_ void *head)
3463 pPLOC *pHead = (pPLOC *)head;
3475 store_pipelocs(pTHX)
3484 char temp[NAM$C_MAXRSS+1];
3488 free_pipelocs(aTHX_ &head_PLOC);
3490 /* the . directory from @INC comes last */
3492 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3493 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3494 p->next = head_PLOC;
3496 strcpy(p->dir,"./");
3498 /* get the directory from $^X */
3500 unixdir = PerlMem_malloc(VMS_MAXRSS);
3501 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3503 #ifdef PERL_IMPLICIT_CONTEXT
3504 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3506 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3508 strcpy(temp, PL_origargv[0]);
3509 x = strrchr(temp,']');
3511 x = strrchr(temp,'>');
3513 /* It could be a UNIX path */
3514 x = strrchr(temp,'/');
3520 /* Got a bare name, so use default directory */
3525 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3526 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3527 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3528 p->next = head_PLOC;
3530 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3531 p->dir[NAM$C_MAXRSS] = '\0';
3535 /* reverse order of @INC entries, skip "." since entered above */
3537 #ifdef PERL_IMPLICIT_CONTEXT
3540 if (PL_incgv) av = GvAVn(PL_incgv);
3542 for (i = 0; av && i <= AvFILL(av); i++) {
3543 dirsv = *av_fetch(av,i,TRUE);
3545 if (SvROK(dirsv)) continue;
3546 dir = SvPVx(dirsv,n_a);
3547 if (strcmp(dir,".") == 0) continue;
3548 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3551 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3552 p->next = head_PLOC;
3554 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3555 p->dir[NAM$C_MAXRSS] = '\0';
3558 /* most likely spot (ARCHLIB) put first in the list */
3561 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3562 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3563 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3564 p->next = head_PLOC;
3566 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3567 p->dir[NAM$C_MAXRSS] = '\0';
3570 PerlMem_free(unixdir);
3574 Perl_cando_by_name_int
3575 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3576 #if !defined(PERL_IMPLICIT_CONTEXT)
3577 #define cando_by_name_int Perl_cando_by_name_int
3579 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3585 static int vmspipe_file_status = 0;
3586 static char vmspipe_file[NAM$C_MAXRSS+1];
3588 /* already found? Check and use ... need read+execute permission */
3590 if (vmspipe_file_status == 1) {
3591 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3592 && cando_by_name_int
3593 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3594 return vmspipe_file;
3596 vmspipe_file_status = 0;
3599 /* scan through stored @INC, $^X */
3601 if (vmspipe_file_status == 0) {
3602 char file[NAM$C_MAXRSS+1];
3603 pPLOC p = head_PLOC;
3608 strcpy(file, p->dir);
3609 dirlen = strlen(file);
3610 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3611 file[NAM$C_MAXRSS] = '\0';
3614 exp_res = do_rmsexpand
3615 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3616 if (!exp_res) continue;
3618 if (cando_by_name_int
3619 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3620 && cando_by_name_int
3621 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3622 vmspipe_file_status = 1;
3623 return vmspipe_file;
3626 vmspipe_file_status = -1; /* failed, use tempfiles */
3633 vmspipe_tempfile(pTHX)
3635 char file[NAM$C_MAXRSS+1];
3637 static int index = 0;
3641 /* create a tempfile */
3643 /* we can't go from W, shr=get to R, shr=get without
3644 an intermediate vulnerable state, so don't bother trying...
3646 and lib$spawn doesn't shr=put, so have to close the write
3648 So... match up the creation date/time and the FID to
3649 make sure we're dealing with the same file
3654 if (!decc_filename_unix_only) {
3655 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3656 fp = fopen(file,"w");
3658 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3659 fp = fopen(file,"w");
3661 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3662 fp = fopen(file,"w");
3667 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3668 fp = fopen(file,"w");
3670 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3671 fp = fopen(file,"w");
3673 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3674 fp = fopen(file,"w");
3678 if (!fp) return 0; /* we're hosed */
3680 fprintf(fp,"$! 'f$verify(0)'\n");
3681 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3682 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3683 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3684 fprintf(fp,"$ perl_on = \"set noon\"\n");
3685 fprintf(fp,"$ perl_exit = \"exit\"\n");
3686 fprintf(fp,"$ perl_del = \"delete\"\n");
3687 fprintf(fp,"$ pif = \"if\"\n");
3688 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3689 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3690 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3691 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3692 fprintf(fp,"$! --- build command line to get max possible length\n");
3693 fprintf(fp,"$c=perl_popen_cmd0\n");
3694 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3695 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3696 fprintf(fp,"$x=perl_popen_cmd3\n");
3697 fprintf(fp,"$c=c+x\n");
3698 fprintf(fp,"$ perl_on\n");
3699 fprintf(fp,"$ 'c'\n");
3700 fprintf(fp,"$ perl_status = $STATUS\n");
3701 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3702 fprintf(fp,"$ perl_exit 'perl_status'\n");
3705 fgetname(fp, file, 1);
3706 fstat(fileno(fp), (struct stat *)&s0);
3709 if (decc_filename_unix_only)
3710 do_tounixspec(file, file, 0, NULL);
3711 fp = fopen(file,"r","shr=get");
3713 fstat(fileno(fp), (struct stat *)&s1);
3715 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3716 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3727 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3729 static int handler_set_up = FALSE;
3730 unsigned long int sts, flags = CLI$M_NOWAIT;
3731 /* The use of a GLOBAL table (as was done previously) rendered
3732 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3733 * environment. Hence we've switched to LOCAL symbol table.
3735 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3737 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3738 char *in, *out, *err, mbx[512];
3740 char tfilebuf[NAM$C_MAXRSS+1];
3742 char cmd_sym_name[20];
3743 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3744 DSC$K_CLASS_S, symbol};
3745 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3747 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3748 DSC$K_CLASS_S, cmd_sym_name};
3749 struct dsc$descriptor_s *vmscmd;
3750 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3751 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3752 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3754 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3756 /* once-per-program initialization...
3757 note that the SETAST calls and the dual test of pipe_ef
3758 makes sure that only the FIRST thread through here does
3759 the initialization...all other threads wait until it's
3762 Yeah, uglier than a pthread call, it's got all the stuff inline
3763 rather than in a separate routine.
3767 _ckvmssts(sys$setast(0));
3769 unsigned long int pidcode = JPI$_PID;
3770 $DESCRIPTOR(d_delay, RETRY_DELAY);
3771 _ckvmssts(lib$get_ef(&pipe_ef));
3772 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3773 _ckvmssts(sys$bintim(&d_delay, delaytime));
3775 if (!handler_set_up) {
3776 _ckvmssts(sys$dclexh(&pipe_exitblock));
3777 handler_set_up = TRUE;
3779 _ckvmssts(sys$setast(1));
3782 /* see if we can find a VMSPIPE.COM */
3785 vmspipe = find_vmspipe(aTHX);
3787 strcpy(tfilebuf+1,vmspipe);
3788 } else { /* uh, oh...we're in tempfile hell */
3789 tpipe = vmspipe_tempfile(aTHX);
3790 if (!tpipe) { /* a fish popular in Boston */
3791 if (ckWARN(WARN_PIPE)) {
3792 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3796 fgetname(tpipe,tfilebuf+1,1);
3798 vmspipedsc.dsc$a_pointer = tfilebuf;
3799 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3801 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3804 case RMS$_FNF: case RMS$_DNF:
3805 set_errno(ENOENT); break;
3807 set_errno(ENOTDIR); break;
3809 set_errno(ENODEV); break;
3811 set_errno(EACCES); break;
3813 set_errno(EINVAL); break;
3814 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3815 set_errno(E2BIG); break;
3816 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3817 _ckvmssts(sts); /* fall through */
3818 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3821 set_vaxc_errno(sts);
3822 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3823 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3829 _ckvmssts(lib$get_vm(&n, &info));
3831 strcpy(mode,in_mode);
3834 info->completion = 0;
3835 info->closing = FALSE;
3842 info->in_done = TRUE;
3843 info->out_done = TRUE;
3844 info->err_done = TRUE;
3846 in = PerlMem_malloc(VMS_MAXRSS);
3847 if (in == NULL) _ckvmssts(SS$_INSFMEM);
3848 out = PerlMem_malloc(VMS_MAXRSS);
3849 if (out == NULL) _ckvmssts(SS$_INSFMEM);
3850 err = PerlMem_malloc(VMS_MAXRSS);
3851 if (err == NULL) _ckvmssts(SS$_INSFMEM);
3853 in[0] = out[0] = err[0] = '\0';
3855 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3859 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3864 if (*mode == 'r') { /* piping from subroutine */
3866 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3868 info->out->pipe_done = &info->out_done;
3869 info->out_done = FALSE;
3870 info->out->info = info;
3872 if (!info->useFILE) {
3873 info->fp = PerlIO_open(mbx, mode);
3875 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3876 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3879 if (!info->fp && info->out) {
3880 sys$cancel(info->out->chan_out);
3882 while (!info->out_done) {
3884 _ckvmssts(sys$setast(0));
3885 done = info->out_done;
3886 if (!done) _ckvmssts(sys$clref(pipe_ef));
3887 _ckvmssts(sys$setast(1));
3888 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3891 if (info->out->buf) {
3892 n = info->out->bufsize * sizeof(char);
3893 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3896 _ckvmssts(lib$free_vm(&n, &info->out));
3898 _ckvmssts(lib$free_vm(&n, &info));
3903 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3905 info->err->pipe_done = &info->err_done;
3906 info->err_done = FALSE;
3907 info->err->info = info;
3910 } else if (*mode == 'w') { /* piping to subroutine */
3912 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3914 info->out->pipe_done = &info->out_done;
3915 info->out_done = FALSE;
3916 info->out->info = info;
3919 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3921 info->err->pipe_done = &info->err_done;
3922 info->err_done = FALSE;
3923 info->err->info = info;
3926 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3927 if (!info->useFILE) {
3928 info->fp = PerlIO_open(mbx, mode);
3930 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3931 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3935 info->in->pipe_done = &info->in_done;
3936 info->in_done = FALSE;
3937 info->in->info = info;
3941 if (!info->fp && info->in) {
3943 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3944 0, 0, 0, 0, 0, 0, 0, 0));
3946 while (!info->in_done) {
3948 _ckvmssts(sys$setast(0));
3949 done = info->in_done;
3950 if (!done) _ckvmssts(sys$clref(pipe_ef));
3951 _ckvmssts(sys$setast(1));
3952 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3955 if (info->in->buf) {
3956 n = info->in->bufsize * sizeof(char);
3957 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3960 _ckvmssts(lib$free_vm(&n, &info->in));
3962 _ckvmssts(lib$free_vm(&n, &info));
3968 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3969 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3971 info->out->pipe_done = &info->out_done;
3972 info->out_done = FALSE;
3973 info->out->info = info;
3976 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3978 info->err->pipe_done = &info->err_done;
3979 info->err_done = FALSE;
3980 info->err->info = info;
3984 symbol[MAX_DCL_SYMBOL] = '\0';
3986 strncpy(symbol, in, MAX_DCL_SYMBOL);
3987 d_symbol.dsc$w_length = strlen(symbol);
3988 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3990 strncpy(symbol, err, MAX_DCL_SYMBOL);
3991 d_symbol.dsc$w_length = strlen(symbol);
3992 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3994 strncpy(symbol, out, MAX_DCL_SYMBOL);
3995 d_symbol.dsc$w_length = strlen(symbol);
3996 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3998 /* Done with the names for the pipes */
4003 p = vmscmd->dsc$a_pointer;
4004 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4005 if (*p == '$') p++; /* remove leading $ */
4006 while (*p == ' ' || *p == '\t') p++;
4008 for (j = 0; j < 4; j++) {
4009 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4010 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4012 strncpy(symbol, p, MAX_DCL_SYMBOL);
4013 d_symbol.dsc$w_length = strlen(symbol);
4014 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4016 if (strlen(p) > MAX_DCL_SYMBOL) {
4017 p += MAX_DCL_SYMBOL;
4022 _ckvmssts(sys$setast(0));
4023 info->next=open_pipes; /* prepend to list */
4025 _ckvmssts(sys$setast(1));
4026 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4027 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4028 * have SYS$COMMAND if we need it.
4030 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4031 0, &info->pid, &info->completion,
4032 0, popen_completion_ast,info,0,0,0));
4034 /* if we were using a tempfile, close it now */
4036 if (tpipe) fclose(tpipe);
4038 /* once the subprocess is spawned, it has copied the symbols and
4039 we can get rid of ours */
4041 for (j = 0; j < 4; j++) {
4042 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4043 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4044 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4046 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4047 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4048 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4049 vms_execfree(vmscmd);
4051 #ifdef PERL_IMPLICIT_CONTEXT
4054 PL_forkprocess = info->pid;
4059 _ckvmssts(sys$setast(0));
4061 if (!done) _ckvmssts(sys$clref(pipe_ef));
4062 _ckvmssts(sys$setast(1));
4063 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4065 *psts = info->completion;
4066 /* Caller thinks it is open and tries to close it. */
4067 /* This causes some problems, as it changes the error status */
4068 /* my_pclose(info->fp); */
4073 } /* end of safe_popen */
4076 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4078 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4082 TAINT_PROPER("popen");
4083 PERL_FLUSHALL_FOR_CHILD;
4084 return safe_popen(aTHX_ cmd,mode,&sts);
4089 /*{{{ I32 my_pclose(PerlIO *fp)*/
4090 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4092 pInfo info, last = NULL;
4093 unsigned long int retsts;
4096 for (info = open_pipes; info != NULL; last = info, info = info->next)
4097 if (info->fp == fp) break;
4099 if (info == NULL) { /* no such pipe open */
4100 set_errno(ECHILD); /* quoth POSIX */
4101 set_vaxc_errno(SS$_NONEXPR);
4105 /* If we were writing to a subprocess, insure that someone reading from
4106 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4107 * produce an EOF record in the mailbox.
4109 * well, at least sometimes it *does*, so we have to watch out for
4110 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4114 PerlIO_flush(info->fp); /* first, flush data */
4116 fflush((FILE *)info->fp);
4119 _ckvmssts(sys$setast(0));
4120 info->closing = TRUE;
4121 done = info->done && info->in_done && info->out_done && info->err_done;
4122 /* hanging on write to Perl's input? cancel it */
4123 if (info->mode == 'r' && info->out && !info->out_done) {
4124 if (info->out->chan_out) {
4125 _ckvmssts(sys$cancel(info->out->chan_out));
4126 if (!info->out->chan_in) { /* EOF generation, need AST */
4127 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4131 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4132 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4134 _ckvmssts(sys$setast(1));
4137 PerlIO_close(info->fp);
4139 fclose((FILE *)info->fp);
4142 we have to wait until subprocess completes, but ALSO wait until all
4143 the i/o completes...otherwise we'll be freeing the "info" structure
4144 that the i/o ASTs could still be using...
4148 _ckvmssts(sys$setast(0));
4149 done = info->done && info->in_done && info->out_done && info->err_done;
4150 if (!done) _ckvmssts(sys$clref(pipe_ef));
4151 _ckvmssts(sys$setast(1));
4152 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4154 retsts = info->completion;
4156 /* remove from list of open pipes */
4157 _ckvmssts(sys$setast(0));
4158 if (last) last->next = info->next;
4159 else open_pipes = info->next;
4160 _ckvmssts(sys$setast(1));
4162 /* free buffers and structures */
4165 if (info->in->buf) {
4166 n = info->in->bufsize * sizeof(char);
4167 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4170 _ckvmssts(lib$free_vm(&n, &info->in));
4173 if (info->out->buf) {
4174 n = info->out->bufsize * sizeof(char);
4175 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4178 _ckvmssts(lib$free_vm(&n, &info->out));
4181 if (info->err->buf) {
4182 n = info->err->bufsize * sizeof(char);
4183 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4186 _ckvmssts(lib$free_vm(&n, &info->err));
4189 _ckvmssts(lib$free_vm(&n, &info));
4193 } /* end of my_pclose() */
4195 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4196 /* Roll our own prototype because we want this regardless of whether
4197 * _VMS_WAIT is defined.
4199 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4201 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4202 created with popen(); otherwise partially emulate waitpid() unless
4203 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4204 Also check processes not considered by the CRTL waitpid().
4206 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4208 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4215 if (statusp) *statusp = 0;
4217 for (info = open_pipes; info != NULL; info = info->next)
4218 if (info->pid == pid) break;
4220 if (info != NULL) { /* we know about this child */
4221 while (!info->done) {
4222 _ckvmssts(sys$setast(0));
4224 if (!done) _ckvmssts(sys$clref(pipe_ef));
4225 _ckvmssts(sys$setast(1));
4226 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4229 if (statusp) *statusp = info->completion;
4233 /* child that already terminated? */
4235 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4236 if (closed_list[j].pid == pid) {
4237 if (statusp) *statusp = closed_list[j].completion;
4242 /* fall through if this child is not one of our own pipe children */
4244 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4246 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4247 * in 7.2 did we get a version that fills in the VMS completion
4248 * status as Perl has always tried to do.
4251 sts = __vms_waitpid( pid, statusp, flags );
4253 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4256 /* If the real waitpid tells us the child does not exist, we
4257 * fall through here to implement waiting for a child that
4258 * was created by some means other than exec() (say, spawned
4259 * from DCL) or to wait for a process that is not a subprocess
4260 * of the current process.
4263 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4266 $DESCRIPTOR(intdsc,"0 00:00:01");
4267 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4268 unsigned long int pidcode = JPI$_PID, mypid;
4269 unsigned long int interval[2];
4270 unsigned int jpi_iosb[2];
4271 struct itmlst_3 jpilist[2] = {
4272 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4277 /* Sorry folks, we don't presently implement rooting around for
4278 the first child we can find, and we definitely don't want to
4279 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4285 /* Get the owner of the child so I can warn if it's not mine. If the
4286 * process doesn't exist or I don't have the privs to look at it,
4287 * I can go home early.
4289 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4290 if (sts & 1) sts = jpi_iosb[0];
4302 set_vaxc_errno(sts);
4306 if (ckWARN(WARN_EXEC)) {
4307 /* remind folks they are asking for non-standard waitpid behavior */
4308 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4309 if (ownerpid != mypid)
4310 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4311 "waitpid: process %x is not a child of process %x",
4315 /* simply check on it once a second until it's not there anymore. */
4317 _ckvmssts(sys$bintim(&intdsc,interval));
4318 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4319 _ckvmssts(sys$schdwk(0,0,interval,0));
4320 _ckvmssts(sys$hiber());
4322 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4327 } /* end of waitpid() */
4332 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4334 my_gconvert(double val, int ndig, int trail, char *buf)
4336 static char __gcvtbuf[DBL_DIG+1];
4339 loc = buf ? buf : __gcvtbuf;
4341 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4343 sprintf(loc,"%.*g",ndig,val);
4349 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4350 return gcvt(val,ndig,loc);
4353 loc[0] = '0'; loc[1] = '\0';
4360 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4361 static int rms_free_search_context(struct FAB * fab)
4365 nam = fab->fab$l_nam;
4366 nam->nam$b_nop |= NAM$M_SYNCHK;
4367 nam->nam$l_rlf = NULL;
4369 return sys$parse(fab, NULL, NULL);
4372 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4373 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4374 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4375 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4376 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4377 #define rms_nam_esll(nam) nam.nam$b_esl
4378 #define rms_nam_esl(nam) nam.nam$b_esl
4379 #define rms_nam_name(nam) nam.nam$l_name
4380 #define rms_nam_namel(nam) nam.nam$l_name
4381 #define rms_nam_type(nam) nam.nam$l_type
4382 #define rms_nam_typel(nam) nam.nam$l_type
4383 #define rms_nam_ver(nam) nam.nam$l_ver
4384 #define rms_nam_verl(nam) nam.nam$l_ver
4385 #define rms_nam_rsll(nam) nam.nam$b_rsl
4386 #define rms_nam_rsl(nam) nam.nam$b_rsl
4387 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4388 #define rms_set_fna(fab, nam, name, size) \
4389 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4390 #define rms_get_fna(fab, nam) fab.fab$l_fna
4391 #define rms_set_dna(fab, nam, name, size) \
4392 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4393 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4394 #define rms_set_esa(fab, nam, name, size) \
4395 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4396 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4397 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4398 #define rms_set_rsa(nam, name, size) \
4399 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4400 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4401 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4402 #define rms_nam_name_type_l_size(nam) \
4403 (nam.nam$b_name + nam.nam$b_type)
4405 static int rms_free_search_context(struct FAB * fab)
4409 nam = fab->fab$l_naml;
4410 nam->naml$b_nop |= NAM$M_SYNCHK;
4411 nam->naml$l_rlf = NULL;
4412 nam->naml$l_long_defname_size = 0;
4415 return sys$parse(fab, NULL, NULL);
4418 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4419 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4420 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4421 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4422 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4423 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4424 #define rms_nam_esl(nam) nam.naml$b_esl
4425 #define rms_nam_name(nam) nam.naml$l_name
4426 #define rms_nam_namel(nam) nam.naml$l_long_name
4427 #define rms_nam_type(nam) nam.naml$l_type
4428 #define rms_nam_typel(nam) nam.naml$l_long_type
4429 #define rms_nam_ver(nam) nam.naml$l_ver
4430 #define rms_nam_verl(nam) nam.naml$l_long_ver
4431 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4432 #define rms_nam_rsl(nam) nam.naml$b_rsl
4433 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4434 #define rms_set_fna(fab, nam, name, size) \
4435 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4436 nam.naml$l_long_filename_size = size; \
4437 nam.naml$l_long_filename = name;}
4438 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4439 #define rms_set_dna(fab, nam, name, size) \
4440 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4441 nam.naml$l_long_defname_size = size; \
4442 nam.naml$l_long_defname = name; }
4443 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4444 #define rms_set_esa(fab, nam, name, size) \
4445 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4446 nam.naml$l_long_expand_alloc = size; \
4447 nam.naml$l_long_expand = name; }
4448 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4449 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4450 nam.naml$l_long_expand = l_name; \
4451 nam.naml$l_long_expand_alloc = l_size; }
4452 #define rms_set_rsa(nam, name, size) \
4453 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4454 nam.naml$l_long_result = name; \
4455 nam.naml$l_long_result_alloc = size; }
4456 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4457 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4458 nam.naml$l_long_result = l_name; \
4459 nam.naml$l_long_result_alloc = l_size; }
4460 #define rms_nam_name_type_l_size(nam) \
4461 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4465 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4466 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4467 * to expand file specification. Allows for a single default file
4468 * specification and a simple mask of options. If outbuf is non-NULL,
4469 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4470 * the resultant file specification is placed. If outbuf is NULL, the
4471 * resultant file specification is placed into a static buffer.
4472 * The third argument, if non-NULL, is taken to be a default file
4473 * specification string. The fourth argument is unused at present.
4474 * rmesexpand() returns the address of the resultant string if
4475 * successful, and NULL on error.
4477 * New functionality for previously unused opts value:
4478 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4479 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4480 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4482 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4486 (pTHX_ const char *filespec,
4489 const char *defspec,
4494 static char __rmsexpand_retbuf[VMS_MAXRSS];
4495 char * vmsfspec, *tmpfspec;
4496 char * esa, *cp, *out = NULL;
4500 struct FAB myfab = cc$rms_fab;
4501 rms_setup_nam(mynam);
4503 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4506 /* temp hack until UTF8 is actually implemented */
4507 if (fs_utf8 != NULL)
4510 if (!filespec || !*filespec) {
4511 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4515 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4516 else outbuf = __rmsexpand_retbuf;
4524 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4525 isunix = is_unix_filespec(filespec);
4527 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4528 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4529 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4530 PerlMem_free(vmsfspec);
4535 filespec = vmsfspec;
4537 /* Unless we are forcing to VMS format, a UNIX input means
4538 * UNIX output, and that requires long names to be used
4540 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4541 opts |= PERL_RMSEXPAND_M_LONG;
4548 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4549 rms_bind_fab_nam(myfab, mynam);
4551 if (defspec && *defspec) {
4553 t_isunix = is_unix_filespec(defspec);
4555 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4556 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4557 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4558 PerlMem_free(tmpfspec);
4559 if (vmsfspec != NULL)
4560 PerlMem_free(vmsfspec);
4567 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4570 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4571 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4572 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4573 esal = PerlMem_malloc(VMS_MAXRSS);
4574 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4576 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4578 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4579 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4582 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4583 outbufl = PerlMem_malloc(VMS_MAXRSS);
4584 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4585 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4587 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4591 #ifdef NAM$M_NO_SHORT_UPCASE
4592 if (decc_efs_case_preserve)
4593 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4596 /* First attempt to parse as an existing file */
4597 retsts = sys$parse(&myfab,0,0);
4598 if (!(retsts & STS$K_SUCCESS)) {
4600 /* Could not find the file, try as syntax only if error is not fatal */
4601 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4602 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4603 retsts = sys$parse(&myfab,0,0);
4604 if (retsts & STS$K_SUCCESS) goto expanded;
4607 /* Still could not parse the file specification */
4608 /*----------------------------------------------*/
4609 sts = rms_free_search_context(&myfab); /* Free search context */
4610 if (out) Safefree(out);
4611 if (tmpfspec != NULL)
4612 PerlMem_free(tmpfspec);
4613 if (vmsfspec != NULL)
4614 PerlMem_free(vmsfspec);
4615 if (outbufl != NULL)
4616 PerlMem_free(outbufl);
4619 set_vaxc_errno(retsts);
4620 if (retsts == RMS$_PRV) set_errno(EACCES);
4621 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4622 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4623 else set_errno(EVMSERR);
4626 retsts = sys$search(&myfab,0,0);
4627 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4628 sts = rms_free_search_context(&myfab); /* Free search context */
4629 if (out) Safefree(out);
4630 if (tmpfspec != NULL)
4631 PerlMem_free(tmpfspec);
4632 if (vmsfspec != NULL)
4633 PerlMem_free(vmsfspec);
4634 if (outbufl != NULL)
4635 PerlMem_free(outbufl);
4638 set_vaxc_errno(retsts);
4639 if (retsts == RMS$_PRV) set_errno(EACCES);
4640 else set_errno(EVMSERR);
4644 /* If the input filespec contained any lowercase characters,
4645 * downcase the result for compatibility with Unix-minded code. */
4647 if (!decc_efs_case_preserve) {
4648 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4649 if (islower(*tbuf)) { haslower = 1; break; }
4652 /* Is a long or a short name expected */
4653 /*------------------------------------*/
4654 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4655 if (rms_nam_rsll(mynam)) {
4657 speclen = rms_nam_rsll(mynam);
4660 tbuf = esal; /* Not esa */
4661 speclen = rms_nam_esll(mynam);
4665 if (rms_nam_rsl(mynam)) {
4667 speclen = rms_nam_rsl(mynam);
4670 tbuf = esa; /* Not esal */
4671 speclen = rms_nam_esl(mynam);
4674 tbuf[speclen] = '\0';
4676 /* Trim off null fields added by $PARSE
4677 * If type > 1 char, must have been specified in original or default spec
4678 * (not true for version; $SEARCH may have added version of existing file).
4680 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4681 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4682 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4683 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4686 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4687 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4689 if (trimver || trimtype) {
4690 if (defspec && *defspec) {
4691 char *defesal = NULL;
4692 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4693 if (defesal != NULL) {
4694 struct FAB deffab = cc$rms_fab;
4695 rms_setup_nam(defnam);
4697 rms_bind_fab_nam(deffab, defnam);
4701 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4703 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4705 rms_clear_nam_nop(defnam);
4706 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4707 #ifdef NAM$M_NO_SHORT_UPCASE
4708 if (decc_efs_case_preserve)
4709 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4711 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4713 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4716 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4719 PerlMem_free(defesal);
4723 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4724 if (*(rms_nam_verl(mynam)) != '\"')
4725 speclen = rms_nam_verl(mynam) - tbuf;
4728 if (*(rms_nam_ver(mynam)) != '\"')
4729 speclen = rms_nam_ver(mynam) - tbuf;
4733 /* If we didn't already trim version, copy down */
4734 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4735 if (speclen > rms_nam_verl(mynam) - tbuf)
4737 (rms_nam_typel(mynam),
4738 rms_nam_verl(mynam),
4739 speclen - (rms_nam_verl(mynam) - tbuf));
4740 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4743 if (speclen > rms_nam_ver(mynam) - tbuf)
4745 (rms_nam_type(mynam),
4747 speclen - (rms_nam_ver(mynam) - tbuf));
4748 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4753 /* Done with these copies of the input files */
4754 /*-------------------------------------------*/
4755 if (vmsfspec != NULL)
4756 PerlMem_free(vmsfspec);
4757 if (tmpfspec != NULL)
4758 PerlMem_free(tmpfspec);
4760 /* If we just had a directory spec on input, $PARSE "helpfully"
4761 * adds an empty name and type for us */
4762 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4763 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4764 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4765 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4766 speclen = rms_nam_namel(mynam) - tbuf;
4769 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4770 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4771 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4772 speclen = rms_nam_name(mynam) - tbuf;
4775 /* Posix format specifications must have matching quotes */
4776 if (speclen < (VMS_MAXRSS - 1)) {
4777 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4778 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4779 tbuf[speclen] = '\"';
4784 tbuf[speclen] = '\0';
4785 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4787 /* Have we been working with an expanded, but not resultant, spec? */
4788 /* Also, convert back to Unix syntax if necessary. */
4790 if (!rms_nam_rsll(mynam)) {
4792 if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
4793 if (out) Safefree(out);
4796 if (outbufl != NULL)
4797 PerlMem_free(outbufl);
4801 else strcpy(outbuf,esa);
4804 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4805 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4806 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
4807 if (out) Safefree(out);
4810 PerlMem_free(tmpfspec);
4811 if (outbufl != NULL)
4812 PerlMem_free(outbufl);
4815 strcpy(outbuf,tmpfspec);
4816 PerlMem_free(tmpfspec);
4819 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4820 sts = rms_free_search_context(&myfab); /* Free search context */
4823 if (outbufl != NULL)
4824 PerlMem_free(outbufl);
4828 /* External entry points */
4829 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4830 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
4831 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4832 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
4833 char *Perl_rmsexpand_utf8
4834 (pTHX_ const char *spec, char *buf, const char *def,
4835 unsigned opt, int * fs_utf8, int * dfs_utf8)
4836 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
4837 char *Perl_rmsexpand_utf8_ts
4838 (pTHX_ const char *spec, char *buf, const char *def,
4839 unsigned opt, int * fs_utf8, int * dfs_utf8)
4840 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
4844 ** The following routines are provided to make life easier when
4845 ** converting among VMS-style and Unix-style directory specifications.
4846 ** All will take input specifications in either VMS or Unix syntax. On
4847 ** failure, all return NULL. If successful, the routines listed below
4848 ** return a pointer to a buffer containing the appropriately
4849 ** reformatted spec (and, therefore, subsequent calls to that routine
4850 ** will clobber the result), while the routines of the same names with
4851 ** a _ts suffix appended will return a pointer to a mallocd string
4852 ** containing the appropriately reformatted spec.
4853 ** In all cases, only explicit syntax is altered; no check is made that
4854 ** the resulting string is valid or that the directory in question
4857 ** fileify_dirspec() - convert a directory spec into the name of the
4858 ** directory file (i.e. what you can stat() to see if it's a dir).
4859 ** The style (VMS or Unix) of the result is the same as the style
4860 ** of the parameter passed in.
4861 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4862 ** what you prepend to a filename to indicate what directory it's in).
4863 ** The style (VMS or Unix) of the result is the same as the style
4864 ** of the parameter passed in.
4865 ** tounixpath() - convert a directory spec into a Unix-style path.
4866 ** tovmspath() - convert a directory spec into a VMS-style path.
4867 ** tounixspec() - convert any file spec into a Unix-style file spec.
4868 ** tovmsspec() - convert any file spec into a VMS-style spec.
4869 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
4871 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4872 ** Permission is given to distribute this code as part of the Perl
4873 ** standard distribution under the terms of the GNU General Public
4874 ** License or the Perl Artistic License. Copies of each may be
4875 ** found in the Perl standard distribution.
4878 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
4879 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
4881 static char __fileify_retbuf[VMS_MAXRSS];
4882 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4883 char *retspec, *cp1, *cp2, *lastdir;
4884 char *trndir, *vmsdir;
4885 unsigned short int trnlnm_iter_count;
4887 if (utf8_fl != NULL)
4890 if (!dir || !*dir) {
4891 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4893 dirlen = strlen(dir);
4894 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4895 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4896 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4903 if (dirlen > (VMS_MAXRSS - 1)) {
4904 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4907 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4908 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4909 if (!strpbrk(dir+1,"/]>:") &&
4910 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4911 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4912 trnlnm_iter_count = 0;
4913 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4914 trnlnm_iter_count++;
4915 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4917 dirlen = strlen(trndir);
4920 strncpy(trndir,dir,dirlen);
4921 trndir[dirlen] = '\0';
4924 /* At this point we are done with *dir and use *trndir which is a
4925 * copy that can be modified. *dir must not be modified.
4928 /* If we were handed a rooted logical name or spec, treat it like a
4929 * simple directory, so that
4930 * $ Define myroot dev:[dir.]
4931 * ... do_fileify_dirspec("myroot",buf,1) ...
4932 * does something useful.
4934 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4935 trndir[--dirlen] = '\0';
4936 trndir[dirlen-1] = ']';
4938 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4939 trndir[--dirlen] = '\0';
4940 trndir[dirlen-1] = '>';
4943 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4944 /* If we've got an explicit filename, we can just shuffle the string. */
4945 if (*(cp1+1)) hasfilename = 1;
4946 /* Similarly, we can just back up a level if we've got multiple levels
4947 of explicit directories in a VMS spec which ends with directories. */
4949 for (cp2 = cp1; cp2 > trndir; cp2--) {
4951 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4952 /* fix-me, can not scan EFS file specs backward like this */
4953 *cp2 = *cp1; *cp1 = '\0';
4958 if (*cp2 == '[' || *cp2 == '<') break;
4963 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4964 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4965 cp1 = strpbrk(trndir,"]:>");
4966 if (hasfilename || !cp1) { /* Unix-style path or filename */
4967 if (trndir[0] == '.') {
4968 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4969 PerlMem_free(trndir);
4970 PerlMem_free(vmsdir);
4971 return do_fileify_dirspec("[]",buf,ts,NULL);
4973 else if (trndir[1] == '.' &&
4974 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4975 PerlMem_free(trndir);
4976 PerlMem_free(vmsdir);
4977 return do_fileify_dirspec("[-]",buf,ts,NULL);
4980 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4981 dirlen -= 1; /* to last element */
4982 lastdir = strrchr(trndir,'/');
4984 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4985 /* If we have "/." or "/..", VMSify it and let the VMS code
4986 * below expand it, rather than repeating the code to handle
4987 * relative components of a filespec here */
4989 if (*(cp1+2) == '.') cp1++;
4990 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4992 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
4993 PerlMem_free(trndir);
4994 PerlMem_free(vmsdir);
4997 if (strchr(vmsdir,'/') != NULL) {
4998 /* If do_tovmsspec() returned it, it must have VMS syntax
4999 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5000 * the time to check this here only so we avoid a recursion
5001 * loop; otherwise, gigo.
5003 PerlMem_free(trndir);
5004 PerlMem_free(vmsdir);
5005 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5008 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5009 PerlMem_free(trndir);
5010 PerlMem_free(vmsdir);
5013 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5014 PerlMem_free(trndir);
5015 PerlMem_free(vmsdir);
5019 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5020 lastdir = strrchr(trndir,'/');
5022 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5024 /* Ditto for specs that end in an MFD -- let the VMS code
5025 * figure out whether it's a real device or a rooted logical. */
5027 /* This should not happen any more. Allowing the fake /000000
5028 * in a UNIX pathname causes all sorts of problems when trying
5029 * to run in UNIX emulation. So the VMS to UNIX conversions
5030 * now remove the fake /000000 directories.
5033 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5034 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5035 PerlMem_free(trndir);
5036 PerlMem_free(vmsdir);
5039 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5040 PerlMem_free(trndir);
5041 PerlMem_free(vmsdir);
5044 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5045 PerlMem_free(trndir);
5046 PerlMem_free(vmsdir);
5051 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5052 !(lastdir = cp1 = strrchr(trndir,']')) &&
5053 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5054 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5057 /* For EFS or ODS-5 look for the last dot */
5058 if (decc_efs_charset) {
5059 cp2 = strrchr(cp1,'.');
5061 if (vms_process_case_tolerant) {
5062 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5063 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5064 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5065 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5066 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5067 (ver || *cp3)))))) {
5068 PerlMem_free(trndir);
5069 PerlMem_free(vmsdir);
5071 set_vaxc_errno(RMS$_DIR);
5076 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5077 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5078 !*(cp2+3) || *(cp2+3) != 'R' ||
5079 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5080 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5081 (ver || *cp3)))))) {
5082 PerlMem_free(trndir);
5083 PerlMem_free(vmsdir);
5085 set_vaxc_errno(RMS$_DIR);
5089 dirlen = cp2 - trndir;
5093 retlen = dirlen + 6;
5094 if (buf) retspec = buf;
5095 else if (ts) Newx(retspec,retlen+1,char);
5096 else retspec = __fileify_retbuf;
5097 memcpy(retspec,trndir,dirlen);
5098 retspec[dirlen] = '\0';
5100 /* We've picked up everything up to the directory file name.
5101 Now just add the type and version, and we're set. */
5102 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5103 strcat(retspec,".dir;1");
5105 strcat(retspec,".DIR;1");
5106 PerlMem_free(trndir);
5107 PerlMem_free(vmsdir);
5110 else { /* VMS-style directory spec */
5112 char *esa, term, *cp;
5113 unsigned long int sts, cmplen, haslower = 0;
5114 unsigned int nam_fnb;
5116 struct FAB dirfab = cc$rms_fab;
5117 rms_setup_nam(savnam);
5118 rms_setup_nam(dirnam);
5120 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5121 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5122 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5123 rms_bind_fab_nam(dirfab, dirnam);
5124 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5125 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5126 #ifdef NAM$M_NO_SHORT_UPCASE
5127 if (decc_efs_case_preserve)
5128 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5131 for (cp = trndir; *cp; cp++)
5132 if (islower(*cp)) { haslower = 1; break; }
5133 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5134 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5135 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5136 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5140 PerlMem_free(trndir);
5141 PerlMem_free(vmsdir);
5143 set_vaxc_errno(dirfab.fab$l_sts);
5149 /* Does the file really exist? */
5150 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5151 /* Yes; fake the fnb bits so we'll check type below */
5152 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5154 else { /* No; just work with potential name */
5155 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5158 fab_sts = dirfab.fab$l_sts;
5159 sts = rms_free_search_context(&dirfab);
5161 PerlMem_free(trndir);
5162 PerlMem_free(vmsdir);
5163 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5168 esa[rms_nam_esll(dirnam)] = '\0';
5169 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5170 cp1 = strchr(esa,']');
5171 if (!cp1) cp1 = strchr(esa,'>');
5172 if (cp1) { /* Should always be true */
5173 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5174 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5177 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5178 /* Yep; check version while we're at it, if it's there. */
5179 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5180 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5181 /* Something other than .DIR[;1]. Bzzt. */
5182 sts = rms_free_search_context(&dirfab);
5184 PerlMem_free(trndir);
5185 PerlMem_free(vmsdir);
5187 set_vaxc_errno(RMS$_DIR);
5192 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5193 /* They provided at least the name; we added the type, if necessary, */
5194 if (buf) retspec = buf; /* in sys$parse() */
5195 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5196 else retspec = __fileify_retbuf;
5197 strcpy(retspec,esa);
5198 sts = rms_free_search_context(&dirfab);
5199 PerlMem_free(trndir);
5201 PerlMem_free(vmsdir);
5204 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5205 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5207 rms_nam_esll(dirnam) -= 9;
5209 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5210 if (cp1 == NULL) { /* should never happen */
5211 sts = rms_free_search_context(&dirfab);
5212 PerlMem_free(trndir);
5214 PerlMem_free(vmsdir);
5219 retlen = strlen(esa);
5220 cp1 = strrchr(esa,'.');
5221 /* ODS-5 directory specifications can have extra "." in them. */
5222 /* Fix-me, can not scan EFS file specifications backwards */
5223 while (cp1 != NULL) {
5224 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5228 while ((cp1 > esa) && (*cp1 != '.'))
5235 if ((cp1) != NULL) {
5236 /* There's more than one directory in the path. Just roll back. */
5238 if (buf) retspec = buf;
5239 else if (ts) Newx(retspec,retlen+7,char);
5240 else retspec = __fileify_retbuf;
5241 strcpy(retspec,esa);
5244 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5245 /* Go back and expand rooted logical name */
5246 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5247 #ifdef NAM$M_NO_SHORT_UPCASE
5248 if (decc_efs_case_preserve)
5249 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5251 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5252 sts = rms_free_search_context(&dirfab);
5254 PerlMem_free(trndir);
5255 PerlMem_free(vmsdir);
5257 set_vaxc_errno(dirfab.fab$l_sts);
5260 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5261 if (buf) retspec = buf;
5262 else if (ts) Newx(retspec,retlen+16,char);
5263 else retspec = __fileify_retbuf;
5264 cp1 = strstr(esa,"][");
5265 if (!cp1) cp1 = strstr(esa,"]<");
5267 memcpy(retspec,esa,dirlen);
5268 if (!strncmp(cp1+2,"000000]",7)) {
5269 retspec[dirlen-1] = '\0';
5270 /* fix-me Not full ODS-5, just extra dots in directories for now */
5271 cp1 = retspec + dirlen - 1;
5272 while (cp1 > retspec)
5277 if (*(cp1-1) != '^')
5282 if (*cp1 == '.') *cp1 = ']';
5284 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5285 memmove(cp1+1,"000000]",7);
5289 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5290 retspec[retlen] = '\0';
5291 /* Convert last '.' to ']' */
5292 cp1 = retspec+retlen-1;
5293 while (*cp != '[') {
5296 /* Do not trip on extra dots in ODS-5 directories */
5297 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5301 if (*cp1 == '.') *cp1 = ']';
5303 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5304 memmove(cp1+1,"000000]",7);
5308 else { /* This is a top-level dir. Add the MFD to the path. */
5309 if (buf) retspec = buf;
5310 else if (ts) Newx(retspec,retlen+16,char);
5311 else retspec = __fileify_retbuf;
5314 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5315 strcpy(cp2,":[000000]");
5320 sts = rms_free_search_context(&dirfab);
5321 /* We've set up the string up through the filename. Add the
5322 type and version, and we're done. */
5323 strcat(retspec,".DIR;1");
5325 /* $PARSE may have upcased filespec, so convert output to lower
5326 * case if input contained any lowercase characters. */
5327 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5328 PerlMem_free(trndir);
5330 PerlMem_free(vmsdir);
5333 } /* end of do_fileify_dirspec() */
5335 /* External entry points */
5336 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5337 { return do_fileify_dirspec(dir,buf,0,NULL); }
5338 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5339 { return do_fileify_dirspec(dir,buf,1,NULL); }
5340 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5341 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5342 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5343 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5345 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5346 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5348 static char __pathify_retbuf[VMS_MAXRSS];
5349 unsigned long int retlen;
5350 char *retpath, *cp1, *cp2, *trndir;
5351 unsigned short int trnlnm_iter_count;
5354 if (utf8_fl != NULL)
5357 if (!dir || !*dir) {
5358 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5361 trndir = PerlMem_malloc(VMS_MAXRSS);
5362 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5363 if (*dir) strcpy(trndir,dir);
5364 else getcwd(trndir,VMS_MAXRSS - 1);
5366 trnlnm_iter_count = 0;
5367 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5368 && my_trnlnm(trndir,trndir,0)) {
5369 trnlnm_iter_count++;
5370 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5371 trnlen = strlen(trndir);
5373 /* Trap simple rooted lnms, and return lnm:[000000] */
5374 if (!strcmp(trndir+trnlen-2,".]")) {
5375 if (buf) retpath = buf;
5376 else if (ts) Newx(retpath,strlen(dir)+10,char);
5377 else retpath = __pathify_retbuf;
5378 strcpy(retpath,dir);
5379 strcat(retpath,":[000000]");
5380 PerlMem_free(trndir);
5385 /* At this point we do not work with *dir, but the copy in
5386 * *trndir that is modifiable.
5389 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5390 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5391 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5392 retlen = 2 + (*(trndir+1) != '\0');
5394 if ( !(cp1 = strrchr(trndir,'/')) &&
5395 !(cp1 = strrchr(trndir,']')) &&
5396 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5397 if ((cp2 = strchr(cp1,'.')) != NULL &&
5398 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5399 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5400 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5401 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5404 /* For EFS or ODS-5 look for the last dot */
5405 if (decc_efs_charset) {
5406 cp2 = strrchr(cp1,'.');
5408 if (vms_process_case_tolerant) {
5409 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5410 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5411 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5412 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5413 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5414 (ver || *cp3)))))) {
5415 PerlMem_free(trndir);
5417 set_vaxc_errno(RMS$_DIR);
5422 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5423 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5424 !*(cp2+3) || *(cp2+3) != 'R' ||
5425 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5426 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5427 (ver || *cp3)))))) {
5428 PerlMem_free(trndir);
5430 set_vaxc_errno(RMS$_DIR);
5434 retlen = cp2 - trndir + 1;
5436 else { /* No file type present. Treat the filename as a directory. */
5437 retlen = strlen(trndir) + 1;
5440 if (buf) retpath = buf;
5441 else if (ts) Newx(retpath,retlen+1,char);
5442 else retpath = __pathify_retbuf;
5443 strncpy(retpath, trndir, retlen-1);
5444 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5445 retpath[retlen-1] = '/'; /* with '/', add it. */
5446 retpath[retlen] = '\0';
5448 else retpath[retlen-1] = '\0';
5450 else { /* VMS-style directory spec */
5452 unsigned long int sts, cmplen, haslower;
5453 struct FAB dirfab = cc$rms_fab;
5455 rms_setup_nam(savnam);
5456 rms_setup_nam(dirnam);
5458 /* If we've got an explicit filename, we can just shuffle the string. */
5459 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5460 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5461 if ((cp2 = strchr(cp1,'.')) != NULL) {
5463 if (vms_process_case_tolerant) {
5464 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5465 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5466 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5467 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5468 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5469 (ver || *cp3)))))) {
5470 PerlMem_free(trndir);
5472 set_vaxc_errno(RMS$_DIR);
5477 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5478 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5479 !*(cp2+3) || *(cp2+3) != 'R' ||
5480 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5481 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5482 (ver || *cp3)))))) {
5483 PerlMem_free(trndir);
5485 set_vaxc_errno(RMS$_DIR);
5490 else { /* No file type, so just draw name into directory part */
5491 for (cp2 = cp1; *cp2; cp2++) ;
5494 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5496 /* We've now got a VMS 'path'; fall through */
5499 dirlen = strlen(trndir);
5500 if (trndir[dirlen-1] == ']' ||
5501 trndir[dirlen-1] == '>' ||
5502 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5503 if (buf) retpath = buf;
5504 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5505 else retpath = __pathify_retbuf;
5506 strcpy(retpath,trndir);
5507 PerlMem_free(trndir);
5510 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5511 esa = PerlMem_malloc(VMS_MAXRSS);
5512 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5513 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5514 rms_bind_fab_nam(dirfab, dirnam);
5515 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5516 #ifdef NAM$M_NO_SHORT_UPCASE
5517 if (decc_efs_case_preserve)
5518 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5521 for (cp = trndir; *cp; cp++)
5522 if (islower(*cp)) { haslower = 1; break; }
5524 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5525 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5526 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5527 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5530 PerlMem_free(trndir);
5533 set_vaxc_errno(dirfab.fab$l_sts);
5539 /* Does the file really exist? */
5540 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5541 if (dirfab.fab$l_sts != RMS$_FNF) {
5543 sts1 = rms_free_search_context(&dirfab);
5544 PerlMem_free(trndir);
5547 set_vaxc_errno(dirfab.fab$l_sts);
5550 dirnam = savnam; /* No; just work with potential name */
5553 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5554 /* Yep; check version while we're at it, if it's there. */
5555 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5556 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5558 /* Something other than .DIR[;1]. Bzzt. */
5559 sts2 = rms_free_search_context(&dirfab);
5560 PerlMem_free(trndir);
5563 set_vaxc_errno(RMS$_DIR);
5567 /* OK, the type was fine. Now pull any file name into the
5569 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5571 cp1 = strrchr(esa,'>');
5572 *(rms_nam_typel(dirnam)) = '>';
5575 *(rms_nam_typel(dirnam) + 1) = '\0';
5576 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5577 if (buf) retpath = buf;
5578 else if (ts) Newx(retpath,retlen,char);
5579 else retpath = __pathify_retbuf;
5580 strcpy(retpath,esa);
5582 sts = rms_free_search_context(&dirfab);
5583 /* $PARSE may have upcased filespec, so convert output to lower
5584 * case if input contained any lowercase characters. */
5585 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5588 PerlMem_free(trndir);
5590 } /* end of do_pathify_dirspec() */
5592 /* External entry points */
5593 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5594 { return do_pathify_dirspec(dir,buf,0,NULL); }
5595 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5596 { return do_pathify_dirspec(dir,buf,1,NULL); }
5597 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5598 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5599 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5600 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5602 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5603 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5605 static char __tounixspec_retbuf[VMS_MAXRSS];
5606 char *dirend, *rslt, *cp1, *cp3, *tmp;
5608 int devlen, dirlen, retlen = VMS_MAXRSS;
5609 int expand = 1; /* guarantee room for leading and trailing slashes */
5610 unsigned short int trnlnm_iter_count;
5612 if (utf8_fl != NULL)
5615 if (spec == NULL) return NULL;
5616 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5617 if (buf) rslt = buf;
5619 Newx(rslt, VMS_MAXRSS, char);
5621 else rslt = __tounixspec_retbuf;
5623 /* New VMS specific format needs translation
5624 * glob passes filenames with trailing '\n' and expects this preserved.
5626 if (decc_posix_compliant_pathnames) {
5627 if (strncmp(spec, "\"^UP^", 5) == 0) {
5633 tunix = PerlMem_malloc(VMS_MAXRSS);
5634 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5635 strcpy(tunix, spec);
5636 tunix_len = strlen(tunix);
5638 if (tunix[tunix_len - 1] == '\n') {
5639 tunix[tunix_len - 1] = '\"';
5640 tunix[tunix_len] = '\0';
5644 uspec = decc$translate_vms(tunix);
5645 PerlMem_free(tunix);
5646 if ((int)uspec > 0) {
5652 /* If we can not translate it, makemaker wants as-is */
5660 cmp_rslt = 0; /* Presume VMS */
5661 cp1 = strchr(spec, '/');
5665 /* Look for EFS ^/ */
5666 if (decc_efs_charset) {
5667 while (cp1 != NULL) {
5670 /* Found illegal VMS, assume UNIX */
5675 cp1 = strchr(cp1, '/');
5679 /* Look for "." and ".." */
5680 if (decc_filename_unix_report) {
5681 if (spec[0] == '.') {
5682 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5686 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5692 /* This is already UNIX or at least nothing VMS understands */
5700 dirend = strrchr(spec,']');
5701 if (dirend == NULL) dirend = strrchr(spec,'>');
5702 if (dirend == NULL) dirend = strchr(spec,':');
5703 if (dirend == NULL) {
5708 /* Special case 1 - sys$posix_root = / */
5709 #if __CRTL_VER >= 70000000
5710 if (!decc_disable_posix_root) {
5711 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5719 /* Special case 2 - Convert NLA0: to /dev/null */
5720 #if __CRTL_VER < 70000000
5721 cmp_rslt = strncmp(spec,"NLA0:", 5);
5723 cmp_rslt = strncmp(spec,"nla0:", 5);
5725 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5727 if (cmp_rslt == 0) {
5728 strcpy(rslt, "/dev/null");
5731 if (spec[6] != '\0') {
5738 /* Also handle special case "SYS$SCRATCH:" */
5739 #if __CRTL_VER < 70000000
5740 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5742 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5744 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5746 tmp = PerlMem_malloc(VMS_MAXRSS);
5747 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5748 if (cmp_rslt == 0) {
5751 islnm = my_trnlnm(tmp, "TMP", 0);
5753 strcpy(rslt, "/tmp");
5756 if (spec[12] != '\0') {
5764 if (*cp2 != '[' && *cp2 != '<') {
5767 else { /* the VMS spec begins with directories */
5769 if (*cp2 == ']' || *cp2 == '>') {
5770 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5774 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5775 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5776 if (ts) Safefree(rslt);
5780 trnlnm_iter_count = 0;
5783 while (*cp3 != ':' && *cp3) cp3++;
5785 if (strchr(cp3,']') != NULL) break;
5786 trnlnm_iter_count++;
5787 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5788 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5790 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5791 retlen = devlen + dirlen;
5792 Renew(rslt,retlen+1+2*expand,char);
5798 *(cp1++) = *(cp3++);
5799 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5801 return NULL; /* No room */
5806 if ((*cp2 == '^')) {
5807 /* EFS file escape, pass the next character as is */
5808 /* Fix me: HEX encoding for UNICODE not implemented */
5811 else if ( *cp2 == '.') {
5812 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5813 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5820 for (; cp2 <= dirend; cp2++) {
5821 if ((*cp2 == '^')) {
5822 /* EFS file escape, pass the next character as is */
5823 /* Fix me: HEX encoding for UNICODE not implemented */
5829 if (*(cp2+1) == '[') cp2++;
5831 else if (*cp2 == ']' || *cp2 == '>') {
5832 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5834 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5836 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5837 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5838 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5839 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5840 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5842 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5843 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5847 else if (*cp2 == '-') {
5848 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5849 while (*cp2 == '-') {
5851 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5853 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5854 if (ts) Safefree(rslt); /* filespecs like */
5855 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5859 else *(cp1++) = *cp2;
5861 else *(cp1++) = *cp2;
5863 while (*cp2) *(cp1++) = *(cp2++);
5866 /* This still leaves /000000/ when working with a
5867 * VMS device root or concealed root.
5873 ulen = strlen(rslt);
5875 /* Get rid of "000000/ in rooted filespecs */
5877 zeros = strstr(rslt, "/000000/");
5878 if (zeros != NULL) {
5880 mlen = ulen - (zeros - rslt) - 7;
5881 memmove(zeros, &zeros[7], mlen);
5890 } /* end of do_tounixspec() */
5892 /* External entry points */
5893 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5894 { return do_tounixspec(spec,buf,0, NULL); }
5895 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5896 { return do_tounixspec(spec,buf,1, NULL); }
5897 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5898 { return do_tounixspec(spec,buf,0, utf8_fl); }
5899 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5900 { return do_tounixspec(spec,buf,1, utf8_fl); }
5902 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5905 This procedure is used to identify if a path is based in either
5906 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5907 it returns the OpenVMS format directory for it.
5909 It is expecting specifications of only '/' or '/xxxx/'
5911 If a posix root does not exist, or 'xxxx' is not a directory
5912 in the posix root, it returns a failure.
5914 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5916 It is used only internally by posix_to_vmsspec_hardway().
5919 static int posix_root_to_vms
5920 (char *vmspath, int vmspath_len,
5921 const char *unixpath,
5922 const int * utf8_fl) {
5924 struct FAB myfab = cc$rms_fab;
5925 struct NAML mynam = cc$rms_naml;
5926 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5927 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5934 unixlen = strlen(unixpath);
5940 #if __CRTL_VER >= 80200000
5941 /* If not a posix spec already, convert it */
5942 if (decc_posix_compliant_pathnames) {
5943 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5944 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5947 /* This is already a VMS specification, no conversion */
5949 strncpy(vmspath,unixpath, vmspath_len);
5958 /* Check to see if this is under the POSIX root */
5959 if (decc_disable_posix_root) {
5963 /* Skip leading / */
5964 if (unixpath[0] == '/') {
5970 strcpy(vmspath,"SYS$POSIX_ROOT:");
5972 /* If this is only the / , or blank, then... */
5973 if (unixpath[0] == '\0') {
5974 /* by definition, this is the answer */
5978 /* Need to look up a directory */
5982 /* Copy and add '^' escape characters as needed */
5985 while (unixpath[i] != 0) {
5988 j += copy_expand_unix_filename_escape
5989 (&vmspath[j], &unixpath[i], &k, utf8_fl);
5993 path_len = strlen(vmspath);
5994 if (vmspath[path_len - 1] == '/')
5996 vmspath[path_len] = ']';
5998 vmspath[path_len] = '\0';
6001 vmspath[vmspath_len] = 0;
6002 if (unixpath[unixlen - 1] == '/')
6004 esa = PerlMem_malloc(VMS_MAXRSS);
6005 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6006 myfab.fab$l_fna = vmspath;
6007 myfab.fab$b_fns = strlen(vmspath);
6008 myfab.fab$l_naml = &mynam;
6009 mynam.naml$l_esa = NULL;
6010 mynam.naml$b_ess = 0;
6011 mynam.naml$l_long_expand = esa;
6012 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6013 mynam.naml$l_rsa = NULL;
6014 mynam.naml$b_rss = 0;
6015 if (decc_efs_case_preserve)
6016 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6017 #ifdef NAML$M_OPEN_SPECIAL
6018 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6021 /* Set up the remaining naml fields */
6022 sts = sys$parse(&myfab);
6024 /* It failed! Try again as a UNIX filespec */
6030 /* get the Device ID and the FID */
6031 sts = sys$search(&myfab);
6032 /* on any failure, returned the POSIX ^UP^ filespec */
6037 specdsc.dsc$a_pointer = vmspath;
6038 specdsc.dsc$w_length = vmspath_len;
6040 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6041 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6042 sts = lib$fid_to_name
6043 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6045 /* on any failure, returned the POSIX ^UP^ filespec */
6047 /* This can happen if user does not have permission to read directories */
6048 if (strncmp(unixpath,"\"^UP^",5) != 0)
6049 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6051 strcpy(vmspath, unixpath);
6054 vmspath[specdsc.dsc$w_length] = 0;
6056 /* Are we expecting a directory? */
6057 if (dir_flag != 0) {
6063 i = specdsc.dsc$w_length - 1;
6067 /* Version must be '1' */
6068 if (vmspath[i--] != '1')
6070 /* Version delimiter is one of ".;" */
6071 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6074 if (vmspath[i--] != 'R')
6076 if (vmspath[i--] != 'I')
6078 if (vmspath[i--] != 'D')
6080 if (vmspath[i--] != '.')
6082 eptr = &vmspath[i+1];
6084 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6085 if (vmspath[i-1] != '^') {
6093 /* Get rid of 6 imaginary zero directory filename */
6094 vmspath[i+1] = '\0';
6098 if (vmspath[i] == '0')
6112 /* /dev/mumble needs to be handled special.
6113 /dev/null becomes NLA0:, And there is the potential for other stuff
6114 like /dev/tty which may need to be mapped to something.
6118 slash_dev_special_to_vms
6119 (const char * unixptr,
6129 nextslash = strchr(unixptr, '/');
6130 len = strlen(unixptr);
6131 if (nextslash != NULL)
6132 len = nextslash - unixptr;
6133 cmp = strncmp("null", unixptr, 5);
6135 if (vmspath_len >= 6) {
6136 strcpy(vmspath, "_NLA0:");
6143 /* The built in routines do not understand perl's special needs, so
6144 doing a manual conversion from UNIX to VMS
6146 If the utf8_fl is not null and points to a non-zero value, then
6147 treat 8 bit characters as UTF-8.
6149 The sequence starting with '$(' and ending with ')' will be passed
6150 through with out interpretation instead of being escaped.
6153 static int posix_to_vmsspec_hardway
6154 (char *vmspath, int vmspath_len,
6155 const char *unixpath,
6160 const char *unixptr;
6161 const char *unixend;
6163 const char *lastslash;
6164 const char *lastdot;
6170 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6171 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6173 if (utf8_fl != NULL)
6179 /* Ignore leading "/" characters */
6180 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6183 unixlen = strlen(unixptr);
6185 /* Do nothing with blank paths */
6192 /* This could have a "^UP^ on the front */
6193 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6199 lastslash = strrchr(unixptr,'/');
6200 lastdot = strrchr(unixptr,'.');
6201 unixend = strrchr(unixptr,'\"');
6202 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6203 unixend = unixptr + unixlen;
6206 /* last dot is last dot or past end of string */
6207 if (lastdot == NULL)
6208 lastdot = unixptr + unixlen;
6210 /* if no directories, set last slash to beginning of string */
6211 if (lastslash == NULL) {
6212 lastslash = unixptr;
6215 /* Watch out for trailing "." after last slash, still a directory */
6216 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6217 lastslash = unixptr + unixlen;
6220 /* Watch out for traiing ".." after last slash, still a directory */
6221 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6222 lastslash = unixptr + unixlen;
6225 /* dots in directories are aways escaped */
6226 if (lastdot < lastslash)
6227 lastdot = unixptr + unixlen;
6230 /* if (unixptr < lastslash) then we are in a directory */
6237 /* Start with the UNIX path */
6238 if (*unixptr != '/') {
6239 /* relative paths */
6241 /* If allowing logical names on relative pathnames, then handle here */
6242 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6243 !decc_posix_compliant_pathnames) {
6249 /* Find the next slash */
6250 nextslash = strchr(unixptr,'/');
6252 esa = PerlMem_malloc(vmspath_len);
6253 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6255 trn = PerlMem_malloc(VMS_MAXRSS);
6256 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6258 if (nextslash != NULL) {
6260 seg_len = nextslash - unixptr;
6261 strncpy(esa, unixptr, seg_len);
6265 strcpy(esa, unixptr);
6266 seg_len = strlen(unixptr);
6268 /* trnlnm(section) */
6269 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6272 /* Now fix up the directory */
6274 /* Split up the path to find the components */
6275 sts = vms_split_path
6294 /* A logical name must be a directory or the full
6295 specification. It is only a full specification if
6296 it is the only component */
6297 if ((unixptr[seg_len] == '\0') ||
6298 (unixptr[seg_len+1] == '\0')) {
6300 /* Is a directory being required? */
6301 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6302 /* Not a logical name */
6307 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6308 /* This must be a directory */
6309 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6310 strcpy(vmsptr, esa);
6311 vmslen=strlen(vmsptr);
6312 vmsptr[vmslen] = ':';
6314 vmsptr[vmslen] = '\0';
6322 /* must be dev/directory - ignore version */
6323 if ((n_len + e_len) != 0)
6326 /* transfer the volume */
6327 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6328 strncpy(vmsptr, v_spec, v_len);
6334 /* unroot the rooted directory */
6335 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6337 r_spec[r_len - 1] = ']';
6339 /* This should not be there, but nothing is perfect */
6341 cmp = strcmp(&r_spec[1], "000000.");
6351 strncpy(vmsptr, r_spec, r_len);
6357 /* Bring over the directory. */
6359 ((d_len + vmslen) < vmspath_len)) {
6361 d_spec[d_len - 1] = ']';
6363 cmp = strcmp(&d_spec[1], "000000.");
6374 /* Remove the redundant root */
6382 strncpy(vmsptr, d_spec, d_len);
6396 if (lastslash > unixptr) {
6399 /* skip leading ./ */
6401 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6407 /* Are we still in a directory? */
6408 if (unixptr <= lastslash) {
6413 /* if not backing up, then it is relative forward. */
6414 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6415 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6423 /* Perl wants an empty directory here to tell the difference
6424 * between a DCL commmand and a filename
6433 /* Handle two special files . and .. */
6434 if (unixptr[0] == '.') {
6435 if (&unixptr[1] == unixend) {
6442 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6453 else { /* Absolute PATH handling */
6457 /* Need to find out where root is */
6459 /* In theory, this procedure should never get an absolute POSIX pathname
6460 * that can not be found on the POSIX root.
6461 * In practice, that can not be relied on, and things will show up
6462 * here that are a VMS device name or concealed logical name instead.
6463 * So to make things work, this procedure must be tolerant.
6465 esa = PerlMem_malloc(vmspath_len);
6466 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6469 nextslash = strchr(&unixptr[1],'/');
6471 if (nextslash != NULL) {
6473 seg_len = nextslash - &unixptr[1];
6474 strncpy(vmspath, unixptr, seg_len + 1);
6475 vmspath[seg_len+1] = 0;
6478 cmp = strncmp(vmspath, "dev", 4);
6480 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6481 if (sts = SS$_NORMAL)
6485 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6488 if ($VMS_STATUS_SUCCESS(sts)) {
6489 /* This is verified to be a real path */
6491 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6492 if ($VMS_STATUS_SUCCESS(sts)) {
6493 strcpy(vmspath, esa);
6494 vmslen = strlen(vmspath);
6495 vmsptr = vmspath + vmslen;
6497 if (unixptr < lastslash) {
6506 cmp = strcmp(rptr,"000000.");
6511 } /* removing 6 zeros */
6512 } /* vmslen < 7, no 6 zeros possible */
6513 } /* Not in a directory */
6514 } /* Posix root found */
6516 /* No posix root, fall back to default directory */
6517 strcpy(vmspath, "SYS$DISK:[");
6518 vmsptr = &vmspath[10];
6520 if (unixptr > lastslash) {
6529 } /* end of verified real path handling */
6534 /* Ok, we have a device or a concealed root that is not in POSIX
6535 * or we have garbage. Make the best of it.
6538 /* Posix to VMS destroyed this, so copy it again */
6539 strncpy(vmspath, &unixptr[1], seg_len);
6540 vmspath[seg_len] = 0;
6542 vmsptr = &vmsptr[vmslen];
6545 /* Now do we need to add the fake 6 zero directory to it? */
6547 if ((*lastslash == '/') && (nextslash < lastslash)) {
6548 /* No there is another directory */
6555 /* now we have foo:bar or foo:[000000]bar to decide from */
6556 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6558 if (!islnm && !decc_posix_compliant_pathnames) {
6560 cmp = strncmp("bin", vmspath, 4);
6562 /* bin => SYS$SYSTEM: */
6563 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6566 /* tmp => SYS$SCRATCH: */
6567 cmp = strncmp("tmp", vmspath, 4);
6569 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6574 trnend = islnm ? islnm - 1 : 0;
6576 /* if this was a logical name, ']' or '>' must be present */
6577 /* if not a logical name, then assume a device and hope. */
6578 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6580 /* if log name and trailing '.' then rooted - treat as device */
6581 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6583 /* Fix me, if not a logical name, a device lookup should be
6584 * done to see if the device is file structured. If the device
6585 * is not file structured, the 6 zeros should not be put on.
6587 * As it is, perl is occasionally looking for dev:[000000]tty.
6588 * which looks a little strange.
6590 * Not that easy to detect as "/dev" may be file structured with
6591 * special device files.
6594 if ((add_6zero == 0) && (*nextslash == '/') &&
6595 (&nextslash[1] == unixend)) {
6596 /* No real directory present */
6601 /* Put the device delimiter on */
6604 unixptr = nextslash;
6607 /* Start directory if needed */
6608 if (!islnm || add_6zero) {
6614 /* add fake 000000] if needed */
6627 } /* non-POSIX translation */
6629 } /* End of relative/absolute path handling */
6631 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6638 if (dir_start != 0) {
6640 /* First characters in a directory are handled special */
6641 while ((*unixptr == '/') ||
6642 ((*unixptr == '.') &&
6643 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6644 (&unixptr[1]==unixend)))) {
6649 /* Skip redundant / in specification */
6650 while ((*unixptr == '/') && (dir_start != 0)) {
6653 if (unixptr == lastslash)
6656 if (unixptr == lastslash)
6659 /* Skip redundant ./ characters */
6660 while ((*unixptr == '.') &&
6661 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6664 if (unixptr == lastslash)
6666 if (*unixptr == '/')
6669 if (unixptr == lastslash)
6672 /* Skip redundant ../ characters */
6673 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6674 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6675 /* Set the backing up flag */
6681 unixptr++; /* first . */
6682 unixptr++; /* second . */
6683 if (unixptr == lastslash)
6685 if (*unixptr == '/') /* The slash */
6688 if (unixptr == lastslash)
6691 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6692 /* Not needed when VMS is pretending to be UNIX. */
6694 /* Is this loop stuck because of too many dots? */
6695 if (loop_flag == 0) {
6696 /* Exit the loop and pass the rest through */
6701 /* Are we done with directories yet? */
6702 if (unixptr >= lastslash) {
6704 /* Watch out for trailing dots */
6713 if (*unixptr == '/')
6717 /* Have we stopped backing up? */
6722 /* dir_start continues to be = 1 */
6724 if (*unixptr == '-') {
6726 *vmsptr++ = *unixptr++;
6730 /* Now are we done with directories yet? */
6731 if (unixptr >= lastslash) {
6733 /* Watch out for trailing dots */
6749 if (unixptr >= unixend)
6752 /* Normal characters - More EFS work probably needed */
6758 /* remove multiple / */
6759 while (unixptr[1] == '/') {
6762 if (unixptr == lastslash) {
6763 /* Watch out for trailing dots */
6775 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6776 /* Not needed when VMS is pretending to be UNIX. */
6780 if (unixptr != unixend)
6785 if ((unixptr < lastdot) || (unixptr < lastslash) ||
6786 (&unixptr[1] == unixend)) {
6792 /* trailing dot ==> '^..' on VMS */
6793 if (unixptr == unixend) {
6801 *vmsptr++ = *unixptr++;
6805 if (quoted && (&unixptr[1] == unixend)) {
6809 in_cnt = copy_expand_unix_filename_escape
6810 (vmsptr, unixptr, &out_cnt, utf8_fl);
6820 in_cnt = copy_expand_unix_filename_escape
6821 (vmsptr, unixptr, &out_cnt, utf8_fl);
6828 /* Make sure directory is closed */
6829 if (unixptr == lastslash) {
6831 vmsptr2 = vmsptr - 1;
6833 if (*vmsptr2 != ']') {
6836 /* directories do not end in a dot bracket */
6837 if (*vmsptr2 == '.') {
6841 if (*vmsptr2 != '^') {
6842 vmsptr--; /* back up over the dot */
6850 /* Add a trailing dot if a file with no extension */
6851 vmsptr2 = vmsptr - 1;
6853 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6854 (*vmsptr2 != ')') && (*lastdot != '.')) {
6865 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6866 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6871 /* If a UTF8 flag is being passed, honor it */
6873 if (utf8_fl != NULL) {
6874 utf8_flag = *utf8_fl;
6879 /* If there is a possibility of UTF8, then if any UTF8 characters
6880 are present, then they must be converted to VTF-7
6882 result = strcpy(rslt, path); /* FIX-ME */
6885 result = strcpy(rslt, path);
6891 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6892 static char *mp_do_tovmsspec
6893 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6894 static char __tovmsspec_retbuf[VMS_MAXRSS];
6895 char *rslt, *dirend;
6900 unsigned long int infront = 0, hasdir = 1;
6903 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6904 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6906 if (path == NULL) return NULL;
6907 rslt_len = VMS_MAXRSS-1;
6908 if (buf) rslt = buf;
6909 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6910 else rslt = __tovmsspec_retbuf;
6912 /* '.' and '..' are "[]" and "[-]" for a quick check */
6913 if (path[0] == '.') {
6914 if (path[1] == '\0') {
6916 if (utf8_flag != NULL)
6921 if (path[1] == '.' && path[2] == '\0') {
6923 if (utf8_flag != NULL)
6930 /* Posix specifications are now a native VMS format */
6931 /*--------------------------------------------------*/
6932 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6933 if (decc_posix_compliant_pathnames) {
6934 if (strncmp(path,"\"^UP^",5) == 0) {
6935 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6941 /* This is really the only way to see if this is already in VMS format */
6942 sts = vms_split_path
6957 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6958 replacement, because the above parse just took care of most of
6959 what is needed to do vmspath when the specification is already
6962 And if it is not already, it is easier to do the conversion as
6963 part of this routine than to call this routine and then work on
6967 /* If VMS punctuation was found, it is already VMS format */
6968 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6969 if (utf8_flag != NULL)
6974 /* Now, what to do with trailing "." cases where there is no
6975 extension? If this is a UNIX specification, and EFS characters
6976 are enabled, then the trailing "." should be converted to a "^.".
6977 But if this was already a VMS specification, then it should be
6980 So in the case of ambiguity, leave the specification alone.
6984 /* If there is a possibility of UTF8, then if any UTF8 characters
6985 are present, then they must be converted to VTF-7
6987 if (utf8_flag != NULL)
6993 dirend = strrchr(path,'/');
6995 if (dirend == NULL) {
6996 /* If we get here with no UNIX directory delimiters, then this is
6997 not a complete file specification, either garbage a UNIX glob
6998 specification that can not be converted to a VMS wildcard, or
6999 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7000 so apparently other programs expect this also.
7002 utf8 flag setting needs to be preserved.
7008 /* If POSIX mode active, handle the conversion */
7009 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7010 if (decc_efs_charset) {
7011 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7016 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7017 if (!*(dirend+2)) dirend +=2;
7018 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7019 if (decc_efs_charset == 0) {
7020 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7026 lastdot = strrchr(cp2,'.');
7032 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7034 if (decc_disable_posix_root) {
7035 strcpy(rslt,"sys$disk:[000000]");
7038 strcpy(rslt,"sys$posix_root:[000000]");
7040 if (utf8_flag != NULL)
7044 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7046 trndev = PerlMem_malloc(VMS_MAXRSS);
7047 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7048 islnm = my_trnlnm(rslt,trndev,0);
7050 /* DECC special handling */
7052 if (strcmp(rslt,"bin") == 0) {
7053 strcpy(rslt,"sys$system");
7056 islnm = my_trnlnm(rslt,trndev,0);
7058 else if (strcmp(rslt,"tmp") == 0) {
7059 strcpy(rslt,"sys$scratch");
7062 islnm = my_trnlnm(rslt,trndev,0);
7064 else if (!decc_disable_posix_root) {
7065 strcpy(rslt, "sys$posix_root");
7069 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7070 islnm = my_trnlnm(rslt,trndev,0);
7072 else if (strcmp(rslt,"dev") == 0) {
7073 if (strncmp(cp2,"/null", 5) == 0) {
7074 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7075 strcpy(rslt,"NLA0");
7079 islnm = my_trnlnm(rslt,trndev,0);
7085 trnend = islnm ? strlen(trndev) - 1 : 0;
7086 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7087 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7088 /* If the first element of the path is a logical name, determine
7089 * whether it has to be translated so we can add more directories. */
7090 if (!islnm || rooted) {
7093 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7097 if (cp2 != dirend) {
7098 strcpy(rslt,trndev);
7099 cp1 = rslt + trnend;
7106 if (decc_disable_posix_root) {
7112 PerlMem_free(trndev);
7117 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7118 cp2 += 2; /* skip over "./" - it's redundant */
7119 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7121 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7122 *(cp1++) = '-'; /* "../" --> "-" */
7125 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7126 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7127 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7128 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7131 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7132 /* Escape the extra dots in EFS file specifications */
7135 if (cp2 > dirend) cp2 = dirend;
7137 else *(cp1++) = '.';
7139 for (; cp2 < dirend; cp2++) {
7141 if (*(cp2-1) == '/') continue;
7142 if (*(cp1-1) != '.') *(cp1++) = '.';
7145 else if (!infront && *cp2 == '.') {
7146 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7147 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7148 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7149 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7150 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7151 else { /* back up over previous directory name */
7153 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7154 if (*(cp1-1) == '[') {
7155 memcpy(cp1,"000000.",7);
7160 if (cp2 == dirend) break;
7162 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7163 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7164 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7165 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7167 *(cp1++) = '.'; /* Simulate trailing '/' */
7168 cp2 += 2; /* for loop will incr this to == dirend */
7170 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7173 if (decc_efs_charset == 0)
7174 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7176 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7182 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7184 if (decc_efs_charset == 0)
7191 else *(cp1++) = *cp2;
7195 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7196 if (hasdir) *(cp1++) = ']';
7197 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7198 /* fixme for ODS5 */
7205 if (decc_efs_charset == 0)
7216 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7217 decc_readdir_dropdotnotype) {
7222 /* trailing dot ==> '^..' on VMS */
7229 *(cp1++) = *(cp2++);
7234 /* This could be a macro to be passed through */
7235 *(cp1++) = *(cp2++);
7237 const char * save_cp2;
7241 /* paranoid check */
7247 *(cp1++) = *(cp2++);
7248 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7249 *(cp1++) = *(cp2++);
7250 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7251 *(cp1++) = *(cp2++);
7254 *(cp1++) = *(cp2++);
7258 if (is_macro == 0) {
7259 /* Not really a macro - never mind */
7289 *(cp1++) = *(cp2++);
7292 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7293 * which is wrong. UNIX notation should be ".dir." unless
7294 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7295 * changing this behavior could break more things at this time.
7296 * efs character set effectively does not allow "." to be a version
7297 * delimiter as a further complication about changing this.
7299 if (decc_filename_unix_report != 0) {
7302 *(cp1++) = *(cp2++);
7305 *(cp1++) = *(cp2++);
7308 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7312 /* Fix me for "^]", but that requires making sure that you do
7313 * not back up past the start of the filename
7315 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7320 if (utf8_flag != NULL)
7324 } /* end of do_tovmsspec() */
7326 /* External entry points */
7327 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7328 { return do_tovmsspec(path,buf,0,NULL); }
7329 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7330 { return do_tovmsspec(path,buf,1,NULL); }
7331 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7332 { return do_tovmsspec(path,buf,0,utf8_fl); }
7333 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7334 { return do_tovmsspec(path,buf,1,utf8_fl); }
7336 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7337 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7338 static char __tovmspath_retbuf[VMS_MAXRSS];
7340 char *pathified, *vmsified, *cp;
7342 if (path == NULL) return NULL;
7343 pathified = PerlMem_malloc(VMS_MAXRSS);
7344 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7345 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7346 PerlMem_free(pathified);
7352 Newx(vmsified, VMS_MAXRSS, char);
7353 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7354 PerlMem_free(pathified);
7355 if (vmsified) Safefree(vmsified);
7358 PerlMem_free(pathified);
7363 vmslen = strlen(vmsified);
7364 Newx(cp,vmslen+1,char);
7365 memcpy(cp,vmsified,vmslen);
7371 strcpy(__tovmspath_retbuf,vmsified);
7373 return __tovmspath_retbuf;
7376 } /* end of do_tovmspath() */
7378 /* External entry points */
7379 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7380 { return do_tovmspath(path,buf,0, NULL); }
7381 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7382 { return do_tovmspath(path,buf,1, NULL); }
7383 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7384 { return do_tovmspath(path,buf,0,utf8_fl); }
7385 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7386 { return do_tovmspath(path,buf,1,utf8_fl); }
7389 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7390 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7391 static char __tounixpath_retbuf[VMS_MAXRSS];
7393 char *pathified, *unixified, *cp;
7395 if (path == NULL) return NULL;
7396 pathified = PerlMem_malloc(VMS_MAXRSS);
7397 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7398 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7399 PerlMem_free(pathified);
7405 Newx(unixified, VMS_MAXRSS, char);
7407 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7408 PerlMem_free(pathified);
7409 if (unixified) Safefree(unixified);
7412 PerlMem_free(pathified);
7417 unixlen = strlen(unixified);
7418 Newx(cp,unixlen+1,char);
7419 memcpy(cp,unixified,unixlen);
7421 Safefree(unixified);
7425 strcpy(__tounixpath_retbuf,unixified);
7426 Safefree(unixified);
7427 return __tounixpath_retbuf;
7430 } /* end of do_tounixpath() */
7432 /* External entry points */
7433 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7434 { return do_tounixpath(path,buf,0,NULL); }
7435 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7436 { return do_tounixpath(path,buf,1,NULL); }
7437 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7438 { return do_tounixpath(path,buf,0,utf8_fl); }
7439 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7440 { return do_tounixpath(path,buf,1,utf8_fl); }
7443 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
7445 *****************************************************************************
7447 * Copyright (C) 1989-1994 by *
7448 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7450 * Permission is hereby granted for the reproduction of this software, *
7451 * on condition that this copyright notice is included in the reproduction, *
7452 * and that such reproduction is not for purposes of profit or material *
7455 * 27-Aug-1994 Modified for inclusion in perl5 *
7456 * by Charles Bailey bailey@newman.upenn.edu *
7457 *****************************************************************************
7461 * getredirection() is intended to aid in porting C programs
7462 * to VMS (Vax-11 C). The native VMS environment does not support
7463 * '>' and '<' I/O redirection, or command line wild card expansion,
7464 * or a command line pipe mechanism using the '|' AND background
7465 * command execution '&'. All of these capabilities are provided to any
7466 * C program which calls this procedure as the first thing in the
7468 * The piping mechanism will probably work with almost any 'filter' type
7469 * of program. With suitable modification, it may useful for other
7470 * portability problems as well.
7472 * Author: Mark Pizzolato mark@infocomm.com
7476 struct list_item *next;
7480 static void add_item(struct list_item **head,
7481 struct list_item **tail,
7485 static void mp_expand_wild_cards(pTHX_ char *item,
7486 struct list_item **head,
7487 struct list_item **tail,
7490 static int background_process(pTHX_ int argc, char **argv);
7492 static void pipe_and_fork(pTHX_ char **cmargv);
7494 /*{{{ void getredirection(int *ac, char ***av)*/
7496 mp_getredirection(pTHX_ int *ac, char ***av)
7498 * Process vms redirection arg's. Exit if any error is seen.
7499 * If getredirection() processes an argument, it is erased
7500 * from the vector. getredirection() returns a new argc and argv value.
7501 * In the event that a background command is requested (by a trailing "&"),
7502 * this routine creates a background subprocess, and simply exits the program.
7504 * Warning: do not try to simplify the code for vms. The code
7505 * presupposes that getredirection() is called before any data is
7506 * read from stdin or written to stdout.
7508 * Normal usage is as follows:
7514 * getredirection(&argc, &argv);
7518 int argc = *ac; /* Argument Count */
7519 char **argv = *av; /* Argument Vector */
7520 char *ap; /* Argument pointer */
7521 int j; /* argv[] index */
7522 int item_count = 0; /* Count of Items in List */
7523 struct list_item *list_head = 0; /* First Item in List */
7524 struct list_item *list_tail; /* Last Item in List */
7525 char *in = NULL; /* Input File Name */
7526 char *out = NULL; /* Output File Name */
7527 char *outmode = "w"; /* Mode to Open Output File */
7528 char *err = NULL; /* Error File Name */
7529 char *errmode = "w"; /* Mode to Open Error File */
7530 int cmargc = 0; /* Piped Command Arg Count */
7531 char **cmargv = NULL;/* Piped Command Arg Vector */
7534 * First handle the case where the last thing on the line ends with
7535 * a '&'. This indicates the desire for the command to be run in a
7536 * subprocess, so we satisfy that desire.
7539 if (0 == strcmp("&", ap))
7540 exit(background_process(aTHX_ --argc, argv));
7541 if (*ap && '&' == ap[strlen(ap)-1])
7543 ap[strlen(ap)-1] = '\0';
7544 exit(background_process(aTHX_ argc, argv));
7547 * Now we handle the general redirection cases that involve '>', '>>',
7548 * '<', and pipes '|'.
7550 for (j = 0; j < argc; ++j)
7552 if (0 == strcmp("<", argv[j]))
7556 fprintf(stderr,"No input file after < on command line");
7557 exit(LIB$_WRONUMARG);
7562 if ('<' == *(ap = argv[j]))
7567 if (0 == strcmp(">", ap))
7571 fprintf(stderr,"No output file after > on command line");
7572 exit(LIB$_WRONUMARG);
7591 fprintf(stderr,"No output file after > or >> on command line");
7592 exit(LIB$_WRONUMARG);
7596 if (('2' == *ap) && ('>' == ap[1]))
7613 fprintf(stderr,"No output file after 2> or 2>> on command line");
7614 exit(LIB$_WRONUMARG);
7618 if (0 == strcmp("|", argv[j]))
7622 fprintf(stderr,"No command into which to pipe on command line");
7623 exit(LIB$_WRONUMARG);
7625 cmargc = argc-(j+1);
7626 cmargv = &argv[j+1];
7630 if ('|' == *(ap = argv[j]))
7638 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7641 * Allocate and fill in the new argument vector, Some Unix's terminate
7642 * the list with an extra null pointer.
7644 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7645 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7647 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7648 argv[j] = list_head->value;
7654 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7655 exit(LIB$_INVARGORD);
7657 pipe_and_fork(aTHX_ cmargv);
7660 /* Check for input from a pipe (mailbox) */
7662 if (in == NULL && 1 == isapipe(0))
7664 char mbxname[L_tmpnam];
7666 long int dvi_item = DVI$_DEVBUFSIZ;
7667 $DESCRIPTOR(mbxnam, "");
7668 $DESCRIPTOR(mbxdevnam, "");
7670 /* Input from a pipe, reopen it in binary mode to disable */
7671 /* carriage control processing. */
7673 fgetname(stdin, mbxname);
7674 mbxnam.dsc$a_pointer = mbxname;
7675 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7676 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7677 mbxdevnam.dsc$a_pointer = mbxname;
7678 mbxdevnam.dsc$w_length = sizeof(mbxname);
7679 dvi_item = DVI$_DEVNAM;
7680 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7681 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7684 freopen(mbxname, "rb", stdin);
7687 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7691 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7693 fprintf(stderr,"Can't open input file %s as stdin",in);
7696 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7698 fprintf(stderr,"Can't open output file %s as stdout",out);
7701 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7704 if (strcmp(err,"&1") == 0) {
7705 dup2(fileno(stdout), fileno(stderr));
7706 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7709 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7711 fprintf(stderr,"Can't open error file %s as stderr",err);
7715 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7719 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7722 #ifdef ARGPROC_DEBUG
7723 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7724 for (j = 0; j < *ac; ++j)
7725 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7727 /* Clear errors we may have hit expanding wildcards, so they don't
7728 show up in Perl's $! later */
7729 set_errno(0); set_vaxc_errno(1);
7730 } /* end of getredirection() */
7733 static void add_item(struct list_item **head,
7734 struct list_item **tail,
7740 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7741 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7745 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7746 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7747 *tail = (*tail)->next;
7749 (*tail)->value = value;
7753 static void mp_expand_wild_cards(pTHX_ char *item,
7754 struct list_item **head,
7755 struct list_item **tail,
7759 unsigned long int context = 0;
7767 $DESCRIPTOR(filespec, "");
7768 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7769 $DESCRIPTOR(resultspec, "");
7770 unsigned long int lff_flags = 0;
7774 #ifdef VMS_LONGNAME_SUPPORT
7775 lff_flags = LIB$M_FIL_LONG_NAMES;
7778 for (cp = item; *cp; cp++) {
7779 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7780 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7782 if (!*cp || isspace(*cp))
7784 add_item(head, tail, item, count);
7789 /* "double quoted" wild card expressions pass as is */
7790 /* From DCL that means using e.g.: */
7791 /* perl program """perl.*""" */
7792 item_len = strlen(item);
7793 if ( '"' == *item && '"' == item[item_len-1] )
7796 item[item_len-2] = '\0';
7797 add_item(head, tail, item, count);
7801 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7802 resultspec.dsc$b_class = DSC$K_CLASS_D;
7803 resultspec.dsc$a_pointer = NULL;
7804 vmsspec = PerlMem_malloc(VMS_MAXRSS);
7805 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7806 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7807 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7808 if (!isunix || !filespec.dsc$a_pointer)
7809 filespec.dsc$a_pointer = item;
7810 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7812 * Only return version specs, if the caller specified a version
7814 had_version = strchr(item, ';');
7816 * Only return device and directory specs, if the caller specifed either.
7818 had_device = strchr(item, ':');
7819 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7821 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7822 (&filespec, &resultspec, &context,
7823 &defaultspec, 0, &rms_sts, &lff_flags)))
7828 string = PerlMem_malloc(resultspec.dsc$w_length+1);
7829 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7830 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7831 string[resultspec.dsc$w_length] = '\0';
7832 if (NULL == had_version)
7833 *(strrchr(string, ';')) = '\0';
7834 if ((!had_directory) && (had_device == NULL))
7836 if (NULL == (devdir = strrchr(string, ']')))
7837 devdir = strrchr(string, '>');
7838 strcpy(string, devdir + 1);
7841 * Be consistent with what the C RTL has already done to the rest of
7842 * the argv items and lowercase all of these names.
7844 if (!decc_efs_case_preserve) {
7845 for (c = string; *c; ++c)
7849 if (isunix) trim_unixpath(string,item,1);
7850 add_item(head, tail, string, count);
7853 PerlMem_free(vmsspec);
7854 if (sts != RMS$_NMF)
7856 set_vaxc_errno(sts);
7859 case RMS$_FNF: case RMS$_DNF:
7860 set_errno(ENOENT); break;
7862 set_errno(ENOTDIR); break;
7864 set_errno(ENODEV); break;
7865 case RMS$_FNM: case RMS$_SYN:
7866 set_errno(EINVAL); break;
7868 set_errno(EACCES); break;
7870 _ckvmssts_noperl(sts);
7874 add_item(head, tail, item, count);
7875 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7876 _ckvmssts_noperl(lib$find_file_end(&context));
7879 static int child_st[2];/* Event Flag set when child process completes */
7881 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
7883 static unsigned long int exit_handler(int *status)
7887 if (0 == child_st[0])
7889 #ifdef ARGPROC_DEBUG
7890 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7892 fflush(stdout); /* Have to flush pipe for binary data to */
7893 /* terminate properly -- <tp@mccall.com> */
7894 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7895 sys$dassgn(child_chan);
7897 sys$synch(0, child_st);
7902 static void sig_child(int chan)
7904 #ifdef ARGPROC_DEBUG
7905 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7907 if (child_st[0] == 0)
7911 static struct exit_control_block exit_block =
7916 &exit_block.exit_status,
7921 pipe_and_fork(pTHX_ char **cmargv)
7924 struct dsc$descriptor_s *vmscmd;
7925 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7926 int sts, j, l, ismcr, quote, tquote = 0;
7928 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
7929 vms_execfree(vmscmd);
7934 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7935 && toupper(*(q+2)) == 'R' && !*(q+3);
7937 while (q && l < MAX_DCL_LINE_LENGTH) {
7939 if (j > 0 && quote) {
7945 if (ismcr && j > 1) quote = 1;
7946 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7949 if (quote || tquote) {
7955 if ((quote||tquote) && *q == '"') {
7965 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7967 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7971 static int background_process(pTHX_ int argc, char **argv)
7973 char command[MAX_DCL_SYMBOL + 1] = "$";
7974 $DESCRIPTOR(value, "");
7975 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7976 static $DESCRIPTOR(null, "NLA0:");
7977 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7979 $DESCRIPTOR(pidstr, "");
7981 unsigned long int flags = 17, one = 1, retsts;
7984 strcat(command, argv[0]);
7985 len = strlen(command);
7986 while (--argc && (len < MAX_DCL_SYMBOL))
7988 strcat(command, " \"");
7989 strcat(command, *(++argv));
7990 strcat(command, "\"");
7991 len = strlen(command);
7993 value.dsc$a_pointer = command;
7994 value.dsc$w_length = strlen(value.dsc$a_pointer);
7995 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7996 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7997 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7998 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8001 _ckvmssts_noperl(retsts);
8003 #ifdef ARGPROC_DEBUG
8004 PerlIO_printf(Perl_debug_log, "%s\n", command);
8006 sprintf(pidstring, "%08X", pid);
8007 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8008 pidstr.dsc$a_pointer = pidstring;
8009 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8010 lib$set_symbol(&pidsymbol, &pidstr);
8014 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8017 /* OS-specific initialization at image activation (not thread startup) */
8018 /* Older VAXC header files lack these constants */
8019 #ifndef JPI$_RIGHTS_SIZE
8020 # define JPI$_RIGHTS_SIZE 817
8022 #ifndef KGB$M_SUBSYSTEM
8023 # define KGB$M_SUBSYSTEM 0x8
8026 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8028 /*{{{void vms_image_init(int *, char ***)*/
8030 vms_image_init(int *argcp, char ***argvp)
8032 char eqv[LNM$C_NAMLENGTH+1] = "";
8033 unsigned int len, tabct = 8, tabidx = 0;
8034 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8035 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8036 unsigned short int dummy, rlen;
8037 struct dsc$descriptor_s **tabvec;
8038 #if defined(PERL_IMPLICIT_CONTEXT)
8041 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8042 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8043 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8046 #ifdef KILL_BY_SIGPRC
8047 Perl_csighandler_init();
8050 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8051 _ckvmssts_noperl(iosb[0]);
8052 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8053 if (iprv[i]) { /* Running image installed with privs? */
8054 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8059 /* Rights identifiers might trigger tainting as well. */
8060 if (!will_taint && (rlen || rsz)) {
8061 while (rlen < rsz) {
8062 /* We didn't get all the identifiers on the first pass. Allocate a
8063 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8064 * were needed to hold all identifiers at time of last call; we'll
8065 * allocate that many unsigned long ints), and go back and get 'em.
8066 * If it gave us less than it wanted to despite ample buffer space,
8067 * something's broken. Is your system missing a system identifier?
8069 if (rsz <= jpilist[1].buflen) {
8070 /* Perl_croak accvios when used this early in startup. */
8071 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8072 rsz, (unsigned long) jpilist[1].buflen,
8073 "Check your rights database for corruption.\n");
8076 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8077 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8078 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8079 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8080 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8081 _ckvmssts_noperl(iosb[0]);
8083 mask = jpilist[1].bufadr;
8084 /* Check attribute flags for each identifier (2nd longword); protected
8085 * subsystem identifiers trigger tainting.
8087 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8088 if (mask[i] & KGB$M_SUBSYSTEM) {
8093 if (mask != rlst) PerlMem_free(mask);
8096 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8097 * logical, some versions of the CRTL will add a phanthom /000000/
8098 * directory. This needs to be removed.
8100 if (decc_filename_unix_report) {
8103 ulen = strlen(argvp[0][0]);
8105 zeros = strstr(argvp[0][0], "/000000/");
8106 if (zeros != NULL) {
8108 mlen = ulen - (zeros - argvp[0][0]) - 7;
8109 memmove(zeros, &zeros[7], mlen);
8111 argvp[0][0][ulen] = '\0';
8114 /* It also may have a trailing dot that needs to be removed otherwise
8115 * it will be converted to VMS mode incorrectly.
8118 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8119 argvp[0][0][ulen] = '\0';
8122 /* We need to use this hack to tell Perl it should run with tainting,
8123 * since its tainting flag may be part of the PL_curinterp struct, which
8124 * hasn't been allocated when vms_image_init() is called.
8127 char **newargv, **oldargv;
8129 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8130 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8131 newargv[0] = oldargv[0];
8132 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8133 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8134 strcpy(newargv[1], "-T");
8135 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8137 newargv[*argcp] = NULL;
8138 /* We orphan the old argv, since we don't know where it's come from,
8139 * so we don't know how to free it.
8143 else { /* Did user explicitly request tainting? */
8145 char *cp, **av = *argvp;
8146 for (i = 1; i < *argcp; i++) {
8147 if (*av[i] != '-') break;
8148 for (cp = av[i]+1; *cp; cp++) {
8149 if (*cp == 'T') { will_taint = 1; break; }
8150 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8151 strchr("DFIiMmx",*cp)) break;
8153 if (will_taint) break;
8158 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8161 tabvec = (struct dsc$descriptor_s **)
8162 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8163 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8165 else if (tabidx >= tabct) {
8167 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8168 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8170 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8171 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8172 tabvec[tabidx]->dsc$w_length = 0;
8173 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8174 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8175 tabvec[tabidx]->dsc$a_pointer = NULL;
8176 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8178 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8180 getredirection(argcp,argvp);
8181 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8183 # include <reentrancy.h>
8184 decc$set_reentrancy(C$C_MULTITHREAD);
8193 * Trim Unix-style prefix off filespec, so it looks like what a shell
8194 * glob expansion would return (i.e. from specified prefix on, not
8195 * full path). Note that returned filespec is Unix-style, regardless
8196 * of whether input filespec was VMS-style or Unix-style.
8198 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8199 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8200 * vector of options; at present, only bit 0 is used, and if set tells
8201 * trim unixpath to try the current default directory as a prefix when
8202 * presented with a possibly ambiguous ... wildcard.
8204 * Returns !=0 on success, with trimmed filespec replacing contents of
8205 * fspec, and 0 on failure, with contents of fpsec unchanged.
8207 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8209 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8211 char *unixified, *unixwild,
8212 *template, *base, *end, *cp1, *cp2;
8213 register int tmplen, reslen = 0, dirs = 0;
8215 unixwild = PerlMem_malloc(VMS_MAXRSS);
8216 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8217 if (!wildspec || !fspec) return 0;
8218 template = unixwild;
8219 if (strpbrk(wildspec,"]>:") != NULL) {
8220 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8221 PerlMem_free(unixwild);
8226 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8227 unixwild[VMS_MAXRSS-1] = 0;
8229 unixified = PerlMem_malloc(VMS_MAXRSS);
8230 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8231 if (strpbrk(fspec,"]>:") != NULL) {
8232 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8233 PerlMem_free(unixwild);
8234 PerlMem_free(unixified);
8237 else base = unixified;
8238 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8239 * check to see that final result fits into (isn't longer than) fspec */
8240 reslen = strlen(fspec);
8244 /* No prefix or absolute path on wildcard, so nothing to remove */
8245 if (!*template || *template == '/') {
8246 PerlMem_free(unixwild);
8247 if (base == fspec) {
8248 PerlMem_free(unixified);
8251 tmplen = strlen(unixified);
8252 if (tmplen > reslen) {
8253 PerlMem_free(unixified);
8254 return 0; /* not enough space */
8256 /* Copy unixified resultant, including trailing NUL */
8257 memmove(fspec,unixified,tmplen+1);
8258 PerlMem_free(unixified);
8262 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8263 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8264 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8265 for (cp1 = end ;cp1 >= base; cp1--)
8266 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8268 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8269 PerlMem_free(unixified);
8270 PerlMem_free(unixwild);
8275 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8276 int ells = 1, totells, segdirs, match;
8277 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8278 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8280 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8282 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8283 tpl = PerlMem_malloc(VMS_MAXRSS);
8284 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8285 if (ellipsis == template && opts & 1) {
8286 /* Template begins with an ellipsis. Since we can't tell how many
8287 * directory names at the front of the resultant to keep for an
8288 * arbitrary starting point, we arbitrarily choose the current
8289 * default directory as a starting point. If it's there as a prefix,
8290 * clip it off. If not, fall through and act as if the leading
8291 * ellipsis weren't there (i.e. return shortest possible path that
8292 * could match template).
8294 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8296 PerlMem_free(unixified);
8297 PerlMem_free(unixwild);
8300 if (!decc_efs_case_preserve) {
8301 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8302 if (_tolower(*cp1) != _tolower(*cp2)) break;
8304 segdirs = dirs - totells; /* Min # of dirs we must have left */
8305 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8306 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8307 memmove(fspec,cp2+1,end - cp2);
8309 PerlMem_free(unixified);
8310 PerlMem_free(unixwild);
8314 /* First off, back up over constant elements at end of path */
8316 for (front = end ; front >= base; front--)
8317 if (*front == '/' && !dirs--) { front++; break; }
8319 lcres = PerlMem_malloc(VMS_MAXRSS);
8320 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8321 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8323 if (!decc_efs_case_preserve) {
8324 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8332 PerlMem_free(unixified);
8333 PerlMem_free(unixwild);
8334 PerlMem_free(lcres);
8335 return 0; /* Path too long. */
8338 *cp2 = '\0'; /* Pick up with memcpy later */
8339 lcfront = lcres + (front - base);
8340 /* Now skip over each ellipsis and try to match the path in front of it. */
8342 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8343 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8344 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8345 if (cp1 < template) break; /* template started with an ellipsis */
8346 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8347 ellipsis = cp1; continue;
8349 wilddsc.dsc$a_pointer = tpl;
8350 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8352 for (segdirs = 0, cp2 = tpl;
8353 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8355 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8357 if (!decc_efs_case_preserve) {
8358 *cp2 = _tolower(*cp1); /* else lowercase for match */
8361 *cp2 = *cp1; /* else preserve case for match */
8364 if (*cp2 == '/') segdirs++;
8366 if (cp1 != ellipsis - 1) {
8368 PerlMem_free(unixified);
8369 PerlMem_free(unixwild);
8370 PerlMem_free(lcres);
8371 return 0; /* Path too long */
8373 /* Back up at least as many dirs as in template before matching */
8374 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8375 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8376 for (match = 0; cp1 > lcres;) {
8377 resdsc.dsc$a_pointer = cp1;
8378 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8380 if (match == 1) lcfront = cp1;
8382 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8386 PerlMem_free(unixified);
8387 PerlMem_free(unixwild);
8388 PerlMem_free(lcres);
8389 return 0; /* Can't find prefix ??? */
8391 if (match > 1 && opts & 1) {
8392 /* This ... wildcard could cover more than one set of dirs (i.e.
8393 * a set of similar dir names is repeated). If the template
8394 * contains more than 1 ..., upstream elements could resolve the
8395 * ambiguity, but it's not worth a full backtracking setup here.
8396 * As a quick heuristic, clip off the current default directory
8397 * if it's present to find the trimmed spec, else use the
8398 * shortest string that this ... could cover.
8400 char def[NAM$C_MAXRSS+1], *st;
8402 if (getcwd(def, sizeof def,0) == NULL) {
8403 Safefree(unixified);
8409 if (!decc_efs_case_preserve) {
8410 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8411 if (_tolower(*cp1) != _tolower(*cp2)) break;
8413 segdirs = dirs - totells; /* Min # of dirs we must have left */
8414 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8415 if (*cp1 == '\0' && *cp2 == '/') {
8416 memmove(fspec,cp2+1,end - cp2);
8418 PerlMem_free(unixified);
8419 PerlMem_free(unixwild);
8420 PerlMem_free(lcres);
8423 /* Nope -- stick with lcfront from above and keep going. */
8426 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8428 PerlMem_free(unixified);
8429 PerlMem_free(unixwild);
8430 PerlMem_free(lcres);
8435 } /* end of trim_unixpath() */
8440 * VMS readdir() routines.
8441 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8443 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8444 * Minor modifications to original routines.
8447 /* readdir may have been redefined by reentr.h, so make sure we get
8448 * the local version for what we do here.
8453 #if !defined(PERL_IMPLICIT_CONTEXT)
8454 # define readdir Perl_readdir
8456 # define readdir(a) Perl_readdir(aTHX_ a)
8459 /* Number of elements in vms_versions array */
8460 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8463 * Open a directory, return a handle for later use.
8465 /*{{{ DIR *opendir(char*name) */
8467 Perl_opendir(pTHX_ const char *name)
8475 if (decc_efs_charset) {
8476 unix_flag = is_unix_filespec(name);
8479 Newx(dir, VMS_MAXRSS, char);
8480 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8484 /* Check access before stat; otherwise stat does not
8485 * accurately report whether it's a directory.
8487 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8488 /* cando_by_name has already set errno */
8492 if (flex_stat(dir,&sb) == -1) return NULL;
8493 if (!S_ISDIR(sb.st_mode)) {
8495 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8498 /* Get memory for the handle, and the pattern. */
8500 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8502 /* Fill in the fields; mainly playing with the descriptor. */
8503 sprintf(dd->pattern, "%s*.*",dir);
8509 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8510 dd->pat.dsc$a_pointer = dd->pattern;
8511 dd->pat.dsc$w_length = strlen(dd->pattern);
8512 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8513 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8514 #if defined(USE_ITHREADS)
8515 Newx(dd->mutex,1,perl_mutex);
8516 MUTEX_INIT( (perl_mutex *) dd->mutex );
8522 } /* end of opendir() */
8526 * Set the flag to indicate we want versions or not.
8528 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8530 vmsreaddirversions(DIR *dd, int flag)
8533 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8535 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8540 * Free up an opened directory.
8542 /*{{{ void closedir(DIR *dd)*/
8544 Perl_closedir(DIR *dd)
8548 sts = lib$find_file_end(&dd->context);
8549 Safefree(dd->pattern);
8550 #if defined(USE_ITHREADS)
8551 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8552 Safefree(dd->mutex);
8559 * Collect all the version numbers for the current file.
8562 collectversions(pTHX_ DIR *dd)
8564 struct dsc$descriptor_s pat;
8565 struct dsc$descriptor_s res;
8567 char *p, *text, *buff;
8569 unsigned long context, tmpsts;
8571 /* Convenient shorthand. */
8574 /* Add the version wildcard, ignoring the "*.*" put on before */
8575 i = strlen(dd->pattern);
8576 Newx(text,i + e->d_namlen + 3,char);
8577 strcpy(text, dd->pattern);
8578 sprintf(&text[i - 3], "%s;*", e->d_name);
8580 /* Set up the pattern descriptor. */
8581 pat.dsc$a_pointer = text;
8582 pat.dsc$w_length = i + e->d_namlen - 1;
8583 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8584 pat.dsc$b_class = DSC$K_CLASS_S;
8586 /* Set up result descriptor. */
8587 Newx(buff, VMS_MAXRSS, char);
8588 res.dsc$a_pointer = buff;
8589 res.dsc$w_length = VMS_MAXRSS - 1;
8590 res.dsc$b_dtype = DSC$K_DTYPE_T;
8591 res.dsc$b_class = DSC$K_CLASS_S;
8593 /* Read files, collecting versions. */
8594 for (context = 0, e->vms_verscount = 0;
8595 e->vms_verscount < VERSIZE(e);
8596 e->vms_verscount++) {
8598 unsigned long flags = 0;
8600 #ifdef VMS_LONGNAME_SUPPORT
8601 flags = LIB$M_FIL_LONG_NAMES;
8603 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8604 if (tmpsts == RMS$_NMF || context == 0) break;
8606 buff[VMS_MAXRSS - 1] = '\0';
8607 if ((p = strchr(buff, ';')))
8608 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8610 e->vms_versions[e->vms_verscount] = -1;
8613 _ckvmssts(lib$find_file_end(&context));
8617 } /* end of collectversions() */
8620 * Read the next entry from the directory.
8622 /*{{{ struct dirent *readdir(DIR *dd)*/
8624 Perl_readdir(pTHX_ DIR *dd)
8626 struct dsc$descriptor_s res;
8628 unsigned long int tmpsts;
8630 unsigned long flags = 0;
8631 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8632 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8634 /* Set up result descriptor, and get next file. */
8635 Newx(buff, VMS_MAXRSS, char);
8636 res.dsc$a_pointer = buff;
8637 res.dsc$w_length = VMS_MAXRSS - 1;
8638 res.dsc$b_dtype = DSC$K_DTYPE_T;
8639 res.dsc$b_class = DSC$K_CLASS_S;
8641 #ifdef VMS_LONGNAME_SUPPORT
8642 flags = LIB$M_FIL_LONG_NAMES;
8645 tmpsts = lib$find_file
8646 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8647 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8648 if (!(tmpsts & 1)) {
8649 set_vaxc_errno(tmpsts);
8652 set_errno(EACCES); break;
8654 set_errno(ENODEV); break;
8656 set_errno(ENOTDIR); break;
8657 case RMS$_FNF: case RMS$_DNF:
8658 set_errno(ENOENT); break;
8666 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8667 if (!decc_efs_case_preserve) {
8668 buff[VMS_MAXRSS - 1] = '\0';
8669 for (p = buff; *p; p++) *p = _tolower(*p);
8672 /* we don't want to force to lowercase, just null terminate */
8673 buff[res.dsc$w_length] = '\0';
8675 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8678 /* Skip any directory component and just copy the name. */
8679 sts = vms_split_path
8694 /* Drop NULL extensions on UNIX file specification */
8695 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8696 (e_len == 1) && decc_readdir_dropdotnotype)) {
8701 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8702 dd->entry.d_name[n_len + e_len] = '\0';
8703 dd->entry.d_namlen = strlen(dd->entry.d_name);
8705 /* Convert the filename to UNIX format if needed */
8706 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8708 /* Translate the encoded characters. */
8709 /* Fixme: unicode handling could result in embedded 0 characters */
8710 if (strchr(dd->entry.d_name, '^') != NULL) {
8714 p = dd->entry.d_name;
8718 x = copy_expand_vms_filename_escape(q, p, &y);
8722 /* if y > 1, then this is a wide file specification */
8723 /* Wide file specifications need to be passed in Perl */
8724 /* counted strings apparently with a unicode flag */
8727 strcpy(dd->entry.d_name, new_name);
8731 dd->entry.vms_verscount = 0;
8732 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8736 } /* end of readdir() */
8740 * Read the next entry from the directory -- thread-safe version.
8742 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8744 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8748 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8750 entry = readdir(dd);
8752 retval = ( *result == NULL ? errno : 0 );
8754 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8758 } /* end of readdir_r() */
8762 * Return something that can be used in a seekdir later.
8764 /*{{{ long telldir(DIR *dd)*/
8766 Perl_telldir(DIR *dd)
8773 * Return to a spot where we used to be. Brute force.
8775 /*{{{ void seekdir(DIR *dd,long count)*/
8777 Perl_seekdir(pTHX_ DIR *dd, long count)
8781 /* If we haven't done anything yet... */
8785 /* Remember some state, and clear it. */
8786 old_flags = dd->flags;
8787 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8788 _ckvmssts(lib$find_file_end(&dd->context));
8791 /* The increment is in readdir(). */
8792 for (dd->count = 0; dd->count < count; )
8795 dd->flags = old_flags;
8797 } /* end of seekdir() */
8800 /* VMS subprocess management
8802 * my_vfork() - just a vfork(), after setting a flag to record that
8803 * the current script is trying a Unix-style fork/exec.
8805 * vms_do_aexec() and vms_do_exec() are called in response to the
8806 * perl 'exec' function. If this follows a vfork call, then they
8807 * call out the regular perl routines in doio.c which do an
8808 * execvp (for those who really want to try this under VMS).
8809 * Otherwise, they do exactly what the perl docs say exec should
8810 * do - terminate the current script and invoke a new command
8811 * (See below for notes on command syntax.)
8813 * do_aspawn() and do_spawn() implement the VMS side of the perl
8814 * 'system' function.
8816 * Note on command arguments to perl 'exec' and 'system': When handled
8817 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8818 * are concatenated to form a DCL command string. If the first arg
8819 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8820 * the command string is handed off to DCL directly. Otherwise,
8821 * the first token of the command is taken as the filespec of an image
8822 * to run. The filespec is expanded using a default type of '.EXE' and
8823 * the process defaults for device, directory, etc., and if found, the resultant
8824 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8825 * the command string as parameters. This is perhaps a bit complicated,
8826 * but I hope it will form a happy medium between what VMS folks expect
8827 * from lib$spawn and what Unix folks expect from exec.
8830 static int vfork_called;
8832 /*{{{int my_vfork()*/
8843 vms_execfree(struct dsc$descriptor_s *vmscmd)
8846 if (vmscmd->dsc$a_pointer) {
8847 PerlMem_free(vmscmd->dsc$a_pointer);
8849 PerlMem_free(vmscmd);
8854 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8856 char *junk, *tmps = Nullch;
8857 register size_t cmdlen = 0;
8864 tmps = SvPV(really,rlen);
8871 for (idx++; idx <= sp; idx++) {
8873 junk = SvPVx(*idx,rlen);
8874 cmdlen += rlen ? rlen + 1 : 0;
8877 Newx(PL_Cmd, cmdlen+1, char);
8879 if (tmps && *tmps) {
8880 strcpy(PL_Cmd,tmps);
8883 else *PL_Cmd = '\0';
8884 while (++mark <= sp) {
8886 char *s = SvPVx(*mark,n_a);
8888 if (*PL_Cmd) strcat(PL_Cmd," ");
8894 } /* end of setup_argstr() */
8897 static unsigned long int
8898 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8899 struct dsc$descriptor_s **pvmscmd)
8901 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8902 char image_name[NAM$C_MAXRSS+1];
8903 char image_argv[NAM$C_MAXRSS+1];
8904 $DESCRIPTOR(defdsc,".EXE");
8905 $DESCRIPTOR(defdsc2,".");
8906 $DESCRIPTOR(resdsc,resspec);
8907 struct dsc$descriptor_s *vmscmd;
8908 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8909 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8910 register char *s, *rest, *cp, *wordbreak;
8915 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8916 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8918 /* Make a copy for modification */
8919 cmdlen = strlen(incmd);
8920 cmd = PerlMem_malloc(cmdlen+1);
8921 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8922 strncpy(cmd, incmd, cmdlen);
8927 vmscmd->dsc$a_pointer = NULL;
8928 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8929 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8930 vmscmd->dsc$w_length = 0;
8931 if (pvmscmd) *pvmscmd = vmscmd;
8933 if (suggest_quote) *suggest_quote = 0;
8935 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8937 return CLI$_BUFOVF; /* continuation lines currently unsupported */
8942 while (*s && isspace(*s)) s++;
8944 if (*s == '@' || *s == '$') {
8945 vmsspec[0] = *s; rest = s + 1;
8946 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8948 else { cp = vmsspec; rest = s; }
8949 if (*rest == '.' || *rest == '/') {
8952 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8953 rest++, cp2++) *cp2 = *rest;
8955 if (do_tovmsspec(resspec,cp,0,NULL)) {
8958 for (cp2 = vmsspec + strlen(vmsspec);
8959 *rest && cp2 - vmsspec < sizeof vmsspec;
8960 rest++, cp2++) *cp2 = *rest;
8965 /* Intuit whether verb (first word of cmd) is a DCL command:
8966 * - if first nonspace char is '@', it's a DCL indirection
8968 * - if verb contains a filespec separator, it's not a DCL command
8969 * - if it doesn't, caller tells us whether to default to a DCL
8970 * command, or to a local image unless told it's DCL (by leading '$')
8974 if (suggest_quote) *suggest_quote = 1;
8976 register char *filespec = strpbrk(s,":<[.;");
8977 rest = wordbreak = strpbrk(s," \"\t/");
8978 if (!wordbreak) wordbreak = s + strlen(s);
8979 if (*s == '$') check_img = 0;
8980 if (filespec && (filespec < wordbreak)) isdcl = 0;
8981 else isdcl = !check_img;
8986 imgdsc.dsc$a_pointer = s;
8987 imgdsc.dsc$w_length = wordbreak - s;
8988 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8990 _ckvmssts(lib$find_file_end(&cxt));
8991 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8992 if (!(retsts & 1) && *s == '$') {
8993 _ckvmssts(lib$find_file_end(&cxt));
8994 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8995 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8997 _ckvmssts(lib$find_file_end(&cxt));
8998 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9002 _ckvmssts(lib$find_file_end(&cxt));
9007 while (*s && !isspace(*s)) s++;
9010 /* check that it's really not DCL with no file extension */
9011 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9013 char b[256] = {0,0,0,0};
9014 read(fileno(fp), b, 256);
9015 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9019 /* Check for script */
9021 if ((b[0] == '#') && (b[1] == '!'))
9023 #ifdef ALTERNATE_SHEBANG
9025 shebang_len = strlen(ALTERNATE_SHEBANG);
9026 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9028 perlstr = strstr("perl",b);
9029 if (perlstr == NULL)
9037 if (shebang_len > 0) {
9040 char tmpspec[NAM$C_MAXRSS + 1];
9043 /* Image is following after white space */
9044 /*--------------------------------------*/
9045 while (isprint(b[i]) && isspace(b[i]))
9049 while (isprint(b[i]) && !isspace(b[i])) {
9050 tmpspec[j++] = b[i++];
9051 if (j >= NAM$C_MAXRSS)
9056 /* There may be some default parameters to the image */
9057 /*---------------------------------------------------*/
9059 while (isprint(b[i])) {
9060 image_argv[j++] = b[i++];
9061 if (j >= NAM$C_MAXRSS)
9064 while ((j > 0) && !isprint(image_argv[j-1]))
9068 /* It will need to be converted to VMS format and validated */
9069 if (tmpspec[0] != '\0') {
9072 /* Try to find the exact program requested to be run */
9073 /*---------------------------------------------------*/
9074 iname = do_rmsexpand
9075 (tmpspec, image_name, 0, ".exe",
9076 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9077 if (iname != NULL) {
9078 if (cando_by_name_int
9079 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9080 /* MCR prefix needed */
9084 /* Try again with a null type */
9085 /*----------------------------*/
9086 iname = do_rmsexpand
9087 (tmpspec, image_name, 0, ".",
9088 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9089 if (iname != NULL) {
9090 if (cando_by_name_int
9091 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9092 /* MCR prefix needed */
9098 /* Did we find the image to run the script? */
9099 /*------------------------------------------*/
9103 /* Assume DCL or foreign command exists */
9104 /*--------------------------------------*/
9105 tchr = strrchr(tmpspec, '/');
9112 strcpy(image_name, tchr);
9120 if (check_img && isdcl) return RMS$_FNF;
9122 if (cando_by_name(S_IXUSR,0,resspec)) {
9123 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9124 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9126 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9127 if (image_name[0] != 0) {
9128 strcat(vmscmd->dsc$a_pointer, image_name);
9129 strcat(vmscmd->dsc$a_pointer, " ");
9131 } else if (image_name[0] != 0) {
9132 strcpy(vmscmd->dsc$a_pointer, image_name);
9133 strcat(vmscmd->dsc$a_pointer, " ");
9135 strcpy(vmscmd->dsc$a_pointer,"@");
9137 if (suggest_quote) *suggest_quote = 1;
9139 /* If there is an image name, use original command */
9140 if (image_name[0] == 0)
9141 strcat(vmscmd->dsc$a_pointer,resspec);
9144 while (*rest && isspace(*rest)) rest++;
9147 if (image_argv[0] != 0) {
9148 strcat(vmscmd->dsc$a_pointer,image_argv);
9149 strcat(vmscmd->dsc$a_pointer, " ");
9155 rest_len = strlen(rest);
9156 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9157 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9158 strcat(vmscmd->dsc$a_pointer,rest);
9160 retsts = CLI$_BUFOVF;
9162 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9164 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9170 /* It's either a DCL command or we couldn't find a suitable image */
9171 vmscmd->dsc$w_length = strlen(cmd);
9173 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9174 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9175 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9179 /* check if it's a symbol (for quoting purposes) */
9180 if (suggest_quote && !*suggest_quote) {
9182 char equiv[LNM$C_NAMLENGTH];
9183 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9184 eqvdsc.dsc$a_pointer = equiv;
9186 iss = lib$get_symbol(vmscmd,&eqvdsc);
9187 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9189 if (!(retsts & 1)) {
9190 /* just hand off status values likely to be due to user error */
9191 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9192 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9193 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9194 else { _ckvmssts(retsts); }
9197 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9199 } /* end of setup_cmddsc() */
9202 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9204 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9210 if (vfork_called) { /* this follows a vfork - act Unixish */
9212 if (vfork_called < 0) {
9213 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9216 else return do_aexec(really,mark,sp);
9218 /* no vfork - act VMSish */
9219 cmd = setup_argstr(aTHX_ really,mark,sp);
9220 exec_sts = vms_do_exec(cmd);
9221 Safefree(cmd); /* Clean up from setup_argstr() */
9226 } /* end of vms_do_aexec() */
9229 /* {{{bool vms_do_exec(char *cmd) */
9231 Perl_vms_do_exec(pTHX_ const char *cmd)
9233 struct dsc$descriptor_s *vmscmd;
9235 if (vfork_called) { /* this follows a vfork - act Unixish */
9237 if (vfork_called < 0) {
9238 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9241 else return do_exec(cmd);
9244 { /* no vfork - act VMSish */
9245 unsigned long int retsts;
9248 TAINT_PROPER("exec");
9249 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9250 retsts = lib$do_command(vmscmd);
9253 case RMS$_FNF: case RMS$_DNF:
9254 set_errno(ENOENT); break;
9256 set_errno(ENOTDIR); break;
9258 set_errno(ENODEV); break;
9260 set_errno(EACCES); break;
9262 set_errno(EINVAL); break;
9263 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9264 set_errno(E2BIG); break;
9265 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9266 _ckvmssts(retsts); /* fall through */
9267 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9270 set_vaxc_errno(retsts);
9271 if (ckWARN(WARN_EXEC)) {
9272 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9273 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9275 vms_execfree(vmscmd);
9280 } /* end of vms_do_exec() */
9283 unsigned long int Perl_do_spawn(pTHX_ const char *);
9285 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9287 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9289 unsigned long int sts;
9293 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9294 sts = do_spawn(cmd);
9295 /* pp_sys will clean up cmd */
9299 } /* end of do_aspawn() */
9302 /* {{{unsigned long int do_spawn(char *cmd) */
9304 Perl_do_spawn(pTHX_ const char *cmd)
9306 unsigned long int sts, substs;
9308 /* The caller of this routine expects to Safefree(PL_Cmd) */
9309 Newx(PL_Cmd,10,char);
9312 TAINT_PROPER("spawn");
9313 if (!cmd || !*cmd) {
9314 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9317 case RMS$_FNF: case RMS$_DNF:
9318 set_errno(ENOENT); break;
9320 set_errno(ENOTDIR); break;
9322 set_errno(ENODEV); break;
9324 set_errno(EACCES); break;
9326 set_errno(EINVAL); break;
9327 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9328 set_errno(E2BIG); break;
9329 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9330 _ckvmssts(sts); /* fall through */
9331 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9334 set_vaxc_errno(sts);
9335 if (ckWARN(WARN_EXEC)) {
9336 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9344 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9349 } /* end of do_spawn() */
9353 static unsigned int *sockflags, sockflagsize;
9356 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9357 * routines found in some versions of the CRTL can't deal with sockets.
9358 * We don't shim the other file open routines since a socket isn't
9359 * likely to be opened by a name.
9361 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9362 FILE *my_fdopen(int fd, const char *mode)
9364 FILE *fp = fdopen(fd, mode);
9367 unsigned int fdoff = fd / sizeof(unsigned int);
9368 Stat_t sbuf; /* native stat; we don't need flex_stat */
9369 if (!sockflagsize || fdoff > sockflagsize) {
9370 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9371 else Newx (sockflags,fdoff+2,unsigned int);
9372 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9373 sockflagsize = fdoff + 2;
9375 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9376 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9385 * Clear the corresponding bit when the (possibly) socket stream is closed.
9386 * There still a small hole: we miss an implicit close which might occur
9387 * via freopen(). >> Todo
9389 /*{{{ int my_fclose(FILE *fp)*/
9390 int my_fclose(FILE *fp) {
9392 unsigned int fd = fileno(fp);
9393 unsigned int fdoff = fd / sizeof(unsigned int);
9395 if (sockflagsize && fdoff <= sockflagsize)
9396 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9404 * A simple fwrite replacement which outputs itmsz*nitm chars without
9405 * introducing record boundaries every itmsz chars.
9406 * We are using fputs, which depends on a terminating null. We may
9407 * well be writing binary data, so we need to accommodate not only
9408 * data with nulls sprinkled in the middle but also data with no null
9411 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9413 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9415 register char *cp, *end, *cpd, *data;
9416 register unsigned int fd = fileno(dest);
9417 register unsigned int fdoff = fd / sizeof(unsigned int);
9419 int bufsize = itmsz * nitm + 1;
9421 if (fdoff < sockflagsize &&
9422 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9423 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9427 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9428 memcpy( data, src, itmsz*nitm );
9429 data[itmsz*nitm] = '\0';
9431 end = data + itmsz * nitm;
9432 retval = (int) nitm; /* on success return # items written */
9435 while (cpd <= end) {
9436 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9437 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9439 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9443 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9446 } /* end of my_fwrite() */
9449 /*{{{ int my_flush(FILE *fp)*/
9451 Perl_my_flush(pTHX_ FILE *fp)
9454 if ((res = fflush(fp)) == 0 && fp) {
9455 #ifdef VMS_DO_SOCKETS
9457 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9459 res = fsync(fileno(fp));
9462 * If the flush succeeded but set end-of-file, we need to clear
9463 * the error because our caller may check ferror(). BTW, this
9464 * probably means we just flushed an empty file.
9466 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9473 * Here are replacements for the following Unix routines in the VMS environment:
9474 * getpwuid Get information for a particular UIC or UID
9475 * getpwnam Get information for a named user
9476 * getpwent Get information for each user in the rights database
9477 * setpwent Reset search to the start of the rights database
9478 * endpwent Finish searching for users in the rights database
9480 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9481 * (defined in pwd.h), which contains the following fields:-
9483 * char *pw_name; Username (in lower case)
9484 * char *pw_passwd; Hashed password
9485 * unsigned int pw_uid; UIC
9486 * unsigned int pw_gid; UIC group number
9487 * char *pw_unixdir; Default device/directory (VMS-style)
9488 * char *pw_gecos; Owner name
9489 * char *pw_dir; Default device/directory (Unix-style)
9490 * char *pw_shell; Default CLI name (eg. DCL)
9492 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9494 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9495 * not the UIC member number (eg. what's returned by getuid()),
9496 * getpwuid() can accept either as input (if uid is specified, the caller's
9497 * UIC group is used), though it won't recognise gid=0.
9499 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9500 * information about other users in your group or in other groups, respectively.
9501 * If the required privilege is not available, then these routines fill only
9502 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9505 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9508 /* sizes of various UAF record fields */
9509 #define UAI$S_USERNAME 12
9510 #define UAI$S_IDENT 31
9511 #define UAI$S_OWNER 31
9512 #define UAI$S_DEFDEV 31
9513 #define UAI$S_DEFDIR 63
9514 #define UAI$S_DEFCLI 31
9517 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9518 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9519 (uic).uic$v_group != UIC$K_WILD_GROUP)
9521 static char __empty[]= "";
9522 static struct passwd __passwd_empty=
9523 {(char *) __empty, (char *) __empty, 0, 0,
9524 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9525 static int contxt= 0;
9526 static struct passwd __pwdcache;
9527 static char __pw_namecache[UAI$S_IDENT+1];
9530 * This routine does most of the work extracting the user information.
9532 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9535 unsigned char length;
9536 char pw_gecos[UAI$S_OWNER+1];
9538 static union uicdef uic;
9540 unsigned char length;
9541 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9544 unsigned char length;
9545 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9548 unsigned char length;
9549 char pw_shell[UAI$S_DEFCLI+1];
9551 static char pw_passwd[UAI$S_PWD+1];
9553 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9554 struct dsc$descriptor_s name_desc;
9555 unsigned long int sts;
9557 static struct itmlst_3 itmlst[]= {
9558 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9559 {sizeof(uic), UAI$_UIC, &uic, &luic},
9560 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9561 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9562 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9563 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9564 {0, 0, NULL, NULL}};
9566 name_desc.dsc$w_length= strlen(name);
9567 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9568 name_desc.dsc$b_class= DSC$K_CLASS_S;
9569 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9571 /* Note that sys$getuai returns many fields as counted strings. */
9572 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9573 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9574 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9576 else { _ckvmssts(sts); }
9577 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9579 if ((int) owner.length < lowner) lowner= (int) owner.length;
9580 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9581 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9582 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9583 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9584 owner.pw_gecos[lowner]= '\0';
9585 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9586 defcli.pw_shell[ldefcli]= '\0';
9587 if (valid_uic(uic)) {
9588 pwd->pw_uid= uic.uic$l_uic;
9589 pwd->pw_gid= uic.uic$v_group;
9592 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9593 pwd->pw_passwd= pw_passwd;
9594 pwd->pw_gecos= owner.pw_gecos;
9595 pwd->pw_dir= defdev.pw_dir;
9596 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9597 pwd->pw_shell= defcli.pw_shell;
9598 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9600 ldir= strlen(pwd->pw_unixdir) - 1;
9601 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9604 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9605 if (!decc_efs_case_preserve)
9606 __mystrtolower(pwd->pw_unixdir);
9611 * Get information for a named user.
9613 /*{{{struct passwd *getpwnam(char *name)*/
9614 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9616 struct dsc$descriptor_s name_desc;
9618 unsigned long int status, sts;
9620 __pwdcache = __passwd_empty;
9621 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9622 /* We still may be able to determine pw_uid and pw_gid */
9623 name_desc.dsc$w_length= strlen(name);
9624 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9625 name_desc.dsc$b_class= DSC$K_CLASS_S;
9626 name_desc.dsc$a_pointer= (char *) name;
9627 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9628 __pwdcache.pw_uid= uic.uic$l_uic;
9629 __pwdcache.pw_gid= uic.uic$v_group;
9632 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9633 set_vaxc_errno(sts);
9634 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9637 else { _ckvmssts(sts); }
9640 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9641 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9642 __pwdcache.pw_name= __pw_namecache;
9644 } /* end of my_getpwnam() */
9648 * Get information for a particular UIC or UID.
9649 * Called by my_getpwent with uid=-1 to list all users.
9651 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9652 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9654 const $DESCRIPTOR(name_desc,__pw_namecache);
9655 unsigned short lname;
9657 unsigned long int status;
9659 if (uid == (unsigned int) -1) {
9661 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9662 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9663 set_vaxc_errno(status);
9664 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9668 else { _ckvmssts(status); }
9669 } while (!valid_uic (uic));
9673 if (!uic.uic$v_group)
9674 uic.uic$v_group= PerlProc_getgid();
9676 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9677 else status = SS$_IVIDENT;
9678 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9679 status == RMS$_PRV) {
9680 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9683 else { _ckvmssts(status); }
9685 __pw_namecache[lname]= '\0';
9686 __mystrtolower(__pw_namecache);
9688 __pwdcache = __passwd_empty;
9689 __pwdcache.pw_name = __pw_namecache;
9691 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9692 The identifier's value is usually the UIC, but it doesn't have to be,
9693 so if we can, we let fillpasswd update this. */
9694 __pwdcache.pw_uid = uic.uic$l_uic;
9695 __pwdcache.pw_gid = uic.uic$v_group;
9697 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9700 } /* end of my_getpwuid() */
9704 * Get information for next user.
9706 /*{{{struct passwd *my_getpwent()*/
9707 struct passwd *Perl_my_getpwent(pTHX)
9709 return (my_getpwuid((unsigned int) -1));
9714 * Finish searching rights database for users.
9716 /*{{{void my_endpwent()*/
9717 void Perl_my_endpwent(pTHX)
9720 _ckvmssts(sys$finish_rdb(&contxt));
9726 #ifdef HOMEGROWN_POSIX_SIGNALS
9727 /* Signal handling routines, pulled into the core from POSIX.xs.
9729 * We need these for threads, so they've been rolled into the core,
9730 * rather than left in POSIX.xs.
9732 * (DRS, Oct 23, 1997)
9735 /* sigset_t is atomic under VMS, so these routines are easy */
9736 /*{{{int my_sigemptyset(sigset_t *) */
9737 int my_sigemptyset(sigset_t *set) {
9738 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9744 /*{{{int my_sigfillset(sigset_t *)*/
9745 int my_sigfillset(sigset_t *set) {
9747 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9748 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9754 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9755 int my_sigaddset(sigset_t *set, int sig) {
9756 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9757 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9758 *set |= (1 << (sig - 1));
9764 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9765 int my_sigdelset(sigset_t *set, int sig) {
9766 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9767 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9768 *set &= ~(1 << (sig - 1));
9774 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9775 int my_sigismember(sigset_t *set, int sig) {
9776 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9777 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9778 return *set & (1 << (sig - 1));
9783 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9784 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9787 /* If set and oset are both null, then things are badly wrong. Bail out. */
9788 if ((oset == NULL) && (set == NULL)) {
9789 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9793 /* If set's null, then we're just handling a fetch. */
9795 tempmask = sigblock(0);
9800 tempmask = sigsetmask(*set);
9803 tempmask = sigblock(*set);
9806 tempmask = sigblock(0);
9807 sigsetmask(*oset & ~tempmask);
9810 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9815 /* Did they pass us an oset? If so, stick our holding mask into it */
9822 #endif /* HOMEGROWN_POSIX_SIGNALS */
9825 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9826 * my_utime(), and flex_stat(), all of which operate on UTC unless
9827 * VMSISH_TIMES is true.
9829 /* method used to handle UTC conversions:
9830 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
9832 static int gmtime_emulation_type;
9833 /* number of secs to add to UTC POSIX-style time to get local time */
9834 static long int utc_offset_secs;
9836 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9837 * in vmsish.h. #undef them here so we can call the CRTL routines
9846 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9847 * qualifier with the extern prefix pragma. This provisional
9848 * hack circumvents this prefix pragma problem in previous
9851 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9852 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9853 # pragma __extern_prefix save
9854 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
9855 # define gmtime decc$__utctz_gmtime
9856 # define localtime decc$__utctz_localtime
9857 # define time decc$__utc_time
9858 # pragma __extern_prefix restore
9860 struct tm *gmtime(), *localtime();
9866 static time_t toutc_dst(time_t loc) {
9869 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9870 loc -= utc_offset_secs;
9871 if (rsltmp->tm_isdst) loc -= 3600;
9874 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9875 ((gmtime_emulation_type || my_time(NULL)), \
9876 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9877 ((secs) - utc_offset_secs))))
9879 static time_t toloc_dst(time_t utc) {
9882 utc += utc_offset_secs;
9883 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9884 if (rsltmp->tm_isdst) utc += 3600;
9887 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9888 ((gmtime_emulation_type || my_time(NULL)), \
9889 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9890 ((secs) + utc_offset_secs))))
9892 #ifndef RTL_USES_UTC
9895 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9896 DST starts on 1st sun of april at 02:00 std time
9897 ends on last sun of october at 02:00 dst time
9898 see the UCX management command reference, SET CONFIG TIMEZONE
9899 for formatting info.
9901 No, it's not as general as it should be, but then again, NOTHING
9902 will handle UK times in a sensible way.
9907 parse the DST start/end info:
9908 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9912 tz_parse_startend(char *s, struct tm *w, int *past)
9914 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9915 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9920 if (!past) return 0;
9923 if (w->tm_year % 4 == 0) ly = 1;
9924 if (w->tm_year % 100 == 0) ly = 0;
9925 if (w->tm_year+1900 % 400 == 0) ly = 1;
9928 dozjd = isdigit(*s);
9929 if (*s == 'J' || *s == 'j' || dozjd) {
9930 if (!dozjd && !isdigit(*++s)) return 0;
9933 d = d*10 + *s++ - '0';
9935 d = d*10 + *s++ - '0';
9938 if (d == 0) return 0;
9939 if (d > 366) return 0;
9941 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9944 } else if (*s == 'M' || *s == 'm') {
9945 if (!isdigit(*++s)) return 0;
9947 if (isdigit(*s)) m = 10*m + *s++ - '0';
9948 if (*s != '.') return 0;
9949 if (!isdigit(*++s)) return 0;
9951 if (n < 1 || n > 5) return 0;
9952 if (*s != '.') return 0;
9953 if (!isdigit(*++s)) return 0;
9955 if (d > 6) return 0;
9959 if (!isdigit(*++s)) return 0;
9961 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9963 if (!isdigit(*++s)) return 0;
9965 if (isdigit(*s)) min = 10*min + *s++ - '0';
9967 if (!isdigit(*++s)) return 0;
9969 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9979 if (w->tm_yday < d) goto before;
9980 if (w->tm_yday > d) goto after;
9982 if (w->tm_mon+1 < m) goto before;
9983 if (w->tm_mon+1 > m) goto after;
9985 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9986 k = d - j; /* mday of first d */
9988 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9989 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9990 if (w->tm_mday < k) goto before;
9991 if (w->tm_mday > k) goto after;
9994 if (w->tm_hour < hour) goto before;
9995 if (w->tm_hour > hour) goto after;
9996 if (w->tm_min < min) goto before;
9997 if (w->tm_min > min) goto after;
9998 if (w->tm_sec < sec) goto before;
10012 /* parse the offset: (+|-)hh[:mm[:ss]] */
10015 tz_parse_offset(char *s, int *offset)
10017 int hour = 0, min = 0, sec = 0;
10020 if (!offset) return 0;
10022 if (*s == '-') {neg++; s++;}
10023 if (*s == '+') s++;
10024 if (!isdigit(*s)) return 0;
10026 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10027 if (hour > 24) return 0;
10029 if (!isdigit(*++s)) return 0;
10031 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10032 if (min > 59) return 0;
10034 if (!isdigit(*++s)) return 0;
10036 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10037 if (sec > 59) return 0;
10041 *offset = (hour*60+min)*60 + sec;
10042 if (neg) *offset = -*offset;
10047 input time is w, whatever type of time the CRTL localtime() uses.
10048 sets dst, the zone, and the gmtoff (seconds)
10050 caches the value of TZ and UCX$TZ env variables; note that
10051 my_setenv looks for these and sets a flag if they're changed
10054 We have to watch out for the "australian" case (dst starts in
10055 october, ends in april)...flagged by "reverse" and checked by
10056 scanning through the months of the previous year.
10061 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10066 char *dstzone, *tz, *s_start, *s_end;
10067 int std_off, dst_off, isdst;
10068 int y, dststart, dstend;
10069 static char envtz[1025]; /* longer than any logical, symbol, ... */
10070 static char ucxtz[1025];
10071 static char reversed = 0;
10077 reversed = -1; /* flag need to check */
10078 envtz[0] = ucxtz[0] = '\0';
10079 tz = my_getenv("TZ",0);
10080 if (tz) strcpy(envtz, tz);
10081 tz = my_getenv("UCX$TZ",0);
10082 if (tz) strcpy(ucxtz, tz);
10083 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10086 if (!*tz) tz = ucxtz;
10089 while (isalpha(*s)) s++;
10090 s = tz_parse_offset(s, &std_off);
10092 if (!*s) { /* no DST, hurray we're done! */
10098 while (isalpha(*s)) s++;
10099 s2 = tz_parse_offset(s, &dst_off);
10103 dst_off = std_off - 3600;
10106 if (!*s) { /* default dst start/end?? */
10107 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10108 s = strchr(ucxtz,',');
10110 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10112 if (*s != ',') return 0;
10115 when = _toutc(when); /* convert to utc */
10116 when = when - std_off; /* convert to pseudolocal time*/
10118 w2 = localtime(&when);
10121 s = tz_parse_startend(s_start,w2,&dststart);
10123 if (*s != ',') return 0;
10126 when = _toutc(when); /* convert to utc */
10127 when = when - dst_off; /* convert to pseudolocal time*/
10128 w2 = localtime(&when);
10129 if (w2->tm_year != y) { /* spans a year, just check one time */
10130 when += dst_off - std_off;
10131 w2 = localtime(&when);
10134 s = tz_parse_startend(s_end,w2,&dstend);
10137 if (reversed == -1) { /* need to check if start later than end */
10141 if (when < 2*365*86400) {
10142 when += 2*365*86400;
10146 w2 =localtime(&when);
10147 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10149 for (j = 0; j < 12; j++) {
10150 w2 =localtime(&when);
10151 tz_parse_startend(s_start,w2,&ds);
10152 tz_parse_startend(s_end,w2,&de);
10153 if (ds != de) break;
10157 if (de && !ds) reversed = 1;
10160 isdst = dststart && !dstend;
10161 if (reversed) isdst = dststart || !dstend;
10164 if (dst) *dst = isdst;
10165 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10166 if (isdst) tz = dstzone;
10168 while(isalpha(*tz)) *zone++ = *tz++;
10174 #endif /* !RTL_USES_UTC */
10176 /* my_time(), my_localtime(), my_gmtime()
10177 * By default traffic in UTC time values, using CRTL gmtime() or
10178 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10179 * Note: We need to use these functions even when the CRTL has working
10180 * UTC support, since they also handle C<use vmsish qw(times);>
10182 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10183 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10186 /*{{{time_t my_time(time_t *timep)*/
10187 time_t Perl_my_time(pTHX_ time_t *timep)
10192 if (gmtime_emulation_type == 0) {
10194 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10195 /* results of calls to gmtime() and localtime() */
10196 /* for same &base */
10198 gmtime_emulation_type++;
10199 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10200 char off[LNM$C_NAMLENGTH+1];;
10202 gmtime_emulation_type++;
10203 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10204 gmtime_emulation_type++;
10205 utc_offset_secs = 0;
10206 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10208 else { utc_offset_secs = atol(off); }
10210 else { /* We've got a working gmtime() */
10211 struct tm gmt, local;
10214 tm_p = localtime(&base);
10216 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10217 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10218 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10219 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10224 # ifdef VMSISH_TIME
10225 # ifdef RTL_USES_UTC
10226 if (VMSISH_TIME) when = _toloc(when);
10228 if (!VMSISH_TIME) when = _toutc(when);
10231 if (timep != NULL) *timep = when;
10234 } /* end of my_time() */
10238 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10240 Perl_my_gmtime(pTHX_ const time_t *timep)
10246 if (timep == NULL) {
10247 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10250 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10253 # ifdef VMSISH_TIME
10254 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10256 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10257 return gmtime(&when);
10259 /* CRTL localtime() wants local time as input, so does no tz correction */
10260 rsltmp = localtime(&when);
10261 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10264 } /* end of my_gmtime() */
10268 /*{{{struct tm *my_localtime(const time_t *timep)*/
10270 Perl_my_localtime(pTHX_ const time_t *timep)
10272 time_t when, whenutc;
10276 if (timep == NULL) {
10277 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10280 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10281 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10284 # ifdef RTL_USES_UTC
10285 # ifdef VMSISH_TIME
10286 if (VMSISH_TIME) when = _toutc(when);
10288 /* CRTL localtime() wants UTC as input, does tz correction itself */
10289 return localtime(&when);
10291 # else /* !RTL_USES_UTC */
10293 # ifdef VMSISH_TIME
10294 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10295 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10298 #ifndef RTL_USES_UTC
10299 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10300 when = whenutc - offset; /* pseudolocal time*/
10303 /* CRTL localtime() wants local time as input, so does no tz correction */
10304 rsltmp = localtime(&when);
10305 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10309 } /* end of my_localtime() */
10312 /* Reset definitions for later calls */
10313 #define gmtime(t) my_gmtime(t)
10314 #define localtime(t) my_localtime(t)
10315 #define time(t) my_time(t)
10318 /* my_utime - update modification/access time of a file
10320 * VMS 7.3 and later implementation
10321 * Only the UTC translation is home-grown. The rest is handled by the
10322 * CRTL utime(), which will take into account the relevant feature
10323 * logicals and ODS-5 volume characteristics for true access times.
10325 * pre VMS 7.3 implementation:
10326 * The calling sequence is identical to POSIX utime(), but under
10327 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10328 * not maintain access times. Restrictions differ from the POSIX
10329 * definition in that the time can be changed as long as the
10330 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10331 * no separate checks are made to insure that the caller is the
10332 * owner of the file or has special privs enabled.
10333 * Code here is based on Joe Meadows' FILE utility.
10337 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10338 * to VMS epoch (01-JAN-1858 00:00:00.00)
10339 * in 100 ns intervals.
10341 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10343 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10344 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10346 #if __CRTL_VER >= 70300000
10347 struct utimbuf utc_utimes, *utc_utimesp;
10349 if (utimes != NULL) {
10350 utc_utimes.actime = utimes->actime;
10351 utc_utimes.modtime = utimes->modtime;
10352 # ifdef VMSISH_TIME
10353 /* If input was local; convert to UTC for sys svc */
10355 utc_utimes.actime = _toutc(utimes->actime);
10356 utc_utimes.modtime = _toutc(utimes->modtime);
10359 utc_utimesp = &utc_utimes;
10362 utc_utimesp = NULL;
10365 return utime(file, utc_utimesp);
10367 #else /* __CRTL_VER < 70300000 */
10371 long int bintime[2], len = 2, lowbit, unixtime,
10372 secscale = 10000000; /* seconds --> 100 ns intervals */
10373 unsigned long int chan, iosb[2], retsts;
10374 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10375 struct FAB myfab = cc$rms_fab;
10376 struct NAM mynam = cc$rms_nam;
10377 #if defined (__DECC) && defined (__VAX)
10378 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10379 * at least through VMS V6.1, which causes a type-conversion warning.
10381 # pragma message save
10382 # pragma message disable cvtdiftypes
10384 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10385 struct fibdef myfib;
10386 #if defined (__DECC) && defined (__VAX)
10387 /* This should be right after the declaration of myatr, but due
10388 * to a bug in VAX DEC C, this takes effect a statement early.
10390 # pragma message restore
10392 /* cast ok for read only parameter */
10393 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10394 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10395 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10397 if (file == NULL || *file == '\0') {
10398 SETERRNO(ENOENT, LIB$_INVARG);
10402 /* Convert to VMS format ensuring that it will fit in 255 characters */
10403 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10404 SETERRNO(ENOENT, LIB$_INVARG);
10407 if (utimes != NULL) {
10408 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10409 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10410 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10411 * as input, we force the sign bit to be clear by shifting unixtime right
10412 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10414 lowbit = (utimes->modtime & 1) ? secscale : 0;
10415 unixtime = (long int) utimes->modtime;
10416 # ifdef VMSISH_TIME
10417 /* If input was UTC; convert to local for sys svc */
10418 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10420 unixtime >>= 1; secscale <<= 1;
10421 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10422 if (!(retsts & 1)) {
10423 SETERRNO(EVMSERR, retsts);
10426 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10427 if (!(retsts & 1)) {
10428 SETERRNO(EVMSERR, retsts);
10433 /* Just get the current time in VMS format directly */
10434 retsts = sys$gettim(bintime);
10435 if (!(retsts & 1)) {
10436 SETERRNO(EVMSERR, retsts);
10441 myfab.fab$l_fna = vmsspec;
10442 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10443 myfab.fab$l_nam = &mynam;
10444 mynam.nam$l_esa = esa;
10445 mynam.nam$b_ess = (unsigned char) sizeof esa;
10446 mynam.nam$l_rsa = rsa;
10447 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10448 if (decc_efs_case_preserve)
10449 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10451 /* Look for the file to be affected, letting RMS parse the file
10452 * specification for us as well. I have set errno using only
10453 * values documented in the utime() man page for VMS POSIX.
10455 retsts = sys$parse(&myfab,0,0);
10456 if (!(retsts & 1)) {
10457 set_vaxc_errno(retsts);
10458 if (retsts == RMS$_PRV) set_errno(EACCES);
10459 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10460 else set_errno(EVMSERR);
10463 retsts = sys$search(&myfab,0,0);
10464 if (!(retsts & 1)) {
10465 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10466 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10467 set_vaxc_errno(retsts);
10468 if (retsts == RMS$_PRV) set_errno(EACCES);
10469 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10470 else set_errno(EVMSERR);
10474 devdsc.dsc$w_length = mynam.nam$b_dev;
10475 /* cast ok for read only parameter */
10476 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10478 retsts = sys$assign(&devdsc,&chan,0,0);
10479 if (!(retsts & 1)) {
10480 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10481 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10482 set_vaxc_errno(retsts);
10483 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10484 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10485 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10486 else set_errno(EVMSERR);
10490 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10491 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10493 memset((void *) &myfib, 0, sizeof myfib);
10494 #if defined(__DECC) || defined(__DECCXX)
10495 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10496 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10497 /* This prevents the revision time of the file being reset to the current
10498 * time as a result of our IO$_MODIFY $QIO. */
10499 myfib.fib$l_acctl = FIB$M_NORECORD;
10501 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10502 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10503 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10505 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10506 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10507 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10508 _ckvmssts(sys$dassgn(chan));
10509 if (retsts & 1) retsts = iosb[0];
10510 if (!(retsts & 1)) {
10511 set_vaxc_errno(retsts);
10512 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10513 else set_errno(EVMSERR);
10519 #endif /* #if __CRTL_VER >= 70300000 */
10521 } /* end of my_utime() */
10525 * flex_stat, flex_lstat, flex_fstat
10526 * basic stat, but gets it right when asked to stat
10527 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10530 #ifndef _USE_STD_STAT
10531 /* encode_dev packs a VMS device name string into an integer to allow
10532 * simple comparisons. This can be used, for example, to check whether two
10533 * files are located on the same device, by comparing their encoded device
10534 * names. Even a string comparison would not do, because stat() reuses the
10535 * device name buffer for each call; so without encode_dev, it would be
10536 * necessary to save the buffer and use strcmp (this would mean a number of
10537 * changes to the standard Perl code, to say nothing of what a Perl script
10538 * would have to do.
10540 * The device lock id, if it exists, should be unique (unless perhaps compared
10541 * with lock ids transferred from other nodes). We have a lock id if the disk is
10542 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10543 * device names. Thus we use the lock id in preference, and only if that isn't
10544 * available, do we try to pack the device name into an integer (flagged by
10545 * the sign bit (LOCKID_MASK) being set).
10547 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10548 * name and its encoded form, but it seems very unlikely that we will find
10549 * two files on different disks that share the same encoded device names,
10550 * and even more remote that they will share the same file id (if the test
10551 * is to check for the same file).
10553 * A better method might be to use sys$device_scan on the first call, and to
10554 * search for the device, returning an index into the cached array.
10555 * The number returned would be more intelligible.
10556 * This is probably not worth it, and anyway would take quite a bit longer
10557 * on the first call.
10559 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10560 static mydev_t encode_dev (pTHX_ const char *dev)
10563 unsigned long int f;
10568 if (!dev || !dev[0]) return 0;
10572 struct dsc$descriptor_s dev_desc;
10573 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10575 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10576 can try that first. */
10577 dev_desc.dsc$w_length = strlen (dev);
10578 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10579 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10580 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10581 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10582 if (!$VMS_STATUS_SUCCESS(status)) {
10584 case SS$_NOSUCHDEV:
10585 SETERRNO(ENODEV, status);
10591 if (lockid) return (lockid & ~LOCKID_MASK);
10595 /* Otherwise we try to encode the device name */
10599 for (q = dev + strlen(dev); q--; q >= dev) {
10604 else if (isalpha (toupper (*q)))
10605 c= toupper (*q) - 'A' + (char)10;
10607 continue; /* Skip '$'s */
10609 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10611 enc += f * (unsigned long int) c;
10613 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10615 } /* end of encode_dev() */
10616 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10617 device_no = encode_dev(aTHX_ devname)
10619 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10620 device_no = new_dev_no
10624 is_null_device(name)
10627 if (decc_bug_devnull != 0) {
10628 if (strncmp("/dev/null", name, 9) == 0)
10631 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10632 The underscore prefix, controller letter, and unit number are
10633 independently optional; for our purposes, the colon punctuation
10634 is not. The colon can be trailed by optional directory and/or
10635 filename, but two consecutive colons indicates a nodename rather
10636 than a device. [pr] */
10637 if (*name == '_') ++name;
10638 if (tolower(*name++) != 'n') return 0;
10639 if (tolower(*name++) != 'l') return 0;
10640 if (tolower(*name) == 'a') ++name;
10641 if (*name == '0') ++name;
10642 return (*name++ == ':') && (*name != ':');
10647 Perl_cando_by_name_int
10648 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10650 static char usrname[L_cuserid];
10651 static struct dsc$descriptor_s usrdsc =
10652 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10653 char vmsname[NAM$C_MAXRSS+1];
10655 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10656 unsigned short int retlen, trnlnm_iter_count;
10657 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10658 union prvdef curprv;
10659 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10660 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10661 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10662 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10663 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10665 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10667 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10669 if (!fname || !*fname) return FALSE;
10670 /* Make sure we expand logical names, since sys$check_access doesn't */
10673 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10674 fileified = PerlMem_malloc(VMS_MAXRSS);
10675 if (!strpbrk(fname,"/]>:")) {
10676 strcpy(fileified,fname);
10677 trnlnm_iter_count = 0;
10678 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10679 trnlnm_iter_count++;
10680 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10684 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10685 PerlMem_free(fileified);
10688 retlen = namdsc.dsc$w_length = strlen(vmsname);
10689 namdsc.dsc$a_pointer = vmsname;
10690 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10691 vmsname[retlen-1] == ':') {
10692 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10693 namdsc.dsc$w_length = strlen(fileified);
10694 namdsc.dsc$a_pointer = fileified;
10698 retlen = namdsc.dsc$w_length = strlen(fname);
10699 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10703 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10704 access = ARM$M_EXECUTE;
10705 flags = CHP$M_READ;
10707 case S_IRUSR: case S_IRGRP: case S_IROTH:
10708 access = ARM$M_READ;
10709 flags = CHP$M_READ | CHP$M_USEREADALL;
10711 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10712 access = ARM$M_WRITE;
10713 flags = CHP$M_READ | CHP$M_WRITE;
10715 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10716 access = ARM$M_DELETE;
10717 flags = CHP$M_READ | CHP$M_WRITE;
10720 if (fileified != NULL)
10721 PerlMem_free(fileified);
10725 /* Before we call $check_access, create a user profile with the current
10726 * process privs since otherwise it just uses the default privs from the
10727 * UAF and might give false positives or negatives. This only works on
10728 * VMS versions v6.0 and later since that's when sys$create_user_profile
10729 * became available.
10732 /* get current process privs and username */
10733 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10734 _ckvmssts(iosb[0]);
10736 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10738 /* find out the space required for the profile */
10739 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10740 &usrprodsc.dsc$w_length,0));
10742 /* allocate space for the profile and get it filled in */
10743 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10744 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10745 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10746 &usrprodsc.dsc$w_length,0));
10748 /* use the profile to check access to the file; free profile & analyze results */
10749 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10750 PerlMem_free(usrprodsc.dsc$a_pointer);
10751 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10755 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10759 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
10760 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10761 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10762 set_vaxc_errno(retsts);
10763 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10764 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10765 else set_errno(ENOENT);
10766 if (fileified != NULL)
10767 PerlMem_free(fileified);
10770 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10771 if (fileified != NULL)
10772 PerlMem_free(fileified);
10777 if (fileified != NULL)
10778 PerlMem_free(fileified);
10779 return FALSE; /* Should never get here */
10783 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
10784 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10785 * subset of the applicable information.
10788 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10790 return cando_by_name_int
10791 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10792 } /* end of cando() */
10796 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10798 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10800 return cando_by_name_int(bit, effective, fname, 0);
10802 } /* end of cando_by_name() */
10806 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10808 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10810 if (!fstat(fd,(stat_t *) statbufp)) {
10812 char *vms_filename;
10813 vms_filename = PerlMem_malloc(VMS_MAXRSS);
10814 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10816 /* Save name for cando by name in VMS format */
10817 cptr = getname(fd, vms_filename, 1);
10819 /* This should not happen, but just in case */
10820 if (cptr == NULL) {
10821 statbufp->st_devnam[0] = 0;
10824 /* Make sure that the saved name fits in 255 characters */
10825 cptr = do_rmsexpand
10827 statbufp->st_devnam,
10830 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10834 statbufp->st_devnam[0] = 0;
10836 PerlMem_free(vms_filename);
10838 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10840 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10842 # ifdef RTL_USES_UTC
10843 # ifdef VMSISH_TIME
10845 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10846 statbufp->st_atime = _toloc(statbufp->st_atime);
10847 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10851 # ifdef VMSISH_TIME
10852 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10856 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10857 statbufp->st_atime = _toutc(statbufp->st_atime);
10858 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10865 } /* end of flex_fstat() */
10868 #if !defined(__VAX) && __CRTL_VER >= 80200000
10876 #define lstat(_x, _y) stat(_x, _y)
10879 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10882 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10884 char fileified[VMS_MAXRSS];
10885 char temp_fspec[VMS_MAXRSS];
10888 int saved_errno, saved_vaxc_errno;
10890 if (!fspec) return retval;
10891 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10892 strcpy(temp_fspec, fspec);
10894 if (decc_bug_devnull != 0) {
10895 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10896 memset(statbufp,0,sizeof *statbufp);
10897 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10898 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10899 statbufp->st_uid = 0x00010001;
10900 statbufp->st_gid = 0x0001;
10901 time((time_t *)&statbufp->st_mtime);
10902 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10907 /* Try for a directory name first. If fspec contains a filename without
10908 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10909 * and sea:[wine.dark]water. exist, we prefer the directory here.
10910 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10911 * not sea:[wine.dark]., if the latter exists. If the intended target is
10912 * the file with null type, specify this by calling flex_stat() with
10913 * a '.' at the end of fspec.
10915 * If we are in Posix filespec mode, accept the filename as is.
10917 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10918 if (decc_posix_compliant_pathnames == 0) {
10920 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10921 if (lstat_flag == 0)
10922 retval = stat(fileified,(stat_t *) statbufp);
10924 retval = lstat(fileified,(stat_t *) statbufp);
10925 save_spec = fileified;
10928 if (lstat_flag == 0)
10929 retval = stat(temp_fspec,(stat_t *) statbufp);
10931 retval = lstat(temp_fspec,(stat_t *) statbufp);
10932 save_spec = temp_fspec;
10934 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10936 if (lstat_flag == 0)
10937 retval = stat(temp_fspec,(stat_t *) statbufp);
10939 retval = lstat(temp_fspec,(stat_t *) statbufp);
10940 save_spec = temp_fspec;
10945 cptr = do_rmsexpand
10946 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10948 statbufp->st_devnam[0] = 0;
10950 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10952 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10953 # ifdef RTL_USES_UTC
10954 # ifdef VMSISH_TIME
10956 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10957 statbufp->st_atime = _toloc(statbufp->st_atime);
10958 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10962 # ifdef VMSISH_TIME
10963 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10967 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10968 statbufp->st_atime = _toutc(statbufp->st_atime);
10969 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10973 /* If we were successful, leave errno where we found it */
10974 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10977 } /* end of flex_stat_int() */
10980 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10982 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10984 return flex_stat_int(fspec, statbufp, 0);
10988 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10990 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10992 return flex_stat_int(fspec, statbufp, 1);
10997 /*{{{char *my_getlogin()*/
10998 /* VMS cuserid == Unix getlogin, except calling sequence */
11002 static char user[L_cuserid];
11003 return cuserid(user);
11008 /* rmscopy - copy a file using VMS RMS routines
11010 * Copies contents and attributes of spec_in to spec_out, except owner
11011 * and protection information. Name and type of spec_in are used as
11012 * defaults for spec_out. The third parameter specifies whether rmscopy()
11013 * should try to propagate timestamps from the input file to the output file.
11014 * If it is less than 0, no timestamps are preserved. If it is 0, then
11015 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11016 * propagated to the output file at creation iff the output file specification
11017 * did not contain an explicit name or type, and the revision date is always
11018 * updated at the end of the copy operation. If it is greater than 0, then
11019 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11020 * other than the revision date should be propagated, and bit 1 indicates
11021 * that the revision date should be propagated.
11023 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11025 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11026 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11027 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11028 * as part of the Perl standard distribution under the terms of the
11029 * GNU General Public License or the Perl Artistic License. Copies
11030 * of each may be found in the Perl standard distribution.
11032 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11034 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11036 char *vmsin, * vmsout, *esa, *esa_out,
11038 unsigned long int i, sts, sts2;
11040 struct FAB fab_in, fab_out;
11041 struct RAB rab_in, rab_out;
11042 rms_setup_nam(nam);
11043 rms_setup_nam(nam_out);
11044 struct XABDAT xabdat;
11045 struct XABFHC xabfhc;
11046 struct XABRDT xabrdt;
11047 struct XABSUM xabsum;
11049 vmsin = PerlMem_malloc(VMS_MAXRSS);
11050 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11051 vmsout = PerlMem_malloc(VMS_MAXRSS);
11052 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11053 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11054 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11055 PerlMem_free(vmsin);
11056 PerlMem_free(vmsout);
11057 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11061 esa = PerlMem_malloc(VMS_MAXRSS);
11062 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11063 fab_in = cc$rms_fab;
11064 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11065 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11066 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11067 fab_in.fab$l_fop = FAB$M_SQO;
11068 rms_bind_fab_nam(fab_in, nam);
11069 fab_in.fab$l_xab = (void *) &xabdat;
11071 rsa = PerlMem_malloc(VMS_MAXRSS);
11072 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11073 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11074 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11075 rms_nam_esl(nam) = 0;
11076 rms_nam_rsl(nam) = 0;
11077 rms_nam_esll(nam) = 0;
11078 rms_nam_rsll(nam) = 0;
11079 #ifdef NAM$M_NO_SHORT_UPCASE
11080 if (decc_efs_case_preserve)
11081 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11084 xabdat = cc$rms_xabdat; /* To get creation date */
11085 xabdat.xab$l_nxt = (void *) &xabfhc;
11087 xabfhc = cc$rms_xabfhc; /* To get record length */
11088 xabfhc.xab$l_nxt = (void *) &xabsum;
11090 xabsum = cc$rms_xabsum; /* To get key and area information */
11092 if (!((sts = sys$open(&fab_in)) & 1)) {
11093 PerlMem_free(vmsin);
11094 PerlMem_free(vmsout);
11097 set_vaxc_errno(sts);
11099 case RMS$_FNF: case RMS$_DNF:
11100 set_errno(ENOENT); break;
11102 set_errno(ENOTDIR); break;
11104 set_errno(ENODEV); break;
11106 set_errno(EINVAL); break;
11108 set_errno(EACCES); break;
11110 set_errno(EVMSERR);
11117 fab_out.fab$w_ifi = 0;
11118 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11119 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11120 fab_out.fab$l_fop = FAB$M_SQO;
11121 rms_bind_fab_nam(fab_out, nam_out);
11122 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11123 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11124 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11125 esa_out = PerlMem_malloc(VMS_MAXRSS);
11126 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11127 rms_set_rsa(nam_out, NULL, 0);
11128 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11130 if (preserve_dates == 0) { /* Act like DCL COPY */
11131 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11132 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11133 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11134 PerlMem_free(vmsin);
11135 PerlMem_free(vmsout);
11138 PerlMem_free(esa_out);
11139 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11140 set_vaxc_errno(sts);
11143 fab_out.fab$l_xab = (void *) &xabdat;
11144 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11145 preserve_dates = 1;
11147 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11148 preserve_dates =0; /* bitmask from this point forward */
11150 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11151 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11152 PerlMem_free(vmsin);
11153 PerlMem_free(vmsout);
11156 PerlMem_free(esa_out);
11157 set_vaxc_errno(sts);
11160 set_errno(ENOENT); break;
11162 set_errno(ENOTDIR); break;
11164 set_errno(ENODEV); break;
11166 set_errno(EINVAL); break;
11168 set_errno(EACCES); break;
11170 set_errno(EVMSERR);
11174 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11175 if (preserve_dates & 2) {
11176 /* sys$close() will process xabrdt, not xabdat */
11177 xabrdt = cc$rms_xabrdt;
11179 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11181 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11182 * is unsigned long[2], while DECC & VAXC use a struct */
11183 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11185 fab_out.fab$l_xab = (void *) &xabrdt;
11188 ubf = PerlMem_malloc(32256);
11189 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11190 rab_in = cc$rms_rab;
11191 rab_in.rab$l_fab = &fab_in;
11192 rab_in.rab$l_rop = RAB$M_BIO;
11193 rab_in.rab$l_ubf = ubf;
11194 rab_in.rab$w_usz = 32256;
11195 if (!((sts = sys$connect(&rab_in)) & 1)) {
11196 sys$close(&fab_in); sys$close(&fab_out);
11197 PerlMem_free(vmsin);
11198 PerlMem_free(vmsout);
11202 PerlMem_free(esa_out);
11203 set_errno(EVMSERR); set_vaxc_errno(sts);
11207 rab_out = cc$rms_rab;
11208 rab_out.rab$l_fab = &fab_out;
11209 rab_out.rab$l_rbf = ubf;
11210 if (!((sts = sys$connect(&rab_out)) & 1)) {
11211 sys$close(&fab_in); sys$close(&fab_out);
11212 PerlMem_free(vmsin);
11213 PerlMem_free(vmsout);
11217 PerlMem_free(esa_out);
11218 set_errno(EVMSERR); set_vaxc_errno(sts);
11222 while ((sts = sys$read(&rab_in))) { /* always true */
11223 if (sts == RMS$_EOF) break;
11224 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11225 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11226 sys$close(&fab_in); sys$close(&fab_out);
11227 PerlMem_free(vmsin);
11228 PerlMem_free(vmsout);
11232 PerlMem_free(esa_out);
11233 set_errno(EVMSERR); set_vaxc_errno(sts);
11239 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11240 sys$close(&fab_in); sys$close(&fab_out);
11241 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11243 PerlMem_free(vmsin);
11244 PerlMem_free(vmsout);
11248 PerlMem_free(esa_out);
11249 set_errno(EVMSERR); set_vaxc_errno(sts);
11253 PerlMem_free(vmsin);
11254 PerlMem_free(vmsout);
11258 PerlMem_free(esa_out);
11261 } /* end of rmscopy() */
11265 /*** The following glue provides 'hooks' to make some of the routines
11266 * from this file available from Perl. These routines are sufficiently
11267 * basic, and are required sufficiently early in the build process,
11268 * that's it's nice to have them available to miniperl as well as the
11269 * full Perl, so they're set up here instead of in an extension. The
11270 * Perl code which handles importation of these names into a given
11271 * package lives in [.VMS]Filespec.pm in @INC.
11275 rmsexpand_fromperl(pTHX_ CV *cv)
11278 char *fspec, *defspec = NULL, *rslt;
11280 int fs_utf8, dfs_utf8;
11284 if (!items || items > 2)
11285 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11286 fspec = SvPV(ST(0),n_a);
11287 fs_utf8 = SvUTF8(ST(0));
11288 if (!fspec || !*fspec) XSRETURN_UNDEF;
11290 defspec = SvPV(ST(1),n_a);
11291 dfs_utf8 = SvUTF8(ST(1));
11293 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11294 ST(0) = sv_newmortal();
11295 if (rslt != NULL) {
11296 sv_usepvn(ST(0),rslt,strlen(rslt));
11305 vmsify_fromperl(pTHX_ CV *cv)
11312 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11313 utf8_fl = SvUTF8(ST(0));
11314 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11315 ST(0) = sv_newmortal();
11316 if (vmsified != NULL) {
11317 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11326 unixify_fromperl(pTHX_ CV *cv)
11333 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11334 utf8_fl = SvUTF8(ST(0));
11335 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11336 ST(0) = sv_newmortal();
11337 if (unixified != NULL) {
11338 sv_usepvn(ST(0),unixified,strlen(unixified));
11347 fileify_fromperl(pTHX_ CV *cv)
11354 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11355 utf8_fl = SvUTF8(ST(0));
11356 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11357 ST(0) = sv_newmortal();
11358 if (fileified != NULL) {
11359 sv_usepvn(ST(0),fileified,strlen(fileified));
11368 pathify_fromperl(pTHX_ CV *cv)
11375 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11376 utf8_fl = SvUTF8(ST(0));
11377 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11378 ST(0) = sv_newmortal();
11379 if (pathified != NULL) {
11380 sv_usepvn(ST(0),pathified,strlen(pathified));
11389 vmspath_fromperl(pTHX_ CV *cv)
11396 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11397 utf8_fl = SvUTF8(ST(0));
11398 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11399 ST(0) = sv_newmortal();
11400 if (vmspath != NULL) {
11401 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11410 unixpath_fromperl(pTHX_ CV *cv)
11417 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11418 utf8_fl = SvUTF8(ST(0));
11419 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11420 ST(0) = sv_newmortal();
11421 if (unixpath != NULL) {
11422 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11431 candelete_fromperl(pTHX_ CV *cv)
11439 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11441 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11442 Newx(fspec, VMS_MAXRSS, char);
11443 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11444 if (SvTYPE(mysv) == SVt_PVGV) {
11445 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11446 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11454 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11455 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11462 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11468 rmscopy_fromperl(pTHX_ CV *cv)
11471 char *inspec, *outspec, *inp, *outp;
11473 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11474 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11475 unsigned long int sts;
11480 if (items < 2 || items > 3)
11481 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11483 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11484 Newx(inspec, VMS_MAXRSS, char);
11485 if (SvTYPE(mysv) == SVt_PVGV) {
11486 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11487 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11495 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11496 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11502 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11503 Newx(outspec, VMS_MAXRSS, char);
11504 if (SvTYPE(mysv) == SVt_PVGV) {
11505 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11506 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11515 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11516 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11523 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11525 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11531 /* The mod2fname is limited to shorter filenames by design, so it should
11532 * not be modified to support longer EFS pathnames
11535 mod2fname(pTHX_ CV *cv)
11538 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11539 workbuff[NAM$C_MAXRSS*1 + 1];
11540 int total_namelen = 3, counter, num_entries;
11541 /* ODS-5 ups this, but we want to be consistent, so... */
11542 int max_name_len = 39;
11543 AV *in_array = (AV *)SvRV(ST(0));
11545 num_entries = av_len(in_array);
11547 /* All the names start with PL_. */
11548 strcpy(ultimate_name, "PL_");
11550 /* Clean up our working buffer */
11551 Zero(work_name, sizeof(work_name), char);
11553 /* Run through the entries and build up a working name */
11554 for(counter = 0; counter <= num_entries; counter++) {
11555 /* If it's not the first name then tack on a __ */
11557 strcat(work_name, "__");
11559 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11563 /* Check to see if we actually have to bother...*/
11564 if (strlen(work_name) + 3 <= max_name_len) {
11565 strcat(ultimate_name, work_name);
11567 /* It's too darned big, so we need to go strip. We use the same */
11568 /* algorithm as xsubpp does. First, strip out doubled __ */
11569 char *source, *dest, last;
11572 for (source = work_name; *source; source++) {
11573 if (last == *source && last == '_') {
11579 /* Go put it back */
11580 strcpy(work_name, workbuff);
11581 /* Is it still too big? */
11582 if (strlen(work_name) + 3 > max_name_len) {
11583 /* Strip duplicate letters */
11586 for (source = work_name; *source; source++) {
11587 if (last == toupper(*source)) {
11591 last = toupper(*source);
11593 strcpy(work_name, workbuff);
11596 /* Is it *still* too big? */
11597 if (strlen(work_name) + 3 > max_name_len) {
11598 /* Too bad, we truncate */
11599 work_name[max_name_len - 2] = 0;
11601 strcat(ultimate_name, work_name);
11604 /* Okay, return it */
11605 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11610 hushexit_fromperl(pTHX_ CV *cv)
11615 VMSISH_HUSHED = SvTRUE(ST(0));
11617 ST(0) = boolSV(VMSISH_HUSHED);
11623 Perl_vms_start_glob
11624 (pTHX_ SV *tmpglob,
11628 struct vs_str_st *rslt;
11632 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11635 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11636 struct dsc$descriptor_vs rsdsc;
11637 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11638 unsigned long hasver = 0, isunix = 0;
11639 unsigned long int lff_flags = 0;
11642 #ifdef VMS_LONGNAME_SUPPORT
11643 lff_flags = LIB$M_FIL_LONG_NAMES;
11645 /* The Newx macro will not allow me to assign a smaller array
11646 * to the rslt pointer, so we will assign it to the begin char pointer
11647 * and then copy the value into the rslt pointer.
11649 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11650 rslt = (struct vs_str_st *)begin;
11652 rstr = &rslt->str[0];
11653 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11654 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11655 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11656 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11658 Newx(vmsspec, VMS_MAXRSS, char);
11660 /* We could find out if there's an explicit dev/dir or version
11661 by peeking into lib$find_file's internal context at
11662 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11663 but that's unsupported, so I don't want to do it now and
11664 have it bite someone in the future. */
11665 /* Fix-me: vms_split_path() is the only way to do this, the
11666 existing method will fail with many legal EFS or UNIX specifications
11669 cp = SvPV(tmpglob,i);
11672 if (cp[i] == ';') hasver = 1;
11673 if (cp[i] == '.') {
11674 if (sts) hasver = 1;
11677 if (cp[i] == '/') {
11678 hasdir = isunix = 1;
11681 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11686 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11689 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11690 if (!stat_sts && S_ISDIR(st.st_mode)) {
11691 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11692 ok = (wilddsc.dsc$a_pointer != NULL);
11695 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11696 ok = (wilddsc.dsc$a_pointer != NULL);
11699 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11701 /* If not extended character set, replace ? with % */
11702 /* With extended character set, ? is a wildcard single character */
11703 if (!decc_efs_case_preserve) {
11704 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11705 if (*cp == '?') *cp = '%';
11708 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11709 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11710 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11712 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11713 &dfltdsc,NULL,&rms_sts,&lff_flags);
11714 if (!$VMS_STATUS_SUCCESS(sts))
11717 /* with varying string, 1st word of buffer contains result length */
11718 rstr[rslt->length] = '\0';
11720 /* Find where all the components are */
11721 v_sts = vms_split_path
11736 /* If no version on input, truncate the version on output */
11737 if (!hasver && (vs_len > 0)) {
11741 /* No version & a null extension on UNIX handling */
11742 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11748 if (!decc_efs_case_preserve) {
11749 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11753 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11757 /* Start with the name */
11760 strcat(begin,"\n");
11761 ok = (PerlIO_puts(tmpfp,begin) != EOF);
11763 if (cxt) (void)lib$find_file_end(&cxt);
11764 if (ok && sts != RMS$_NMF &&
11765 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11768 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11770 PerlIO_close(tmpfp);
11774 PerlIO_rewind(tmpfp);
11775 IoTYPE(io) = IoTYPE_RDONLY;
11776 IoIFP(io) = fp = tmpfp;
11777 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
11787 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11790 vms_realpath_fromperl(pTHX_ CV *cv)
11793 char *fspec, *rslt_spec, *rslt;
11796 if (!items || items != 1)
11797 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11799 fspec = SvPV(ST(0),n_a);
11800 if (!fspec || !*fspec) XSRETURN_UNDEF;
11802 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11803 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11804 ST(0) = sv_newmortal();
11806 sv_usepvn(ST(0),rslt,strlen(rslt));
11808 Safefree(rslt_spec);
11813 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11814 int do_vms_case_tolerant(void);
11817 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11820 ST(0) = boolSV(do_vms_case_tolerant());
11826 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11827 struct interp_intern *dst)
11829 memcpy(dst,src,sizeof(struct interp_intern));
11833 Perl_sys_intern_clear(pTHX)
11838 Perl_sys_intern_init(pTHX)
11840 unsigned int ix = RAND_MAX;
11845 /* fix me later to track running under GNV */
11846 /* this allows some limited testing */
11847 MY_POSIX_EXIT = decc_filename_unix_report;
11850 MY_INV_RAND_MAX = 1./x;
11854 init_os_extras(void)
11857 char* file = __FILE__;
11858 if (decc_disable_to_vms_logname_translation) {
11859 no_translate_barewords = TRUE;
11861 no_translate_barewords = FALSE;
11864 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11865 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11866 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11867 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11868 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11869 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11870 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11871 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11872 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11873 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11874 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11876 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11878 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11879 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11882 store_pipelocs(aTHX); /* will redo any earlier attempts */
11889 #if __CRTL_VER == 80200000
11890 /* This missed getting in to the DECC SDK for 8.2 */
11891 char *realpath(const char *file_name, char * resolved_name, ...);
11894 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11895 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11896 * The perl fallback routine to provide realpath() is not as efficient
11900 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11902 return realpath(filespec, outbuf);
11906 /* External entry points */
11907 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11908 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11910 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11915 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11916 /* case_tolerant */
11918 /*{{{int do_vms_case_tolerant(void)*/
11919 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11920 * controlled by a process setting.
11922 int do_vms_case_tolerant(void)
11924 return vms_process_case_tolerant;
11927 /* External entry points */
11928 int Perl_vms_case_tolerant(void)
11929 { return do_vms_case_tolerant(); }
11931 int Perl_vms_case_tolerant(void)
11932 { return vms_process_case_tolerant; }
11936 /* Start of DECC RTL Feature handling */
11938 static int sys_trnlnm
11939 (const char * logname,
11943 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11944 const unsigned long attr = LNM$M_CASE_BLIND;
11945 struct dsc$descriptor_s name_dsc;
11947 unsigned short result;
11948 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11951 name_dsc.dsc$w_length = strlen(logname);
11952 name_dsc.dsc$a_pointer = (char *)logname;
11953 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11954 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11956 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11958 if ($VMS_STATUS_SUCCESS(status)) {
11960 /* Null terminate and return the string */
11961 /*--------------------------------------*/
11968 static int sys_crelnm
11969 (const char * logname,
11970 const char * value)
11973 const char * proc_table = "LNM$PROCESS_TABLE";
11974 struct dsc$descriptor_s proc_table_dsc;
11975 struct dsc$descriptor_s logname_dsc;
11976 struct itmlst_3 item_list[2];
11978 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11979 proc_table_dsc.dsc$w_length = strlen(proc_table);
11980 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11981 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11983 logname_dsc.dsc$a_pointer = (char *) logname;
11984 logname_dsc.dsc$w_length = strlen(logname);
11985 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11986 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11988 item_list[0].buflen = strlen(value);
11989 item_list[0].itmcode = LNM$_STRING;
11990 item_list[0].bufadr = (char *)value;
11991 item_list[0].retlen = NULL;
11993 item_list[1].buflen = 0;
11994 item_list[1].itmcode = 0;
11996 ret_val = sys$crelnm
11998 (const struct dsc$descriptor_s *)&proc_table_dsc,
11999 (const struct dsc$descriptor_s *)&logname_dsc,
12001 (const struct item_list_3 *) item_list);
12006 /* C RTL Feature settings */
12008 static int set_features
12009 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12010 int (* cli_routine)(void), /* Not documented */
12011 void *image_info) /* Not documented */
12018 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12019 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12020 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12021 unsigned long case_perm;
12022 unsigned long case_image;
12025 /* Allow an exception to bring Perl into the VMS debugger */
12026 vms_debug_on_exception = 0;
12027 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12028 if ($VMS_STATUS_SUCCESS(status)) {
12029 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12030 vms_debug_on_exception = 1;
12032 vms_debug_on_exception = 0;
12035 /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12036 vms_vtf7_filenames = 0;
12037 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12038 if ($VMS_STATUS_SUCCESS(status)) {
12039 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12040 vms_vtf7_filenames = 1;
12042 vms_vtf7_filenames = 0;
12045 /* Dectect running under GNV Bash or other UNIX like shell */
12046 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12047 gnv_unix_shell = 0;
12048 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12049 if ($VMS_STATUS_SUCCESS(status)) {
12050 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12051 gnv_unix_shell = 1;
12052 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12053 set_feature_default("DECC$EFS_CHARSET", 1);
12054 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12055 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12056 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12057 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12060 gnv_unix_shell = 0;
12064 /* hacks to see if known bugs are still present for testing */
12066 /* Readdir is returning filenames in VMS syntax always */
12067 decc_bug_readdir_efs1 = 1;
12068 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12069 if ($VMS_STATUS_SUCCESS(status)) {
12070 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12071 decc_bug_readdir_efs1 = 1;
12073 decc_bug_readdir_efs1 = 0;
12076 /* PCP mode requires creating /dev/null special device file */
12077 decc_bug_devnull = 0;
12078 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12079 if ($VMS_STATUS_SUCCESS(status)) {
12080 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12081 decc_bug_devnull = 1;
12083 decc_bug_devnull = 0;
12086 /* fgetname returning a VMS name in UNIX mode */
12087 decc_bug_fgetname = 1;
12088 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12089 if ($VMS_STATUS_SUCCESS(status)) {
12090 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12091 decc_bug_fgetname = 1;
12093 decc_bug_fgetname = 0;
12096 /* UNIX directory names with no paths are broken in a lot of places */
12097 decc_dir_barename = 1;
12098 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12099 if ($VMS_STATUS_SUCCESS(status)) {
12100 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12101 decc_dir_barename = 1;
12103 decc_dir_barename = 0;
12106 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12107 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12109 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12110 if (decc_disable_to_vms_logname_translation < 0)
12111 decc_disable_to_vms_logname_translation = 0;
12114 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12116 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12117 if (decc_efs_case_preserve < 0)
12118 decc_efs_case_preserve = 0;
12121 s = decc$feature_get_index("DECC$EFS_CHARSET");
12123 decc_efs_charset = decc$feature_get_value(s, 1);
12124 if (decc_efs_charset < 0)
12125 decc_efs_charset = 0;
12128 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12130 decc_filename_unix_report = decc$feature_get_value(s, 1);
12131 if (decc_filename_unix_report > 0)
12132 decc_filename_unix_report = 1;
12134 decc_filename_unix_report = 0;
12137 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12139 decc_filename_unix_only = decc$feature_get_value(s, 1);
12140 if (decc_filename_unix_only > 0) {
12141 decc_filename_unix_only = 1;
12144 decc_filename_unix_only = 0;
12148 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12150 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12151 if (decc_filename_unix_no_version < 0)
12152 decc_filename_unix_no_version = 0;
12155 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12157 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12158 if (decc_readdir_dropdotnotype < 0)
12159 decc_readdir_dropdotnotype = 0;
12162 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12163 if ($VMS_STATUS_SUCCESS(status)) {
12164 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12166 dflt = decc$feature_get_value(s, 4);
12168 decc_disable_posix_root = decc$feature_get_value(s, 1);
12169 if (decc_disable_posix_root <= 0) {
12170 decc$feature_set_value(s, 1, 1);
12171 decc_disable_posix_root = 1;
12175 /* Traditionally Perl assumes this is off */
12176 decc_disable_posix_root = 1;
12177 decc$feature_set_value(s, 1, 1);
12182 #if __CRTL_VER >= 80200000
12183 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12185 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12186 if (decc_posix_compliant_pathnames < 0)
12187 decc_posix_compliant_pathnames = 0;
12188 if (decc_posix_compliant_pathnames > 4)
12189 decc_posix_compliant_pathnames = 0;
12194 status = sys_trnlnm
12195 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12196 if ($VMS_STATUS_SUCCESS(status)) {
12197 val_str[0] = _toupper(val_str[0]);
12198 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12199 decc_disable_to_vms_logname_translation = 1;
12204 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12205 if ($VMS_STATUS_SUCCESS(status)) {
12206 val_str[0] = _toupper(val_str[0]);
12207 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12208 decc_efs_case_preserve = 1;
12213 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12214 if ($VMS_STATUS_SUCCESS(status)) {
12215 val_str[0] = _toupper(val_str[0]);
12216 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12217 decc_filename_unix_report = 1;
12220 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12221 if ($VMS_STATUS_SUCCESS(status)) {
12222 val_str[0] = _toupper(val_str[0]);
12223 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12224 decc_filename_unix_only = 1;
12225 decc_filename_unix_report = 1;
12228 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12229 if ($VMS_STATUS_SUCCESS(status)) {
12230 val_str[0] = _toupper(val_str[0]);
12231 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12232 decc_filename_unix_no_version = 1;
12235 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12236 if ($VMS_STATUS_SUCCESS(status)) {
12237 val_str[0] = _toupper(val_str[0]);
12238 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12239 decc_readdir_dropdotnotype = 1;
12244 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12246 /* Report true case tolerance */
12247 /*----------------------------*/
12248 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12249 if (!$VMS_STATUS_SUCCESS(status))
12250 case_perm = PPROP$K_CASE_BLIND;
12251 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12252 if (!$VMS_STATUS_SUCCESS(status))
12253 case_image = PPROP$K_CASE_BLIND;
12254 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12255 (case_image == PPROP$K_CASE_SENSITIVE))
12256 vms_process_case_tolerant = 0;
12261 /* CRTL can be initialized past this point, but not before. */
12262 /* DECC$CRTL_INIT(); */
12268 /* DECC dependent attributes */
12269 #if __DECC_VER < 60560002
12271 #define not_executable
12273 #define relative ,rel
12274 #define not_executable ,noexe
12277 #pragma extern_model save
12278 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12280 const __align (LONGWORD) int spare[8] = {0};
12281 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12284 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12285 nowrt,noshr relative not_executable
12287 const long vms_cc_features = (const long)set_features;
12290 ** Force a reference to LIB$INITIALIZE to ensure it
12291 ** exists in the image.
12293 int lib$initialize(void);
12295 #pragma extern_model strict_refdef
12297 int lib_init_ref = (int) lib$initialize;
12300 #pragma extern_model restore