3 * VMS-specific routines for perl5
6 * August 2005 Convert VMS status code to UNIX status codes
7 * August 2000 tweaks to vms_image_init, my_flush, my_fwrite, cando_by_name,
8 * and Perl_cando by Craig Berry
9 * 29-Aug-2000 Charles Lane's piping improvements rolled in
10 * 20-Aug-1999 revisions by Charles Bailey bailey@newman.upenn.edu
19 #include <climsgdef.h>
29 #include <libclidef.h>
31 #include <lib$routines.h>
34 #if __CRTL_VER >= 70301000 && !defined(__VAX)
44 #include <str$routines.h>
50 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
52 #define NO_EFN EFN$C_ENF
57 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
58 int decc$feature_get_index(const char *name);
59 char* decc$feature_get_name(int index);
60 int decc$feature_get_value(int index, int mode);
61 int decc$feature_set_value(int index, int mode, int value);
66 #pragma member_alignment save
67 #pragma nomember_alignment longword
72 unsigned short * retadr;
74 #pragma member_alignment restore
76 /* More specific prototype than in starlet_c.h makes programming errors
85 const struct dsc$descriptor_s * devnam,
86 const struct item_list_3 * itmlst,
88 void * (astadr)(unsigned long),
92 #if __CRTL_VER >= 70300000 && !defined(__VAX)
94 static int set_feature_default(const char *name, int value)
99 index = decc$feature_get_index(name);
101 status = decc$feature_set_value(index, 1, value);
102 if (index == -1 || (status == -1)) {
106 status = decc$feature_get_value(index, 1);
107 if (status != value) {
115 /* Older versions of ssdef.h don't have these */
116 #ifndef SS$_INVFILFOROP
117 # define SS$_INVFILFOROP 3930
119 #ifndef SS$_NOSUCHOBJECT
120 # define SS$_NOSUCHOBJECT 2696
123 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
124 #define PERLIO_NOT_STDIO 0
126 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
127 * code below needs to get to the underlying CRTL routines. */
128 #define DONT_MASK_RTL_CALLS
132 /* Anticipating future expansion in lexical warnings . . . */
133 #ifndef WARN_INTERNAL
134 # define WARN_INTERNAL WARN_MISC
137 #ifdef VMS_LONGNAME_SUPPORT
138 #include <libfildef.h>
141 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
142 # define RTL_USES_UTC 1
146 /* gcc's header files don't #define direct access macros
147 * corresponding to VAXC's variant structs */
149 # define uic$v_format uic$r_uic_form.uic$v_format
150 # define uic$v_group uic$r_uic_form.uic$v_group
151 # define uic$v_member uic$r_uic_form.uic$v_member
152 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
153 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
154 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
155 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
158 #if defined(NEED_AN_H_ERRNO)
163 #pragma message disable pragma
164 #pragma member_alignment save
165 #pragma nomember_alignment longword
167 #pragma message disable misalgndmem
170 unsigned short int buflen;
171 unsigned short int itmcode;
173 unsigned short int *retlen;
176 struct filescan_itmlst_2 {
177 unsigned short length;
178 unsigned short itmcode;
183 unsigned short length;
188 #pragma message restore
189 #pragma member_alignment restore
192 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
193 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
194 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
195 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
196 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
197 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
198 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
199 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
200 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
201 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
202 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
204 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
205 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
206 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
207 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
209 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
210 #define PERL_LNM_MAX_ALLOWED_INDEX 127
212 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
213 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
216 #define PERL_LNM_MAX_ITER 10
218 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
219 #if __CRTL_VER >= 70302000 && !defined(__VAX)
220 #define MAX_DCL_SYMBOL (8192)
221 #define MAX_DCL_LINE_LENGTH (4096 - 4)
223 #define MAX_DCL_SYMBOL (1024)
224 #define MAX_DCL_LINE_LENGTH (1024 - 4)
227 static char *__mystrtolower(char *str)
229 if (str) for (; *str; ++str) *str= tolower(*str);
233 static struct dsc$descriptor_s fildevdsc =
234 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
235 static struct dsc$descriptor_s crtlenvdsc =
236 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
237 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
238 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
239 static struct dsc$descriptor_s **env_tables = defenv;
240 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
242 /* True if we shouldn't treat barewords as logicals during directory */
244 static int no_translate_barewords;
247 static int tz_updated = 1;
250 /* DECC Features that may need to affect how Perl interprets
251 * displays filename information
253 static int decc_disable_to_vms_logname_translation = 1;
254 static int decc_disable_posix_root = 1;
255 int decc_efs_case_preserve = 0;
256 static int decc_efs_charset = 0;
257 static int decc_filename_unix_no_version = 0;
258 static int decc_filename_unix_only = 0;
259 int decc_filename_unix_report = 0;
260 int decc_posix_compliant_pathnames = 0;
261 int decc_readdir_dropdotnotype = 0;
262 static int vms_process_case_tolerant = 1;
263 int vms_vtf7_filenames = 0;
264 int gnv_unix_shell = 0;
266 /* bug workarounds if needed */
267 int decc_bug_readdir_efs1 = 0;
268 int decc_bug_devnull = 1;
269 int decc_bug_fgetname = 0;
270 int decc_dir_barename = 0;
272 static int vms_debug_on_exception = 0;
274 /* Is this a UNIX file specification?
275 * No longer a simple check with EFS file specs
276 * For now, not a full check, but need to
277 * handle POSIX ^UP^ specifications
278 * Fixing to handle ^/ cases would require
279 * changes to many other conversion routines.
282 static int is_unix_filespec(const char *path)
288 if (strncmp(path,"\"^UP^",5) != 0) {
289 pch1 = strchr(path, '/');
294 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
295 if (decc_filename_unix_report || decc_filename_unix_only) {
296 if (strcmp(path,".") == 0)
304 /* This routine converts a UCS-2 character to be VTF-7 encoded.
307 static void ucs2_to_vtf7
309 unsigned long ucs2_char,
312 unsigned char * ucs_ptr;
315 ucs_ptr = (unsigned char *)&ucs2_char;
319 hex = (ucs_ptr[1] >> 4) & 0xf;
321 outspec[2] = hex + '0';
323 outspec[2] = (hex - 9) + 'A';
324 hex = ucs_ptr[1] & 0xF;
326 outspec[3] = hex + '0';
328 outspec[3] = (hex - 9) + 'A';
330 hex = (ucs_ptr[0] >> 4) & 0xf;
332 outspec[4] = hex + '0';
334 outspec[4] = (hex - 9) + 'A';
335 hex = ucs_ptr[1] & 0xF;
337 outspec[5] = hex + '0';
339 outspec[5] = (hex - 9) + 'A';
345 /* This handles the conversion of a UNIX extended character set to a ^
346 * escaped VMS character.
347 * in a UNIX file specification.
349 * The output count variable contains the number of characters added
350 * to the output string.
352 * The return value is the number of characters read from the input string
354 static int copy_expand_unix_filename_escape
355 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
363 utf8_flag = *utf8_fl;
367 if (*inspec >= 0x80) {
368 if (utf8_fl && vms_vtf7_filenames) {
369 unsigned long ucs_char;
373 if ((*inspec & 0xE0) == 0xC0) {
375 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
376 if (ucs_char >= 0x80) {
377 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
380 } else if ((*inspec & 0xF0) == 0xE0) {
382 ucs_char = ((inspec[0] & 0xF) << 12) +
383 ((inspec[1] & 0x3f) << 6) +
385 if (ucs_char >= 0x800) {
386 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
390 #if 0 /* I do not see longer sequences supported by OpenVMS */
391 /* Maybe some one can fix this later */
392 } else if ((*inspec & 0xF8) == 0xF0) {
395 } else if ((*inspec & 0xFC) == 0xF8) {
398 } else if ((*inspec & 0xFE) == 0xFC) {
405 /* High bit set, but not a unicode character! */
407 /* Non printing DECMCS or ISO Latin-1 character? */
408 if (*inspec <= 0x9F) {
412 hex = (*inspec >> 4) & 0xF;
414 outspec[1] = hex + '0';
416 outspec[1] = (hex - 9) + 'A';
420 outspec[2] = hex + '0';
422 outspec[2] = (hex - 9) + 'A';
426 } else if (*inspec == 0xA0) {
432 } else if (*inspec == 0xFF) {
444 /* Is this a macro that needs to be passed through?
445 * Macros start with $( and an alpha character, followed
446 * by a string of alpha numeric characters ending with a )
447 * If this does not match, then encode it as ODS-5.
449 if ((inspec[0] == '$') && (inspec[1] == '(')) {
452 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
454 outspec[0] = inspec[0];
455 outspec[1] = inspec[1];
456 outspec[2] = inspec[2];
458 while(isalnum(inspec[tcnt]) ||
459 (inspec[2] == '.') || (inspec[2] == '_')) {
460 outspec[tcnt] = inspec[tcnt];
463 if (inspec[tcnt] == ')') {
464 outspec[tcnt] = inspec[tcnt];
481 if (decc_efs_charset == 0)
508 /* Assume that this is to be escaped */
510 outspec[1] = *inspec;
514 case ' ': /* space */
515 /* Assume that this is to be escaped */
530 /* This handles the expansion of a '^' prefix to the proper character
531 * in a UNIX file specification.
533 * The output count variable contains the number of characters added
534 * to the output string.
536 * The return value is the number of characters read from the input
539 static int copy_expand_vms_filename_escape
540 (char *outspec, const char *inspec, int *output_cnt)
547 if (*inspec == '^') {
551 /* Non trailing dots should just be passed through */
556 case '_': /* space */
562 case 'U': /* Unicode - FIX-ME this is wrong. */
565 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
568 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
569 outspec[0] == c1 & 0xff;
570 outspec[1] == c2 & 0xff;
577 /* Error - do best we can to continue */
587 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
591 scnt = sscanf(inspec, "%2x", &c1);
592 outspec[0] = c1 & 0xff;
615 (const struct dsc$descriptor_s * srcstr,
616 struct filescan_itmlst_2 * valuelist,
617 unsigned long * fldflags,
618 struct dsc$descriptor_s *auxout,
619 unsigned short * retlen);
621 /* vms_split_path - Verify that the input file specification is a
622 * VMS format file specification, and provide pointers to the components of
623 * it. With EFS format filenames, this is virtually the only way to
624 * parse a VMS path specification into components.
626 * If the sum of the components do not add up to the length of the
627 * string, then the passed file specification is probably a UNIX style
630 static int vms_split_path
645 struct dsc$descriptor path_desc;
649 struct filescan_itmlst_2 item_list[9];
650 const int filespec = 0;
651 const int nodespec = 1;
652 const int devspec = 2;
653 const int rootspec = 3;
654 const int dirspec = 4;
655 const int namespec = 5;
656 const int typespec = 6;
657 const int verspec = 7;
659 /* Assume the worst for an easy exit */
674 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
675 path_desc.dsc$w_length = strlen(path);
676 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
677 path_desc.dsc$b_class = DSC$K_CLASS_S;
679 /* Get the total length, if it is shorter than the string passed
680 * then this was probably not a VMS formatted file specification
682 item_list[filespec].itmcode = FSCN$_FILESPEC;
683 item_list[filespec].length = 0;
684 item_list[filespec].component = NULL;
686 /* If the node is present, then it gets considered as part of the
687 * volume name to hopefully make things simple.
689 item_list[nodespec].itmcode = FSCN$_NODE;
690 item_list[nodespec].length = 0;
691 item_list[nodespec].component = NULL;
693 item_list[devspec].itmcode = FSCN$_DEVICE;
694 item_list[devspec].length = 0;
695 item_list[devspec].component = NULL;
697 /* root is a special case, adding it to either the directory or
698 * the device components will probalby complicate things for the
699 * callers of this routine, so leave it separate.
701 item_list[rootspec].itmcode = FSCN$_ROOT;
702 item_list[rootspec].length = 0;
703 item_list[rootspec].component = NULL;
705 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
706 item_list[dirspec].length = 0;
707 item_list[dirspec].component = NULL;
709 item_list[namespec].itmcode = FSCN$_NAME;
710 item_list[namespec].length = 0;
711 item_list[namespec].component = NULL;
713 item_list[typespec].itmcode = FSCN$_TYPE;
714 item_list[typespec].length = 0;
715 item_list[typespec].component = NULL;
717 item_list[verspec].itmcode = FSCN$_VERSION;
718 item_list[verspec].length = 0;
719 item_list[verspec].component = NULL;
721 item_list[8].itmcode = 0;
722 item_list[8].length = 0;
723 item_list[8].component = NULL;
725 status = SYS$FILESCAN
726 ((const struct dsc$descriptor_s *)&path_desc, item_list,
728 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
730 /* If we parsed it successfully these two lengths should be the same */
731 if (path_desc.dsc$w_length != item_list[filespec].length)
734 /* If we got here, then it is a VMS file specification */
737 /* set the volume name */
738 if (item_list[nodespec].length > 0) {
739 *volume = item_list[nodespec].component;
740 *vol_len = item_list[nodespec].length + item_list[devspec].length;
743 *volume = item_list[devspec].component;
744 *vol_len = item_list[devspec].length;
747 *root = item_list[rootspec].component;
748 *root_len = item_list[rootspec].length;
750 *dir = item_list[dirspec].component;
751 *dir_len = item_list[dirspec].length;
753 /* Now fun with versions and EFS file specifications
754 * The parser can not tell the difference when a "." is a version
755 * delimiter or a part of the file specification.
757 if ((decc_efs_charset) &&
758 (item_list[verspec].length > 0) &&
759 (item_list[verspec].component[0] == '.')) {
760 *name = item_list[namespec].component;
761 *name_len = item_list[namespec].length + item_list[typespec].length;
762 *ext = item_list[verspec].component;
763 *ext_len = item_list[verspec].length;
768 *name = item_list[namespec].component;
769 *name_len = item_list[namespec].length;
770 *ext = item_list[typespec].component;
771 *ext_len = item_list[typespec].length;
772 *version = item_list[verspec].component;
773 *ver_len = item_list[verspec].length;
780 * Routine to retrieve the maximum equivalence index for an input
781 * logical name. Some calls to this routine have no knowledge if
782 * the variable is a logical or not. So on error we return a max
785 /*{{{int my_maxidx(const char *lnm) */
787 my_maxidx(const char *lnm)
791 int attr = LNM$M_CASE_BLIND;
792 struct dsc$descriptor lnmdsc;
793 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
796 lnmdsc.dsc$w_length = strlen(lnm);
797 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
798 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
799 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
801 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
802 if ((status & 1) == 0)
809 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
811 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
812 struct dsc$descriptor_s **tabvec, unsigned long int flags)
815 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
816 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
817 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
819 unsigned char acmode;
820 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
821 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
822 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
823 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
825 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
826 #if defined(PERL_IMPLICIT_CONTEXT)
829 aTHX = PERL_GET_INTERP;
835 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
836 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
838 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
839 *cp2 = _toupper(*cp1);
840 if (cp1 - lnm > LNM$C_NAMLENGTH) {
841 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
845 lnmdsc.dsc$w_length = cp1 - lnm;
846 lnmdsc.dsc$a_pointer = uplnm;
847 uplnm[lnmdsc.dsc$w_length] = '\0';
848 secure = flags & PERL__TRNENV_SECURE;
849 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
850 if (!tabvec || !*tabvec) tabvec = env_tables;
852 for (curtab = 0; tabvec[curtab]; curtab++) {
853 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
854 if (!ivenv && !secure) {
859 Perl_warn(aTHX_ "Can't read CRTL environ\n");
862 retsts = SS$_NOLOGNAM;
863 for (i = 0; environ[i]; i++) {
864 if ((eq = strchr(environ[i],'=')) &&
865 lnmdsc.dsc$w_length == (eq - environ[i]) &&
866 !strncmp(environ[i],uplnm,eq - environ[i])) {
868 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
869 if (!eqvlen) continue;
874 if (retsts != SS$_NOLOGNAM) break;
877 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
878 !str$case_blind_compare(&tmpdsc,&clisym)) {
879 if (!ivsym && !secure) {
880 unsigned short int deflen = LNM$C_NAMLENGTH;
881 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
882 /* dynamic dsc to accomodate possible long value */
883 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
884 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
886 if (eqvlen > MAX_DCL_SYMBOL) {
887 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
888 eqvlen = MAX_DCL_SYMBOL;
889 /* Special hack--we might be called before the interpreter's */
890 /* fully initialized, in which case either thr or PL_curcop */
891 /* might be bogus. We have to check, since ckWARN needs them */
892 /* both to be valid if running threaded */
893 if (ckWARN(WARN_MISC)) {
894 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
897 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
899 _ckvmssts(lib$sfree1_dd(&eqvdsc));
900 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
901 if (retsts == LIB$_NOSUCHSYM) continue;
906 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
907 midx = my_maxidx(lnm);
908 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
909 lnmlst[1].bufadr = cp2;
911 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
912 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
913 if (retsts == SS$_NOLOGNAM) break;
914 /* PPFs have a prefix */
917 *((int *)uplnm) == *((int *)"SYS$") &&
919 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
920 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
921 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
922 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
923 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
924 memmove(eqv,eqv+4,eqvlen-4);
930 if ((retsts == SS$_IVLOGNAM) ||
931 (retsts == SS$_NOLOGNAM)) { continue; }
934 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
935 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
936 if (retsts == SS$_NOLOGNAM) continue;
939 eqvlen = strlen(eqv);
943 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
944 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
945 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
946 retsts == SS$_NOLOGNAM) {
947 set_errno(EINVAL); set_vaxc_errno(retsts);
949 else _ckvmssts(retsts);
951 } /* end of vmstrnenv */
954 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
955 /* Define as a function so we can access statics. */
956 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
958 return vmstrnenv(lnm,eqv,idx,fildev,
959 #ifdef SECURE_INTERNAL_GETENV
960 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
969 * Note: Uses Perl temp to store result so char * can be returned to
970 * caller; this pointer will be invalidated at next Perl statement
972 * We define this as a function rather than a macro in terms of my_getenv_len()
973 * so that it'll work when PL_curinterp is undefined (and we therefore can't
976 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
978 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
981 static char *__my_getenv_eqv = NULL;
982 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
983 unsigned long int idx = 0;
984 int trnsuccess, success, secure, saverr, savvmserr;
988 midx = my_maxidx(lnm) + 1;
990 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
991 /* Set up a temporary buffer for the return value; Perl will
992 * clean it up at the next statement transition */
993 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
994 if (!tmpsv) return NULL;
998 /* Assume no interpreter ==> single thread */
999 if (__my_getenv_eqv != NULL) {
1000 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1003 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1005 eqv = __my_getenv_eqv;
1008 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1009 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1011 getcwd(eqv,LNM$C_NAMLENGTH);
1015 /* Get rid of "000000/ in rooted filespecs */
1018 zeros = strstr(eqv, "/000000/");
1019 if (zeros != NULL) {
1021 mlen = len - (zeros - eqv) - 7;
1022 memmove(zeros, &zeros[7], mlen);
1030 /* Impose security constraints only if tainting */
1032 /* Impose security constraints only if tainting */
1033 secure = PL_curinterp ? PL_tainting : will_taint;
1034 saverr = errno; savvmserr = vaxc$errno;
1041 #ifdef SECURE_INTERNAL_GETENV
1042 secure ? PERL__TRNENV_SECURE : 0
1048 /* For the getenv interface we combine all the equivalence names
1049 * of a search list logical into one value to acquire a maximum
1050 * value length of 255*128 (assuming %ENV is using logicals).
1052 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1054 /* If the name contains a semicolon-delimited index, parse it
1055 * off and make sure we only retrieve the equivalence name for
1057 if ((cp2 = strchr(lnm,';')) != NULL) {
1059 uplnm[cp2-lnm] = '\0';
1060 idx = strtoul(cp2+1,NULL,0);
1062 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1065 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1067 /* Discard NOLOGNAM on internal calls since we're often looking
1068 * for an optional name, and this "error" often shows up as the
1069 * (bogus) exit status for a die() call later on. */
1070 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1071 return success ? eqv : Nullch;
1074 } /* end of my_getenv() */
1078 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1080 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1084 unsigned long idx = 0;
1086 static char *__my_getenv_len_eqv = NULL;
1087 int secure, saverr, savvmserr;
1090 midx = my_maxidx(lnm) + 1;
1092 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1093 /* Set up a temporary buffer for the return value; Perl will
1094 * clean it up at the next statement transition */
1095 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1096 if (!tmpsv) return NULL;
1100 /* Assume no interpreter ==> single thread */
1101 if (__my_getenv_len_eqv != NULL) {
1102 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1105 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1107 buf = __my_getenv_len_eqv;
1110 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1111 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1114 getcwd(buf,LNM$C_NAMLENGTH);
1117 /* Get rid of "000000/ in rooted filespecs */
1119 zeros = strstr(buf, "/000000/");
1120 if (zeros != NULL) {
1122 mlen = *len - (zeros - buf) - 7;
1123 memmove(zeros, &zeros[7], mlen);
1132 /* Impose security constraints only if tainting */
1133 secure = PL_curinterp ? PL_tainting : will_taint;
1134 saverr = errno; savvmserr = vaxc$errno;
1141 #ifdef SECURE_INTERNAL_GETENV
1142 secure ? PERL__TRNENV_SECURE : 0
1148 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1150 if ((cp2 = strchr(lnm,';')) != NULL) {
1152 buf[cp2-lnm] = '\0';
1153 idx = strtoul(cp2+1,NULL,0);
1155 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1158 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1160 /* Get rid of "000000/ in rooted filespecs */
1163 zeros = strstr(buf, "/000000/");
1164 if (zeros != NULL) {
1166 mlen = *len - (zeros - buf) - 7;
1167 memmove(zeros, &zeros[7], mlen);
1173 /* Discard NOLOGNAM on internal calls since we're often looking
1174 * for an optional name, and this "error" often shows up as the
1175 * (bogus) exit status for a die() call later on. */
1176 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1177 return *len ? buf : Nullch;
1180 } /* end of my_getenv_len() */
1183 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1185 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1187 /*{{{ void prime_env_iter() */
1189 prime_env_iter(void)
1190 /* Fill the %ENV associative array with all logical names we can
1191 * find, in preparation for iterating over it.
1194 static int primed = 0;
1195 HV *seenhv = NULL, *envhv;
1197 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1198 unsigned short int chan;
1199 #ifndef CLI$M_TRUSTED
1200 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1202 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1203 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1205 bool have_sym = FALSE, have_lnm = FALSE;
1206 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1207 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1208 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1209 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1210 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1211 #if defined(PERL_IMPLICIT_CONTEXT)
1214 #if defined(USE_ITHREADS)
1215 static perl_mutex primenv_mutex;
1216 MUTEX_INIT(&primenv_mutex);
1219 #if defined(PERL_IMPLICIT_CONTEXT)
1220 /* We jump through these hoops because we can be called at */
1221 /* platform-specific initialization time, which is before anything is */
1222 /* set up--we can't even do a plain dTHX since that relies on the */
1223 /* interpreter structure to be initialized */
1225 aTHX = PERL_GET_INTERP;
1231 if (primed || !PL_envgv) return;
1232 MUTEX_LOCK(&primenv_mutex);
1233 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1234 envhv = GvHVn(PL_envgv);
1235 /* Perform a dummy fetch as an lval to insure that the hash table is
1236 * set up. Otherwise, the hv_store() will turn into a nullop. */
1237 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1239 for (i = 0; env_tables[i]; i++) {
1240 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1241 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1242 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1244 if (have_sym || have_lnm) {
1245 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1246 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1247 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1248 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1251 for (i--; i >= 0; i--) {
1252 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1255 for (j = 0; environ[j]; j++) {
1256 if (!(start = strchr(environ[j],'='))) {
1257 if (ckWARN(WARN_INTERNAL))
1258 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1262 sv = newSVpv(start,0);
1264 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1269 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1270 !str$case_blind_compare(&tmpdsc,&clisym)) {
1271 strcpy(cmd,"Show Symbol/Global *");
1272 cmddsc.dsc$w_length = 20;
1273 if (env_tables[i]->dsc$w_length == 12 &&
1274 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1275 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1276 flags = defflags | CLI$M_NOLOGNAM;
1279 strcpy(cmd,"Show Logical *");
1280 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1281 strcat(cmd," /Table=");
1282 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1283 cmddsc.dsc$w_length = strlen(cmd);
1285 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1286 flags = defflags | CLI$M_NOCLISYM;
1289 /* Create a new subprocess to execute each command, to exclude the
1290 * remote possibility that someone could subvert a mbx or file used
1291 * to write multiple commands to a single subprocess.
1294 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1295 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1296 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1297 defflags &= ~CLI$M_TRUSTED;
1298 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1300 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1301 if (seenhv) SvREFCNT_dec(seenhv);
1304 char *cp1, *cp2, *key;
1305 unsigned long int sts, iosb[2], retlen, keylen;
1308 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1309 if (sts & 1) sts = iosb[0] & 0xffff;
1310 if (sts == SS$_ENDOFFILE) {
1312 while (substs == 0) { sys$hiber(); wakect++;}
1313 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1318 retlen = iosb[0] >> 16;
1319 if (!retlen) continue; /* blank line */
1321 if (iosb[1] != subpid) {
1323 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1327 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1328 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1330 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1331 if (*cp1 == '(' || /* Logical name table name */
1332 *cp1 == '=' /* Next eqv of searchlist */) continue;
1333 if (*cp1 == '"') cp1++;
1334 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1335 key = cp1; keylen = cp2 - cp1;
1336 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1337 while (*cp2 && *cp2 != '=') cp2++;
1338 while (*cp2 && *cp2 == '=') cp2++;
1339 while (*cp2 && *cp2 == ' ') cp2++;
1340 if (*cp2 == '"') { /* String translation; may embed "" */
1341 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1342 cp2++; cp1--; /* Skip "" surrounding translation */
1344 else { /* Numeric translation */
1345 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1346 cp1--; /* stop on last non-space char */
1348 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1349 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1352 PERL_HASH(hash,key,keylen);
1354 if (cp1 == cp2 && *cp2 == '.') {
1355 /* A single dot usually means an unprintable character, such as a null
1356 * to indicate a zero-length value. Get the actual value to make sure.
1358 char lnm[LNM$C_NAMLENGTH+1];
1359 char eqv[MAX_DCL_SYMBOL+1];
1361 strncpy(lnm, key, keylen);
1362 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1363 sv = newSVpvn(eqv, strlen(eqv));
1366 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1370 hv_store(envhv,key,keylen,sv,hash);
1371 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1373 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1374 /* get the PPFs for this process, not the subprocess */
1375 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1376 char eqv[LNM$C_NAMLENGTH+1];
1378 for (i = 0; ppfs[i]; i++) {
1379 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1380 sv = newSVpv(eqv,trnlen);
1382 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1387 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1388 if (buf) Safefree(buf);
1389 if (seenhv) SvREFCNT_dec(seenhv);
1390 MUTEX_UNLOCK(&primenv_mutex);
1393 } /* end of prime_env_iter */
1397 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1398 /* Define or delete an element in the same "environment" as
1399 * vmstrnenv(). If an element is to be deleted, it's removed from
1400 * the first place it's found. If it's to be set, it's set in the
1401 * place designated by the first element of the table vector.
1402 * Like setenv() returns 0 for success, non-zero on error.
1405 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1408 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1409 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1411 unsigned long int retsts, usermode = PSL$C_USER;
1412 struct itmlst_3 *ile, *ilist;
1413 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1414 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1415 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1416 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1417 $DESCRIPTOR(local,"_LOCAL");
1420 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1421 return SS$_IVLOGNAM;
1424 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1425 *cp2 = _toupper(*cp1);
1426 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1427 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1428 return SS$_IVLOGNAM;
1431 lnmdsc.dsc$w_length = cp1 - lnm;
1432 if (!tabvec || !*tabvec) tabvec = env_tables;
1434 if (!eqv) { /* we're deleting n element */
1435 for (curtab = 0; tabvec[curtab]; curtab++) {
1436 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1438 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1439 if ((cp1 = strchr(environ[i],'=')) &&
1440 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1441 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1443 return setenv(lnm,"",1) ? vaxc$errno : 0;
1446 ivenv = 1; retsts = SS$_NOLOGNAM;
1448 if (ckWARN(WARN_INTERNAL))
1449 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1450 ivenv = 1; retsts = SS$_NOSUCHPGM;
1456 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1457 !str$case_blind_compare(&tmpdsc,&clisym)) {
1458 unsigned int symtype;
1459 if (tabvec[curtab]->dsc$w_length == 12 &&
1460 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1461 !str$case_blind_compare(&tmpdsc,&local))
1462 symtype = LIB$K_CLI_LOCAL_SYM;
1463 else symtype = LIB$K_CLI_GLOBAL_SYM;
1464 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1465 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1466 if (retsts == LIB$_NOSUCHSYM) continue;
1470 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1471 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1472 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1473 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1474 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1478 else { /* we're defining a value */
1479 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1481 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1483 if (ckWARN(WARN_INTERNAL))
1484 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1485 retsts = SS$_NOSUCHPGM;
1489 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1490 eqvdsc.dsc$w_length = strlen(eqv);
1491 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1492 !str$case_blind_compare(&tmpdsc,&clisym)) {
1493 unsigned int symtype;
1494 if (tabvec[0]->dsc$w_length == 12 &&
1495 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1496 !str$case_blind_compare(&tmpdsc,&local))
1497 symtype = LIB$K_CLI_LOCAL_SYM;
1498 else symtype = LIB$K_CLI_GLOBAL_SYM;
1499 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1502 if (!*eqv) eqvdsc.dsc$w_length = 1;
1503 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1505 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1506 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1507 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1508 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1509 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1510 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1513 Newx(ilist,nseg+1,struct itmlst_3);
1516 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1519 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1521 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1522 ile->itmcode = LNM$_STRING;
1524 if ((j+1) == nseg) {
1525 ile->buflen = strlen(c);
1526 /* in case we are truncating one that's too long */
1527 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1530 ile->buflen = LNM$C_NAMLENGTH;
1534 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1538 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1543 if (!(retsts & 1)) {
1545 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1546 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1547 set_errno(EVMSERR); break;
1548 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1549 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1550 set_errno(EINVAL); break;
1552 set_errno(EACCES); break;
1557 set_vaxc_errno(retsts);
1558 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1561 /* We reset error values on success because Perl does an hv_fetch()
1562 * before each hv_store(), and if the thing we're setting didn't
1563 * previously exist, we've got a leftover error message. (Of course,
1564 * this fails in the face of
1565 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1566 * in that the error reported in $! isn't spurious,
1567 * but it's right more often than not.)
1569 set_errno(0); set_vaxc_errno(retsts);
1573 } /* end of vmssetenv() */
1576 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1577 /* This has to be a function since there's a prototype for it in proto.h */
1579 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1582 int len = strlen(lnm);
1586 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1587 if (!strcmp(uplnm,"DEFAULT")) {
1588 if (eqv && *eqv) my_chdir(eqv);
1592 #ifndef RTL_USES_UTC
1593 if (len == 6 || len == 2) {
1596 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1598 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1599 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1603 (void) vmssetenv(lnm,eqv,NULL);
1607 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1609 * sets a user-mode logical in the process logical name table
1610 * used for redirection of sys$error
1613 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1615 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1616 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1617 unsigned long int iss, attr = LNM$M_CONFINE;
1618 unsigned char acmode = PSL$C_USER;
1619 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1621 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1622 d_name.dsc$w_length = strlen(name);
1624 lnmlst[0].buflen = strlen(eqv);
1625 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1627 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1628 if (!(iss&1)) lib$signal(iss);
1633 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1634 /* my_crypt - VMS password hashing
1635 * my_crypt() provides an interface compatible with the Unix crypt()
1636 * C library function, and uses sys$hash_password() to perform VMS
1637 * password hashing. The quadword hashed password value is returned
1638 * as a NUL-terminated 8 character string. my_crypt() does not change
1639 * the case of its string arguments; in order to match the behavior
1640 * of LOGINOUT et al., alphabetic characters in both arguments must
1641 * be upcased by the caller.
1643 * - fix me to call ACM services when available
1646 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1648 # ifndef UAI$C_PREFERRED_ALGORITHM
1649 # define UAI$C_PREFERRED_ALGORITHM 127
1651 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1652 unsigned short int salt = 0;
1653 unsigned long int sts;
1655 unsigned short int dsc$w_length;
1656 unsigned char dsc$b_type;
1657 unsigned char dsc$b_class;
1658 const char * dsc$a_pointer;
1659 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1660 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1661 struct itmlst_3 uailst[3] = {
1662 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1663 { sizeof salt, UAI$_SALT, &salt, 0},
1664 { 0, 0, NULL, NULL}};
1665 static char hash[9];
1667 usrdsc.dsc$w_length = strlen(usrname);
1668 usrdsc.dsc$a_pointer = usrname;
1669 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1671 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1675 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1680 set_vaxc_errno(sts);
1681 if (sts != RMS$_RNF) return NULL;
1684 txtdsc.dsc$w_length = strlen(textpasswd);
1685 txtdsc.dsc$a_pointer = textpasswd;
1686 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1687 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1690 return (char *) hash;
1692 } /* end of my_crypt() */
1696 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1697 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1698 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1700 /* fixup barenames that are directories for internal use.
1701 * There have been problems with the consistent handling of UNIX
1702 * style directory names when routines are presented with a name that
1703 * has no directory delimitors at all. So this routine will eventually
1706 static char * fixup_bare_dirnames(const char * name)
1708 if (decc_disable_to_vms_logname_translation) {
1715 * A little hack to get around a bug in some implemenation of remove()
1716 * that do not know how to delete a directory
1718 * Delete any file to which user has control access, regardless of whether
1719 * delete access is explicitly allowed.
1720 * Limitations: User must have write access to parent directory.
1721 * Does not block signals or ASTs; if interrupted in midstream
1722 * may leave file with an altered ACL.
1725 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1727 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1729 char *vmsname, *rspec;
1731 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1732 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1733 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1735 unsigned char myace$b_length;
1736 unsigned char myace$b_type;
1737 unsigned short int myace$w_flags;
1738 unsigned long int myace$l_access;
1739 unsigned long int myace$l_ident;
1740 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1741 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1742 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1744 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1745 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1746 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1747 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1748 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1749 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1751 /* Expand the input spec using RMS, since the CRTL remove() and
1752 * system services won't do this by themselves, so we may miss
1753 * a file "hiding" behind a logical name or search list. */
1754 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1755 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1757 if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1758 PerlMem_free(vmsname);
1762 if (decc_posix_compliant_pathnames) {
1763 /* In POSIX mode, we prefer to remove the UNIX name */
1765 remove_name = (char *)name;
1768 rspec = PerlMem_malloc(NAM$C_MAXRSS+1);
1769 if (rspec == NULL) _ckvmssts(SS$_INSFMEM);
1770 if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
1771 PerlMem_free(rspec);
1772 PerlMem_free(vmsname);
1775 PerlMem_free(vmsname);
1776 remove_name = rspec;
1779 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1781 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1782 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1783 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1785 do_pathify_dirspec(name, remove_name, 0, NULL);
1786 if (!rmdir(remove_name)) {
1788 PerlMem_free(remove_name);
1789 PerlMem_free(rspec);
1790 return 0; /* Can we just get rid of it? */
1794 if (!rmdir(remove_name)) {
1795 PerlMem_free(rspec);
1796 return 0; /* Can we just get rid of it? */
1802 if (!remove(remove_name)) {
1803 PerlMem_free(rspec);
1804 return 0; /* Can we just get rid of it? */
1807 /* If not, can changing protections help? */
1808 if (vaxc$errno != RMS$_PRV) {
1809 PerlMem_free(rspec);
1813 /* No, so we get our own UIC to use as a rights identifier,
1814 * and the insert an ACE at the head of the ACL which allows us
1815 * to delete the file.
1817 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1818 fildsc.dsc$w_length = strlen(rspec);
1819 fildsc.dsc$a_pointer = rspec;
1821 newace.myace$l_ident = oldace.myace$l_ident;
1822 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1824 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1825 set_errno(ENOENT); break;
1827 set_errno(ENOTDIR); break;
1829 set_errno(ENODEV); break;
1830 case RMS$_SYN: case SS$_INVFILFOROP:
1831 set_errno(EINVAL); break;
1833 set_errno(EACCES); break;
1837 set_vaxc_errno(aclsts);
1838 PerlMem_free(rspec);
1841 /* Grab any existing ACEs with this identifier in case we fail */
1842 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1843 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1844 || fndsts == SS$_NOMOREACE ) {
1845 /* Add the new ACE . . . */
1846 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1849 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000
1851 if (decc_dir_barename && decc_posix_compliant_pathnames) {
1852 remove_name = PerlMem_malloc(NAM$C_MAXRSS+1);
1853 if (remove_name == NULL) _ckvmssts(SS$_INSFMEM);
1855 do_pathify_dirspec(name, remove_name, 0, NULL);
1856 rmsts = rmdir(remove_name);
1857 PerlMem_free(remove_name);
1860 rmsts = rmdir(remove_name);
1864 rmsts = remove(remove_name);
1866 /* We blew it - dir with files in it, no write priv for
1867 * parent directory, etc. Put things back the way they were. */
1868 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1871 addlst[0].bufadr = &oldace;
1872 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1879 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1880 /* We just deleted it, so of course it's not there. Some versions of
1881 * VMS seem to return success on the unlock operation anyhow (after all
1882 * the unlock is successful), but others don't.
1884 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1885 if (aclsts & 1) aclsts = fndsts;
1886 if (!(aclsts & 1)) {
1888 set_vaxc_errno(aclsts);
1889 PerlMem_free(rspec);
1893 PerlMem_free(rspec);
1896 } /* end of kill_file() */
1900 /*{{{int do_rmdir(char *name)*/
1902 Perl_do_rmdir(pTHX_ const char *name)
1904 char dirfile[NAM$C_MAXRSS+1];
1908 if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1;
1909 if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
1910 else retval = mp_do_kill_file(aTHX_ dirfile, 1);
1913 } /* end of do_rmdir */
1917 * Delete any file to which user has control access, regardless of whether
1918 * delete access is explicitly allowed.
1919 * Limitations: User must have write access to parent directory.
1920 * Does not block signals or ASTs; if interrupted in midstream
1921 * may leave file with an altered ACL.
1924 /*{{{int kill_file(char *name)*/
1926 Perl_kill_file(pTHX_ const char *name)
1928 char rspec[NAM$C_MAXRSS+1];
1930 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1931 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1932 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1934 unsigned char myace$b_length;
1935 unsigned char myace$b_type;
1936 unsigned short int myace$w_flags;
1937 unsigned long int myace$l_access;
1938 unsigned long int myace$l_ident;
1939 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1940 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1941 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1943 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1944 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1945 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1946 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1947 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1948 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1950 /* Expand the input spec using RMS, since the CRTL remove() and
1951 * system services won't do this by themselves, so we may miss
1952 * a file "hiding" behind a logical name or search list. */
1953 tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
1954 if (tspec == NULL) return -1;
1955 if (!remove(rspec)) return 0; /* Can we just get rid of it? */
1956 /* If not, can changing protections help? */
1957 if (vaxc$errno != RMS$_PRV) return -1;
1959 /* No, so we get our own UIC to use as a rights identifier,
1960 * and the insert an ACE at the head of the ACL which allows us
1961 * to delete the file.
1963 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1964 fildsc.dsc$w_length = strlen(rspec);
1965 fildsc.dsc$a_pointer = rspec;
1967 newace.myace$l_ident = oldace.myace$l_ident;
1968 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1970 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1971 set_errno(ENOENT); break;
1973 set_errno(ENOTDIR); break;
1975 set_errno(ENODEV); break;
1976 case RMS$_SYN: case SS$_INVFILFOROP:
1977 set_errno(EINVAL); break;
1979 set_errno(EACCES); break;
1983 set_vaxc_errno(aclsts);
1986 /* Grab any existing ACEs with this identifier in case we fail */
1987 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1988 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1989 || fndsts == SS$_NOMOREACE ) {
1990 /* Add the new ACE . . . */
1991 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1993 if ((rmsts = remove(name))) {
1994 /* We blew it - dir with files in it, no write priv for
1995 * parent directory, etc. Put things back the way they were. */
1996 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1999 addlst[0].bufadr = &oldace;
2000 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2007 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2008 /* We just deleted it, so of course it's not there. Some versions of
2009 * VMS seem to return success on the unlock operation anyhow (after all
2010 * the unlock is successful), but others don't.
2012 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2013 if (aclsts & 1) aclsts = fndsts;
2014 if (!(aclsts & 1)) {
2016 set_vaxc_errno(aclsts);
2022 } /* end of kill_file() */
2026 /*{{{int my_mkdir(char *,Mode_t)*/
2028 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2030 STRLEN dirlen = strlen(dir);
2032 /* zero length string sometimes gives ACCVIO */
2033 if (dirlen == 0) return -1;
2035 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2036 * null file name/type. However, it's commonplace under Unix,
2037 * so we'll allow it for a gain in portability.
2039 if (dir[dirlen-1] == '/') {
2040 char *newdir = savepvn(dir,dirlen-1);
2041 int ret = mkdir(newdir,mode);
2045 else return mkdir(dir,mode);
2046 } /* end of my_mkdir */
2049 /*{{{int my_chdir(char *)*/
2051 Perl_my_chdir(pTHX_ const char *dir)
2053 STRLEN dirlen = strlen(dir);
2055 /* zero length string sometimes gives ACCVIO */
2056 if (dirlen == 0) return -1;
2059 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2060 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2061 * so that existing scripts do not need to be changed.
2064 while ((dirlen > 0) && (*dir1 == ' ')) {
2069 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2071 * null file name/type. However, it's commonplace under Unix,
2072 * so we'll allow it for a gain in portability.
2074 * - Preview- '/' will be valid soon on VMS
2076 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2077 char *newdir = savepvn(dir1,dirlen-1);
2078 int ret = chdir(newdir);
2082 else return chdir(dir1);
2083 } /* end of my_chdir */
2087 /*{{{FILE *my_tmpfile()*/
2094 if ((fp = tmpfile())) return fp;
2096 cp = PerlMem_malloc(L_tmpnam+24);
2097 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2099 if (decc_filename_unix_only == 0)
2100 strcpy(cp,"Sys$Scratch:");
2103 tmpnam(cp+strlen(cp));
2104 strcat(cp,".Perltmp");
2105 fp = fopen(cp,"w+","fop=dlt");
2112 #ifndef HOMEGROWN_POSIX_SIGNALS
2114 * The C RTL's sigaction fails to check for invalid signal numbers so we
2115 * help it out a bit. The docs are correct, but the actual routine doesn't
2116 * do what the docs say it will.
2118 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2120 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2121 struct sigaction* oact)
2123 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2124 SETERRNO(EINVAL, SS$_INVARG);
2127 return sigaction(sig, act, oact);
2132 #ifdef KILL_BY_SIGPRC
2133 #include <errnodef.h>
2135 /* We implement our own kill() using the undocumented system service
2136 sys$sigprc for one of two reasons:
2138 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2139 target process to do a sys$exit, which usually can't be handled
2140 gracefully...certainly not by Perl and the %SIG{} mechanism.
2142 2.) If the kill() in the CRTL can't be called from a signal
2143 handler without disappearing into the ether, i.e., the signal
2144 it purportedly sends is never trapped. Still true as of VMS 7.3.
2146 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2147 in the target process rather than calling sys$exit.
2149 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2150 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2151 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2152 with condition codes C$_SIG0+nsig*8, catching the exception on the
2153 target process and resignaling with appropriate arguments.
2155 But we don't have that VMS 7.0+ exception handler, so if you
2156 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2158 Also note that SIGTERM is listed in the docs as being "unimplemented",
2159 yet always seems to be signaled with a VMS condition code of 4 (and
2160 correctly handled for that code). So we hardwire it in.
2162 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2163 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2164 than signalling with an unrecognized (and unhandled by CRTL) code.
2167 #define _MY_SIG_MAX 28
2170 Perl_sig_to_vmscondition_int(int sig)
2172 static unsigned int sig_code[_MY_SIG_MAX+1] =
2175 SS$_HANGUP, /* 1 SIGHUP */
2176 SS$_CONTROLC, /* 2 SIGINT */
2177 SS$_CONTROLY, /* 3 SIGQUIT */
2178 SS$_RADRMOD, /* 4 SIGILL */
2179 SS$_BREAK, /* 5 SIGTRAP */
2180 SS$_OPCCUS, /* 6 SIGABRT */
2181 SS$_COMPAT, /* 7 SIGEMT */
2183 SS$_FLTOVF, /* 8 SIGFPE VAX */
2185 SS$_HPARITH, /* 8 SIGFPE AXP */
2187 SS$_ABORT, /* 9 SIGKILL */
2188 SS$_ACCVIO, /* 10 SIGBUS */
2189 SS$_ACCVIO, /* 11 SIGSEGV */
2190 SS$_BADPARAM, /* 12 SIGSYS */
2191 SS$_NOMBX, /* 13 SIGPIPE */
2192 SS$_ASTFLT, /* 14 SIGALRM */
2209 #if __VMS_VER >= 60200000
2210 static int initted = 0;
2213 sig_code[16] = C$_SIGUSR1;
2214 sig_code[17] = C$_SIGUSR2;
2215 #if __CRTL_VER >= 70000000
2216 sig_code[20] = C$_SIGCHLD;
2218 #if __CRTL_VER >= 70300000
2219 sig_code[28] = C$_SIGWINCH;
2224 if (sig < _SIG_MIN) return 0;
2225 if (sig > _MY_SIG_MAX) return 0;
2226 return sig_code[sig];
2230 Perl_sig_to_vmscondition(int sig)
2233 if (vms_debug_on_exception != 0)
2234 lib$signal(SS$_DEBUG);
2236 return Perl_sig_to_vmscondition_int(sig);
2241 Perl_my_kill(int pid, int sig)
2246 int sys$sigprc(unsigned int *pidadr,
2247 struct dsc$descriptor_s *prcname,
2250 /* sig 0 means validate the PID */
2251 /*------------------------------*/
2253 const unsigned long int jpicode = JPI$_PID;
2256 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2257 if ($VMS_STATUS_SUCCESS(status))
2260 case SS$_NOSUCHNODE:
2261 case SS$_UNREACHABLE:
2275 code = Perl_sig_to_vmscondition_int(sig);
2278 SETERRNO(EINVAL, SS$_BADPARAM);
2282 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2283 * signals are to be sent to multiple processes.
2284 * pid = 0 - all processes in group except ones that the system exempts
2285 * pid = -1 - all processes except ones that the system exempts
2286 * pid = -n - all processes in group (abs(n)) except ...
2287 * For now, just report as not supported.
2291 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2295 iss = sys$sigprc((unsigned int *)&pid,0,code);
2296 if (iss&1) return 0;
2300 set_errno(EPERM); break;
2302 case SS$_NOSUCHNODE:
2303 case SS$_UNREACHABLE:
2304 set_errno(ESRCH); break;
2306 set_errno(ENOMEM); break;
2311 set_vaxc_errno(iss);
2317 /* Routine to convert a VMS status code to a UNIX status code.
2318 ** More tricky than it appears because of conflicting conventions with
2321 ** VMS status codes are a bit mask, with the least significant bit set for
2324 ** Special UNIX status of EVMSERR indicates that no translation is currently
2325 ** available, and programs should check the VMS status code.
2327 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2331 #ifndef C_FACILITY_NO
2332 #define C_FACILITY_NO 0x350000
2335 #define DCL_IVVERB 0x38090
2338 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2346 /* Assume the best or the worst */
2347 if (vms_status & STS$M_SUCCESS)
2350 unix_status = EVMSERR;
2352 msg_status = vms_status & ~STS$M_CONTROL;
2354 facility = vms_status & STS$M_FAC_NO;
2355 fac_sp = vms_status & STS$M_FAC_SP;
2356 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2358 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2364 unix_status = EFAULT;
2366 case SS$_DEVOFFLINE:
2367 unix_status = EBUSY;
2370 unix_status = ENOTCONN;
2378 case SS$_INVFILFOROP:
2382 unix_status = EINVAL;
2384 case SS$_UNSUPPORTED:
2385 unix_status = ENOTSUP;
2390 unix_status = EACCES;
2392 case SS$_DEVICEFULL:
2393 unix_status = ENOSPC;
2396 unix_status = ENODEV;
2398 case SS$_NOSUCHFILE:
2399 case SS$_NOSUCHOBJECT:
2400 unix_status = ENOENT;
2402 case SS$_ABORT: /* Fatal case */
2403 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2404 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2405 unix_status = EINTR;
2408 unix_status = E2BIG;
2411 unix_status = ENOMEM;
2414 unix_status = EPERM;
2416 case SS$_NOSUCHNODE:
2417 case SS$_UNREACHABLE:
2418 unix_status = ESRCH;
2421 unix_status = ECHILD;
2424 if ((facility == 0) && (msg_no < 8)) {
2425 /* These are not real VMS status codes so assume that they are
2426 ** already UNIX status codes
2428 unix_status = msg_no;
2434 /* Translate a POSIX exit code to a UNIX exit code */
2435 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2436 unix_status = (msg_no & 0x07F8) >> 3;
2440 /* Documented traditional behavior for handling VMS child exits */
2441 /*--------------------------------------------------------------*/
2442 if (child_flag != 0) {
2444 /* Success / Informational return 0 */
2445 /*----------------------------------*/
2446 if (msg_no & STS$K_SUCCESS)
2449 /* Warning returns 1 */
2450 /*-------------------*/
2451 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2454 /* Everything else pass through the severity bits */
2455 /*------------------------------------------------*/
2456 return (msg_no & STS$M_SEVERITY);
2459 /* Normal VMS status to ERRNO mapping attempt */
2460 /*--------------------------------------------*/
2461 switch(msg_status) {
2462 /* case RMS$_EOF: */ /* End of File */
2463 case RMS$_FNF: /* File Not Found */
2464 case RMS$_DNF: /* Dir Not Found */
2465 unix_status = ENOENT;
2467 case RMS$_RNF: /* Record Not Found */
2468 unix_status = ESRCH;
2471 unix_status = ENOTDIR;
2474 unix_status = ENODEV;
2479 unix_status = EBADF;
2482 unix_status = EEXIST;
2486 case LIB$_INVSTRDES:
2488 case LIB$_NOSUCHSYM:
2489 case LIB$_INVSYMNAM:
2491 unix_status = EINVAL;
2497 unix_status = E2BIG;
2499 case RMS$_PRV: /* No privilege */
2500 case RMS$_ACC: /* ACP file access failed */
2501 case RMS$_WLK: /* Device write locked */
2502 unix_status = EACCES;
2504 /* case RMS$_NMF: */ /* No more files */
2512 /* Try to guess at what VMS error status should go with a UNIX errno
2513 * value. This is hard to do as there could be many possible VMS
2514 * error statuses that caused the errno value to be set.
2517 int Perl_unix_status_to_vms(int unix_status)
2519 int test_unix_status;
2521 /* Trivial cases first */
2522 /*---------------------*/
2523 if (unix_status == EVMSERR)
2526 /* Is vaxc$errno sane? */
2527 /*---------------------*/
2528 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2529 if (test_unix_status == unix_status)
2532 /* If way out of range, must be VMS code already */
2533 /*-----------------------------------------------*/
2534 if (unix_status > EVMSERR)
2537 /* If out of range, punt */
2538 /*-----------------------*/
2539 if (unix_status > __ERRNO_MAX)
2543 /* Ok, now we have to do it the hard way. */
2544 /*----------------------------------------*/
2545 switch(unix_status) {
2546 case 0: return SS$_NORMAL;
2547 case EPERM: return SS$_NOPRIV;
2548 case ENOENT: return SS$_NOSUCHOBJECT;
2549 case ESRCH: return SS$_UNREACHABLE;
2550 case EINTR: return SS$_ABORT;
2553 case E2BIG: return SS$_BUFFEROVF;
2555 case EBADF: return RMS$_IFI;
2556 case ECHILD: return SS$_NONEXPR;
2558 case ENOMEM: return SS$_INSFMEM;
2559 case EACCES: return SS$_FILACCERR;
2560 case EFAULT: return SS$_ACCVIO;
2562 case EBUSY: return SS$_DEVOFFLINE;
2563 case EEXIST: return RMS$_FEX;
2565 case ENODEV: return SS$_NOSUCHDEV;
2566 case ENOTDIR: return RMS$_DIR;
2568 case EINVAL: return SS$_INVARG;
2574 case ENOSPC: return SS$_DEVICEFULL;
2575 case ESPIPE: return LIB$_INVARG;
2580 case ERANGE: return LIB$_INVARG;
2581 /* case EWOULDBLOCK */
2582 /* case EINPROGRESS */
2585 /* case EDESTADDRREQ */
2587 /* case EPROTOTYPE */
2588 /* case ENOPROTOOPT */
2589 /* case EPROTONOSUPPORT */
2590 /* case ESOCKTNOSUPPORT */
2591 /* case EOPNOTSUPP */
2592 /* case EPFNOSUPPORT */
2593 /* case EAFNOSUPPORT */
2594 /* case EADDRINUSE */
2595 /* case EADDRNOTAVAIL */
2597 /* case ENETUNREACH */
2598 /* case ENETRESET */
2599 /* case ECONNABORTED */
2600 /* case ECONNRESET */
2603 case ENOTCONN: return SS$_CLEARED;
2604 /* case ESHUTDOWN */
2605 /* case ETOOMANYREFS */
2606 /* case ETIMEDOUT */
2607 /* case ECONNREFUSED */
2609 /* case ENAMETOOLONG */
2610 /* case EHOSTDOWN */
2611 /* case EHOSTUNREACH */
2612 /* case ENOTEMPTY */
2624 /* case ECANCELED */
2628 return SS$_UNSUPPORTED;
2634 /* case EABANDONED */
2636 return SS$_ABORT; /* punt */
2639 return SS$_ABORT; /* Should not get here */
2643 /* default piping mailbox size */
2644 #define PERL_BUFSIZ 512
2648 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2650 unsigned long int mbxbufsiz;
2651 static unsigned long int syssize = 0;
2652 unsigned long int dviitm = DVI$_DEVNAM;
2653 char csize[LNM$C_NAMLENGTH+1];
2657 unsigned long syiitm = SYI$_MAXBUF;
2659 * Get the SYSGEN parameter MAXBUF
2661 * If the logical 'PERL_MBX_SIZE' is defined
2662 * use the value of the logical instead of PERL_BUFSIZ, but
2663 * keep the size between 128 and MAXBUF.
2666 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2669 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2670 mbxbufsiz = atoi(csize);
2672 mbxbufsiz = PERL_BUFSIZ;
2674 if (mbxbufsiz < 128) mbxbufsiz = 128;
2675 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2677 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2679 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2680 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2682 } /* end of create_mbx() */
2685 /*{{{ my_popen and my_pclose*/
2687 typedef struct _iosb IOSB;
2688 typedef struct _iosb* pIOSB;
2689 typedef struct _pipe Pipe;
2690 typedef struct _pipe* pPipe;
2691 typedef struct pipe_details Info;
2692 typedef struct pipe_details* pInfo;
2693 typedef struct _srqp RQE;
2694 typedef struct _srqp* pRQE;
2695 typedef struct _tochildbuf CBuf;
2696 typedef struct _tochildbuf* pCBuf;
2699 unsigned short status;
2700 unsigned short count;
2701 unsigned long dvispec;
2704 #pragma member_alignment save
2705 #pragma nomember_alignment quadword
2706 struct _srqp { /* VMS self-relative queue entry */
2707 unsigned long qptr[2];
2709 #pragma member_alignment restore
2710 static RQE RQE_ZERO = {0,0};
2712 struct _tochildbuf {
2715 unsigned short size;
2723 unsigned short chan_in;
2724 unsigned short chan_out;
2726 unsigned int bufsize;
2738 #if defined(PERL_IMPLICIT_CONTEXT)
2739 void *thx; /* Either a thread or an interpreter */
2740 /* pointer, depending on how we're built */
2748 PerlIO *fp; /* file pointer to pipe mailbox */
2749 int useFILE; /* using stdio, not perlio */
2750 int pid; /* PID of subprocess */
2751 int mode; /* == 'r' if pipe open for reading */
2752 int done; /* subprocess has completed */
2753 int waiting; /* waiting for completion/closure */
2754 int closing; /* my_pclose is closing this pipe */
2755 unsigned long completion; /* termination status of subprocess */
2756 pPipe in; /* pipe in to sub */
2757 pPipe out; /* pipe out of sub */
2758 pPipe err; /* pipe of sub's sys$error */
2759 int in_done; /* true when in pipe finished */
2764 struct exit_control_block
2766 struct exit_control_block *flink;
2767 unsigned long int (*exit_routine)();
2768 unsigned long int arg_count;
2769 unsigned long int *status_address;
2770 unsigned long int exit_status;
2773 typedef struct _closed_pipes Xpipe;
2774 typedef struct _closed_pipes* pXpipe;
2776 struct _closed_pipes {
2777 int pid; /* PID of subprocess */
2778 unsigned long completion; /* termination status of subprocess */
2780 #define NKEEPCLOSED 50
2781 static Xpipe closed_list[NKEEPCLOSED];
2782 static int closed_index = 0;
2783 static int closed_num = 0;
2785 #define RETRY_DELAY "0 ::0.20"
2786 #define MAX_RETRY 50
2788 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2789 static unsigned long mypid;
2790 static unsigned long delaytime[2];
2792 static pInfo open_pipes = NULL;
2793 static $DESCRIPTOR(nl_desc, "NL:");
2795 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2799 static unsigned long int
2800 pipe_exit_routine(pTHX)
2803 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2804 int sts, did_stuff, need_eof, j;
2807 flush any pending i/o
2813 PerlIO_flush(info->fp); /* first, flush data */
2815 fflush((FILE *)info->fp);
2821 next we try sending an EOF...ignore if doesn't work, make sure we
2829 _ckvmssts_noperl(sys$setast(0));
2830 if (info->in && !info->in->shut_on_empty) {
2831 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2836 _ckvmssts_noperl(sys$setast(1));
2840 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2842 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2847 _ckvmssts_noperl(sys$setast(0));
2848 if (info->waiting && info->done)
2850 nwait += info->waiting;
2851 _ckvmssts_noperl(sys$setast(1));
2861 _ckvmssts_noperl(sys$setast(0));
2862 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2863 sts = sys$forcex(&info->pid,0,&abort);
2864 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2867 _ckvmssts_noperl(sys$setast(1));
2871 /* again, wait for effect */
2873 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2878 _ckvmssts_noperl(sys$setast(0));
2879 if (info->waiting && info->done)
2881 nwait += info->waiting;
2882 _ckvmssts_noperl(sys$setast(1));
2891 _ckvmssts_noperl(sys$setast(0));
2892 if (!info->done) { /* We tried to be nice . . . */
2893 sts = sys$delprc(&info->pid,0);
2894 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2896 _ckvmssts_noperl(sys$setast(1));
2901 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2902 else if (!(sts & 1)) retsts = sts;
2907 static struct exit_control_block pipe_exitblock =
2908 {(struct exit_control_block *) 0,
2909 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2911 static void pipe_mbxtofd_ast(pPipe p);
2912 static void pipe_tochild1_ast(pPipe p);
2913 static void pipe_tochild2_ast(pPipe p);
2916 popen_completion_ast(pInfo info)
2918 pInfo i = open_pipes;
2923 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2924 closed_list[closed_index].pid = info->pid;
2925 closed_list[closed_index].completion = info->completion;
2927 if (closed_index == NKEEPCLOSED)
2932 if (i == info) break;
2935 if (!i) return; /* unlinked, probably freed too */
2940 Writing to subprocess ...
2941 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2943 chan_out may be waiting for "done" flag, or hung waiting
2944 for i/o completion to child...cancel the i/o. This will
2945 put it into "snarf mode" (done but no EOF yet) that discards
2948 Output from subprocess (stdout, stderr) needs to be flushed and
2949 shut down. We try sending an EOF, but if the mbx is full the pipe
2950 routine should still catch the "shut_on_empty" flag, telling it to
2951 use immediate-style reads so that "mbx empty" -> EOF.
2955 if (info->in && !info->in_done) { /* only for mode=w */
2956 if (info->in->shut_on_empty && info->in->need_wake) {
2957 info->in->need_wake = FALSE;
2958 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2960 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2964 if (info->out && !info->out_done) { /* were we also piping output? */
2965 info->out->shut_on_empty = TRUE;
2966 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2967 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2968 _ckvmssts_noperl(iss);
2971 if (info->err && !info->err_done) { /* we were piping stderr */
2972 info->err->shut_on_empty = TRUE;
2973 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2974 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2975 _ckvmssts_noperl(iss);
2977 _ckvmssts_noperl(sys$setef(pipe_ef));
2981 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2982 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2985 we actually differ from vmstrnenv since we use this to
2986 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2987 are pointing to the same thing
2990 static unsigned short
2991 popen_translate(pTHX_ char *logical, char *result)
2994 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2995 $DESCRIPTOR(d_log,"");
2997 unsigned short length;
2998 unsigned short code;
3000 unsigned short *retlenaddr;
3002 unsigned short l, ifi;
3004 d_log.dsc$a_pointer = logical;
3005 d_log.dsc$w_length = strlen(logical);
3007 itmlst[0].code = LNM$_STRING;
3008 itmlst[0].length = 255;
3009 itmlst[0].buffer_addr = result;
3010 itmlst[0].retlenaddr = &l;
3013 itmlst[1].length = 0;
3014 itmlst[1].buffer_addr = 0;
3015 itmlst[1].retlenaddr = 0;
3017 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3018 if (iss == SS$_NOLOGNAM) {
3022 if (!(iss&1)) lib$signal(iss);
3025 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3026 strip it off and return the ifi, if any
3029 if (result[0] == 0x1b && result[1] == 0x00) {
3030 memmove(&ifi,result+2,2);
3031 strcpy(result,result+4);
3033 return ifi; /* this is the RMS internal file id */
3036 static void pipe_infromchild_ast(pPipe p);
3039 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3040 inside an AST routine without worrying about reentrancy and which Perl
3041 memory allocator is being used.
3043 We read data and queue up the buffers, then spit them out one at a
3044 time to the output mailbox when the output mailbox is ready for one.
3047 #define INITIAL_TOCHILDQUEUE 2
3050 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3054 char mbx1[64], mbx2[64];
3055 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3056 DSC$K_CLASS_S, mbx1},
3057 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3058 DSC$K_CLASS_S, mbx2};
3059 unsigned int dviitm = DVI$_DEVBUFSIZ;
3063 _ckvmssts(lib$get_vm(&n, &p));
3065 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3066 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3067 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3070 p->shut_on_empty = FALSE;
3071 p->need_wake = FALSE;
3074 p->iosb.status = SS$_NORMAL;
3075 p->iosb2.status = SS$_NORMAL;
3081 #ifdef PERL_IMPLICIT_CONTEXT
3085 n = sizeof(CBuf) + p->bufsize;
3087 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3088 _ckvmssts(lib$get_vm(&n, &b));
3089 b->buf = (char *) b + sizeof(CBuf);
3090 _ckvmssts(lib$insqhi(b, &p->free));
3093 pipe_tochild2_ast(p);
3094 pipe_tochild1_ast(p);
3100 /* reads the MBX Perl is writing, and queues */
3103 pipe_tochild1_ast(pPipe p)
3106 int iss = p->iosb.status;
3107 int eof = (iss == SS$_ENDOFFILE);
3109 #ifdef PERL_IMPLICIT_CONTEXT
3115 p->shut_on_empty = TRUE;
3117 _ckvmssts(sys$dassgn(p->chan_in));
3123 b->size = p->iosb.count;
3124 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3126 p->need_wake = FALSE;
3127 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3130 p->retry = 1; /* initial call */
3133 if (eof) { /* flush the free queue, return when done */
3134 int n = sizeof(CBuf) + p->bufsize;
3136 iss = lib$remqti(&p->free, &b);
3137 if (iss == LIB$_QUEWASEMP) return;
3139 _ckvmssts(lib$free_vm(&n, &b));
3143 iss = lib$remqti(&p->free, &b);
3144 if (iss == LIB$_QUEWASEMP) {
3145 int n = sizeof(CBuf) + p->bufsize;
3146 _ckvmssts(lib$get_vm(&n, &b));
3147 b->buf = (char *) b + sizeof(CBuf);
3153 iss = sys$qio(0,p->chan_in,
3154 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3156 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3157 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3162 /* writes queued buffers to output, waits for each to complete before
3166 pipe_tochild2_ast(pPipe p)
3169 int iss = p->iosb2.status;
3170 int n = sizeof(CBuf) + p->bufsize;
3171 int done = (p->info && p->info->done) ||
3172 iss == SS$_CANCEL || iss == SS$_ABORT;
3173 #if defined(PERL_IMPLICIT_CONTEXT)
3178 if (p->type) { /* type=1 has old buffer, dispose */
3179 if (p->shut_on_empty) {
3180 _ckvmssts(lib$free_vm(&n, &b));
3182 _ckvmssts(lib$insqhi(b, &p->free));
3187 iss = lib$remqti(&p->wait, &b);
3188 if (iss == LIB$_QUEWASEMP) {
3189 if (p->shut_on_empty) {
3191 _ckvmssts(sys$dassgn(p->chan_out));
3192 *p->pipe_done = TRUE;
3193 _ckvmssts(sys$setef(pipe_ef));
3195 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3196 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3200 p->need_wake = TRUE;
3210 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3211 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3213 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3214 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3223 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3226 char mbx1[64], mbx2[64];
3227 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3228 DSC$K_CLASS_S, mbx1},
3229 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3230 DSC$K_CLASS_S, mbx2};
3231 unsigned int dviitm = DVI$_DEVBUFSIZ;
3233 int n = sizeof(Pipe);
3234 _ckvmssts(lib$get_vm(&n, &p));
3235 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3236 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3238 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3239 n = p->bufsize * sizeof(char);
3240 _ckvmssts(lib$get_vm(&n, &p->buf));
3241 p->shut_on_empty = FALSE;
3244 p->iosb.status = SS$_NORMAL;
3245 #if defined(PERL_IMPLICIT_CONTEXT)
3248 pipe_infromchild_ast(p);
3256 pipe_infromchild_ast(pPipe p)
3258 int iss = p->iosb.status;
3259 int eof = (iss == SS$_ENDOFFILE);
3260 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3261 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3262 #if defined(PERL_IMPLICIT_CONTEXT)
3266 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3267 _ckvmssts(sys$dassgn(p->chan_out));
3272 input shutdown if EOF from self (done or shut_on_empty)
3273 output shutdown if closing flag set (my_pclose)
3274 send data/eof from child or eof from self
3275 otherwise, re-read (snarf of data from child)
3280 if (myeof && p->chan_in) { /* input shutdown */
3281 _ckvmssts(sys$dassgn(p->chan_in));
3286 if (myeof || kideof) { /* pass EOF to parent */
3287 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3288 pipe_infromchild_ast, p,
3291 } else if (eof) { /* eat EOF --- fall through to read*/
3293 } else { /* transmit data */
3294 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3295 pipe_infromchild_ast,p,
3296 p->buf, p->iosb.count, 0, 0, 0, 0));
3302 /* everything shut? flag as done */
3304 if (!p->chan_in && !p->chan_out) {
3305 *p->pipe_done = TRUE;
3306 _ckvmssts(sys$setef(pipe_ef));
3310 /* write completed (or read, if snarfing from child)
3311 if still have input active,
3312 queue read...immediate mode if shut_on_empty so we get EOF if empty
3314 check if Perl reading, generate EOFs as needed
3320 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3321 pipe_infromchild_ast,p,
3322 p->buf, p->bufsize, 0, 0, 0, 0);
3323 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3325 } else { /* send EOFs for extra reads */
3326 p->iosb.status = SS$_ENDOFFILE;
3327 p->iosb.dvispec = 0;
3328 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3330 pipe_infromchild_ast, p, 0, 0, 0, 0));
3336 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3340 unsigned long dviitm = DVI$_DEVBUFSIZ;
3342 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3343 DSC$K_CLASS_S, mbx};
3344 int n = sizeof(Pipe);
3346 /* things like terminals and mbx's don't need this filter */
3347 if (fd && fstat(fd,&s) == 0) {
3348 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3350 unsigned short dev_len;
3351 struct dsc$descriptor_s d_dev;
3353 struct item_list_3 items[3];
3355 unsigned short dvi_iosb[4];
3357 cptr = getname(fd, out, 1);
3358 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3359 d_dev.dsc$a_pointer = out;
3360 d_dev.dsc$w_length = strlen(out);
3361 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3362 d_dev.dsc$b_class = DSC$K_CLASS_S;
3365 items[0].code = DVI$_DEVCHAR;
3366 items[0].bufadr = &devchar;
3367 items[0].retadr = NULL;
3369 items[1].code = DVI$_FULLDEVNAM;
3370 items[1].bufadr = device;
3371 items[1].retadr = &dev_len;
3375 status = sys$getdviw
3376 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3378 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3379 device[dev_len] = 0;
3381 if (!(devchar & DEV$M_DIR)) {
3382 strcpy(out, device);
3388 _ckvmssts(lib$get_vm(&n, &p));
3389 p->fd_out = dup(fd);
3390 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3391 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3392 n = (p->bufsize+1) * sizeof(char);
3393 _ckvmssts(lib$get_vm(&n, &p->buf));
3394 p->shut_on_empty = FALSE;
3399 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3400 pipe_mbxtofd_ast, p,
3401 p->buf, p->bufsize, 0, 0, 0, 0));
3407 pipe_mbxtofd_ast(pPipe p)
3409 int iss = p->iosb.status;
3410 int done = p->info->done;
3412 int eof = (iss == SS$_ENDOFFILE);
3413 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3414 int err = !(iss&1) && !eof;
3415 #if defined(PERL_IMPLICIT_CONTEXT)
3419 if (done && myeof) { /* end piping */
3421 sys$dassgn(p->chan_in);
3422 *p->pipe_done = TRUE;
3423 _ckvmssts(sys$setef(pipe_ef));
3427 if (!err && !eof) { /* good data to send to file */
3428 p->buf[p->iosb.count] = '\n';
3429 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3432 if (p->retry < MAX_RETRY) {
3433 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3443 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3444 pipe_mbxtofd_ast, p,
3445 p->buf, p->bufsize, 0, 0, 0, 0);
3446 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3451 typedef struct _pipeloc PLOC;
3452 typedef struct _pipeloc* pPLOC;
3456 char dir[NAM$C_MAXRSS+1];
3458 static pPLOC head_PLOC = 0;
3461 free_pipelocs(pTHX_ void *head)
3464 pPLOC *pHead = (pPLOC *)head;
3476 store_pipelocs(pTHX)
3485 char temp[NAM$C_MAXRSS+1];
3489 free_pipelocs(aTHX_ &head_PLOC);
3491 /* the . directory from @INC comes last */
3493 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3494 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3495 p->next = head_PLOC;
3497 strcpy(p->dir,"./");
3499 /* get the directory from $^X */
3501 unixdir = PerlMem_malloc(VMS_MAXRSS);
3502 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3504 #ifdef PERL_IMPLICIT_CONTEXT
3505 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3507 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3509 strcpy(temp, PL_origargv[0]);
3510 x = strrchr(temp,']');
3512 x = strrchr(temp,'>');
3514 /* It could be a UNIX path */
3515 x = strrchr(temp,'/');
3521 /* Got a bare name, so use default directory */
3526 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3527 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3528 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3529 p->next = head_PLOC;
3531 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3532 p->dir[NAM$C_MAXRSS] = '\0';
3536 /* reverse order of @INC entries, skip "." since entered above */
3538 #ifdef PERL_IMPLICIT_CONTEXT
3541 if (PL_incgv) av = GvAVn(PL_incgv);
3543 for (i = 0; av && i <= AvFILL(av); i++) {
3544 dirsv = *av_fetch(av,i,TRUE);
3546 if (SvROK(dirsv)) continue;
3547 dir = SvPVx(dirsv,n_a);
3548 if (strcmp(dir,".") == 0) continue;
3549 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3552 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3553 p->next = head_PLOC;
3555 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3556 p->dir[NAM$C_MAXRSS] = '\0';
3559 /* most likely spot (ARCHLIB) put first in the list */
3562 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3563 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3564 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3565 p->next = head_PLOC;
3567 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3568 p->dir[NAM$C_MAXRSS] = '\0';
3571 PerlMem_free(unixdir);
3575 Perl_cando_by_name_int
3576 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3577 #if !defined(PERL_IMPLICIT_CONTEXT)
3578 #define cando_by_name_int Perl_cando_by_name_int
3580 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3586 static int vmspipe_file_status = 0;
3587 static char vmspipe_file[NAM$C_MAXRSS+1];
3589 /* already found? Check and use ... need read+execute permission */
3591 if (vmspipe_file_status == 1) {
3592 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3593 && cando_by_name_int
3594 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3595 return vmspipe_file;
3597 vmspipe_file_status = 0;
3600 /* scan through stored @INC, $^X */
3602 if (vmspipe_file_status == 0) {
3603 char file[NAM$C_MAXRSS+1];
3604 pPLOC p = head_PLOC;
3609 strcpy(file, p->dir);
3610 dirlen = strlen(file);
3611 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3612 file[NAM$C_MAXRSS] = '\0';
3615 exp_res = do_rmsexpand
3616 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3617 if (!exp_res) continue;
3619 if (cando_by_name_int
3620 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3621 && cando_by_name_int
3622 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3623 vmspipe_file_status = 1;
3624 return vmspipe_file;
3627 vmspipe_file_status = -1; /* failed, use tempfiles */
3634 vmspipe_tempfile(pTHX)
3636 char file[NAM$C_MAXRSS+1];
3638 static int index = 0;
3642 /* create a tempfile */
3644 /* we can't go from W, shr=get to R, shr=get without
3645 an intermediate vulnerable state, so don't bother trying...
3647 and lib$spawn doesn't shr=put, so have to close the write
3649 So... match up the creation date/time and the FID to
3650 make sure we're dealing with the same file
3655 if (!decc_filename_unix_only) {
3656 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3657 fp = fopen(file,"w");
3659 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3660 fp = fopen(file,"w");
3662 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3663 fp = fopen(file,"w");
3668 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3669 fp = fopen(file,"w");
3671 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3672 fp = fopen(file,"w");
3674 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3675 fp = fopen(file,"w");
3679 if (!fp) return 0; /* we're hosed */
3681 fprintf(fp,"$! 'f$verify(0)'\n");
3682 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3683 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3684 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3685 fprintf(fp,"$ perl_on = \"set noon\"\n");
3686 fprintf(fp,"$ perl_exit = \"exit\"\n");
3687 fprintf(fp,"$ perl_del = \"delete\"\n");
3688 fprintf(fp,"$ pif = \"if\"\n");
3689 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3690 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3691 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3692 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3693 fprintf(fp,"$! --- build command line to get max possible length\n");
3694 fprintf(fp,"$c=perl_popen_cmd0\n");
3695 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3696 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3697 fprintf(fp,"$x=perl_popen_cmd3\n");
3698 fprintf(fp,"$c=c+x\n");
3699 fprintf(fp,"$ perl_on\n");
3700 fprintf(fp,"$ 'c'\n");
3701 fprintf(fp,"$ perl_status = $STATUS\n");
3702 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3703 fprintf(fp,"$ perl_exit 'perl_status'\n");
3706 fgetname(fp, file, 1);
3707 fstat(fileno(fp), (struct stat *)&s0);
3710 if (decc_filename_unix_only)
3711 do_tounixspec(file, file, 0, NULL);
3712 fp = fopen(file,"r","shr=get");
3714 fstat(fileno(fp), (struct stat *)&s1);
3716 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3717 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3728 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3730 static int handler_set_up = FALSE;
3731 unsigned long int sts, flags = CLI$M_NOWAIT;
3732 /* The use of a GLOBAL table (as was done previously) rendered
3733 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3734 * environment. Hence we've switched to LOCAL symbol table.
3736 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3738 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3739 char *in, *out, *err, mbx[512];
3741 char tfilebuf[NAM$C_MAXRSS+1];
3743 char cmd_sym_name[20];
3744 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3745 DSC$K_CLASS_S, symbol};
3746 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3748 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3749 DSC$K_CLASS_S, cmd_sym_name};
3750 struct dsc$descriptor_s *vmscmd;
3751 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3752 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3753 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3755 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3757 /* once-per-program initialization...
3758 note that the SETAST calls and the dual test of pipe_ef
3759 makes sure that only the FIRST thread through here does
3760 the initialization...all other threads wait until it's
3763 Yeah, uglier than a pthread call, it's got all the stuff inline
3764 rather than in a separate routine.
3768 _ckvmssts(sys$setast(0));
3770 unsigned long int pidcode = JPI$_PID;
3771 $DESCRIPTOR(d_delay, RETRY_DELAY);
3772 _ckvmssts(lib$get_ef(&pipe_ef));
3773 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
3774 _ckvmssts(sys$bintim(&d_delay, delaytime));
3776 if (!handler_set_up) {
3777 _ckvmssts(sys$dclexh(&pipe_exitblock));
3778 handler_set_up = TRUE;
3780 _ckvmssts(sys$setast(1));
3783 /* see if we can find a VMSPIPE.COM */
3786 vmspipe = find_vmspipe(aTHX);
3788 strcpy(tfilebuf+1,vmspipe);
3789 } else { /* uh, oh...we're in tempfile hell */
3790 tpipe = vmspipe_tempfile(aTHX);
3791 if (!tpipe) { /* a fish popular in Boston */
3792 if (ckWARN(WARN_PIPE)) {
3793 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
3797 fgetname(tpipe,tfilebuf+1,1);
3799 vmspipedsc.dsc$a_pointer = tfilebuf;
3800 vmspipedsc.dsc$w_length = strlen(tfilebuf);
3802 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
3805 case RMS$_FNF: case RMS$_DNF:
3806 set_errno(ENOENT); break;
3808 set_errno(ENOTDIR); break;
3810 set_errno(ENODEV); break;
3812 set_errno(EACCES); break;
3814 set_errno(EINVAL); break;
3815 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
3816 set_errno(E2BIG); break;
3817 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
3818 _ckvmssts(sts); /* fall through */
3819 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
3822 set_vaxc_errno(sts);
3823 if (*mode != 'n' && ckWARN(WARN_PIPE)) {
3824 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
3830 _ckvmssts(lib$get_vm(&n, &info));
3832 strcpy(mode,in_mode);
3835 info->completion = 0;
3836 info->closing = FALSE;
3843 info->in_done = TRUE;
3844 info->out_done = TRUE;
3845 info->err_done = TRUE;
3847 in = PerlMem_malloc(VMS_MAXRSS);
3848 if (in == NULL) _ckvmssts(SS$_INSFMEM);
3849 out = PerlMem_malloc(VMS_MAXRSS);
3850 if (out == NULL) _ckvmssts(SS$_INSFMEM);
3851 err = PerlMem_malloc(VMS_MAXRSS);
3852 if (err == NULL) _ckvmssts(SS$_INSFMEM);
3854 in[0] = out[0] = err[0] = '\0';
3856 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
3860 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
3865 if (*mode == 'r') { /* piping from subroutine */
3867 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
3869 info->out->pipe_done = &info->out_done;
3870 info->out_done = FALSE;
3871 info->out->info = info;
3873 if (!info->useFILE) {
3874 info->fp = PerlIO_open(mbx, mode);
3876 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
3877 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
3880 if (!info->fp && info->out) {
3881 sys$cancel(info->out->chan_out);
3883 while (!info->out_done) {
3885 _ckvmssts(sys$setast(0));
3886 done = info->out_done;
3887 if (!done) _ckvmssts(sys$clref(pipe_ef));
3888 _ckvmssts(sys$setast(1));
3889 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3892 if (info->out->buf) {
3893 n = info->out->bufsize * sizeof(char);
3894 _ckvmssts(lib$free_vm(&n, &info->out->buf));
3897 _ckvmssts(lib$free_vm(&n, &info->out));
3899 _ckvmssts(lib$free_vm(&n, &info));
3904 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3906 info->err->pipe_done = &info->err_done;
3907 info->err_done = FALSE;
3908 info->err->info = info;
3911 } else if (*mode == 'w') { /* piping to subroutine */
3913 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3915 info->out->pipe_done = &info->out_done;
3916 info->out_done = FALSE;
3917 info->out->info = info;
3920 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3922 info->err->pipe_done = &info->err_done;
3923 info->err_done = FALSE;
3924 info->err->info = info;
3927 info->in = pipe_tochild_setup(aTHX_ in,mbx);
3928 if (!info->useFILE) {
3929 info->fp = PerlIO_open(mbx, mode);
3931 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
3932 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
3936 info->in->pipe_done = &info->in_done;
3937 info->in_done = FALSE;
3938 info->in->info = info;
3942 if (!info->fp && info->in) {
3944 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
3945 0, 0, 0, 0, 0, 0, 0, 0));
3947 while (!info->in_done) {
3949 _ckvmssts(sys$setast(0));
3950 done = info->in_done;
3951 if (!done) _ckvmssts(sys$clref(pipe_ef));
3952 _ckvmssts(sys$setast(1));
3953 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
3956 if (info->in->buf) {
3957 n = info->in->bufsize * sizeof(char);
3958 _ckvmssts(lib$free_vm(&n, &info->in->buf));
3961 _ckvmssts(lib$free_vm(&n, &info->in));
3963 _ckvmssts(lib$free_vm(&n, &info));
3969 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
3970 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
3972 info->out->pipe_done = &info->out_done;
3973 info->out_done = FALSE;
3974 info->out->info = info;
3977 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
3979 info->err->pipe_done = &info->err_done;
3980 info->err_done = FALSE;
3981 info->err->info = info;
3985 symbol[MAX_DCL_SYMBOL] = '\0';
3987 strncpy(symbol, in, MAX_DCL_SYMBOL);
3988 d_symbol.dsc$w_length = strlen(symbol);
3989 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
3991 strncpy(symbol, err, MAX_DCL_SYMBOL);
3992 d_symbol.dsc$w_length = strlen(symbol);
3993 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
3995 strncpy(symbol, out, MAX_DCL_SYMBOL);
3996 d_symbol.dsc$w_length = strlen(symbol);
3997 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
3999 /* Done with the names for the pipes */
4004 p = vmscmd->dsc$a_pointer;
4005 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4006 if (*p == '$') p++; /* remove leading $ */
4007 while (*p == ' ' || *p == '\t') p++;
4009 for (j = 0; j < 4; j++) {
4010 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4011 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4013 strncpy(symbol, p, MAX_DCL_SYMBOL);
4014 d_symbol.dsc$w_length = strlen(symbol);
4015 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4017 if (strlen(p) > MAX_DCL_SYMBOL) {
4018 p += MAX_DCL_SYMBOL;
4023 _ckvmssts(sys$setast(0));
4024 info->next=open_pipes; /* prepend to list */
4026 _ckvmssts(sys$setast(1));
4027 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4028 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4029 * have SYS$COMMAND if we need it.
4031 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4032 0, &info->pid, &info->completion,
4033 0, popen_completion_ast,info,0,0,0));
4035 /* if we were using a tempfile, close it now */
4037 if (tpipe) fclose(tpipe);
4039 /* once the subprocess is spawned, it has copied the symbols and
4040 we can get rid of ours */
4042 for (j = 0; j < 4; j++) {
4043 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4044 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4045 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4047 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4048 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4049 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4050 vms_execfree(vmscmd);
4052 #ifdef PERL_IMPLICIT_CONTEXT
4055 PL_forkprocess = info->pid;
4060 _ckvmssts(sys$setast(0));
4062 if (!done) _ckvmssts(sys$clref(pipe_ef));
4063 _ckvmssts(sys$setast(1));
4064 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4066 *psts = info->completion;
4067 /* Caller thinks it is open and tries to close it. */
4068 /* This causes some problems, as it changes the error status */
4069 /* my_pclose(info->fp); */
4074 } /* end of safe_popen */
4077 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4079 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4083 TAINT_PROPER("popen");
4084 PERL_FLUSHALL_FOR_CHILD;
4085 return safe_popen(aTHX_ cmd,mode,&sts);
4090 /*{{{ I32 my_pclose(PerlIO *fp)*/
4091 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4093 pInfo info, last = NULL;
4094 unsigned long int retsts;
4097 for (info = open_pipes; info != NULL; last = info, info = info->next)
4098 if (info->fp == fp) break;
4100 if (info == NULL) { /* no such pipe open */
4101 set_errno(ECHILD); /* quoth POSIX */
4102 set_vaxc_errno(SS$_NONEXPR);
4106 /* If we were writing to a subprocess, insure that someone reading from
4107 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4108 * produce an EOF record in the mailbox.
4110 * well, at least sometimes it *does*, so we have to watch out for
4111 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4115 PerlIO_flush(info->fp); /* first, flush data */
4117 fflush((FILE *)info->fp);
4120 _ckvmssts(sys$setast(0));
4121 info->closing = TRUE;
4122 done = info->done && info->in_done && info->out_done && info->err_done;
4123 /* hanging on write to Perl's input? cancel it */
4124 if (info->mode == 'r' && info->out && !info->out_done) {
4125 if (info->out->chan_out) {
4126 _ckvmssts(sys$cancel(info->out->chan_out));
4127 if (!info->out->chan_in) { /* EOF generation, need AST */
4128 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4132 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4133 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4135 _ckvmssts(sys$setast(1));
4138 PerlIO_close(info->fp);
4140 fclose((FILE *)info->fp);
4143 we have to wait until subprocess completes, but ALSO wait until all
4144 the i/o completes...otherwise we'll be freeing the "info" structure
4145 that the i/o ASTs could still be using...
4149 _ckvmssts(sys$setast(0));
4150 done = info->done && info->in_done && info->out_done && info->err_done;
4151 if (!done) _ckvmssts(sys$clref(pipe_ef));
4152 _ckvmssts(sys$setast(1));
4153 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4155 retsts = info->completion;
4157 /* remove from list of open pipes */
4158 _ckvmssts(sys$setast(0));
4159 if (last) last->next = info->next;
4160 else open_pipes = info->next;
4161 _ckvmssts(sys$setast(1));
4163 /* free buffers and structures */
4166 if (info->in->buf) {
4167 n = info->in->bufsize * sizeof(char);
4168 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4171 _ckvmssts(lib$free_vm(&n, &info->in));
4174 if (info->out->buf) {
4175 n = info->out->bufsize * sizeof(char);
4176 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4179 _ckvmssts(lib$free_vm(&n, &info->out));
4182 if (info->err->buf) {
4183 n = info->err->bufsize * sizeof(char);
4184 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4187 _ckvmssts(lib$free_vm(&n, &info->err));
4190 _ckvmssts(lib$free_vm(&n, &info));
4194 } /* end of my_pclose() */
4196 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4197 /* Roll our own prototype because we want this regardless of whether
4198 * _VMS_WAIT is defined.
4200 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4202 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4203 created with popen(); otherwise partially emulate waitpid() unless
4204 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4205 Also check processes not considered by the CRTL waitpid().
4207 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4209 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4216 if (statusp) *statusp = 0;
4218 for (info = open_pipes; info != NULL; info = info->next)
4219 if (info->pid == pid) break;
4221 if (info != NULL) { /* we know about this child */
4222 while (!info->done) {
4223 _ckvmssts(sys$setast(0));
4225 if (!done) _ckvmssts(sys$clref(pipe_ef));
4226 _ckvmssts(sys$setast(1));
4227 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4230 if (statusp) *statusp = info->completion;
4234 /* child that already terminated? */
4236 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4237 if (closed_list[j].pid == pid) {
4238 if (statusp) *statusp = closed_list[j].completion;
4243 /* fall through if this child is not one of our own pipe children */
4245 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4247 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4248 * in 7.2 did we get a version that fills in the VMS completion
4249 * status as Perl has always tried to do.
4252 sts = __vms_waitpid( pid, statusp, flags );
4254 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4257 /* If the real waitpid tells us the child does not exist, we
4258 * fall through here to implement waiting for a child that
4259 * was created by some means other than exec() (say, spawned
4260 * from DCL) or to wait for a process that is not a subprocess
4261 * of the current process.
4264 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4267 $DESCRIPTOR(intdsc,"0 00:00:01");
4268 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4269 unsigned long int pidcode = JPI$_PID, mypid;
4270 unsigned long int interval[2];
4271 unsigned int jpi_iosb[2];
4272 struct itmlst_3 jpilist[2] = {
4273 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4278 /* Sorry folks, we don't presently implement rooting around for
4279 the first child we can find, and we definitely don't want to
4280 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4286 /* Get the owner of the child so I can warn if it's not mine. If the
4287 * process doesn't exist or I don't have the privs to look at it,
4288 * I can go home early.
4290 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4291 if (sts & 1) sts = jpi_iosb[0];
4303 set_vaxc_errno(sts);
4307 if (ckWARN(WARN_EXEC)) {
4308 /* remind folks they are asking for non-standard waitpid behavior */
4309 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4310 if (ownerpid != mypid)
4311 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4312 "waitpid: process %x is not a child of process %x",
4316 /* simply check on it once a second until it's not there anymore. */
4318 _ckvmssts(sys$bintim(&intdsc,interval));
4319 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4320 _ckvmssts(sys$schdwk(0,0,interval,0));
4321 _ckvmssts(sys$hiber());
4323 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4328 } /* end of waitpid() */
4333 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4335 my_gconvert(double val, int ndig, int trail, char *buf)
4337 static char __gcvtbuf[DBL_DIG+1];
4340 loc = buf ? buf : __gcvtbuf;
4342 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4344 sprintf(loc,"%.*g",ndig,val);
4350 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4351 return gcvt(val,ndig,loc);
4354 loc[0] = '0'; loc[1] = '\0';
4361 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4362 static int rms_free_search_context(struct FAB * fab)
4366 nam = fab->fab$l_nam;
4367 nam->nam$b_nop |= NAM$M_SYNCHK;
4368 nam->nam$l_rlf = NULL;
4370 return sys$parse(fab, NULL, NULL);
4373 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4374 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4375 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4376 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4377 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4378 #define rms_nam_esll(nam) nam.nam$b_esl
4379 #define rms_nam_esl(nam) nam.nam$b_esl
4380 #define rms_nam_name(nam) nam.nam$l_name
4381 #define rms_nam_namel(nam) nam.nam$l_name
4382 #define rms_nam_type(nam) nam.nam$l_type
4383 #define rms_nam_typel(nam) nam.nam$l_type
4384 #define rms_nam_ver(nam) nam.nam$l_ver
4385 #define rms_nam_verl(nam) nam.nam$l_ver
4386 #define rms_nam_rsll(nam) nam.nam$b_rsl
4387 #define rms_nam_rsl(nam) nam.nam$b_rsl
4388 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4389 #define rms_set_fna(fab, nam, name, size) \
4390 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4391 #define rms_get_fna(fab, nam) fab.fab$l_fna
4392 #define rms_set_dna(fab, nam, name, size) \
4393 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4394 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4395 #define rms_set_esa(fab, nam, name, size) \
4396 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4397 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4398 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4399 #define rms_set_rsa(nam, name, size) \
4400 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4401 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4402 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4403 #define rms_nam_name_type_l_size(nam) \
4404 (nam.nam$b_name + nam.nam$b_type)
4406 static int rms_free_search_context(struct FAB * fab)
4410 nam = fab->fab$l_naml;
4411 nam->naml$b_nop |= NAM$M_SYNCHK;
4412 nam->naml$l_rlf = NULL;
4413 nam->naml$l_long_defname_size = 0;
4416 return sys$parse(fab, NULL, NULL);
4419 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4420 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4421 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4422 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4423 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4424 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4425 #define rms_nam_esl(nam) nam.naml$b_esl
4426 #define rms_nam_name(nam) nam.naml$l_name
4427 #define rms_nam_namel(nam) nam.naml$l_long_name
4428 #define rms_nam_type(nam) nam.naml$l_type
4429 #define rms_nam_typel(nam) nam.naml$l_long_type
4430 #define rms_nam_ver(nam) nam.naml$l_ver
4431 #define rms_nam_verl(nam) nam.naml$l_long_ver
4432 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4433 #define rms_nam_rsl(nam) nam.naml$b_rsl
4434 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4435 #define rms_set_fna(fab, nam, name, size) \
4436 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4437 nam.naml$l_long_filename_size = size; \
4438 nam.naml$l_long_filename = name;}
4439 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4440 #define rms_set_dna(fab, nam, name, size) \
4441 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4442 nam.naml$l_long_defname_size = size; \
4443 nam.naml$l_long_defname = name; }
4444 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4445 #define rms_set_esa(fab, nam, name, size) \
4446 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4447 nam.naml$l_long_expand_alloc = size; \
4448 nam.naml$l_long_expand = name; }
4449 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4450 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4451 nam.naml$l_long_expand = l_name; \
4452 nam.naml$l_long_expand_alloc = l_size; }
4453 #define rms_set_rsa(nam, name, size) \
4454 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4455 nam.naml$l_long_result = name; \
4456 nam.naml$l_long_result_alloc = size; }
4457 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4458 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4459 nam.naml$l_long_result = l_name; \
4460 nam.naml$l_long_result_alloc = l_size; }
4461 #define rms_nam_name_type_l_size(nam) \
4462 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4466 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4467 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4468 * to expand file specification. Allows for a single default file
4469 * specification and a simple mask of options. If outbuf is non-NULL,
4470 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4471 * the resultant file specification is placed. If outbuf is NULL, the
4472 * resultant file specification is placed into a static buffer.
4473 * The third argument, if non-NULL, is taken to be a default file
4474 * specification string. The fourth argument is unused at present.
4475 * rmesexpand() returns the address of the resultant string if
4476 * successful, and NULL on error.
4478 * New functionality for previously unused opts value:
4479 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4480 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4481 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4483 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4487 (pTHX_ const char *filespec,
4490 const char *defspec,
4495 static char __rmsexpand_retbuf[VMS_MAXRSS];
4496 char * vmsfspec, *tmpfspec;
4497 char * esa, *cp, *out = NULL;
4501 struct FAB myfab = cc$rms_fab;
4502 rms_setup_nam(mynam);
4504 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4507 /* temp hack until UTF8 is actually implemented */
4508 if (fs_utf8 != NULL)
4511 if (!filespec || !*filespec) {
4512 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4516 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4517 else outbuf = __rmsexpand_retbuf;
4525 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4526 isunix = is_unix_filespec(filespec);
4528 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4529 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4530 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4531 PerlMem_free(vmsfspec);
4536 filespec = vmsfspec;
4538 /* Unless we are forcing to VMS format, a UNIX input means
4539 * UNIX output, and that requires long names to be used
4541 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4542 opts |= PERL_RMSEXPAND_M_LONG;
4549 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4550 rms_bind_fab_nam(myfab, mynam);
4552 if (defspec && *defspec) {
4554 t_isunix = is_unix_filespec(defspec);
4556 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4557 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4558 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4559 PerlMem_free(tmpfspec);
4560 if (vmsfspec != NULL)
4561 PerlMem_free(vmsfspec);
4568 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4571 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4572 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4573 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4574 esal = PerlMem_malloc(VMS_MAXRSS);
4575 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4577 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4579 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4580 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4583 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4584 outbufl = PerlMem_malloc(VMS_MAXRSS);
4585 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4586 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4588 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4592 #ifdef NAM$M_NO_SHORT_UPCASE
4593 if (decc_efs_case_preserve)
4594 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4597 /* First attempt to parse as an existing file */
4598 retsts = sys$parse(&myfab,0,0);
4599 if (!(retsts & STS$K_SUCCESS)) {
4601 /* Could not find the file, try as syntax only if error is not fatal */
4602 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4603 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4604 retsts = sys$parse(&myfab,0,0);
4605 if (retsts & STS$K_SUCCESS) goto expanded;
4608 /* Still could not parse the file specification */
4609 /*----------------------------------------------*/
4610 sts = rms_free_search_context(&myfab); /* Free search context */
4611 if (out) Safefree(out);
4612 if (tmpfspec != NULL)
4613 PerlMem_free(tmpfspec);
4614 if (vmsfspec != NULL)
4615 PerlMem_free(vmsfspec);
4616 if (outbufl != NULL)
4617 PerlMem_free(outbufl);
4620 set_vaxc_errno(retsts);
4621 if (retsts == RMS$_PRV) set_errno(EACCES);
4622 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4623 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4624 else set_errno(EVMSERR);
4627 retsts = sys$search(&myfab,0,0);
4628 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4629 sts = rms_free_search_context(&myfab); /* Free search context */
4630 if (out) Safefree(out);
4631 if (tmpfspec != NULL)
4632 PerlMem_free(tmpfspec);
4633 if (vmsfspec != NULL)
4634 PerlMem_free(vmsfspec);
4635 if (outbufl != NULL)
4636 PerlMem_free(outbufl);
4639 set_vaxc_errno(retsts);
4640 if (retsts == RMS$_PRV) set_errno(EACCES);
4641 else set_errno(EVMSERR);
4645 /* If the input filespec contained any lowercase characters,
4646 * downcase the result for compatibility with Unix-minded code. */
4648 if (!decc_efs_case_preserve) {
4649 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4650 if (islower(*tbuf)) { haslower = 1; break; }
4653 /* Is a long or a short name expected */
4654 /*------------------------------------*/
4655 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4656 if (rms_nam_rsll(mynam)) {
4658 speclen = rms_nam_rsll(mynam);
4661 tbuf = esal; /* Not esa */
4662 speclen = rms_nam_esll(mynam);
4666 if (rms_nam_rsl(mynam)) {
4668 speclen = rms_nam_rsl(mynam);
4671 tbuf = esa; /* Not esal */
4672 speclen = rms_nam_esl(mynam);
4675 tbuf[speclen] = '\0';
4677 /* Trim off null fields added by $PARSE
4678 * If type > 1 char, must have been specified in original or default spec
4679 * (not true for version; $SEARCH may have added version of existing file).
4681 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4682 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4683 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4684 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4687 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4688 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4690 if (trimver || trimtype) {
4691 if (defspec && *defspec) {
4692 char *defesal = NULL;
4693 defesal = PerlMem_malloc(NAML$C_MAXRSS + 1);
4694 if (defesal != NULL) {
4695 struct FAB deffab = cc$rms_fab;
4696 rms_setup_nam(defnam);
4698 rms_bind_fab_nam(deffab, defnam);
4702 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4704 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4706 rms_clear_nam_nop(defnam);
4707 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4708 #ifdef NAM$M_NO_SHORT_UPCASE
4709 if (decc_efs_case_preserve)
4710 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4712 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
4714 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
4717 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
4720 PerlMem_free(defesal);
4724 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4725 if (*(rms_nam_verl(mynam)) != '\"')
4726 speclen = rms_nam_verl(mynam) - tbuf;
4729 if (*(rms_nam_ver(mynam)) != '\"')
4730 speclen = rms_nam_ver(mynam) - tbuf;
4734 /* If we didn't already trim version, copy down */
4735 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4736 if (speclen > rms_nam_verl(mynam) - tbuf)
4738 (rms_nam_typel(mynam),
4739 rms_nam_verl(mynam),
4740 speclen - (rms_nam_verl(mynam) - tbuf));
4741 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
4744 if (speclen > rms_nam_ver(mynam) - tbuf)
4746 (rms_nam_type(mynam),
4748 speclen - (rms_nam_ver(mynam) - tbuf));
4749 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
4754 /* Done with these copies of the input files */
4755 /*-------------------------------------------*/
4756 if (vmsfspec != NULL)
4757 PerlMem_free(vmsfspec);
4758 if (tmpfspec != NULL)
4759 PerlMem_free(tmpfspec);
4761 /* If we just had a directory spec on input, $PARSE "helpfully"
4762 * adds an empty name and type for us */
4763 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4764 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
4765 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
4766 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4767 speclen = rms_nam_namel(mynam) - tbuf;
4770 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
4771 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
4772 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
4773 speclen = rms_nam_name(mynam) - tbuf;
4776 /* Posix format specifications must have matching quotes */
4777 if (speclen < (VMS_MAXRSS - 1)) {
4778 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
4779 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
4780 tbuf[speclen] = '\"';
4785 tbuf[speclen] = '\0';
4786 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
4788 /* Have we been working with an expanded, but not resultant, spec? */
4789 /* Also, convert back to Unix syntax if necessary. */
4791 if (!rms_nam_rsll(mynam)) {
4793 if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) {
4794 if (out) Safefree(out);
4797 if (outbufl != NULL)
4798 PerlMem_free(outbufl);
4802 else strcpy(outbuf,esa);
4805 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4806 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4807 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
4808 if (out) Safefree(out);
4811 PerlMem_free(tmpfspec);
4812 if (outbufl != NULL)
4813 PerlMem_free(outbufl);
4816 strcpy(outbuf,tmpfspec);
4817 PerlMem_free(tmpfspec);
4820 rms_set_rsal(mynam, NULL, 0, NULL, 0);
4821 sts = rms_free_search_context(&myfab); /* Free search context */
4824 if (outbufl != NULL)
4825 PerlMem_free(outbufl);
4829 /* External entry points */
4830 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4831 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
4832 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
4833 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
4834 char *Perl_rmsexpand_utf8
4835 (pTHX_ const char *spec, char *buf, const char *def,
4836 unsigned opt, int * fs_utf8, int * dfs_utf8)
4837 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
4838 char *Perl_rmsexpand_utf8_ts
4839 (pTHX_ const char *spec, char *buf, const char *def,
4840 unsigned opt, int * fs_utf8, int * dfs_utf8)
4841 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
4845 ** The following routines are provided to make life easier when
4846 ** converting among VMS-style and Unix-style directory specifications.
4847 ** All will take input specifications in either VMS or Unix syntax. On
4848 ** failure, all return NULL. If successful, the routines listed below
4849 ** return a pointer to a buffer containing the appropriately
4850 ** reformatted spec (and, therefore, subsequent calls to that routine
4851 ** will clobber the result), while the routines of the same names with
4852 ** a _ts suffix appended will return a pointer to a mallocd string
4853 ** containing the appropriately reformatted spec.
4854 ** In all cases, only explicit syntax is altered; no check is made that
4855 ** the resulting string is valid or that the directory in question
4858 ** fileify_dirspec() - convert a directory spec into the name of the
4859 ** directory file (i.e. what you can stat() to see if it's a dir).
4860 ** The style (VMS or Unix) of the result is the same as the style
4861 ** of the parameter passed in.
4862 ** pathify_dirspec() - convert a directory spec into a path (i.e.
4863 ** what you prepend to a filename to indicate what directory it's in).
4864 ** The style (VMS or Unix) of the result is the same as the style
4865 ** of the parameter passed in.
4866 ** tounixpath() - convert a directory spec into a Unix-style path.
4867 ** tovmspath() - convert a directory spec into a VMS-style path.
4868 ** tounixspec() - convert any file spec into a Unix-style file spec.
4869 ** tovmsspec() - convert any file spec into a VMS-style spec.
4870 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
4872 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
4873 ** Permission is given to distribute this code as part of the Perl
4874 ** standard distribution under the terms of the GNU General Public
4875 ** License or the Perl Artistic License. Copies of each may be
4876 ** found in the Perl standard distribution.
4879 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
4880 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
4882 static char __fileify_retbuf[VMS_MAXRSS];
4883 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
4884 char *retspec, *cp1, *cp2, *lastdir;
4885 char *trndir, *vmsdir;
4886 unsigned short int trnlnm_iter_count;
4888 if (utf8_fl != NULL)
4891 if (!dir || !*dir) {
4892 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
4894 dirlen = strlen(dir);
4895 while (dirlen && dir[dirlen-1] == '/') --dirlen;
4896 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
4897 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
4904 if (dirlen > (VMS_MAXRSS - 1)) {
4905 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
4908 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
4909 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
4910 if (!strpbrk(dir+1,"/]>:") &&
4911 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
4912 strcpy(trndir,*dir == '/' ? dir + 1: dir);
4913 trnlnm_iter_count = 0;
4914 while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) {
4915 trnlnm_iter_count++;
4916 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
4918 dirlen = strlen(trndir);
4921 strncpy(trndir,dir,dirlen);
4922 trndir[dirlen] = '\0';
4925 /* At this point we are done with *dir and use *trndir which is a
4926 * copy that can be modified. *dir must not be modified.
4929 /* If we were handed a rooted logical name or spec, treat it like a
4930 * simple directory, so that
4931 * $ Define myroot dev:[dir.]
4932 * ... do_fileify_dirspec("myroot",buf,1) ...
4933 * does something useful.
4935 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
4936 trndir[--dirlen] = '\0';
4937 trndir[dirlen-1] = ']';
4939 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
4940 trndir[--dirlen] = '\0';
4941 trndir[dirlen-1] = '>';
4944 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
4945 /* If we've got an explicit filename, we can just shuffle the string. */
4946 if (*(cp1+1)) hasfilename = 1;
4947 /* Similarly, we can just back up a level if we've got multiple levels
4948 of explicit directories in a VMS spec which ends with directories. */
4950 for (cp2 = cp1; cp2 > trndir; cp2--) {
4952 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
4953 /* fix-me, can not scan EFS file specs backward like this */
4954 *cp2 = *cp1; *cp1 = '\0';
4959 if (*cp2 == '[' || *cp2 == '<') break;
4964 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
4965 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
4966 cp1 = strpbrk(trndir,"]:>");
4967 if (hasfilename || !cp1) { /* Unix-style path or filename */
4968 if (trndir[0] == '.') {
4969 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
4970 PerlMem_free(trndir);
4971 PerlMem_free(vmsdir);
4972 return do_fileify_dirspec("[]",buf,ts,NULL);
4974 else if (trndir[1] == '.' &&
4975 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
4976 PerlMem_free(trndir);
4977 PerlMem_free(vmsdir);
4978 return do_fileify_dirspec("[-]",buf,ts,NULL);
4981 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
4982 dirlen -= 1; /* to last element */
4983 lastdir = strrchr(trndir,'/');
4985 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
4986 /* If we have "/." or "/..", VMSify it and let the VMS code
4987 * below expand it, rather than repeating the code to handle
4988 * relative components of a filespec here */
4990 if (*(cp1+2) == '.') cp1++;
4991 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
4993 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
4994 PerlMem_free(trndir);
4995 PerlMem_free(vmsdir);
4998 if (strchr(vmsdir,'/') != NULL) {
4999 /* If do_tovmsspec() returned it, it must have VMS syntax
5000 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5001 * the time to check this here only so we avoid a recursion
5002 * loop; otherwise, gigo.
5004 PerlMem_free(trndir);
5005 PerlMem_free(vmsdir);
5006 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5009 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5010 PerlMem_free(trndir);
5011 PerlMem_free(vmsdir);
5014 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5015 PerlMem_free(trndir);
5016 PerlMem_free(vmsdir);
5020 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5021 lastdir = strrchr(trndir,'/');
5023 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5025 /* Ditto for specs that end in an MFD -- let the VMS code
5026 * figure out whether it's a real device or a rooted logical. */
5028 /* This should not happen any more. Allowing the fake /000000
5029 * in a UNIX pathname causes all sorts of problems when trying
5030 * to run in UNIX emulation. So the VMS to UNIX conversions
5031 * now remove the fake /000000 directories.
5034 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5035 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5036 PerlMem_free(trndir);
5037 PerlMem_free(vmsdir);
5040 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5041 PerlMem_free(trndir);
5042 PerlMem_free(vmsdir);
5045 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5046 PerlMem_free(trndir);
5047 PerlMem_free(vmsdir);
5052 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5053 !(lastdir = cp1 = strrchr(trndir,']')) &&
5054 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5055 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5058 /* For EFS or ODS-5 look for the last dot */
5059 if (decc_efs_charset) {
5060 cp2 = strrchr(cp1,'.');
5062 if (vms_process_case_tolerant) {
5063 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5064 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5065 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5066 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5067 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5068 (ver || *cp3)))))) {
5069 PerlMem_free(trndir);
5070 PerlMem_free(vmsdir);
5072 set_vaxc_errno(RMS$_DIR);
5077 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5078 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5079 !*(cp2+3) || *(cp2+3) != 'R' ||
5080 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5081 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5082 (ver || *cp3)))))) {
5083 PerlMem_free(trndir);
5084 PerlMem_free(vmsdir);
5086 set_vaxc_errno(RMS$_DIR);
5090 dirlen = cp2 - trndir;
5094 retlen = dirlen + 6;
5095 if (buf) retspec = buf;
5096 else if (ts) Newx(retspec,retlen+1,char);
5097 else retspec = __fileify_retbuf;
5098 memcpy(retspec,trndir,dirlen);
5099 retspec[dirlen] = '\0';
5101 /* We've picked up everything up to the directory file name.
5102 Now just add the type and version, and we're set. */
5103 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5104 strcat(retspec,".dir;1");
5106 strcat(retspec,".DIR;1");
5107 PerlMem_free(trndir);
5108 PerlMem_free(vmsdir);
5111 else { /* VMS-style directory spec */
5113 char *esa, term, *cp;
5114 unsigned long int sts, cmplen, haslower = 0;
5115 unsigned int nam_fnb;
5117 struct FAB dirfab = cc$rms_fab;
5118 rms_setup_nam(savnam);
5119 rms_setup_nam(dirnam);
5121 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5122 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5123 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5124 rms_bind_fab_nam(dirfab, dirnam);
5125 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5126 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5127 #ifdef NAM$M_NO_SHORT_UPCASE
5128 if (decc_efs_case_preserve)
5129 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5132 for (cp = trndir; *cp; cp++)
5133 if (islower(*cp)) { haslower = 1; break; }
5134 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5135 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5136 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5137 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5141 PerlMem_free(trndir);
5142 PerlMem_free(vmsdir);
5144 set_vaxc_errno(dirfab.fab$l_sts);
5150 /* Does the file really exist? */
5151 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5152 /* Yes; fake the fnb bits so we'll check type below */
5153 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5155 else { /* No; just work with potential name */
5156 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5159 fab_sts = dirfab.fab$l_sts;
5160 sts = rms_free_search_context(&dirfab);
5162 PerlMem_free(trndir);
5163 PerlMem_free(vmsdir);
5164 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5169 esa[rms_nam_esll(dirnam)] = '\0';
5170 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5171 cp1 = strchr(esa,']');
5172 if (!cp1) cp1 = strchr(esa,'>');
5173 if (cp1) { /* Should always be true */
5174 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5175 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5178 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5179 /* Yep; check version while we're at it, if it's there. */
5180 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5181 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5182 /* Something other than .DIR[;1]. Bzzt. */
5183 sts = rms_free_search_context(&dirfab);
5185 PerlMem_free(trndir);
5186 PerlMem_free(vmsdir);
5188 set_vaxc_errno(RMS$_DIR);
5193 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5194 /* They provided at least the name; we added the type, if necessary, */
5195 if (buf) retspec = buf; /* in sys$parse() */
5196 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5197 else retspec = __fileify_retbuf;
5198 strcpy(retspec,esa);
5199 sts = rms_free_search_context(&dirfab);
5200 PerlMem_free(trndir);
5202 PerlMem_free(vmsdir);
5205 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5206 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5208 rms_nam_esll(dirnam) -= 9;
5210 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5211 if (cp1 == NULL) { /* should never happen */
5212 sts = rms_free_search_context(&dirfab);
5213 PerlMem_free(trndir);
5215 PerlMem_free(vmsdir);
5220 retlen = strlen(esa);
5221 cp1 = strrchr(esa,'.');
5222 /* ODS-5 directory specifications can have extra "." in them. */
5223 /* Fix-me, can not scan EFS file specifications backwards */
5224 while (cp1 != NULL) {
5225 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5229 while ((cp1 > esa) && (*cp1 != '.'))
5236 if ((cp1) != NULL) {
5237 /* There's more than one directory in the path. Just roll back. */
5239 if (buf) retspec = buf;
5240 else if (ts) Newx(retspec,retlen+7,char);
5241 else retspec = __fileify_retbuf;
5242 strcpy(retspec,esa);
5245 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5246 /* Go back and expand rooted logical name */
5247 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5248 #ifdef NAM$M_NO_SHORT_UPCASE
5249 if (decc_efs_case_preserve)
5250 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5252 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5253 sts = rms_free_search_context(&dirfab);
5255 PerlMem_free(trndir);
5256 PerlMem_free(vmsdir);
5258 set_vaxc_errno(dirfab.fab$l_sts);
5261 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5262 if (buf) retspec = buf;
5263 else if (ts) Newx(retspec,retlen+16,char);
5264 else retspec = __fileify_retbuf;
5265 cp1 = strstr(esa,"][");
5266 if (!cp1) cp1 = strstr(esa,"]<");
5268 memcpy(retspec,esa,dirlen);
5269 if (!strncmp(cp1+2,"000000]",7)) {
5270 retspec[dirlen-1] = '\0';
5271 /* fix-me Not full ODS-5, just extra dots in directories for now */
5272 cp1 = retspec + dirlen - 1;
5273 while (cp1 > retspec)
5278 if (*(cp1-1) != '^')
5283 if (*cp1 == '.') *cp1 = ']';
5285 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5286 memmove(cp1+1,"000000]",7);
5290 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5291 retspec[retlen] = '\0';
5292 /* Convert last '.' to ']' */
5293 cp1 = retspec+retlen-1;
5294 while (*cp != '[') {
5297 /* Do not trip on extra dots in ODS-5 directories */
5298 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5302 if (*cp1 == '.') *cp1 = ']';
5304 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5305 memmove(cp1+1,"000000]",7);
5309 else { /* This is a top-level dir. Add the MFD to the path. */
5310 if (buf) retspec = buf;
5311 else if (ts) Newx(retspec,retlen+16,char);
5312 else retspec = __fileify_retbuf;
5315 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5316 strcpy(cp2,":[000000]");
5321 sts = rms_free_search_context(&dirfab);
5322 /* We've set up the string up through the filename. Add the
5323 type and version, and we're done. */
5324 strcat(retspec,".DIR;1");
5326 /* $PARSE may have upcased filespec, so convert output to lower
5327 * case if input contained any lowercase characters. */
5328 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5329 PerlMem_free(trndir);
5331 PerlMem_free(vmsdir);
5334 } /* end of do_fileify_dirspec() */
5336 /* External entry points */
5337 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5338 { return do_fileify_dirspec(dir,buf,0,NULL); }
5339 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5340 { return do_fileify_dirspec(dir,buf,1,NULL); }
5341 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5342 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5343 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5344 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5346 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5347 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5349 static char __pathify_retbuf[VMS_MAXRSS];
5350 unsigned long int retlen;
5351 char *retpath, *cp1, *cp2, *trndir;
5352 unsigned short int trnlnm_iter_count;
5355 if (utf8_fl != NULL)
5358 if (!dir || !*dir) {
5359 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5362 trndir = PerlMem_malloc(VMS_MAXRSS);
5363 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5364 if (*dir) strcpy(trndir,dir);
5365 else getcwd(trndir,VMS_MAXRSS - 1);
5367 trnlnm_iter_count = 0;
5368 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5369 && my_trnlnm(trndir,trndir,0)) {
5370 trnlnm_iter_count++;
5371 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5372 trnlen = strlen(trndir);
5374 /* Trap simple rooted lnms, and return lnm:[000000] */
5375 if (!strcmp(trndir+trnlen-2,".]")) {
5376 if (buf) retpath = buf;
5377 else if (ts) Newx(retpath,strlen(dir)+10,char);
5378 else retpath = __pathify_retbuf;
5379 strcpy(retpath,dir);
5380 strcat(retpath,":[000000]");
5381 PerlMem_free(trndir);
5386 /* At this point we do not work with *dir, but the copy in
5387 * *trndir that is modifiable.
5390 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5391 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5392 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5393 retlen = 2 + (*(trndir+1) != '\0');
5395 if ( !(cp1 = strrchr(trndir,'/')) &&
5396 !(cp1 = strrchr(trndir,']')) &&
5397 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5398 if ((cp2 = strchr(cp1,'.')) != NULL &&
5399 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5400 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5401 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5402 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5405 /* For EFS or ODS-5 look for the last dot */
5406 if (decc_efs_charset) {
5407 cp2 = strrchr(cp1,'.');
5409 if (vms_process_case_tolerant) {
5410 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5411 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5412 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5413 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5414 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5415 (ver || *cp3)))))) {
5416 PerlMem_free(trndir);
5418 set_vaxc_errno(RMS$_DIR);
5423 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5424 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5425 !*(cp2+3) || *(cp2+3) != 'R' ||
5426 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5427 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5428 (ver || *cp3)))))) {
5429 PerlMem_free(trndir);
5431 set_vaxc_errno(RMS$_DIR);
5435 retlen = cp2 - trndir + 1;
5437 else { /* No file type present. Treat the filename as a directory. */
5438 retlen = strlen(trndir) + 1;
5441 if (buf) retpath = buf;
5442 else if (ts) Newx(retpath,retlen+1,char);
5443 else retpath = __pathify_retbuf;
5444 strncpy(retpath, trndir, retlen-1);
5445 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5446 retpath[retlen-1] = '/'; /* with '/', add it. */
5447 retpath[retlen] = '\0';
5449 else retpath[retlen-1] = '\0';
5451 else { /* VMS-style directory spec */
5453 unsigned long int sts, cmplen, haslower;
5454 struct FAB dirfab = cc$rms_fab;
5456 rms_setup_nam(savnam);
5457 rms_setup_nam(dirnam);
5459 /* If we've got an explicit filename, we can just shuffle the string. */
5460 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5461 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5462 if ((cp2 = strchr(cp1,'.')) != NULL) {
5464 if (vms_process_case_tolerant) {
5465 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5466 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5467 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5468 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5469 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5470 (ver || *cp3)))))) {
5471 PerlMem_free(trndir);
5473 set_vaxc_errno(RMS$_DIR);
5478 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5479 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5480 !*(cp2+3) || *(cp2+3) != 'R' ||
5481 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5482 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5483 (ver || *cp3)))))) {
5484 PerlMem_free(trndir);
5486 set_vaxc_errno(RMS$_DIR);
5491 else { /* No file type, so just draw name into directory part */
5492 for (cp2 = cp1; *cp2; cp2++) ;
5495 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5497 /* We've now got a VMS 'path'; fall through */
5500 dirlen = strlen(trndir);
5501 if (trndir[dirlen-1] == ']' ||
5502 trndir[dirlen-1] == '>' ||
5503 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5504 if (buf) retpath = buf;
5505 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5506 else retpath = __pathify_retbuf;
5507 strcpy(retpath,trndir);
5508 PerlMem_free(trndir);
5511 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5512 esa = PerlMem_malloc(VMS_MAXRSS);
5513 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5514 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5515 rms_bind_fab_nam(dirfab, dirnam);
5516 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5517 #ifdef NAM$M_NO_SHORT_UPCASE
5518 if (decc_efs_case_preserve)
5519 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5522 for (cp = trndir; *cp; cp++)
5523 if (islower(*cp)) { haslower = 1; break; }
5525 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5526 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5527 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5528 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5531 PerlMem_free(trndir);
5534 set_vaxc_errno(dirfab.fab$l_sts);
5540 /* Does the file really exist? */
5541 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5542 if (dirfab.fab$l_sts != RMS$_FNF) {
5544 sts1 = rms_free_search_context(&dirfab);
5545 PerlMem_free(trndir);
5548 set_vaxc_errno(dirfab.fab$l_sts);
5551 dirnam = savnam; /* No; just work with potential name */
5554 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5555 /* Yep; check version while we're at it, if it's there. */
5556 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5557 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5559 /* Something other than .DIR[;1]. Bzzt. */
5560 sts2 = rms_free_search_context(&dirfab);
5561 PerlMem_free(trndir);
5564 set_vaxc_errno(RMS$_DIR);
5568 /* OK, the type was fine. Now pull any file name into the
5570 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5572 cp1 = strrchr(esa,'>');
5573 *(rms_nam_typel(dirnam)) = '>';
5576 *(rms_nam_typel(dirnam) + 1) = '\0';
5577 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5578 if (buf) retpath = buf;
5579 else if (ts) Newx(retpath,retlen,char);
5580 else retpath = __pathify_retbuf;
5581 strcpy(retpath,esa);
5583 sts = rms_free_search_context(&dirfab);
5584 /* $PARSE may have upcased filespec, so convert output to lower
5585 * case if input contained any lowercase characters. */
5586 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5589 PerlMem_free(trndir);
5591 } /* end of do_pathify_dirspec() */
5593 /* External entry points */
5594 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5595 { return do_pathify_dirspec(dir,buf,0,NULL); }
5596 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5597 { return do_pathify_dirspec(dir,buf,1,NULL); }
5598 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5599 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5600 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5601 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5603 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5604 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5606 static char __tounixspec_retbuf[VMS_MAXRSS];
5607 char *dirend, *rslt, *cp1, *cp3, *tmp;
5609 int devlen, dirlen, retlen = VMS_MAXRSS;
5610 int expand = 1; /* guarantee room for leading and trailing slashes */
5611 unsigned short int trnlnm_iter_count;
5613 if (utf8_fl != NULL)
5616 if (spec == NULL) return NULL;
5617 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5618 if (buf) rslt = buf;
5620 Newx(rslt, VMS_MAXRSS, char);
5622 else rslt = __tounixspec_retbuf;
5624 /* New VMS specific format needs translation
5625 * glob passes filenames with trailing '\n' and expects this preserved.
5627 if (decc_posix_compliant_pathnames) {
5628 if (strncmp(spec, "\"^UP^", 5) == 0) {
5634 tunix = PerlMem_malloc(VMS_MAXRSS);
5635 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5636 strcpy(tunix, spec);
5637 tunix_len = strlen(tunix);
5639 if (tunix[tunix_len - 1] == '\n') {
5640 tunix[tunix_len - 1] = '\"';
5641 tunix[tunix_len] = '\0';
5645 uspec = decc$translate_vms(tunix);
5646 PerlMem_free(tunix);
5647 if ((int)uspec > 0) {
5653 /* If we can not translate it, makemaker wants as-is */
5661 cmp_rslt = 0; /* Presume VMS */
5662 cp1 = strchr(spec, '/');
5666 /* Look for EFS ^/ */
5667 if (decc_efs_charset) {
5668 while (cp1 != NULL) {
5671 /* Found illegal VMS, assume UNIX */
5676 cp1 = strchr(cp1, '/');
5680 /* Look for "." and ".." */
5681 if (decc_filename_unix_report) {
5682 if (spec[0] == '.') {
5683 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5687 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5693 /* This is already UNIX or at least nothing VMS understands */
5701 dirend = strrchr(spec,']');
5702 if (dirend == NULL) dirend = strrchr(spec,'>');
5703 if (dirend == NULL) dirend = strchr(spec,':');
5704 if (dirend == NULL) {
5709 /* Special case 1 - sys$posix_root = / */
5710 #if __CRTL_VER >= 70000000
5711 if (!decc_disable_posix_root) {
5712 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
5720 /* Special case 2 - Convert NLA0: to /dev/null */
5721 #if __CRTL_VER < 70000000
5722 cmp_rslt = strncmp(spec,"NLA0:", 5);
5724 cmp_rslt = strncmp(spec,"nla0:", 5);
5726 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
5728 if (cmp_rslt == 0) {
5729 strcpy(rslt, "/dev/null");
5732 if (spec[6] != '\0') {
5739 /* Also handle special case "SYS$SCRATCH:" */
5740 #if __CRTL_VER < 70000000
5741 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
5743 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
5745 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
5747 tmp = PerlMem_malloc(VMS_MAXRSS);
5748 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
5749 if (cmp_rslt == 0) {
5752 islnm = my_trnlnm(tmp, "TMP", 0);
5754 strcpy(rslt, "/tmp");
5757 if (spec[12] != '\0') {
5765 if (*cp2 != '[' && *cp2 != '<') {
5768 else { /* the VMS spec begins with directories */
5770 if (*cp2 == ']' || *cp2 == '>') {
5771 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
5775 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
5776 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
5777 if (ts) Safefree(rslt);
5781 trnlnm_iter_count = 0;
5784 while (*cp3 != ':' && *cp3) cp3++;
5786 if (strchr(cp3,']') != NULL) break;
5787 trnlnm_iter_count++;
5788 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
5789 } while (vmstrnenv(tmp,tmp,0,fildev,0));
5791 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
5792 retlen = devlen + dirlen;
5793 Renew(rslt,retlen+1+2*expand,char);
5799 *(cp1++) = *(cp3++);
5800 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
5802 return NULL; /* No room */
5807 if ((*cp2 == '^')) {
5808 /* EFS file escape, pass the next character as is */
5809 /* Fix me: HEX encoding for UNICODE not implemented */
5812 else if ( *cp2 == '.') {
5813 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
5814 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5821 for (; cp2 <= dirend; cp2++) {
5822 if ((*cp2 == '^')) {
5823 /* EFS file escape, pass the next character as is */
5824 /* Fix me: HEX encoding for UNICODE not implemented */
5830 if (*(cp2+1) == '[') cp2++;
5832 else if (*cp2 == ']' || *cp2 == '>') {
5833 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
5835 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
5837 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
5838 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
5839 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
5840 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
5841 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
5843 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
5844 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
5848 else if (*cp2 == '-') {
5849 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
5850 while (*cp2 == '-') {
5852 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
5854 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
5855 if (ts) Safefree(rslt); /* filespecs like */
5856 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
5860 else *(cp1++) = *cp2;
5862 else *(cp1++) = *cp2;
5864 while (*cp2) *(cp1++) = *(cp2++);
5867 /* This still leaves /000000/ when working with a
5868 * VMS device root or concealed root.
5874 ulen = strlen(rslt);
5876 /* Get rid of "000000/ in rooted filespecs */
5878 zeros = strstr(rslt, "/000000/");
5879 if (zeros != NULL) {
5881 mlen = ulen - (zeros - rslt) - 7;
5882 memmove(zeros, &zeros[7], mlen);
5891 } /* end of do_tounixspec() */
5893 /* External entry points */
5894 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
5895 { return do_tounixspec(spec,buf,0, NULL); }
5896 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
5897 { return do_tounixspec(spec,buf,1, NULL); }
5898 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
5899 { return do_tounixspec(spec,buf,0, utf8_fl); }
5900 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
5901 { return do_tounixspec(spec,buf,1, utf8_fl); }
5903 #if __CRTL_VER >= 70200000 && !defined(__VAX)
5906 This procedure is used to identify if a path is based in either
5907 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
5908 it returns the OpenVMS format directory for it.
5910 It is expecting specifications of only '/' or '/xxxx/'
5912 If a posix root does not exist, or 'xxxx' is not a directory
5913 in the posix root, it returns a failure.
5915 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
5917 It is used only internally by posix_to_vmsspec_hardway().
5920 static int posix_root_to_vms
5921 (char *vmspath, int vmspath_len,
5922 const char *unixpath,
5923 const int * utf8_fl) {
5925 struct FAB myfab = cc$rms_fab;
5926 struct NAML mynam = cc$rms_naml;
5927 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5928 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5935 unixlen = strlen(unixpath);
5941 #if __CRTL_VER >= 80200000
5942 /* If not a posix spec already, convert it */
5943 if (decc_posix_compliant_pathnames) {
5944 if (strncmp(unixpath,"\"^UP^",5) != 0) {
5945 sprintf(vmspath,"\"^UP^%s\"",unixpath);
5948 /* This is already a VMS specification, no conversion */
5950 strncpy(vmspath,unixpath, vmspath_len);
5959 /* Check to see if this is under the POSIX root */
5960 if (decc_disable_posix_root) {
5964 /* Skip leading / */
5965 if (unixpath[0] == '/') {
5971 strcpy(vmspath,"SYS$POSIX_ROOT:");
5973 /* If this is only the / , or blank, then... */
5974 if (unixpath[0] == '\0') {
5975 /* by definition, this is the answer */
5979 /* Need to look up a directory */
5983 /* Copy and add '^' escape characters as needed */
5986 while (unixpath[i] != 0) {
5989 j += copy_expand_unix_filename_escape
5990 (&vmspath[j], &unixpath[i], &k, utf8_fl);
5994 path_len = strlen(vmspath);
5995 if (vmspath[path_len - 1] == '/')
5997 vmspath[path_len] = ']';
5999 vmspath[path_len] = '\0';
6002 vmspath[vmspath_len] = 0;
6003 if (unixpath[unixlen - 1] == '/')
6005 esa = PerlMem_malloc(VMS_MAXRSS);
6006 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6007 myfab.fab$l_fna = vmspath;
6008 myfab.fab$b_fns = strlen(vmspath);
6009 myfab.fab$l_naml = &mynam;
6010 mynam.naml$l_esa = NULL;
6011 mynam.naml$b_ess = 0;
6012 mynam.naml$l_long_expand = esa;
6013 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6014 mynam.naml$l_rsa = NULL;
6015 mynam.naml$b_rss = 0;
6016 if (decc_efs_case_preserve)
6017 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6018 #ifdef NAML$M_OPEN_SPECIAL
6019 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6022 /* Set up the remaining naml fields */
6023 sts = sys$parse(&myfab);
6025 /* It failed! Try again as a UNIX filespec */
6031 /* get the Device ID and the FID */
6032 sts = sys$search(&myfab);
6033 /* on any failure, returned the POSIX ^UP^ filespec */
6038 specdsc.dsc$a_pointer = vmspath;
6039 specdsc.dsc$w_length = vmspath_len;
6041 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6042 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6043 sts = lib$fid_to_name
6044 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6046 /* on any failure, returned the POSIX ^UP^ filespec */
6048 /* This can happen if user does not have permission to read directories */
6049 if (strncmp(unixpath,"\"^UP^",5) != 0)
6050 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6052 strcpy(vmspath, unixpath);
6055 vmspath[specdsc.dsc$w_length] = 0;
6057 /* Are we expecting a directory? */
6058 if (dir_flag != 0) {
6064 i = specdsc.dsc$w_length - 1;
6068 /* Version must be '1' */
6069 if (vmspath[i--] != '1')
6071 /* Version delimiter is one of ".;" */
6072 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6075 if (vmspath[i--] != 'R')
6077 if (vmspath[i--] != 'I')
6079 if (vmspath[i--] != 'D')
6081 if (vmspath[i--] != '.')
6083 eptr = &vmspath[i+1];
6085 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6086 if (vmspath[i-1] != '^') {
6094 /* Get rid of 6 imaginary zero directory filename */
6095 vmspath[i+1] = '\0';
6099 if (vmspath[i] == '0')
6113 /* /dev/mumble needs to be handled special.
6114 /dev/null becomes NLA0:, And there is the potential for other stuff
6115 like /dev/tty which may need to be mapped to something.
6119 slash_dev_special_to_vms
6120 (const char * unixptr,
6130 nextslash = strchr(unixptr, '/');
6131 len = strlen(unixptr);
6132 if (nextslash != NULL)
6133 len = nextslash - unixptr;
6134 cmp = strncmp("null", unixptr, 5);
6136 if (vmspath_len >= 6) {
6137 strcpy(vmspath, "_NLA0:");
6144 /* The built in routines do not understand perl's special needs, so
6145 doing a manual conversion from UNIX to VMS
6147 If the utf8_fl is not null and points to a non-zero value, then
6148 treat 8 bit characters as UTF-8.
6150 The sequence starting with '$(' and ending with ')' will be passed
6151 through with out interpretation instead of being escaped.
6154 static int posix_to_vmsspec_hardway
6155 (char *vmspath, int vmspath_len,
6156 const char *unixpath,
6161 const char *unixptr;
6162 const char *unixend;
6164 const char *lastslash;
6165 const char *lastdot;
6171 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6172 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6174 if (utf8_fl != NULL)
6180 /* Ignore leading "/" characters */
6181 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6184 unixlen = strlen(unixptr);
6186 /* Do nothing with blank paths */
6193 /* This could have a "^UP^ on the front */
6194 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6200 lastslash = strrchr(unixptr,'/');
6201 lastdot = strrchr(unixptr,'.');
6202 unixend = strrchr(unixptr,'\"');
6203 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6204 unixend = unixptr + unixlen;
6207 /* last dot is last dot or past end of string */
6208 if (lastdot == NULL)
6209 lastdot = unixptr + unixlen;
6211 /* if no directories, set last slash to beginning of string */
6212 if (lastslash == NULL) {
6213 lastslash = unixptr;
6216 /* Watch out for trailing "." after last slash, still a directory */
6217 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6218 lastslash = unixptr + unixlen;
6221 /* Watch out for traiing ".." after last slash, still a directory */
6222 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6223 lastslash = unixptr + unixlen;
6226 /* dots in directories are aways escaped */
6227 if (lastdot < lastslash)
6228 lastdot = unixptr + unixlen;
6231 /* if (unixptr < lastslash) then we are in a directory */
6238 /* Start with the UNIX path */
6239 if (*unixptr != '/') {
6240 /* relative paths */
6242 /* If allowing logical names on relative pathnames, then handle here */
6243 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6244 !decc_posix_compliant_pathnames) {
6250 /* Find the next slash */
6251 nextslash = strchr(unixptr,'/');
6253 esa = PerlMem_malloc(vmspath_len);
6254 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6256 trn = PerlMem_malloc(VMS_MAXRSS);
6257 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6259 if (nextslash != NULL) {
6261 seg_len = nextslash - unixptr;
6262 strncpy(esa, unixptr, seg_len);
6266 strcpy(esa, unixptr);
6267 seg_len = strlen(unixptr);
6269 /* trnlnm(section) */
6270 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6273 /* Now fix up the directory */
6275 /* Split up the path to find the components */
6276 sts = vms_split_path
6295 /* A logical name must be a directory or the full
6296 specification. It is only a full specification if
6297 it is the only component */
6298 if ((unixptr[seg_len] == '\0') ||
6299 (unixptr[seg_len+1] == '\0')) {
6301 /* Is a directory being required? */
6302 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6303 /* Not a logical name */
6308 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6309 /* This must be a directory */
6310 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6311 strcpy(vmsptr, esa);
6312 vmslen=strlen(vmsptr);
6313 vmsptr[vmslen] = ':';
6315 vmsptr[vmslen] = '\0';
6323 /* must be dev/directory - ignore version */
6324 if ((n_len + e_len) != 0)
6327 /* transfer the volume */
6328 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6329 strncpy(vmsptr, v_spec, v_len);
6335 /* unroot the rooted directory */
6336 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6338 r_spec[r_len - 1] = ']';
6340 /* This should not be there, but nothing is perfect */
6342 cmp = strcmp(&r_spec[1], "000000.");
6352 strncpy(vmsptr, r_spec, r_len);
6358 /* Bring over the directory. */
6360 ((d_len + vmslen) < vmspath_len)) {
6362 d_spec[d_len - 1] = ']';
6364 cmp = strcmp(&d_spec[1], "000000.");
6375 /* Remove the redundant root */
6383 strncpy(vmsptr, d_spec, d_len);
6397 if (lastslash > unixptr) {
6400 /* skip leading ./ */
6402 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6408 /* Are we still in a directory? */
6409 if (unixptr <= lastslash) {
6414 /* if not backing up, then it is relative forward. */
6415 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6416 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6424 /* Perl wants an empty directory here to tell the difference
6425 * between a DCL commmand and a filename
6434 /* Handle two special files . and .. */
6435 if (unixptr[0] == '.') {
6436 if (&unixptr[1] == unixend) {
6443 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6454 else { /* Absolute PATH handling */
6458 /* Need to find out where root is */
6460 /* In theory, this procedure should never get an absolute POSIX pathname
6461 * that can not be found on the POSIX root.
6462 * In practice, that can not be relied on, and things will show up
6463 * here that are a VMS device name or concealed logical name instead.
6464 * So to make things work, this procedure must be tolerant.
6466 esa = PerlMem_malloc(vmspath_len);
6467 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6470 nextslash = strchr(&unixptr[1],'/');
6472 if (nextslash != NULL) {
6474 seg_len = nextslash - &unixptr[1];
6475 strncpy(vmspath, unixptr, seg_len + 1);
6476 vmspath[seg_len+1] = 0;
6479 cmp = strncmp(vmspath, "dev", 4);
6481 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6482 if (sts = SS$_NORMAL)
6486 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6489 if ($VMS_STATUS_SUCCESS(sts)) {
6490 /* This is verified to be a real path */
6492 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6493 if ($VMS_STATUS_SUCCESS(sts)) {
6494 strcpy(vmspath, esa);
6495 vmslen = strlen(vmspath);
6496 vmsptr = vmspath + vmslen;
6498 if (unixptr < lastslash) {
6507 cmp = strcmp(rptr,"000000.");
6512 } /* removing 6 zeros */
6513 } /* vmslen < 7, no 6 zeros possible */
6514 } /* Not in a directory */
6515 } /* Posix root found */
6517 /* No posix root, fall back to default directory */
6518 strcpy(vmspath, "SYS$DISK:[");
6519 vmsptr = &vmspath[10];
6521 if (unixptr > lastslash) {
6530 } /* end of verified real path handling */
6535 /* Ok, we have a device or a concealed root that is not in POSIX
6536 * or we have garbage. Make the best of it.
6539 /* Posix to VMS destroyed this, so copy it again */
6540 strncpy(vmspath, &unixptr[1], seg_len);
6541 vmspath[seg_len] = 0;
6543 vmsptr = &vmsptr[vmslen];
6546 /* Now do we need to add the fake 6 zero directory to it? */
6548 if ((*lastslash == '/') && (nextslash < lastslash)) {
6549 /* No there is another directory */
6556 /* now we have foo:bar or foo:[000000]bar to decide from */
6557 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6559 if (!islnm && !decc_posix_compliant_pathnames) {
6561 cmp = strncmp("bin", vmspath, 4);
6563 /* bin => SYS$SYSTEM: */
6564 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6567 /* tmp => SYS$SCRATCH: */
6568 cmp = strncmp("tmp", vmspath, 4);
6570 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6575 trnend = islnm ? islnm - 1 : 0;
6577 /* if this was a logical name, ']' or '>' must be present */
6578 /* if not a logical name, then assume a device and hope. */
6579 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6581 /* if log name and trailing '.' then rooted - treat as device */
6582 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6584 /* Fix me, if not a logical name, a device lookup should be
6585 * done to see if the device is file structured. If the device
6586 * is not file structured, the 6 zeros should not be put on.
6588 * As it is, perl is occasionally looking for dev:[000000]tty.
6589 * which looks a little strange.
6591 * Not that easy to detect as "/dev" may be file structured with
6592 * special device files.
6595 if ((add_6zero == 0) && (*nextslash == '/') &&
6596 (&nextslash[1] == unixend)) {
6597 /* No real directory present */
6602 /* Put the device delimiter on */
6605 unixptr = nextslash;
6608 /* Start directory if needed */
6609 if (!islnm || add_6zero) {
6615 /* add fake 000000] if needed */
6628 } /* non-POSIX translation */
6630 } /* End of relative/absolute path handling */
6632 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6639 if (dir_start != 0) {
6641 /* First characters in a directory are handled special */
6642 while ((*unixptr == '/') ||
6643 ((*unixptr == '.') &&
6644 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6645 (&unixptr[1]==unixend)))) {
6650 /* Skip redundant / in specification */
6651 while ((*unixptr == '/') && (dir_start != 0)) {
6654 if (unixptr == lastslash)
6657 if (unixptr == lastslash)
6660 /* Skip redundant ./ characters */
6661 while ((*unixptr == '.') &&
6662 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6665 if (unixptr == lastslash)
6667 if (*unixptr == '/')
6670 if (unixptr == lastslash)
6673 /* Skip redundant ../ characters */
6674 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6675 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6676 /* Set the backing up flag */
6682 unixptr++; /* first . */
6683 unixptr++; /* second . */
6684 if (unixptr == lastslash)
6686 if (*unixptr == '/') /* The slash */
6689 if (unixptr == lastslash)
6692 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6693 /* Not needed when VMS is pretending to be UNIX. */
6695 /* Is this loop stuck because of too many dots? */
6696 if (loop_flag == 0) {
6697 /* Exit the loop and pass the rest through */
6702 /* Are we done with directories yet? */
6703 if (unixptr >= lastslash) {
6705 /* Watch out for trailing dots */
6714 if (*unixptr == '/')
6718 /* Have we stopped backing up? */
6723 /* dir_start continues to be = 1 */
6725 if (*unixptr == '-') {
6727 *vmsptr++ = *unixptr++;
6731 /* Now are we done with directories yet? */
6732 if (unixptr >= lastslash) {
6734 /* Watch out for trailing dots */
6750 if (unixptr >= unixend)
6753 /* Normal characters - More EFS work probably needed */
6759 /* remove multiple / */
6760 while (unixptr[1] == '/') {
6763 if (unixptr == lastslash) {
6764 /* Watch out for trailing dots */
6776 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6777 /* Not needed when VMS is pretending to be UNIX. */
6781 if (unixptr != unixend)
6786 if ((unixptr < lastdot) || (unixptr < lastslash) ||
6787 (&unixptr[1] == unixend)) {
6793 /* trailing dot ==> '^..' on VMS */
6794 if (unixptr == unixend) {
6802 *vmsptr++ = *unixptr++;
6806 if (quoted && (&unixptr[1] == unixend)) {
6810 in_cnt = copy_expand_unix_filename_escape
6811 (vmsptr, unixptr, &out_cnt, utf8_fl);
6821 in_cnt = copy_expand_unix_filename_escape
6822 (vmsptr, unixptr, &out_cnt, utf8_fl);
6829 /* Make sure directory is closed */
6830 if (unixptr == lastslash) {
6832 vmsptr2 = vmsptr - 1;
6834 if (*vmsptr2 != ']') {
6837 /* directories do not end in a dot bracket */
6838 if (*vmsptr2 == '.') {
6842 if (*vmsptr2 != '^') {
6843 vmsptr--; /* back up over the dot */
6851 /* Add a trailing dot if a file with no extension */
6852 vmsptr2 = vmsptr - 1;
6854 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
6855 (*vmsptr2 != ')') && (*lastdot != '.')) {
6866 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
6867 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
6872 /* If a UTF8 flag is being passed, honor it */
6874 if (utf8_fl != NULL) {
6875 utf8_flag = *utf8_fl;
6880 /* If there is a possibility of UTF8, then if any UTF8 characters
6881 are present, then they must be converted to VTF-7
6883 result = strcpy(rslt, path); /* FIX-ME */
6886 result = strcpy(rslt, path);
6892 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
6893 static char *mp_do_tovmsspec
6894 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
6895 static char __tovmsspec_retbuf[VMS_MAXRSS];
6896 char *rslt, *dirend;
6901 unsigned long int infront = 0, hasdir = 1;
6904 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6905 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6907 if (path == NULL) return NULL;
6908 rslt_len = VMS_MAXRSS-1;
6909 if (buf) rslt = buf;
6910 else if (ts) Newx(rslt, VMS_MAXRSS, char);
6911 else rslt = __tovmsspec_retbuf;
6913 /* '.' and '..' are "[]" and "[-]" for a quick check */
6914 if (path[0] == '.') {
6915 if (path[1] == '\0') {
6917 if (utf8_flag != NULL)
6922 if (path[1] == '.' && path[2] == '\0') {
6924 if (utf8_flag != NULL)
6931 /* Posix specifications are now a native VMS format */
6932 /*--------------------------------------------------*/
6933 #if __CRTL_VER >= 80200000 && !defined(__VAX)
6934 if (decc_posix_compliant_pathnames) {
6935 if (strncmp(path,"\"^UP^",5) == 0) {
6936 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
6942 /* This is really the only way to see if this is already in VMS format */
6943 sts = vms_split_path
6958 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
6959 replacement, because the above parse just took care of most of
6960 what is needed to do vmspath when the specification is already
6963 And if it is not already, it is easier to do the conversion as
6964 part of this routine than to call this routine and then work on
6968 /* If VMS punctuation was found, it is already VMS format */
6969 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
6970 if (utf8_flag != NULL)
6975 /* Now, what to do with trailing "." cases where there is no
6976 extension? If this is a UNIX specification, and EFS characters
6977 are enabled, then the trailing "." should be converted to a "^.".
6978 But if this was already a VMS specification, then it should be
6981 So in the case of ambiguity, leave the specification alone.
6985 /* If there is a possibility of UTF8, then if any UTF8 characters
6986 are present, then they must be converted to VTF-7
6988 if (utf8_flag != NULL)
6994 dirend = strrchr(path,'/');
6996 if (dirend == NULL) {
6997 /* If we get here with no UNIX directory delimiters, then this is
6998 not a complete file specification, either garbage a UNIX glob
6999 specification that can not be converted to a VMS wildcard, or
7000 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7001 so apparently other programs expect this also.
7003 utf8 flag setting needs to be preserved.
7009 /* If POSIX mode active, handle the conversion */
7010 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7011 if (decc_efs_charset) {
7012 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7017 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7018 if (!*(dirend+2)) dirend +=2;
7019 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7020 if (decc_efs_charset == 0) {
7021 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7027 lastdot = strrchr(cp2,'.');
7033 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7035 if (decc_disable_posix_root) {
7036 strcpy(rslt,"sys$disk:[000000]");
7039 strcpy(rslt,"sys$posix_root:[000000]");
7041 if (utf8_flag != NULL)
7045 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7047 trndev = PerlMem_malloc(VMS_MAXRSS);
7048 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7049 islnm = my_trnlnm(rslt,trndev,0);
7051 /* DECC special handling */
7053 if (strcmp(rslt,"bin") == 0) {
7054 strcpy(rslt,"sys$system");
7057 islnm = my_trnlnm(rslt,trndev,0);
7059 else if (strcmp(rslt,"tmp") == 0) {
7060 strcpy(rslt,"sys$scratch");
7063 islnm = my_trnlnm(rslt,trndev,0);
7065 else if (!decc_disable_posix_root) {
7066 strcpy(rslt, "sys$posix_root");
7070 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7071 islnm = my_trnlnm(rslt,trndev,0);
7073 else if (strcmp(rslt,"dev") == 0) {
7074 if (strncmp(cp2,"/null", 5) == 0) {
7075 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7076 strcpy(rslt,"NLA0");
7080 islnm = my_trnlnm(rslt,trndev,0);
7086 trnend = islnm ? strlen(trndev) - 1 : 0;
7087 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7088 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7089 /* If the first element of the path is a logical name, determine
7090 * whether it has to be translated so we can add more directories. */
7091 if (!islnm || rooted) {
7094 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7098 if (cp2 != dirend) {
7099 strcpy(rslt,trndev);
7100 cp1 = rslt + trnend;
7107 if (decc_disable_posix_root) {
7113 PerlMem_free(trndev);
7118 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7119 cp2 += 2; /* skip over "./" - it's redundant */
7120 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7122 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7123 *(cp1++) = '-'; /* "../" --> "-" */
7126 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7127 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7128 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7129 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7132 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7133 /* Escape the extra dots in EFS file specifications */
7136 if (cp2 > dirend) cp2 = dirend;
7138 else *(cp1++) = '.';
7140 for (; cp2 < dirend; cp2++) {
7142 if (*(cp2-1) == '/') continue;
7143 if (*(cp1-1) != '.') *(cp1++) = '.';
7146 else if (!infront && *cp2 == '.') {
7147 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7148 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7149 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7150 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7151 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7152 else { /* back up over previous directory name */
7154 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7155 if (*(cp1-1) == '[') {
7156 memcpy(cp1,"000000.",7);
7161 if (cp2 == dirend) break;
7163 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7164 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7165 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7166 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7168 *(cp1++) = '.'; /* Simulate trailing '/' */
7169 cp2 += 2; /* for loop will incr this to == dirend */
7171 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7174 if (decc_efs_charset == 0)
7175 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7177 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7183 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7185 if (decc_efs_charset == 0)
7192 else *(cp1++) = *cp2;
7196 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7197 if (hasdir) *(cp1++) = ']';
7198 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7199 /* fixme for ODS5 */
7206 if (decc_efs_charset == 0)
7217 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7218 decc_readdir_dropdotnotype) {
7223 /* trailing dot ==> '^..' on VMS */
7230 *(cp1++) = *(cp2++);
7235 /* This could be a macro to be passed through */
7236 *(cp1++) = *(cp2++);
7238 const char * save_cp2;
7242 /* paranoid check */
7248 *(cp1++) = *(cp2++);
7249 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7250 *(cp1++) = *(cp2++);
7251 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7252 *(cp1++) = *(cp2++);
7255 *(cp1++) = *(cp2++);
7259 if (is_macro == 0) {
7260 /* Not really a macro - never mind */
7290 *(cp1++) = *(cp2++);
7293 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7294 * which is wrong. UNIX notation should be ".dir." unless
7295 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7296 * changing this behavior could break more things at this time.
7297 * efs character set effectively does not allow "." to be a version
7298 * delimiter as a further complication about changing this.
7300 if (decc_filename_unix_report != 0) {
7303 *(cp1++) = *(cp2++);
7306 *(cp1++) = *(cp2++);
7309 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7313 /* Fix me for "^]", but that requires making sure that you do
7314 * not back up past the start of the filename
7316 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7321 if (utf8_flag != NULL)
7325 } /* end of do_tovmsspec() */
7327 /* External entry points */
7328 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7329 { return do_tovmsspec(path,buf,0,NULL); }
7330 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7331 { return do_tovmsspec(path,buf,1,NULL); }
7332 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7333 { return do_tovmsspec(path,buf,0,utf8_fl); }
7334 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7335 { return do_tovmsspec(path,buf,1,utf8_fl); }
7337 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7338 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7339 static char __tovmspath_retbuf[VMS_MAXRSS];
7341 char *pathified, *vmsified, *cp;
7343 if (path == NULL) return NULL;
7344 pathified = PerlMem_malloc(VMS_MAXRSS);
7345 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7346 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7347 PerlMem_free(pathified);
7353 Newx(vmsified, VMS_MAXRSS, char);
7354 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7355 PerlMem_free(pathified);
7356 if (vmsified) Safefree(vmsified);
7359 PerlMem_free(pathified);
7364 vmslen = strlen(vmsified);
7365 Newx(cp,vmslen+1,char);
7366 memcpy(cp,vmsified,vmslen);
7372 strcpy(__tovmspath_retbuf,vmsified);
7374 return __tovmspath_retbuf;
7377 } /* end of do_tovmspath() */
7379 /* External entry points */
7380 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7381 { return do_tovmspath(path,buf,0, NULL); }
7382 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7383 { return do_tovmspath(path,buf,1, NULL); }
7384 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7385 { return do_tovmspath(path,buf,0,utf8_fl); }
7386 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7387 { return do_tovmspath(path,buf,1,utf8_fl); }
7390 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7391 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7392 static char __tounixpath_retbuf[VMS_MAXRSS];
7394 char *pathified, *unixified, *cp;
7396 if (path == NULL) return NULL;
7397 pathified = PerlMem_malloc(VMS_MAXRSS);
7398 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7399 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7400 PerlMem_free(pathified);
7406 Newx(unixified, VMS_MAXRSS, char);
7408 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7409 PerlMem_free(pathified);
7410 if (unixified) Safefree(unixified);
7413 PerlMem_free(pathified);
7418 unixlen = strlen(unixified);
7419 Newx(cp,unixlen+1,char);
7420 memcpy(cp,unixified,unixlen);
7422 Safefree(unixified);
7426 strcpy(__tounixpath_retbuf,unixified);
7427 Safefree(unixified);
7428 return __tounixpath_retbuf;
7431 } /* end of do_tounixpath() */
7433 /* External entry points */
7434 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7435 { return do_tounixpath(path,buf,0,NULL); }
7436 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7437 { return do_tounixpath(path,buf,1,NULL); }
7438 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7439 { return do_tounixpath(path,buf,0,utf8_fl); }
7440 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7441 { return do_tounixpath(path,buf,1,utf8_fl); }
7444 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com)
7446 *****************************************************************************
7448 * Copyright (C) 1989-1994 by *
7449 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7451 * Permission is hereby granted for the reproduction of this software, *
7452 * on condition that this copyright notice is included in the reproduction, *
7453 * and that such reproduction is not for purposes of profit or material *
7456 * 27-Aug-1994 Modified for inclusion in perl5 *
7457 * by Charles Bailey bailey@newman.upenn.edu *
7458 *****************************************************************************
7462 * getredirection() is intended to aid in porting C programs
7463 * to VMS (Vax-11 C). The native VMS environment does not support
7464 * '>' and '<' I/O redirection, or command line wild card expansion,
7465 * or a command line pipe mechanism using the '|' AND background
7466 * command execution '&'. All of these capabilities are provided to any
7467 * C program which calls this procedure as the first thing in the
7469 * The piping mechanism will probably work with almost any 'filter' type
7470 * of program. With suitable modification, it may useful for other
7471 * portability problems as well.
7473 * Author: Mark Pizzolato mark@infocomm.com
7477 struct list_item *next;
7481 static void add_item(struct list_item **head,
7482 struct list_item **tail,
7486 static void mp_expand_wild_cards(pTHX_ char *item,
7487 struct list_item **head,
7488 struct list_item **tail,
7491 static int background_process(pTHX_ int argc, char **argv);
7493 static void pipe_and_fork(pTHX_ char **cmargv);
7495 /*{{{ void getredirection(int *ac, char ***av)*/
7497 mp_getredirection(pTHX_ int *ac, char ***av)
7499 * Process vms redirection arg's. Exit if any error is seen.
7500 * If getredirection() processes an argument, it is erased
7501 * from the vector. getredirection() returns a new argc and argv value.
7502 * In the event that a background command is requested (by a trailing "&"),
7503 * this routine creates a background subprocess, and simply exits the program.
7505 * Warning: do not try to simplify the code for vms. The code
7506 * presupposes that getredirection() is called before any data is
7507 * read from stdin or written to stdout.
7509 * Normal usage is as follows:
7515 * getredirection(&argc, &argv);
7519 int argc = *ac; /* Argument Count */
7520 char **argv = *av; /* Argument Vector */
7521 char *ap; /* Argument pointer */
7522 int j; /* argv[] index */
7523 int item_count = 0; /* Count of Items in List */
7524 struct list_item *list_head = 0; /* First Item in List */
7525 struct list_item *list_tail; /* Last Item in List */
7526 char *in = NULL; /* Input File Name */
7527 char *out = NULL; /* Output File Name */
7528 char *outmode = "w"; /* Mode to Open Output File */
7529 char *err = NULL; /* Error File Name */
7530 char *errmode = "w"; /* Mode to Open Error File */
7531 int cmargc = 0; /* Piped Command Arg Count */
7532 char **cmargv = NULL;/* Piped Command Arg Vector */
7535 * First handle the case where the last thing on the line ends with
7536 * a '&'. This indicates the desire for the command to be run in a
7537 * subprocess, so we satisfy that desire.
7540 if (0 == strcmp("&", ap))
7541 exit(background_process(aTHX_ --argc, argv));
7542 if (*ap && '&' == ap[strlen(ap)-1])
7544 ap[strlen(ap)-1] = '\0';
7545 exit(background_process(aTHX_ argc, argv));
7548 * Now we handle the general redirection cases that involve '>', '>>',
7549 * '<', and pipes '|'.
7551 for (j = 0; j < argc; ++j)
7553 if (0 == strcmp("<", argv[j]))
7557 fprintf(stderr,"No input file after < on command line");
7558 exit(LIB$_WRONUMARG);
7563 if ('<' == *(ap = argv[j]))
7568 if (0 == strcmp(">", ap))
7572 fprintf(stderr,"No output file after > on command line");
7573 exit(LIB$_WRONUMARG);
7592 fprintf(stderr,"No output file after > or >> on command line");
7593 exit(LIB$_WRONUMARG);
7597 if (('2' == *ap) && ('>' == ap[1]))
7614 fprintf(stderr,"No output file after 2> or 2>> on command line");
7615 exit(LIB$_WRONUMARG);
7619 if (0 == strcmp("|", argv[j]))
7623 fprintf(stderr,"No command into which to pipe on command line");
7624 exit(LIB$_WRONUMARG);
7626 cmargc = argc-(j+1);
7627 cmargv = &argv[j+1];
7631 if ('|' == *(ap = argv[j]))
7639 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7642 * Allocate and fill in the new argument vector, Some Unix's terminate
7643 * the list with an extra null pointer.
7645 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7646 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7648 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7649 argv[j] = list_head->value;
7655 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7656 exit(LIB$_INVARGORD);
7658 pipe_and_fork(aTHX_ cmargv);
7661 /* Check for input from a pipe (mailbox) */
7663 if (in == NULL && 1 == isapipe(0))
7665 char mbxname[L_tmpnam];
7667 long int dvi_item = DVI$_DEVBUFSIZ;
7668 $DESCRIPTOR(mbxnam, "");
7669 $DESCRIPTOR(mbxdevnam, "");
7671 /* Input from a pipe, reopen it in binary mode to disable */
7672 /* carriage control processing. */
7674 fgetname(stdin, mbxname);
7675 mbxnam.dsc$a_pointer = mbxname;
7676 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7677 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7678 mbxdevnam.dsc$a_pointer = mbxname;
7679 mbxdevnam.dsc$w_length = sizeof(mbxname);
7680 dvi_item = DVI$_DEVNAM;
7681 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7682 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7685 freopen(mbxname, "rb", stdin);
7688 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7692 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7694 fprintf(stderr,"Can't open input file %s as stdin",in);
7697 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
7699 fprintf(stderr,"Can't open output file %s as stdout",out);
7702 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
7705 if (strcmp(err,"&1") == 0) {
7706 dup2(fileno(stdout), fileno(stderr));
7707 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
7710 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
7712 fprintf(stderr,"Can't open error file %s as stderr",err);
7716 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
7720 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
7723 #ifdef ARGPROC_DEBUG
7724 PerlIO_printf(Perl_debug_log, "Arglist:\n");
7725 for (j = 0; j < *ac; ++j)
7726 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
7728 /* Clear errors we may have hit expanding wildcards, so they don't
7729 show up in Perl's $! later */
7730 set_errno(0); set_vaxc_errno(1);
7731 } /* end of getredirection() */
7734 static void add_item(struct list_item **head,
7735 struct list_item **tail,
7741 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7742 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7746 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
7747 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7748 *tail = (*tail)->next;
7750 (*tail)->value = value;
7754 static void mp_expand_wild_cards(pTHX_ char *item,
7755 struct list_item **head,
7756 struct list_item **tail,
7760 unsigned long int context = 0;
7768 $DESCRIPTOR(filespec, "");
7769 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
7770 $DESCRIPTOR(resultspec, "");
7771 unsigned long int lff_flags = 0;
7775 #ifdef VMS_LONGNAME_SUPPORT
7776 lff_flags = LIB$M_FIL_LONG_NAMES;
7779 for (cp = item; *cp; cp++) {
7780 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
7781 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
7783 if (!*cp || isspace(*cp))
7785 add_item(head, tail, item, count);
7790 /* "double quoted" wild card expressions pass as is */
7791 /* From DCL that means using e.g.: */
7792 /* perl program """perl.*""" */
7793 item_len = strlen(item);
7794 if ( '"' == *item && '"' == item[item_len-1] )
7797 item[item_len-2] = '\0';
7798 add_item(head, tail, item, count);
7802 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
7803 resultspec.dsc$b_class = DSC$K_CLASS_D;
7804 resultspec.dsc$a_pointer = NULL;
7805 vmsspec = PerlMem_malloc(VMS_MAXRSS);
7806 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7807 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
7808 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
7809 if (!isunix || !filespec.dsc$a_pointer)
7810 filespec.dsc$a_pointer = item;
7811 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
7813 * Only return version specs, if the caller specified a version
7815 had_version = strchr(item, ';');
7817 * Only return device and directory specs, if the caller specifed either.
7819 had_device = strchr(item, ':');
7820 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
7822 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
7823 (&filespec, &resultspec, &context,
7824 &defaultspec, 0, &rms_sts, &lff_flags)))
7829 string = PerlMem_malloc(resultspec.dsc$w_length+1);
7830 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7831 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
7832 string[resultspec.dsc$w_length] = '\0';
7833 if (NULL == had_version)
7834 *(strrchr(string, ';')) = '\0';
7835 if ((!had_directory) && (had_device == NULL))
7837 if (NULL == (devdir = strrchr(string, ']')))
7838 devdir = strrchr(string, '>');
7839 strcpy(string, devdir + 1);
7842 * Be consistent with what the C RTL has already done to the rest of
7843 * the argv items and lowercase all of these names.
7845 if (!decc_efs_case_preserve) {
7846 for (c = string; *c; ++c)
7850 if (isunix) trim_unixpath(string,item,1);
7851 add_item(head, tail, string, count);
7854 PerlMem_free(vmsspec);
7855 if (sts != RMS$_NMF)
7857 set_vaxc_errno(sts);
7860 case RMS$_FNF: case RMS$_DNF:
7861 set_errno(ENOENT); break;
7863 set_errno(ENOTDIR); break;
7865 set_errno(ENODEV); break;
7866 case RMS$_FNM: case RMS$_SYN:
7867 set_errno(EINVAL); break;
7869 set_errno(EACCES); break;
7871 _ckvmssts_noperl(sts);
7875 add_item(head, tail, item, count);
7876 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
7877 _ckvmssts_noperl(lib$find_file_end(&context));
7880 static int child_st[2];/* Event Flag set when child process completes */
7882 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
7884 static unsigned long int exit_handler(int *status)
7888 if (0 == child_st[0])
7890 #ifdef ARGPROC_DEBUG
7891 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
7893 fflush(stdout); /* Have to flush pipe for binary data to */
7894 /* terminate properly -- <tp@mccall.com> */
7895 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
7896 sys$dassgn(child_chan);
7898 sys$synch(0, child_st);
7903 static void sig_child(int chan)
7905 #ifdef ARGPROC_DEBUG
7906 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
7908 if (child_st[0] == 0)
7912 static struct exit_control_block exit_block =
7917 &exit_block.exit_status,
7922 pipe_and_fork(pTHX_ char **cmargv)
7925 struct dsc$descriptor_s *vmscmd;
7926 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
7927 int sts, j, l, ismcr, quote, tquote = 0;
7929 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
7930 vms_execfree(vmscmd);
7935 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
7936 && toupper(*(q+2)) == 'R' && !*(q+3);
7938 while (q && l < MAX_DCL_LINE_LENGTH) {
7940 if (j > 0 && quote) {
7946 if (ismcr && j > 1) quote = 1;
7947 tquote = (strchr(q,' ')) != NULL || *q == '\0';
7950 if (quote || tquote) {
7956 if ((quote||tquote) && *q == '"') {
7966 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
7968 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
7972 static int background_process(pTHX_ int argc, char **argv)
7974 char command[MAX_DCL_SYMBOL + 1] = "$";
7975 $DESCRIPTOR(value, "");
7976 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
7977 static $DESCRIPTOR(null, "NLA0:");
7978 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
7980 $DESCRIPTOR(pidstr, "");
7982 unsigned long int flags = 17, one = 1, retsts;
7985 strcat(command, argv[0]);
7986 len = strlen(command);
7987 while (--argc && (len < MAX_DCL_SYMBOL))
7989 strcat(command, " \"");
7990 strcat(command, *(++argv));
7991 strcat(command, "\"");
7992 len = strlen(command);
7994 value.dsc$a_pointer = command;
7995 value.dsc$w_length = strlen(value.dsc$a_pointer);
7996 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
7997 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
7998 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
7999 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8002 _ckvmssts_noperl(retsts);
8004 #ifdef ARGPROC_DEBUG
8005 PerlIO_printf(Perl_debug_log, "%s\n", command);
8007 sprintf(pidstring, "%08X", pid);
8008 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8009 pidstr.dsc$a_pointer = pidstring;
8010 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8011 lib$set_symbol(&pidsymbol, &pidstr);
8015 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8018 /* OS-specific initialization at image activation (not thread startup) */
8019 /* Older VAXC header files lack these constants */
8020 #ifndef JPI$_RIGHTS_SIZE
8021 # define JPI$_RIGHTS_SIZE 817
8023 #ifndef KGB$M_SUBSYSTEM
8024 # define KGB$M_SUBSYSTEM 0x8
8027 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8029 /*{{{void vms_image_init(int *, char ***)*/
8031 vms_image_init(int *argcp, char ***argvp)
8033 char eqv[LNM$C_NAMLENGTH+1] = "";
8034 unsigned int len, tabct = 8, tabidx = 0;
8035 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8036 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8037 unsigned short int dummy, rlen;
8038 struct dsc$descriptor_s **tabvec;
8039 #if defined(PERL_IMPLICIT_CONTEXT)
8042 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8043 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8044 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8047 #ifdef KILL_BY_SIGPRC
8048 Perl_csighandler_init();
8051 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8052 _ckvmssts_noperl(iosb[0]);
8053 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8054 if (iprv[i]) { /* Running image installed with privs? */
8055 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8060 /* Rights identifiers might trigger tainting as well. */
8061 if (!will_taint && (rlen || rsz)) {
8062 while (rlen < rsz) {
8063 /* We didn't get all the identifiers on the first pass. Allocate a
8064 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8065 * were needed to hold all identifiers at time of last call; we'll
8066 * allocate that many unsigned long ints), and go back and get 'em.
8067 * If it gave us less than it wanted to despite ample buffer space,
8068 * something's broken. Is your system missing a system identifier?
8070 if (rsz <= jpilist[1].buflen) {
8071 /* Perl_croak accvios when used this early in startup. */
8072 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8073 rsz, (unsigned long) jpilist[1].buflen,
8074 "Check your rights database for corruption.\n");
8077 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8078 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8079 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8080 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8081 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8082 _ckvmssts_noperl(iosb[0]);
8084 mask = jpilist[1].bufadr;
8085 /* Check attribute flags for each identifier (2nd longword); protected
8086 * subsystem identifiers trigger tainting.
8088 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8089 if (mask[i] & KGB$M_SUBSYSTEM) {
8094 if (mask != rlst) PerlMem_free(mask);
8097 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8098 * logical, some versions of the CRTL will add a phanthom /000000/
8099 * directory. This needs to be removed.
8101 if (decc_filename_unix_report) {
8104 ulen = strlen(argvp[0][0]);
8106 zeros = strstr(argvp[0][0], "/000000/");
8107 if (zeros != NULL) {
8109 mlen = ulen - (zeros - argvp[0][0]) - 7;
8110 memmove(zeros, &zeros[7], mlen);
8112 argvp[0][0][ulen] = '\0';
8115 /* It also may have a trailing dot that needs to be removed otherwise
8116 * it will be converted to VMS mode incorrectly.
8119 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8120 argvp[0][0][ulen] = '\0';
8123 /* We need to use this hack to tell Perl it should run with tainting,
8124 * since its tainting flag may be part of the PL_curinterp struct, which
8125 * hasn't been allocated when vms_image_init() is called.
8128 char **newargv, **oldargv;
8130 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8131 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8132 newargv[0] = oldargv[0];
8133 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8134 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8135 strcpy(newargv[1], "-T");
8136 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8138 newargv[*argcp] = NULL;
8139 /* We orphan the old argv, since we don't know where it's come from,
8140 * so we don't know how to free it.
8144 else { /* Did user explicitly request tainting? */
8146 char *cp, **av = *argvp;
8147 for (i = 1; i < *argcp; i++) {
8148 if (*av[i] != '-') break;
8149 for (cp = av[i]+1; *cp; cp++) {
8150 if (*cp == 'T') { will_taint = 1; break; }
8151 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8152 strchr("DFIiMmx",*cp)) break;
8154 if (will_taint) break;
8159 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8162 tabvec = (struct dsc$descriptor_s **)
8163 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8164 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8166 else if (tabidx >= tabct) {
8168 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8169 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8171 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8172 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8173 tabvec[tabidx]->dsc$w_length = 0;
8174 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8175 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8176 tabvec[tabidx]->dsc$a_pointer = NULL;
8177 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8179 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8181 getredirection(argcp,argvp);
8182 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8184 # include <reentrancy.h>
8185 decc$set_reentrancy(C$C_MULTITHREAD);
8194 * Trim Unix-style prefix off filespec, so it looks like what a shell
8195 * glob expansion would return (i.e. from specified prefix on, not
8196 * full path). Note that returned filespec is Unix-style, regardless
8197 * of whether input filespec was VMS-style or Unix-style.
8199 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8200 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8201 * vector of options; at present, only bit 0 is used, and if set tells
8202 * trim unixpath to try the current default directory as a prefix when
8203 * presented with a possibly ambiguous ... wildcard.
8205 * Returns !=0 on success, with trimmed filespec replacing contents of
8206 * fspec, and 0 on failure, with contents of fpsec unchanged.
8208 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8210 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8212 char *unixified, *unixwild,
8213 *template, *base, *end, *cp1, *cp2;
8214 register int tmplen, reslen = 0, dirs = 0;
8216 unixwild = PerlMem_malloc(VMS_MAXRSS);
8217 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8218 if (!wildspec || !fspec) return 0;
8219 template = unixwild;
8220 if (strpbrk(wildspec,"]>:") != NULL) {
8221 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8222 PerlMem_free(unixwild);
8227 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8228 unixwild[VMS_MAXRSS-1] = 0;
8230 unixified = PerlMem_malloc(VMS_MAXRSS);
8231 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8232 if (strpbrk(fspec,"]>:") != NULL) {
8233 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8234 PerlMem_free(unixwild);
8235 PerlMem_free(unixified);
8238 else base = unixified;
8239 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8240 * check to see that final result fits into (isn't longer than) fspec */
8241 reslen = strlen(fspec);
8245 /* No prefix or absolute path on wildcard, so nothing to remove */
8246 if (!*template || *template == '/') {
8247 PerlMem_free(unixwild);
8248 if (base == fspec) {
8249 PerlMem_free(unixified);
8252 tmplen = strlen(unixified);
8253 if (tmplen > reslen) {
8254 PerlMem_free(unixified);
8255 return 0; /* not enough space */
8257 /* Copy unixified resultant, including trailing NUL */
8258 memmove(fspec,unixified,tmplen+1);
8259 PerlMem_free(unixified);
8263 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8264 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8265 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8266 for (cp1 = end ;cp1 >= base; cp1--)
8267 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8269 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8270 PerlMem_free(unixified);
8271 PerlMem_free(unixwild);
8276 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8277 int ells = 1, totells, segdirs, match;
8278 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8279 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8281 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8283 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8284 tpl = PerlMem_malloc(VMS_MAXRSS);
8285 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8286 if (ellipsis == template && opts & 1) {
8287 /* Template begins with an ellipsis. Since we can't tell how many
8288 * directory names at the front of the resultant to keep for an
8289 * arbitrary starting point, we arbitrarily choose the current
8290 * default directory as a starting point. If it's there as a prefix,
8291 * clip it off. If not, fall through and act as if the leading
8292 * ellipsis weren't there (i.e. return shortest possible path that
8293 * could match template).
8295 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8297 PerlMem_free(unixified);
8298 PerlMem_free(unixwild);
8301 if (!decc_efs_case_preserve) {
8302 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8303 if (_tolower(*cp1) != _tolower(*cp2)) break;
8305 segdirs = dirs - totells; /* Min # of dirs we must have left */
8306 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8307 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8308 memmove(fspec,cp2+1,end - cp2);
8310 PerlMem_free(unixified);
8311 PerlMem_free(unixwild);
8315 /* First off, back up over constant elements at end of path */
8317 for (front = end ; front >= base; front--)
8318 if (*front == '/' && !dirs--) { front++; break; }
8320 lcres = PerlMem_malloc(VMS_MAXRSS);
8321 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8322 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8324 if (!decc_efs_case_preserve) {
8325 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8333 PerlMem_free(unixified);
8334 PerlMem_free(unixwild);
8335 PerlMem_free(lcres);
8336 return 0; /* Path too long. */
8339 *cp2 = '\0'; /* Pick up with memcpy later */
8340 lcfront = lcres + (front - base);
8341 /* Now skip over each ellipsis and try to match the path in front of it. */
8343 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8344 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8345 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8346 if (cp1 < template) break; /* template started with an ellipsis */
8347 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8348 ellipsis = cp1; continue;
8350 wilddsc.dsc$a_pointer = tpl;
8351 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8353 for (segdirs = 0, cp2 = tpl;
8354 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8356 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8358 if (!decc_efs_case_preserve) {
8359 *cp2 = _tolower(*cp1); /* else lowercase for match */
8362 *cp2 = *cp1; /* else preserve case for match */
8365 if (*cp2 == '/') segdirs++;
8367 if (cp1 != ellipsis - 1) {
8369 PerlMem_free(unixified);
8370 PerlMem_free(unixwild);
8371 PerlMem_free(lcres);
8372 return 0; /* Path too long */
8374 /* Back up at least as many dirs as in template before matching */
8375 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8376 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8377 for (match = 0; cp1 > lcres;) {
8378 resdsc.dsc$a_pointer = cp1;
8379 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8381 if (match == 1) lcfront = cp1;
8383 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8387 PerlMem_free(unixified);
8388 PerlMem_free(unixwild);
8389 PerlMem_free(lcres);
8390 return 0; /* Can't find prefix ??? */
8392 if (match > 1 && opts & 1) {
8393 /* This ... wildcard could cover more than one set of dirs (i.e.
8394 * a set of similar dir names is repeated). If the template
8395 * contains more than 1 ..., upstream elements could resolve the
8396 * ambiguity, but it's not worth a full backtracking setup here.
8397 * As a quick heuristic, clip off the current default directory
8398 * if it's present to find the trimmed spec, else use the
8399 * shortest string that this ... could cover.
8401 char def[NAM$C_MAXRSS+1], *st;
8403 if (getcwd(def, sizeof def,0) == NULL) {
8404 Safefree(unixified);
8410 if (!decc_efs_case_preserve) {
8411 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8412 if (_tolower(*cp1) != _tolower(*cp2)) break;
8414 segdirs = dirs - totells; /* Min # of dirs we must have left */
8415 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8416 if (*cp1 == '\0' && *cp2 == '/') {
8417 memmove(fspec,cp2+1,end - cp2);
8419 PerlMem_free(unixified);
8420 PerlMem_free(unixwild);
8421 PerlMem_free(lcres);
8424 /* Nope -- stick with lcfront from above and keep going. */
8427 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8429 PerlMem_free(unixified);
8430 PerlMem_free(unixwild);
8431 PerlMem_free(lcres);
8436 } /* end of trim_unixpath() */
8441 * VMS readdir() routines.
8442 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8444 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8445 * Minor modifications to original routines.
8448 /* readdir may have been redefined by reentr.h, so make sure we get
8449 * the local version for what we do here.
8454 #if !defined(PERL_IMPLICIT_CONTEXT)
8455 # define readdir Perl_readdir
8457 # define readdir(a) Perl_readdir(aTHX_ a)
8460 /* Number of elements in vms_versions array */
8461 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8464 * Open a directory, return a handle for later use.
8466 /*{{{ DIR *opendir(char*name) */
8468 Perl_opendir(pTHX_ const char *name)
8476 if (decc_efs_charset) {
8477 unix_flag = is_unix_filespec(name);
8480 Newx(dir, VMS_MAXRSS, char);
8481 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8485 /* Check access before stat; otherwise stat does not
8486 * accurately report whether it's a directory.
8488 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8489 /* cando_by_name has already set errno */
8493 if (flex_stat(dir,&sb) == -1) return NULL;
8494 if (!S_ISDIR(sb.st_mode)) {
8496 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8499 /* Get memory for the handle, and the pattern. */
8501 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8503 /* Fill in the fields; mainly playing with the descriptor. */
8504 sprintf(dd->pattern, "%s*.*",dir);
8510 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8511 dd->pat.dsc$a_pointer = dd->pattern;
8512 dd->pat.dsc$w_length = strlen(dd->pattern);
8513 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8514 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8515 #if defined(USE_ITHREADS)
8516 Newx(dd->mutex,1,perl_mutex);
8517 MUTEX_INIT( (perl_mutex *) dd->mutex );
8523 } /* end of opendir() */
8527 * Set the flag to indicate we want versions or not.
8529 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8531 vmsreaddirversions(DIR *dd, int flag)
8534 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8536 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8541 * Free up an opened directory.
8543 /*{{{ void closedir(DIR *dd)*/
8545 Perl_closedir(DIR *dd)
8549 sts = lib$find_file_end(&dd->context);
8550 Safefree(dd->pattern);
8551 #if defined(USE_ITHREADS)
8552 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8553 Safefree(dd->mutex);
8560 * Collect all the version numbers for the current file.
8563 collectversions(pTHX_ DIR *dd)
8565 struct dsc$descriptor_s pat;
8566 struct dsc$descriptor_s res;
8568 char *p, *text, *buff;
8570 unsigned long context, tmpsts;
8572 /* Convenient shorthand. */
8575 /* Add the version wildcard, ignoring the "*.*" put on before */
8576 i = strlen(dd->pattern);
8577 Newx(text,i + e->d_namlen + 3,char);
8578 strcpy(text, dd->pattern);
8579 sprintf(&text[i - 3], "%s;*", e->d_name);
8581 /* Set up the pattern descriptor. */
8582 pat.dsc$a_pointer = text;
8583 pat.dsc$w_length = i + e->d_namlen - 1;
8584 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8585 pat.dsc$b_class = DSC$K_CLASS_S;
8587 /* Set up result descriptor. */
8588 Newx(buff, VMS_MAXRSS, char);
8589 res.dsc$a_pointer = buff;
8590 res.dsc$w_length = VMS_MAXRSS - 1;
8591 res.dsc$b_dtype = DSC$K_DTYPE_T;
8592 res.dsc$b_class = DSC$K_CLASS_S;
8594 /* Read files, collecting versions. */
8595 for (context = 0, e->vms_verscount = 0;
8596 e->vms_verscount < VERSIZE(e);
8597 e->vms_verscount++) {
8599 unsigned long flags = 0;
8601 #ifdef VMS_LONGNAME_SUPPORT
8602 flags = LIB$M_FIL_LONG_NAMES;
8604 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8605 if (tmpsts == RMS$_NMF || context == 0) break;
8607 buff[VMS_MAXRSS - 1] = '\0';
8608 if ((p = strchr(buff, ';')))
8609 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8611 e->vms_versions[e->vms_verscount] = -1;
8614 _ckvmssts(lib$find_file_end(&context));
8618 } /* end of collectversions() */
8621 * Read the next entry from the directory.
8623 /*{{{ struct dirent *readdir(DIR *dd)*/
8625 Perl_readdir(pTHX_ DIR *dd)
8627 struct dsc$descriptor_s res;
8629 unsigned long int tmpsts;
8631 unsigned long flags = 0;
8632 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8633 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8635 /* Set up result descriptor, and get next file. */
8636 Newx(buff, VMS_MAXRSS, char);
8637 res.dsc$a_pointer = buff;
8638 res.dsc$w_length = VMS_MAXRSS - 1;
8639 res.dsc$b_dtype = DSC$K_DTYPE_T;
8640 res.dsc$b_class = DSC$K_CLASS_S;
8642 #ifdef VMS_LONGNAME_SUPPORT
8643 flags = LIB$M_FIL_LONG_NAMES;
8646 tmpsts = lib$find_file
8647 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8648 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8649 if (!(tmpsts & 1)) {
8650 set_vaxc_errno(tmpsts);
8653 set_errno(EACCES); break;
8655 set_errno(ENODEV); break;
8657 set_errno(ENOTDIR); break;
8658 case RMS$_FNF: case RMS$_DNF:
8659 set_errno(ENOENT); break;
8667 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8668 if (!decc_efs_case_preserve) {
8669 buff[VMS_MAXRSS - 1] = '\0';
8670 for (p = buff; *p; p++) *p = _tolower(*p);
8673 /* we don't want to force to lowercase, just null terminate */
8674 buff[res.dsc$w_length] = '\0';
8676 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8679 /* Skip any directory component and just copy the name. */
8680 sts = vms_split_path
8695 /* Drop NULL extensions on UNIX file specification */
8696 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8697 (e_len == 1) && decc_readdir_dropdotnotype)) {
8702 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
8703 dd->entry.d_name[n_len + e_len] = '\0';
8704 dd->entry.d_namlen = strlen(dd->entry.d_name);
8706 /* Convert the filename to UNIX format if needed */
8707 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
8709 /* Translate the encoded characters. */
8710 /* Fixme: unicode handling could result in embedded 0 characters */
8711 if (strchr(dd->entry.d_name, '^') != NULL) {
8715 p = dd->entry.d_name;
8719 x = copy_expand_vms_filename_escape(q, p, &y);
8723 /* if y > 1, then this is a wide file specification */
8724 /* Wide file specifications need to be passed in Perl */
8725 /* counted strings apparently with a unicode flag */
8728 strcpy(dd->entry.d_name, new_name);
8732 dd->entry.vms_verscount = 0;
8733 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
8737 } /* end of readdir() */
8741 * Read the next entry from the directory -- thread-safe version.
8743 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
8745 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
8749 MUTEX_LOCK( (perl_mutex *) dd->mutex );
8751 entry = readdir(dd);
8753 retval = ( *result == NULL ? errno : 0 );
8755 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
8759 } /* end of readdir_r() */
8763 * Return something that can be used in a seekdir later.
8765 /*{{{ long telldir(DIR *dd)*/
8767 Perl_telldir(DIR *dd)
8774 * Return to a spot where we used to be. Brute force.
8776 /*{{{ void seekdir(DIR *dd,long count)*/
8778 Perl_seekdir(pTHX_ DIR *dd, long count)
8782 /* If we haven't done anything yet... */
8786 /* Remember some state, and clear it. */
8787 old_flags = dd->flags;
8788 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8789 _ckvmssts(lib$find_file_end(&dd->context));
8792 /* The increment is in readdir(). */
8793 for (dd->count = 0; dd->count < count; )
8796 dd->flags = old_flags;
8798 } /* end of seekdir() */
8801 /* VMS subprocess management
8803 * my_vfork() - just a vfork(), after setting a flag to record that
8804 * the current script is trying a Unix-style fork/exec.
8806 * vms_do_aexec() and vms_do_exec() are called in response to the
8807 * perl 'exec' function. If this follows a vfork call, then they
8808 * call out the regular perl routines in doio.c which do an
8809 * execvp (for those who really want to try this under VMS).
8810 * Otherwise, they do exactly what the perl docs say exec should
8811 * do - terminate the current script and invoke a new command
8812 * (See below for notes on command syntax.)
8814 * do_aspawn() and do_spawn() implement the VMS side of the perl
8815 * 'system' function.
8817 * Note on command arguments to perl 'exec' and 'system': When handled
8818 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
8819 * are concatenated to form a DCL command string. If the first arg
8820 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
8821 * the command string is handed off to DCL directly. Otherwise,
8822 * the first token of the command is taken as the filespec of an image
8823 * to run. The filespec is expanded using a default type of '.EXE' and
8824 * the process defaults for device, directory, etc., and if found, the resultant
8825 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
8826 * the command string as parameters. This is perhaps a bit complicated,
8827 * but I hope it will form a happy medium between what VMS folks expect
8828 * from lib$spawn and what Unix folks expect from exec.
8831 static int vfork_called;
8833 /*{{{int my_vfork()*/
8844 vms_execfree(struct dsc$descriptor_s *vmscmd)
8847 if (vmscmd->dsc$a_pointer) {
8848 PerlMem_free(vmscmd->dsc$a_pointer);
8850 PerlMem_free(vmscmd);
8855 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
8857 char *junk, *tmps = Nullch;
8858 register size_t cmdlen = 0;
8865 tmps = SvPV(really,rlen);
8872 for (idx++; idx <= sp; idx++) {
8874 junk = SvPVx(*idx,rlen);
8875 cmdlen += rlen ? rlen + 1 : 0;
8878 Newx(PL_Cmd, cmdlen+1, char);
8880 if (tmps && *tmps) {
8881 strcpy(PL_Cmd,tmps);
8884 else *PL_Cmd = '\0';
8885 while (++mark <= sp) {
8887 char *s = SvPVx(*mark,n_a);
8889 if (*PL_Cmd) strcat(PL_Cmd," ");
8895 } /* end of setup_argstr() */
8898 static unsigned long int
8899 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
8900 struct dsc$descriptor_s **pvmscmd)
8902 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
8903 char image_name[NAM$C_MAXRSS+1];
8904 char image_argv[NAM$C_MAXRSS+1];
8905 $DESCRIPTOR(defdsc,".EXE");
8906 $DESCRIPTOR(defdsc2,".");
8907 $DESCRIPTOR(resdsc,resspec);
8908 struct dsc$descriptor_s *vmscmd;
8909 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8910 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
8911 register char *s, *rest, *cp, *wordbreak;
8916 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8917 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
8919 /* Make a copy for modification */
8920 cmdlen = strlen(incmd);
8921 cmd = PerlMem_malloc(cmdlen+1);
8922 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
8923 strncpy(cmd, incmd, cmdlen);
8928 vmscmd->dsc$a_pointer = NULL;
8929 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
8930 vmscmd->dsc$b_class = DSC$K_CLASS_S;
8931 vmscmd->dsc$w_length = 0;
8932 if (pvmscmd) *pvmscmd = vmscmd;
8934 if (suggest_quote) *suggest_quote = 0;
8936 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
8938 return CLI$_BUFOVF; /* continuation lines currently unsupported */
8943 while (*s && isspace(*s)) s++;
8945 if (*s == '@' || *s == '$') {
8946 vmsspec[0] = *s; rest = s + 1;
8947 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
8949 else { cp = vmsspec; rest = s; }
8950 if (*rest == '.' || *rest == '/') {
8953 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
8954 rest++, cp2++) *cp2 = *rest;
8956 if (do_tovmsspec(resspec,cp,0,NULL)) {
8959 for (cp2 = vmsspec + strlen(vmsspec);
8960 *rest && cp2 - vmsspec < sizeof vmsspec;
8961 rest++, cp2++) *cp2 = *rest;
8966 /* Intuit whether verb (first word of cmd) is a DCL command:
8967 * - if first nonspace char is '@', it's a DCL indirection
8969 * - if verb contains a filespec separator, it's not a DCL command
8970 * - if it doesn't, caller tells us whether to default to a DCL
8971 * command, or to a local image unless told it's DCL (by leading '$')
8975 if (suggest_quote) *suggest_quote = 1;
8977 register char *filespec = strpbrk(s,":<[.;");
8978 rest = wordbreak = strpbrk(s," \"\t/");
8979 if (!wordbreak) wordbreak = s + strlen(s);
8980 if (*s == '$') check_img = 0;
8981 if (filespec && (filespec < wordbreak)) isdcl = 0;
8982 else isdcl = !check_img;
8987 imgdsc.dsc$a_pointer = s;
8988 imgdsc.dsc$w_length = wordbreak - s;
8989 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8991 _ckvmssts(lib$find_file_end(&cxt));
8992 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
8993 if (!(retsts & 1) && *s == '$') {
8994 _ckvmssts(lib$find_file_end(&cxt));
8995 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
8996 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
8998 _ckvmssts(lib$find_file_end(&cxt));
8999 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9003 _ckvmssts(lib$find_file_end(&cxt));
9008 while (*s && !isspace(*s)) s++;
9011 /* check that it's really not DCL with no file extension */
9012 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9014 char b[256] = {0,0,0,0};
9015 read(fileno(fp), b, 256);
9016 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9020 /* Check for script */
9022 if ((b[0] == '#') && (b[1] == '!'))
9024 #ifdef ALTERNATE_SHEBANG
9026 shebang_len = strlen(ALTERNATE_SHEBANG);
9027 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9029 perlstr = strstr("perl",b);
9030 if (perlstr == NULL)
9038 if (shebang_len > 0) {
9041 char tmpspec[NAM$C_MAXRSS + 1];
9044 /* Image is following after white space */
9045 /*--------------------------------------*/
9046 while (isprint(b[i]) && isspace(b[i]))
9050 while (isprint(b[i]) && !isspace(b[i])) {
9051 tmpspec[j++] = b[i++];
9052 if (j >= NAM$C_MAXRSS)
9057 /* There may be some default parameters to the image */
9058 /*---------------------------------------------------*/
9060 while (isprint(b[i])) {
9061 image_argv[j++] = b[i++];
9062 if (j >= NAM$C_MAXRSS)
9065 while ((j > 0) && !isprint(image_argv[j-1]))
9069 /* It will need to be converted to VMS format and validated */
9070 if (tmpspec[0] != '\0') {
9073 /* Try to find the exact program requested to be run */
9074 /*---------------------------------------------------*/
9075 iname = do_rmsexpand
9076 (tmpspec, image_name, 0, ".exe",
9077 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9078 if (iname != NULL) {
9079 if (cando_by_name_int
9080 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9081 /* MCR prefix needed */
9085 /* Try again with a null type */
9086 /*----------------------------*/
9087 iname = do_rmsexpand
9088 (tmpspec, image_name, 0, ".",
9089 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9090 if (iname != NULL) {
9091 if (cando_by_name_int
9092 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9093 /* MCR prefix needed */
9099 /* Did we find the image to run the script? */
9100 /*------------------------------------------*/
9104 /* Assume DCL or foreign command exists */
9105 /*--------------------------------------*/
9106 tchr = strrchr(tmpspec, '/');
9113 strcpy(image_name, tchr);
9121 if (check_img && isdcl) return RMS$_FNF;
9123 if (cando_by_name(S_IXUSR,0,resspec)) {
9124 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9125 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9127 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9128 if (image_name[0] != 0) {
9129 strcat(vmscmd->dsc$a_pointer, image_name);
9130 strcat(vmscmd->dsc$a_pointer, " ");
9132 } else if (image_name[0] != 0) {
9133 strcpy(vmscmd->dsc$a_pointer, image_name);
9134 strcat(vmscmd->dsc$a_pointer, " ");
9136 strcpy(vmscmd->dsc$a_pointer,"@");
9138 if (suggest_quote) *suggest_quote = 1;
9140 /* If there is an image name, use original command */
9141 if (image_name[0] == 0)
9142 strcat(vmscmd->dsc$a_pointer,resspec);
9145 while (*rest && isspace(*rest)) rest++;
9148 if (image_argv[0] != 0) {
9149 strcat(vmscmd->dsc$a_pointer,image_argv);
9150 strcat(vmscmd->dsc$a_pointer, " ");
9156 rest_len = strlen(rest);
9157 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9158 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9159 strcat(vmscmd->dsc$a_pointer,rest);
9161 retsts = CLI$_BUFOVF;
9163 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9165 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9171 /* It's either a DCL command or we couldn't find a suitable image */
9172 vmscmd->dsc$w_length = strlen(cmd);
9174 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9175 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9176 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9180 /* check if it's a symbol (for quoting purposes) */
9181 if (suggest_quote && !*suggest_quote) {
9183 char equiv[LNM$C_NAMLENGTH];
9184 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9185 eqvdsc.dsc$a_pointer = equiv;
9187 iss = lib$get_symbol(vmscmd,&eqvdsc);
9188 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9190 if (!(retsts & 1)) {
9191 /* just hand off status values likely to be due to user error */
9192 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9193 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9194 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9195 else { _ckvmssts(retsts); }
9198 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9200 } /* end of setup_cmddsc() */
9203 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9205 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9211 if (vfork_called) { /* this follows a vfork - act Unixish */
9213 if (vfork_called < 0) {
9214 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9217 else return do_aexec(really,mark,sp);
9219 /* no vfork - act VMSish */
9220 cmd = setup_argstr(aTHX_ really,mark,sp);
9221 exec_sts = vms_do_exec(cmd);
9222 Safefree(cmd); /* Clean up from setup_argstr() */
9227 } /* end of vms_do_aexec() */
9230 /* {{{bool vms_do_exec(char *cmd) */
9232 Perl_vms_do_exec(pTHX_ const char *cmd)
9234 struct dsc$descriptor_s *vmscmd;
9236 if (vfork_called) { /* this follows a vfork - act Unixish */
9238 if (vfork_called < 0) {
9239 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9242 else return do_exec(cmd);
9245 { /* no vfork - act VMSish */
9246 unsigned long int retsts;
9249 TAINT_PROPER("exec");
9250 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9251 retsts = lib$do_command(vmscmd);
9254 case RMS$_FNF: case RMS$_DNF:
9255 set_errno(ENOENT); break;
9257 set_errno(ENOTDIR); break;
9259 set_errno(ENODEV); break;
9261 set_errno(EACCES); break;
9263 set_errno(EINVAL); break;
9264 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9265 set_errno(E2BIG); break;
9266 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9267 _ckvmssts(retsts); /* fall through */
9268 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9271 set_vaxc_errno(retsts);
9272 if (ckWARN(WARN_EXEC)) {
9273 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9274 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9276 vms_execfree(vmscmd);
9281 } /* end of vms_do_exec() */
9284 unsigned long int Perl_do_spawn(pTHX_ const char *);
9286 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9288 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9290 unsigned long int sts;
9294 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9295 sts = do_spawn(cmd);
9296 /* pp_sys will clean up cmd */
9300 } /* end of do_aspawn() */
9303 /* {{{unsigned long int do_spawn(char *cmd) */
9305 Perl_do_spawn(pTHX_ const char *cmd)
9307 unsigned long int sts, substs;
9309 /* The caller of this routine expects to Safefree(PL_Cmd) */
9310 Newx(PL_Cmd,10,char);
9313 TAINT_PROPER("spawn");
9314 if (!cmd || !*cmd) {
9315 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9318 case RMS$_FNF: case RMS$_DNF:
9319 set_errno(ENOENT); break;
9321 set_errno(ENOTDIR); break;
9323 set_errno(ENODEV); break;
9325 set_errno(EACCES); break;
9327 set_errno(EINVAL); break;
9328 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9329 set_errno(E2BIG); break;
9330 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9331 _ckvmssts(sts); /* fall through */
9332 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9335 set_vaxc_errno(sts);
9336 if (ckWARN(WARN_EXEC)) {
9337 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9345 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9350 } /* end of do_spawn() */
9354 static unsigned int *sockflags, sockflagsize;
9357 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9358 * routines found in some versions of the CRTL can't deal with sockets.
9359 * We don't shim the other file open routines since a socket isn't
9360 * likely to be opened by a name.
9362 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9363 FILE *my_fdopen(int fd, const char *mode)
9365 FILE *fp = fdopen(fd, mode);
9368 unsigned int fdoff = fd / sizeof(unsigned int);
9369 Stat_t sbuf; /* native stat; we don't need flex_stat */
9370 if (!sockflagsize || fdoff > sockflagsize) {
9371 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9372 else Newx (sockflags,fdoff+2,unsigned int);
9373 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9374 sockflagsize = fdoff + 2;
9376 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9377 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9386 * Clear the corresponding bit when the (possibly) socket stream is closed.
9387 * There still a small hole: we miss an implicit close which might occur
9388 * via freopen(). >> Todo
9390 /*{{{ int my_fclose(FILE *fp)*/
9391 int my_fclose(FILE *fp) {
9393 unsigned int fd = fileno(fp);
9394 unsigned int fdoff = fd / sizeof(unsigned int);
9396 if (sockflagsize && fdoff <= sockflagsize)
9397 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9405 * A simple fwrite replacement which outputs itmsz*nitm chars without
9406 * introducing record boundaries every itmsz chars.
9407 * We are using fputs, which depends on a terminating null. We may
9408 * well be writing binary data, so we need to accommodate not only
9409 * data with nulls sprinkled in the middle but also data with no null
9412 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9414 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9416 register char *cp, *end, *cpd, *data;
9417 register unsigned int fd = fileno(dest);
9418 register unsigned int fdoff = fd / sizeof(unsigned int);
9420 int bufsize = itmsz * nitm + 1;
9422 if (fdoff < sockflagsize &&
9423 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9424 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9428 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9429 memcpy( data, src, itmsz*nitm );
9430 data[itmsz*nitm] = '\0';
9432 end = data + itmsz * nitm;
9433 retval = (int) nitm; /* on success return # items written */
9436 while (cpd <= end) {
9437 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9438 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9440 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9444 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9447 } /* end of my_fwrite() */
9450 /*{{{ int my_flush(FILE *fp)*/
9452 Perl_my_flush(pTHX_ FILE *fp)
9455 if ((res = fflush(fp)) == 0 && fp) {
9456 #ifdef VMS_DO_SOCKETS
9458 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9460 res = fsync(fileno(fp));
9463 * If the flush succeeded but set end-of-file, we need to clear
9464 * the error because our caller may check ferror(). BTW, this
9465 * probably means we just flushed an empty file.
9467 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9474 * Here are replacements for the following Unix routines in the VMS environment:
9475 * getpwuid Get information for a particular UIC or UID
9476 * getpwnam Get information for a named user
9477 * getpwent Get information for each user in the rights database
9478 * setpwent Reset search to the start of the rights database
9479 * endpwent Finish searching for users in the rights database
9481 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9482 * (defined in pwd.h), which contains the following fields:-
9484 * char *pw_name; Username (in lower case)
9485 * char *pw_passwd; Hashed password
9486 * unsigned int pw_uid; UIC
9487 * unsigned int pw_gid; UIC group number
9488 * char *pw_unixdir; Default device/directory (VMS-style)
9489 * char *pw_gecos; Owner name
9490 * char *pw_dir; Default device/directory (Unix-style)
9491 * char *pw_shell; Default CLI name (eg. DCL)
9493 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9495 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9496 * not the UIC member number (eg. what's returned by getuid()),
9497 * getpwuid() can accept either as input (if uid is specified, the caller's
9498 * UIC group is used), though it won't recognise gid=0.
9500 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9501 * information about other users in your group or in other groups, respectively.
9502 * If the required privilege is not available, then these routines fill only
9503 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9506 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9509 /* sizes of various UAF record fields */
9510 #define UAI$S_USERNAME 12
9511 #define UAI$S_IDENT 31
9512 #define UAI$S_OWNER 31
9513 #define UAI$S_DEFDEV 31
9514 #define UAI$S_DEFDIR 63
9515 #define UAI$S_DEFCLI 31
9518 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9519 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9520 (uic).uic$v_group != UIC$K_WILD_GROUP)
9522 static char __empty[]= "";
9523 static struct passwd __passwd_empty=
9524 {(char *) __empty, (char *) __empty, 0, 0,
9525 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9526 static int contxt= 0;
9527 static struct passwd __pwdcache;
9528 static char __pw_namecache[UAI$S_IDENT+1];
9531 * This routine does most of the work extracting the user information.
9533 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9536 unsigned char length;
9537 char pw_gecos[UAI$S_OWNER+1];
9539 static union uicdef uic;
9541 unsigned char length;
9542 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9545 unsigned char length;
9546 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9549 unsigned char length;
9550 char pw_shell[UAI$S_DEFCLI+1];
9552 static char pw_passwd[UAI$S_PWD+1];
9554 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9555 struct dsc$descriptor_s name_desc;
9556 unsigned long int sts;
9558 static struct itmlst_3 itmlst[]= {
9559 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9560 {sizeof(uic), UAI$_UIC, &uic, &luic},
9561 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9562 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9563 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9564 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9565 {0, 0, NULL, NULL}};
9567 name_desc.dsc$w_length= strlen(name);
9568 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9569 name_desc.dsc$b_class= DSC$K_CLASS_S;
9570 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9572 /* Note that sys$getuai returns many fields as counted strings. */
9573 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9574 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9575 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9577 else { _ckvmssts(sts); }
9578 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9580 if ((int) owner.length < lowner) lowner= (int) owner.length;
9581 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9582 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9583 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9584 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9585 owner.pw_gecos[lowner]= '\0';
9586 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9587 defcli.pw_shell[ldefcli]= '\0';
9588 if (valid_uic(uic)) {
9589 pwd->pw_uid= uic.uic$l_uic;
9590 pwd->pw_gid= uic.uic$v_group;
9593 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9594 pwd->pw_passwd= pw_passwd;
9595 pwd->pw_gecos= owner.pw_gecos;
9596 pwd->pw_dir= defdev.pw_dir;
9597 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9598 pwd->pw_shell= defcli.pw_shell;
9599 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9601 ldir= strlen(pwd->pw_unixdir) - 1;
9602 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9605 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9606 if (!decc_efs_case_preserve)
9607 __mystrtolower(pwd->pw_unixdir);
9612 * Get information for a named user.
9614 /*{{{struct passwd *getpwnam(char *name)*/
9615 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9617 struct dsc$descriptor_s name_desc;
9619 unsigned long int status, sts;
9621 __pwdcache = __passwd_empty;
9622 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9623 /* We still may be able to determine pw_uid and pw_gid */
9624 name_desc.dsc$w_length= strlen(name);
9625 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9626 name_desc.dsc$b_class= DSC$K_CLASS_S;
9627 name_desc.dsc$a_pointer= (char *) name;
9628 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9629 __pwdcache.pw_uid= uic.uic$l_uic;
9630 __pwdcache.pw_gid= uic.uic$v_group;
9633 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9634 set_vaxc_errno(sts);
9635 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9638 else { _ckvmssts(sts); }
9641 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9642 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9643 __pwdcache.pw_name= __pw_namecache;
9645 } /* end of my_getpwnam() */
9649 * Get information for a particular UIC or UID.
9650 * Called by my_getpwent with uid=-1 to list all users.
9652 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9653 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9655 const $DESCRIPTOR(name_desc,__pw_namecache);
9656 unsigned short lname;
9658 unsigned long int status;
9660 if (uid == (unsigned int) -1) {
9662 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9663 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9664 set_vaxc_errno(status);
9665 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9669 else { _ckvmssts(status); }
9670 } while (!valid_uic (uic));
9674 if (!uic.uic$v_group)
9675 uic.uic$v_group= PerlProc_getgid();
9677 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9678 else status = SS$_IVIDENT;
9679 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9680 status == RMS$_PRV) {
9681 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9684 else { _ckvmssts(status); }
9686 __pw_namecache[lname]= '\0';
9687 __mystrtolower(__pw_namecache);
9689 __pwdcache = __passwd_empty;
9690 __pwdcache.pw_name = __pw_namecache;
9692 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9693 The identifier's value is usually the UIC, but it doesn't have to be,
9694 so if we can, we let fillpasswd update this. */
9695 __pwdcache.pw_uid = uic.uic$l_uic;
9696 __pwdcache.pw_gid = uic.uic$v_group;
9698 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
9701 } /* end of my_getpwuid() */
9705 * Get information for next user.
9707 /*{{{struct passwd *my_getpwent()*/
9708 struct passwd *Perl_my_getpwent(pTHX)
9710 return (my_getpwuid((unsigned int) -1));
9715 * Finish searching rights database for users.
9717 /*{{{void my_endpwent()*/
9718 void Perl_my_endpwent(pTHX)
9721 _ckvmssts(sys$finish_rdb(&contxt));
9727 #ifdef HOMEGROWN_POSIX_SIGNALS
9728 /* Signal handling routines, pulled into the core from POSIX.xs.
9730 * We need these for threads, so they've been rolled into the core,
9731 * rather than left in POSIX.xs.
9733 * (DRS, Oct 23, 1997)
9736 /* sigset_t is atomic under VMS, so these routines are easy */
9737 /*{{{int my_sigemptyset(sigset_t *) */
9738 int my_sigemptyset(sigset_t *set) {
9739 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9745 /*{{{int my_sigfillset(sigset_t *)*/
9746 int my_sigfillset(sigset_t *set) {
9748 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9749 for (i = 0; i < NSIG; i++) *set |= (1 << i);
9755 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
9756 int my_sigaddset(sigset_t *set, int sig) {
9757 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9758 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9759 *set |= (1 << (sig - 1));
9765 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
9766 int my_sigdelset(sigset_t *set, int sig) {
9767 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9768 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9769 *set &= ~(1 << (sig - 1));
9775 /*{{{int my_sigismember(sigset_t *set, int sig)*/
9776 int my_sigismember(sigset_t *set, int sig) {
9777 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
9778 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
9779 return *set & (1 << (sig - 1));
9784 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
9785 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
9788 /* If set and oset are both null, then things are badly wrong. Bail out. */
9789 if ((oset == NULL) && (set == NULL)) {
9790 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
9794 /* If set's null, then we're just handling a fetch. */
9796 tempmask = sigblock(0);
9801 tempmask = sigsetmask(*set);
9804 tempmask = sigblock(*set);
9807 tempmask = sigblock(0);
9808 sigsetmask(*oset & ~tempmask);
9811 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
9816 /* Did they pass us an oset? If so, stick our holding mask into it */
9823 #endif /* HOMEGROWN_POSIX_SIGNALS */
9826 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
9827 * my_utime(), and flex_stat(), all of which operate on UTC unless
9828 * VMSISH_TIMES is true.
9830 /* method used to handle UTC conversions:
9831 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
9833 static int gmtime_emulation_type;
9834 /* number of secs to add to UTC POSIX-style time to get local time */
9835 static long int utc_offset_secs;
9837 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
9838 * in vmsish.h. #undef them here so we can call the CRTL routines
9847 * DEC C previous to 6.0 corrupts the behavior of the /prefix
9848 * qualifier with the extern prefix pragma. This provisional
9849 * hack circumvents this prefix pragma problem in previous
9852 #if defined(__VMS_VER) && __VMS_VER >= 70000000
9853 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
9854 # pragma __extern_prefix save
9855 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
9856 # define gmtime decc$__utctz_gmtime
9857 # define localtime decc$__utctz_localtime
9858 # define time decc$__utc_time
9859 # pragma __extern_prefix restore
9861 struct tm *gmtime(), *localtime();
9867 static time_t toutc_dst(time_t loc) {
9870 if ((rsltmp = localtime(&loc)) == NULL) return -1;
9871 loc -= utc_offset_secs;
9872 if (rsltmp->tm_isdst) loc -= 3600;
9875 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9876 ((gmtime_emulation_type || my_time(NULL)), \
9877 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
9878 ((secs) - utc_offset_secs))))
9880 static time_t toloc_dst(time_t utc) {
9883 utc += utc_offset_secs;
9884 if ((rsltmp = localtime(&utc)) == NULL) return -1;
9885 if (rsltmp->tm_isdst) utc += 3600;
9888 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
9889 ((gmtime_emulation_type || my_time(NULL)), \
9890 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
9891 ((secs) + utc_offset_secs))))
9893 #ifndef RTL_USES_UTC
9896 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
9897 DST starts on 1st sun of april at 02:00 std time
9898 ends on last sun of october at 02:00 dst time
9899 see the UCX management command reference, SET CONFIG TIMEZONE
9900 for formatting info.
9902 No, it's not as general as it should be, but then again, NOTHING
9903 will handle UK times in a sensible way.
9908 parse the DST start/end info:
9909 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
9913 tz_parse_startend(char *s, struct tm *w, int *past)
9915 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
9916 int ly, dozjd, d, m, n, hour, min, sec, j, k;
9921 if (!past) return 0;
9924 if (w->tm_year % 4 == 0) ly = 1;
9925 if (w->tm_year % 100 == 0) ly = 0;
9926 if (w->tm_year+1900 % 400 == 0) ly = 1;
9929 dozjd = isdigit(*s);
9930 if (*s == 'J' || *s == 'j' || dozjd) {
9931 if (!dozjd && !isdigit(*++s)) return 0;
9934 d = d*10 + *s++ - '0';
9936 d = d*10 + *s++ - '0';
9939 if (d == 0) return 0;
9940 if (d > 366) return 0;
9942 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
9945 } else if (*s == 'M' || *s == 'm') {
9946 if (!isdigit(*++s)) return 0;
9948 if (isdigit(*s)) m = 10*m + *s++ - '0';
9949 if (*s != '.') return 0;
9950 if (!isdigit(*++s)) return 0;
9952 if (n < 1 || n > 5) return 0;
9953 if (*s != '.') return 0;
9954 if (!isdigit(*++s)) return 0;
9956 if (d > 6) return 0;
9960 if (!isdigit(*++s)) return 0;
9962 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
9964 if (!isdigit(*++s)) return 0;
9966 if (isdigit(*s)) min = 10*min + *s++ - '0';
9968 if (!isdigit(*++s)) return 0;
9970 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
9980 if (w->tm_yday < d) goto before;
9981 if (w->tm_yday > d) goto after;
9983 if (w->tm_mon+1 < m) goto before;
9984 if (w->tm_mon+1 > m) goto after;
9986 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
9987 k = d - j; /* mday of first d */
9989 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
9990 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
9991 if (w->tm_mday < k) goto before;
9992 if (w->tm_mday > k) goto after;
9995 if (w->tm_hour < hour) goto before;
9996 if (w->tm_hour > hour) goto after;
9997 if (w->tm_min < min) goto before;
9998 if (w->tm_min > min) goto after;
9999 if (w->tm_sec < sec) goto before;
10013 /* parse the offset: (+|-)hh[:mm[:ss]] */
10016 tz_parse_offset(char *s, int *offset)
10018 int hour = 0, min = 0, sec = 0;
10021 if (!offset) return 0;
10023 if (*s == '-') {neg++; s++;}
10024 if (*s == '+') s++;
10025 if (!isdigit(*s)) return 0;
10027 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10028 if (hour > 24) return 0;
10030 if (!isdigit(*++s)) return 0;
10032 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10033 if (min > 59) return 0;
10035 if (!isdigit(*++s)) return 0;
10037 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10038 if (sec > 59) return 0;
10042 *offset = (hour*60+min)*60 + sec;
10043 if (neg) *offset = -*offset;
10048 input time is w, whatever type of time the CRTL localtime() uses.
10049 sets dst, the zone, and the gmtoff (seconds)
10051 caches the value of TZ and UCX$TZ env variables; note that
10052 my_setenv looks for these and sets a flag if they're changed
10055 We have to watch out for the "australian" case (dst starts in
10056 october, ends in april)...flagged by "reverse" and checked by
10057 scanning through the months of the previous year.
10062 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10067 char *dstzone, *tz, *s_start, *s_end;
10068 int std_off, dst_off, isdst;
10069 int y, dststart, dstend;
10070 static char envtz[1025]; /* longer than any logical, symbol, ... */
10071 static char ucxtz[1025];
10072 static char reversed = 0;
10078 reversed = -1; /* flag need to check */
10079 envtz[0] = ucxtz[0] = '\0';
10080 tz = my_getenv("TZ",0);
10081 if (tz) strcpy(envtz, tz);
10082 tz = my_getenv("UCX$TZ",0);
10083 if (tz) strcpy(ucxtz, tz);
10084 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10087 if (!*tz) tz = ucxtz;
10090 while (isalpha(*s)) s++;
10091 s = tz_parse_offset(s, &std_off);
10093 if (!*s) { /* no DST, hurray we're done! */
10099 while (isalpha(*s)) s++;
10100 s2 = tz_parse_offset(s, &dst_off);
10104 dst_off = std_off - 3600;
10107 if (!*s) { /* default dst start/end?? */
10108 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10109 s = strchr(ucxtz,',');
10111 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10113 if (*s != ',') return 0;
10116 when = _toutc(when); /* convert to utc */
10117 when = when - std_off; /* convert to pseudolocal time*/
10119 w2 = localtime(&when);
10122 s = tz_parse_startend(s_start,w2,&dststart);
10124 if (*s != ',') return 0;
10127 when = _toutc(when); /* convert to utc */
10128 when = when - dst_off; /* convert to pseudolocal time*/
10129 w2 = localtime(&when);
10130 if (w2->tm_year != y) { /* spans a year, just check one time */
10131 when += dst_off - std_off;
10132 w2 = localtime(&when);
10135 s = tz_parse_startend(s_end,w2,&dstend);
10138 if (reversed == -1) { /* need to check if start later than end */
10142 if (when < 2*365*86400) {
10143 when += 2*365*86400;
10147 w2 =localtime(&when);
10148 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10150 for (j = 0; j < 12; j++) {
10151 w2 =localtime(&when);
10152 tz_parse_startend(s_start,w2,&ds);
10153 tz_parse_startend(s_end,w2,&de);
10154 if (ds != de) break;
10158 if (de && !ds) reversed = 1;
10161 isdst = dststart && !dstend;
10162 if (reversed) isdst = dststart || !dstend;
10165 if (dst) *dst = isdst;
10166 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10167 if (isdst) tz = dstzone;
10169 while(isalpha(*tz)) *zone++ = *tz++;
10175 #endif /* !RTL_USES_UTC */
10177 /* my_time(), my_localtime(), my_gmtime()
10178 * By default traffic in UTC time values, using CRTL gmtime() or
10179 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10180 * Note: We need to use these functions even when the CRTL has working
10181 * UTC support, since they also handle C<use vmsish qw(times);>
10183 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10184 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10187 /*{{{time_t my_time(time_t *timep)*/
10188 time_t Perl_my_time(pTHX_ time_t *timep)
10193 if (gmtime_emulation_type == 0) {
10195 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10196 /* results of calls to gmtime() and localtime() */
10197 /* for same &base */
10199 gmtime_emulation_type++;
10200 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10201 char off[LNM$C_NAMLENGTH+1];;
10203 gmtime_emulation_type++;
10204 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10205 gmtime_emulation_type++;
10206 utc_offset_secs = 0;
10207 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10209 else { utc_offset_secs = atol(off); }
10211 else { /* We've got a working gmtime() */
10212 struct tm gmt, local;
10215 tm_p = localtime(&base);
10217 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10218 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10219 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10220 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10225 # ifdef VMSISH_TIME
10226 # ifdef RTL_USES_UTC
10227 if (VMSISH_TIME) when = _toloc(when);
10229 if (!VMSISH_TIME) when = _toutc(when);
10232 if (timep != NULL) *timep = when;
10235 } /* end of my_time() */
10239 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10241 Perl_my_gmtime(pTHX_ const time_t *timep)
10247 if (timep == NULL) {
10248 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10251 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10254 # ifdef VMSISH_TIME
10255 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10257 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10258 return gmtime(&when);
10260 /* CRTL localtime() wants local time as input, so does no tz correction */
10261 rsltmp = localtime(&when);
10262 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10265 } /* end of my_gmtime() */
10269 /*{{{struct tm *my_localtime(const time_t *timep)*/
10271 Perl_my_localtime(pTHX_ const time_t *timep)
10273 time_t when, whenutc;
10277 if (timep == NULL) {
10278 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10281 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10282 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10285 # ifdef RTL_USES_UTC
10286 # ifdef VMSISH_TIME
10287 if (VMSISH_TIME) when = _toutc(when);
10289 /* CRTL localtime() wants UTC as input, does tz correction itself */
10290 return localtime(&when);
10292 # else /* !RTL_USES_UTC */
10294 # ifdef VMSISH_TIME
10295 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10296 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10299 #ifndef RTL_USES_UTC
10300 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10301 when = whenutc - offset; /* pseudolocal time*/
10304 /* CRTL localtime() wants local time as input, so does no tz correction */
10305 rsltmp = localtime(&when);
10306 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10310 } /* end of my_localtime() */
10313 /* Reset definitions for later calls */
10314 #define gmtime(t) my_gmtime(t)
10315 #define localtime(t) my_localtime(t)
10316 #define time(t) my_time(t)
10319 /* my_utime - update modification/access time of a file
10321 * VMS 7.3 and later implementation
10322 * Only the UTC translation is home-grown. The rest is handled by the
10323 * CRTL utime(), which will take into account the relevant feature
10324 * logicals and ODS-5 volume characteristics for true access times.
10326 * pre VMS 7.3 implementation:
10327 * The calling sequence is identical to POSIX utime(), but under
10328 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10329 * not maintain access times. Restrictions differ from the POSIX
10330 * definition in that the time can be changed as long as the
10331 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10332 * no separate checks are made to insure that the caller is the
10333 * owner of the file or has special privs enabled.
10334 * Code here is based on Joe Meadows' FILE utility.
10338 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10339 * to VMS epoch (01-JAN-1858 00:00:00.00)
10340 * in 100 ns intervals.
10342 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10344 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10345 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10347 #if __CRTL_VER >= 70300000
10348 struct utimbuf utc_utimes, *utc_utimesp;
10350 if (utimes != NULL) {
10351 utc_utimes.actime = utimes->actime;
10352 utc_utimes.modtime = utimes->modtime;
10353 # ifdef VMSISH_TIME
10354 /* If input was local; convert to UTC for sys svc */
10356 utc_utimes.actime = _toutc(utimes->actime);
10357 utc_utimes.modtime = _toutc(utimes->modtime);
10360 utc_utimesp = &utc_utimes;
10363 utc_utimesp = NULL;
10366 return utime(file, utc_utimesp);
10368 #else /* __CRTL_VER < 70300000 */
10372 long int bintime[2], len = 2, lowbit, unixtime,
10373 secscale = 10000000; /* seconds --> 100 ns intervals */
10374 unsigned long int chan, iosb[2], retsts;
10375 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10376 struct FAB myfab = cc$rms_fab;
10377 struct NAM mynam = cc$rms_nam;
10378 #if defined (__DECC) && defined (__VAX)
10379 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10380 * at least through VMS V6.1, which causes a type-conversion warning.
10382 # pragma message save
10383 # pragma message disable cvtdiftypes
10385 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10386 struct fibdef myfib;
10387 #if defined (__DECC) && defined (__VAX)
10388 /* This should be right after the declaration of myatr, but due
10389 * to a bug in VAX DEC C, this takes effect a statement early.
10391 # pragma message restore
10393 /* cast ok for read only parameter */
10394 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10395 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10396 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10398 if (file == NULL || *file == '\0') {
10399 SETERRNO(ENOENT, LIB$_INVARG);
10403 /* Convert to VMS format ensuring that it will fit in 255 characters */
10404 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10405 SETERRNO(ENOENT, LIB$_INVARG);
10408 if (utimes != NULL) {
10409 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10410 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10411 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10412 * as input, we force the sign bit to be clear by shifting unixtime right
10413 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10415 lowbit = (utimes->modtime & 1) ? secscale : 0;
10416 unixtime = (long int) utimes->modtime;
10417 # ifdef VMSISH_TIME
10418 /* If input was UTC; convert to local for sys svc */
10419 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10421 unixtime >>= 1; secscale <<= 1;
10422 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10423 if (!(retsts & 1)) {
10424 SETERRNO(EVMSERR, retsts);
10427 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10428 if (!(retsts & 1)) {
10429 SETERRNO(EVMSERR, retsts);
10434 /* Just get the current time in VMS format directly */
10435 retsts = sys$gettim(bintime);
10436 if (!(retsts & 1)) {
10437 SETERRNO(EVMSERR, retsts);
10442 myfab.fab$l_fna = vmsspec;
10443 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10444 myfab.fab$l_nam = &mynam;
10445 mynam.nam$l_esa = esa;
10446 mynam.nam$b_ess = (unsigned char) sizeof esa;
10447 mynam.nam$l_rsa = rsa;
10448 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10449 if (decc_efs_case_preserve)
10450 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10452 /* Look for the file to be affected, letting RMS parse the file
10453 * specification for us as well. I have set errno using only
10454 * values documented in the utime() man page for VMS POSIX.
10456 retsts = sys$parse(&myfab,0,0);
10457 if (!(retsts & 1)) {
10458 set_vaxc_errno(retsts);
10459 if (retsts == RMS$_PRV) set_errno(EACCES);
10460 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10461 else set_errno(EVMSERR);
10464 retsts = sys$search(&myfab,0,0);
10465 if (!(retsts & 1)) {
10466 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10467 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10468 set_vaxc_errno(retsts);
10469 if (retsts == RMS$_PRV) set_errno(EACCES);
10470 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10471 else set_errno(EVMSERR);
10475 devdsc.dsc$w_length = mynam.nam$b_dev;
10476 /* cast ok for read only parameter */
10477 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10479 retsts = sys$assign(&devdsc,&chan,0,0);
10480 if (!(retsts & 1)) {
10481 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10482 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10483 set_vaxc_errno(retsts);
10484 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10485 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10486 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10487 else set_errno(EVMSERR);
10491 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10492 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10494 memset((void *) &myfib, 0, sizeof myfib);
10495 #if defined(__DECC) || defined(__DECCXX)
10496 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10497 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10498 /* This prevents the revision time of the file being reset to the current
10499 * time as a result of our IO$_MODIFY $QIO. */
10500 myfib.fib$l_acctl = FIB$M_NORECORD;
10502 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10503 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10504 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10506 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10507 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10508 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10509 _ckvmssts(sys$dassgn(chan));
10510 if (retsts & 1) retsts = iosb[0];
10511 if (!(retsts & 1)) {
10512 set_vaxc_errno(retsts);
10513 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10514 else set_errno(EVMSERR);
10520 #endif /* #if __CRTL_VER >= 70300000 */
10522 } /* end of my_utime() */
10526 * flex_stat, flex_lstat, flex_fstat
10527 * basic stat, but gets it right when asked to stat
10528 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10531 #ifndef _USE_STD_STAT
10532 /* encode_dev packs a VMS device name string into an integer to allow
10533 * simple comparisons. This can be used, for example, to check whether two
10534 * files are located on the same device, by comparing their encoded device
10535 * names. Even a string comparison would not do, because stat() reuses the
10536 * device name buffer for each call; so without encode_dev, it would be
10537 * necessary to save the buffer and use strcmp (this would mean a number of
10538 * changes to the standard Perl code, to say nothing of what a Perl script
10539 * would have to do.
10541 * The device lock id, if it exists, should be unique (unless perhaps compared
10542 * with lock ids transferred from other nodes). We have a lock id if the disk is
10543 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10544 * device names. Thus we use the lock id in preference, and only if that isn't
10545 * available, do we try to pack the device name into an integer (flagged by
10546 * the sign bit (LOCKID_MASK) being set).
10548 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10549 * name and its encoded form, but it seems very unlikely that we will find
10550 * two files on different disks that share the same encoded device names,
10551 * and even more remote that they will share the same file id (if the test
10552 * is to check for the same file).
10554 * A better method might be to use sys$device_scan on the first call, and to
10555 * search for the device, returning an index into the cached array.
10556 * The number returned would be more intelligible.
10557 * This is probably not worth it, and anyway would take quite a bit longer
10558 * on the first call.
10560 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10561 static mydev_t encode_dev (pTHX_ const char *dev)
10564 unsigned long int f;
10569 if (!dev || !dev[0]) return 0;
10573 struct dsc$descriptor_s dev_desc;
10574 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10576 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10577 can try that first. */
10578 dev_desc.dsc$w_length = strlen (dev);
10579 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10580 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10581 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10582 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10583 if (!$VMS_STATUS_SUCCESS(status)) {
10585 case SS$_NOSUCHDEV:
10586 SETERRNO(ENODEV, status);
10592 if (lockid) return (lockid & ~LOCKID_MASK);
10596 /* Otherwise we try to encode the device name */
10600 for (q = dev + strlen(dev); q--; q >= dev) {
10605 else if (isalpha (toupper (*q)))
10606 c= toupper (*q) - 'A' + (char)10;
10608 continue; /* Skip '$'s */
10610 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10612 enc += f * (unsigned long int) c;
10614 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10616 } /* end of encode_dev() */
10617 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10618 device_no = encode_dev(aTHX_ devname)
10620 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10621 device_no = new_dev_no
10625 is_null_device(name)
10628 if (decc_bug_devnull != 0) {
10629 if (strncmp("/dev/null", name, 9) == 0)
10632 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10633 The underscore prefix, controller letter, and unit number are
10634 independently optional; for our purposes, the colon punctuation
10635 is not. The colon can be trailed by optional directory and/or
10636 filename, but two consecutive colons indicates a nodename rather
10637 than a device. [pr] */
10638 if (*name == '_') ++name;
10639 if (tolower(*name++) != 'n') return 0;
10640 if (tolower(*name++) != 'l') return 0;
10641 if (tolower(*name) == 'a') ++name;
10642 if (*name == '0') ++name;
10643 return (*name++ == ':') && (*name != ':');
10648 Perl_cando_by_name_int
10649 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10651 static char usrname[L_cuserid];
10652 static struct dsc$descriptor_s usrdsc =
10653 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10654 char vmsname[NAM$C_MAXRSS+1];
10656 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10657 unsigned short int retlen, trnlnm_iter_count;
10658 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10659 union prvdef curprv;
10660 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10661 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10662 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10663 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10664 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10666 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10668 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10670 if (!fname || !*fname) return FALSE;
10671 /* Make sure we expand logical names, since sys$check_access doesn't */
10674 if ((opts & PERL_RMSEXPAND_M_VMS_IN) != 0) {
10675 fileified = PerlMem_malloc(VMS_MAXRSS);
10676 if (!strpbrk(fname,"/]>:")) {
10677 strcpy(fileified,fname);
10678 trnlnm_iter_count = 0;
10679 while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) {
10680 trnlnm_iter_count++;
10681 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10685 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10686 PerlMem_free(fileified);
10689 retlen = namdsc.dsc$w_length = strlen(vmsname);
10690 namdsc.dsc$a_pointer = vmsname;
10691 if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' ||
10692 vmsname[retlen-1] == ':') {
10693 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) return FALSE;
10694 namdsc.dsc$w_length = strlen(fileified);
10695 namdsc.dsc$a_pointer = fileified;
10699 retlen = namdsc.dsc$w_length = strlen(fname);
10700 namdsc.dsc$a_pointer = (char *)fname; /* cast ok */
10704 case S_IXUSR: case S_IXGRP: case S_IXOTH:
10705 access = ARM$M_EXECUTE;
10706 flags = CHP$M_READ;
10708 case S_IRUSR: case S_IRGRP: case S_IROTH:
10709 access = ARM$M_READ;
10710 flags = CHP$M_READ | CHP$M_USEREADALL;
10712 case S_IWUSR: case S_IWGRP: case S_IWOTH:
10713 access = ARM$M_WRITE;
10714 flags = CHP$M_READ | CHP$M_WRITE;
10716 case S_IDUSR: case S_IDGRP: case S_IDOTH:
10717 access = ARM$M_DELETE;
10718 flags = CHP$M_READ | CHP$M_WRITE;
10721 if (fileified != NULL)
10722 PerlMem_free(fileified);
10726 /* Before we call $check_access, create a user profile with the current
10727 * process privs since otherwise it just uses the default privs from the
10728 * UAF and might give false positives or negatives. This only works on
10729 * VMS versions v6.0 and later since that's when sys$create_user_profile
10730 * became available.
10733 /* get current process privs and username */
10734 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
10735 _ckvmssts(iosb[0]);
10737 #if defined(__VMS_VER) && __VMS_VER >= 60000000
10739 /* find out the space required for the profile */
10740 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
10741 &usrprodsc.dsc$w_length,0));
10743 /* allocate space for the profile and get it filled in */
10744 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
10745 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10746 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
10747 &usrprodsc.dsc$w_length,0));
10749 /* use the profile to check access to the file; free profile & analyze results */
10750 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc);
10751 PerlMem_free(usrprodsc.dsc$a_pointer);
10752 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
10756 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
10760 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
10761 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
10762 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
10763 set_vaxc_errno(retsts);
10764 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10765 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
10766 else set_errno(ENOENT);
10767 if (fileified != NULL)
10768 PerlMem_free(fileified);
10771 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
10772 if (fileified != NULL)
10773 PerlMem_free(fileified);
10778 if (fileified != NULL)
10779 PerlMem_free(fileified);
10780 return FALSE; /* Should never get here */
10784 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
10785 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
10786 * subset of the applicable information.
10789 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
10791 return cando_by_name_int
10792 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
10793 } /* end of cando() */
10797 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
10799 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
10801 return cando_by_name_int(bit, effective, fname, 0);
10803 } /* end of cando_by_name() */
10807 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
10809 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
10811 if (!fstat(fd,(stat_t *) statbufp)) {
10813 char *vms_filename;
10814 vms_filename = PerlMem_malloc(VMS_MAXRSS);
10815 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
10817 /* Save name for cando by name in VMS format */
10818 cptr = getname(fd, vms_filename, 1);
10820 /* This should not happen, but just in case */
10821 if (cptr == NULL) {
10822 statbufp->st_devnam[0] = 0;
10825 /* Make sure that the saved name fits in 255 characters */
10826 cptr = do_rmsexpand
10828 statbufp->st_devnam,
10831 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
10835 statbufp->st_devnam[0] = 0;
10837 PerlMem_free(vms_filename);
10839 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10841 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10843 # ifdef RTL_USES_UTC
10844 # ifdef VMSISH_TIME
10846 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10847 statbufp->st_atime = _toloc(statbufp->st_atime);
10848 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10852 # ifdef VMSISH_TIME
10853 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10857 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10858 statbufp->st_atime = _toutc(statbufp->st_atime);
10859 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10866 } /* end of flex_fstat() */
10869 #if !defined(__VAX) && __CRTL_VER >= 80200000
10877 #define lstat(_x, _y) stat(_x, _y)
10880 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
10883 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
10885 char fileified[VMS_MAXRSS];
10886 char temp_fspec[VMS_MAXRSS];
10889 int saved_errno, saved_vaxc_errno;
10891 if (!fspec) return retval;
10892 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
10893 strcpy(temp_fspec, fspec);
10895 if (decc_bug_devnull != 0) {
10896 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
10897 memset(statbufp,0,sizeof *statbufp);
10898 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
10899 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
10900 statbufp->st_uid = 0x00010001;
10901 statbufp->st_gid = 0x0001;
10902 time((time_t *)&statbufp->st_mtime);
10903 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
10908 /* Try for a directory name first. If fspec contains a filename without
10909 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
10910 * and sea:[wine.dark]water. exist, we prefer the directory here.
10911 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
10912 * not sea:[wine.dark]., if the latter exists. If the intended target is
10913 * the file with null type, specify this by calling flex_stat() with
10914 * a '.' at the end of fspec.
10916 * If we are in Posix filespec mode, accept the filename as is.
10918 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10919 if (decc_posix_compliant_pathnames == 0) {
10921 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
10922 if (lstat_flag == 0)
10923 retval = stat(fileified,(stat_t *) statbufp);
10925 retval = lstat(fileified,(stat_t *) statbufp);
10926 save_spec = fileified;
10929 if (lstat_flag == 0)
10930 retval = stat(temp_fspec,(stat_t *) statbufp);
10932 retval = lstat(temp_fspec,(stat_t *) statbufp);
10933 save_spec = temp_fspec;
10935 #if __CRTL_VER >= 80200000 && !defined(__VAX)
10937 if (lstat_flag == 0)
10938 retval = stat(temp_fspec,(stat_t *) statbufp);
10940 retval = lstat(temp_fspec,(stat_t *) statbufp);
10941 save_spec = temp_fspec;
10946 cptr = do_rmsexpand
10947 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
10949 statbufp->st_devnam[0] = 0;
10951 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
10953 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
10954 # ifdef RTL_USES_UTC
10955 # ifdef VMSISH_TIME
10957 statbufp->st_mtime = _toloc(statbufp->st_mtime);
10958 statbufp->st_atime = _toloc(statbufp->st_atime);
10959 statbufp->st_ctime = _toloc(statbufp->st_ctime);
10963 # ifdef VMSISH_TIME
10964 if (!VMSISH_TIME) { /* Return UTC instead of local time */
10968 statbufp->st_mtime = _toutc(statbufp->st_mtime);
10969 statbufp->st_atime = _toutc(statbufp->st_atime);
10970 statbufp->st_ctime = _toutc(statbufp->st_ctime);
10974 /* If we were successful, leave errno where we found it */
10975 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
10978 } /* end of flex_stat_int() */
10981 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
10983 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
10985 return flex_stat_int(fspec, statbufp, 0);
10989 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
10991 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
10993 return flex_stat_int(fspec, statbufp, 1);
10998 /*{{{char *my_getlogin()*/
10999 /* VMS cuserid == Unix getlogin, except calling sequence */
11003 static char user[L_cuserid];
11004 return cuserid(user);
11009 /* rmscopy - copy a file using VMS RMS routines
11011 * Copies contents and attributes of spec_in to spec_out, except owner
11012 * and protection information. Name and type of spec_in are used as
11013 * defaults for spec_out. The third parameter specifies whether rmscopy()
11014 * should try to propagate timestamps from the input file to the output file.
11015 * If it is less than 0, no timestamps are preserved. If it is 0, then
11016 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11017 * propagated to the output file at creation iff the output file specification
11018 * did not contain an explicit name or type, and the revision date is always
11019 * updated at the end of the copy operation. If it is greater than 0, then
11020 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11021 * other than the revision date should be propagated, and bit 1 indicates
11022 * that the revision date should be propagated.
11024 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11026 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11027 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11028 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11029 * as part of the Perl standard distribution under the terms of the
11030 * GNU General Public License or the Perl Artistic License. Copies
11031 * of each may be found in the Perl standard distribution.
11033 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11035 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11037 char *vmsin, * vmsout, *esa, *esa_out,
11039 unsigned long int i, sts, sts2;
11041 struct FAB fab_in, fab_out;
11042 struct RAB rab_in, rab_out;
11043 rms_setup_nam(nam);
11044 rms_setup_nam(nam_out);
11045 struct XABDAT xabdat;
11046 struct XABFHC xabfhc;
11047 struct XABRDT xabrdt;
11048 struct XABSUM xabsum;
11050 vmsin = PerlMem_malloc(VMS_MAXRSS);
11051 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11052 vmsout = PerlMem_malloc(VMS_MAXRSS);
11053 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11054 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11055 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11056 PerlMem_free(vmsin);
11057 PerlMem_free(vmsout);
11058 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11062 esa = PerlMem_malloc(VMS_MAXRSS);
11063 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11064 fab_in = cc$rms_fab;
11065 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11066 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11067 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11068 fab_in.fab$l_fop = FAB$M_SQO;
11069 rms_bind_fab_nam(fab_in, nam);
11070 fab_in.fab$l_xab = (void *) &xabdat;
11072 rsa = PerlMem_malloc(VMS_MAXRSS);
11073 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11074 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11075 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11076 rms_nam_esl(nam) = 0;
11077 rms_nam_rsl(nam) = 0;
11078 rms_nam_esll(nam) = 0;
11079 rms_nam_rsll(nam) = 0;
11080 #ifdef NAM$M_NO_SHORT_UPCASE
11081 if (decc_efs_case_preserve)
11082 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11085 xabdat = cc$rms_xabdat; /* To get creation date */
11086 xabdat.xab$l_nxt = (void *) &xabfhc;
11088 xabfhc = cc$rms_xabfhc; /* To get record length */
11089 xabfhc.xab$l_nxt = (void *) &xabsum;
11091 xabsum = cc$rms_xabsum; /* To get key and area information */
11093 if (!((sts = sys$open(&fab_in)) & 1)) {
11094 PerlMem_free(vmsin);
11095 PerlMem_free(vmsout);
11098 set_vaxc_errno(sts);
11100 case RMS$_FNF: case RMS$_DNF:
11101 set_errno(ENOENT); break;
11103 set_errno(ENOTDIR); break;
11105 set_errno(ENODEV); break;
11107 set_errno(EINVAL); break;
11109 set_errno(EACCES); break;
11111 set_errno(EVMSERR);
11118 fab_out.fab$w_ifi = 0;
11119 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11120 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11121 fab_out.fab$l_fop = FAB$M_SQO;
11122 rms_bind_fab_nam(fab_out, nam_out);
11123 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11124 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11125 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11126 esa_out = PerlMem_malloc(VMS_MAXRSS);
11127 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11128 rms_set_rsa(nam_out, NULL, 0);
11129 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11131 if (preserve_dates == 0) { /* Act like DCL COPY */
11132 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11133 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11134 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11135 PerlMem_free(vmsin);
11136 PerlMem_free(vmsout);
11139 PerlMem_free(esa_out);
11140 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11141 set_vaxc_errno(sts);
11144 fab_out.fab$l_xab = (void *) &xabdat;
11145 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11146 preserve_dates = 1;
11148 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11149 preserve_dates =0; /* bitmask from this point forward */
11151 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11152 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11153 PerlMem_free(vmsin);
11154 PerlMem_free(vmsout);
11157 PerlMem_free(esa_out);
11158 set_vaxc_errno(sts);
11161 set_errno(ENOENT); break;
11163 set_errno(ENOTDIR); break;
11165 set_errno(ENODEV); break;
11167 set_errno(EINVAL); break;
11169 set_errno(EACCES); break;
11171 set_errno(EVMSERR);
11175 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11176 if (preserve_dates & 2) {
11177 /* sys$close() will process xabrdt, not xabdat */
11178 xabrdt = cc$rms_xabrdt;
11180 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11182 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11183 * is unsigned long[2], while DECC & VAXC use a struct */
11184 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11186 fab_out.fab$l_xab = (void *) &xabrdt;
11189 ubf = PerlMem_malloc(32256);
11190 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11191 rab_in = cc$rms_rab;
11192 rab_in.rab$l_fab = &fab_in;
11193 rab_in.rab$l_rop = RAB$M_BIO;
11194 rab_in.rab$l_ubf = ubf;
11195 rab_in.rab$w_usz = 32256;
11196 if (!((sts = sys$connect(&rab_in)) & 1)) {
11197 sys$close(&fab_in); sys$close(&fab_out);
11198 PerlMem_free(vmsin);
11199 PerlMem_free(vmsout);
11203 PerlMem_free(esa_out);
11204 set_errno(EVMSERR); set_vaxc_errno(sts);
11208 rab_out = cc$rms_rab;
11209 rab_out.rab$l_fab = &fab_out;
11210 rab_out.rab$l_rbf = ubf;
11211 if (!((sts = sys$connect(&rab_out)) & 1)) {
11212 sys$close(&fab_in); sys$close(&fab_out);
11213 PerlMem_free(vmsin);
11214 PerlMem_free(vmsout);
11218 PerlMem_free(esa_out);
11219 set_errno(EVMSERR); set_vaxc_errno(sts);
11223 while ((sts = sys$read(&rab_in))) { /* always true */
11224 if (sts == RMS$_EOF) break;
11225 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11226 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11227 sys$close(&fab_in); sys$close(&fab_out);
11228 PerlMem_free(vmsin);
11229 PerlMem_free(vmsout);
11233 PerlMem_free(esa_out);
11234 set_errno(EVMSERR); set_vaxc_errno(sts);
11240 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11241 sys$close(&fab_in); sys$close(&fab_out);
11242 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11244 PerlMem_free(vmsin);
11245 PerlMem_free(vmsout);
11249 PerlMem_free(esa_out);
11250 set_errno(EVMSERR); set_vaxc_errno(sts);
11254 PerlMem_free(vmsin);
11255 PerlMem_free(vmsout);
11259 PerlMem_free(esa_out);
11262 } /* end of rmscopy() */
11266 /*** The following glue provides 'hooks' to make some of the routines
11267 * from this file available from Perl. These routines are sufficiently
11268 * basic, and are required sufficiently early in the build process,
11269 * that's it's nice to have them available to miniperl as well as the
11270 * full Perl, so they're set up here instead of in an extension. The
11271 * Perl code which handles importation of these names into a given
11272 * package lives in [.VMS]Filespec.pm in @INC.
11276 rmsexpand_fromperl(pTHX_ CV *cv)
11279 char *fspec, *defspec = NULL, *rslt;
11281 int fs_utf8, dfs_utf8;
11285 if (!items || items > 2)
11286 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11287 fspec = SvPV(ST(0),n_a);
11288 fs_utf8 = SvUTF8(ST(0));
11289 if (!fspec || !*fspec) XSRETURN_UNDEF;
11291 defspec = SvPV(ST(1),n_a);
11292 dfs_utf8 = SvUTF8(ST(1));
11294 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11295 ST(0) = sv_newmortal();
11296 if (rslt != NULL) {
11297 sv_usepvn(ST(0),rslt,strlen(rslt));
11306 vmsify_fromperl(pTHX_ CV *cv)
11313 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11314 utf8_fl = SvUTF8(ST(0));
11315 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11316 ST(0) = sv_newmortal();
11317 if (vmsified != NULL) {
11318 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11327 unixify_fromperl(pTHX_ CV *cv)
11334 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11335 utf8_fl = SvUTF8(ST(0));
11336 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11337 ST(0) = sv_newmortal();
11338 if (unixified != NULL) {
11339 sv_usepvn(ST(0),unixified,strlen(unixified));
11348 fileify_fromperl(pTHX_ CV *cv)
11355 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11356 utf8_fl = SvUTF8(ST(0));
11357 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11358 ST(0) = sv_newmortal();
11359 if (fileified != NULL) {
11360 sv_usepvn(ST(0),fileified,strlen(fileified));
11369 pathify_fromperl(pTHX_ CV *cv)
11376 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11377 utf8_fl = SvUTF8(ST(0));
11378 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11379 ST(0) = sv_newmortal();
11380 if (pathified != NULL) {
11381 sv_usepvn(ST(0),pathified,strlen(pathified));
11390 vmspath_fromperl(pTHX_ CV *cv)
11397 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11398 utf8_fl = SvUTF8(ST(0));
11399 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11400 ST(0) = sv_newmortal();
11401 if (vmspath != NULL) {
11402 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11411 unixpath_fromperl(pTHX_ CV *cv)
11418 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11419 utf8_fl = SvUTF8(ST(0));
11420 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11421 ST(0) = sv_newmortal();
11422 if (unixpath != NULL) {
11423 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11432 candelete_fromperl(pTHX_ CV *cv)
11440 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11442 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11443 Newx(fspec, VMS_MAXRSS, char);
11444 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11445 if (SvTYPE(mysv) == SVt_PVGV) {
11446 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11447 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11455 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11456 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11463 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11469 rmscopy_fromperl(pTHX_ CV *cv)
11472 char *inspec, *outspec, *inp, *outp;
11474 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11475 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11476 unsigned long int sts;
11481 if (items < 2 || items > 3)
11482 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11484 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11485 Newx(inspec, VMS_MAXRSS, char);
11486 if (SvTYPE(mysv) == SVt_PVGV) {
11487 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11488 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11496 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11497 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11503 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11504 Newx(outspec, VMS_MAXRSS, char);
11505 if (SvTYPE(mysv) == SVt_PVGV) {
11506 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11507 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11516 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11517 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11524 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11526 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11532 /* The mod2fname is limited to shorter filenames by design, so it should
11533 * not be modified to support longer EFS pathnames
11536 mod2fname(pTHX_ CV *cv)
11539 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11540 workbuff[NAM$C_MAXRSS*1 + 1];
11541 int total_namelen = 3, counter, num_entries;
11542 /* ODS-5 ups this, but we want to be consistent, so... */
11543 int max_name_len = 39;
11544 AV *in_array = (AV *)SvRV(ST(0));
11546 num_entries = av_len(in_array);
11548 /* All the names start with PL_. */
11549 strcpy(ultimate_name, "PL_");
11551 /* Clean up our working buffer */
11552 Zero(work_name, sizeof(work_name), char);
11554 /* Run through the entries and build up a working name */
11555 for(counter = 0; counter <= num_entries; counter++) {
11556 /* If it's not the first name then tack on a __ */
11558 strcat(work_name, "__");
11560 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11564 /* Check to see if we actually have to bother...*/
11565 if (strlen(work_name) + 3 <= max_name_len) {
11566 strcat(ultimate_name, work_name);
11568 /* It's too darned big, so we need to go strip. We use the same */
11569 /* algorithm as xsubpp does. First, strip out doubled __ */
11570 char *source, *dest, last;
11573 for (source = work_name; *source; source++) {
11574 if (last == *source && last == '_') {
11580 /* Go put it back */
11581 strcpy(work_name, workbuff);
11582 /* Is it still too big? */
11583 if (strlen(work_name) + 3 > max_name_len) {
11584 /* Strip duplicate letters */
11587 for (source = work_name; *source; source++) {
11588 if (last == toupper(*source)) {
11592 last = toupper(*source);
11594 strcpy(work_name, workbuff);
11597 /* Is it *still* too big? */
11598 if (strlen(work_name) + 3 > max_name_len) {
11599 /* Too bad, we truncate */
11600 work_name[max_name_len - 2] = 0;
11602 strcat(ultimate_name, work_name);
11605 /* Okay, return it */
11606 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11611 hushexit_fromperl(pTHX_ CV *cv)
11616 VMSISH_HUSHED = SvTRUE(ST(0));
11618 ST(0) = boolSV(VMSISH_HUSHED);
11624 Perl_vms_start_glob
11625 (pTHX_ SV *tmpglob,
11629 struct vs_str_st *rslt;
11633 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11636 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11637 struct dsc$descriptor_vs rsdsc;
11638 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11639 unsigned long hasver = 0, isunix = 0;
11640 unsigned long int lff_flags = 0;
11643 #ifdef VMS_LONGNAME_SUPPORT
11644 lff_flags = LIB$M_FIL_LONG_NAMES;
11646 /* The Newx macro will not allow me to assign a smaller array
11647 * to the rslt pointer, so we will assign it to the begin char pointer
11648 * and then copy the value into the rslt pointer.
11650 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11651 rslt = (struct vs_str_st *)begin;
11653 rstr = &rslt->str[0];
11654 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
11655 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
11656 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
11657 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
11659 Newx(vmsspec, VMS_MAXRSS, char);
11661 /* We could find out if there's an explicit dev/dir or version
11662 by peeking into lib$find_file's internal context at
11663 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
11664 but that's unsupported, so I don't want to do it now and
11665 have it bite someone in the future. */
11666 /* Fix-me: vms_split_path() is the only way to do this, the
11667 existing method will fail with many legal EFS or UNIX specifications
11670 cp = SvPV(tmpglob,i);
11673 if (cp[i] == ';') hasver = 1;
11674 if (cp[i] == '.') {
11675 if (sts) hasver = 1;
11678 if (cp[i] == '/') {
11679 hasdir = isunix = 1;
11682 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
11687 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
11690 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
11691 if (!stat_sts && S_ISDIR(st.st_mode)) {
11692 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
11693 ok = (wilddsc.dsc$a_pointer != NULL);
11696 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
11697 ok = (wilddsc.dsc$a_pointer != NULL);
11700 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
11702 /* If not extended character set, replace ? with % */
11703 /* With extended character set, ? is a wildcard single character */
11704 if (!decc_efs_case_preserve) {
11705 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
11706 if (*cp == '?') *cp = '%';
11709 while (ok && $VMS_STATUS_SUCCESS(sts)) {
11710 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
11711 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
11713 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
11714 &dfltdsc,NULL,&rms_sts,&lff_flags);
11715 if (!$VMS_STATUS_SUCCESS(sts))
11718 /* with varying string, 1st word of buffer contains result length */
11719 rstr[rslt->length] = '\0';
11721 /* Find where all the components are */
11722 v_sts = vms_split_path
11737 /* If no version on input, truncate the version on output */
11738 if (!hasver && (vs_len > 0)) {
11742 /* No version & a null extension on UNIX handling */
11743 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
11749 if (!decc_efs_case_preserve) {
11750 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
11754 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
11758 /* Start with the name */
11761 strcat(begin,"\n");
11762 ok = (PerlIO_puts(tmpfp,begin) != EOF);
11764 if (cxt) (void)lib$find_file_end(&cxt);
11765 if (ok && sts != RMS$_NMF &&
11766 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
11769 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
11771 PerlIO_close(tmpfp);
11775 PerlIO_rewind(tmpfp);
11776 IoTYPE(io) = IoTYPE_RDONLY;
11777 IoIFP(io) = fp = tmpfp;
11778 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
11788 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, const int *utf8_fl);
11791 vms_realpath_fromperl(pTHX_ CV *cv)
11794 char *fspec, *rslt_spec, *rslt;
11797 if (!items || items != 1)
11798 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
11800 fspec = SvPV(ST(0),n_a);
11801 if (!fspec || !*fspec) XSRETURN_UNDEF;
11803 Newx(rslt_spec, VMS_MAXRSS + 1, char);
11804 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
11805 ST(0) = sv_newmortal();
11807 sv_usepvn(ST(0),rslt,strlen(rslt));
11809 Safefree(rslt_spec);
11814 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11815 int do_vms_case_tolerant(void);
11818 vms_case_tolerant_fromperl(pTHX_ CV *cv)
11821 ST(0) = boolSV(do_vms_case_tolerant());
11827 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
11828 struct interp_intern *dst)
11830 memcpy(dst,src,sizeof(struct interp_intern));
11834 Perl_sys_intern_clear(pTHX)
11839 Perl_sys_intern_init(pTHX)
11841 unsigned int ix = RAND_MAX;
11846 /* fix me later to track running under GNV */
11847 /* this allows some limited testing */
11848 MY_POSIX_EXIT = decc_filename_unix_report;
11851 MY_INV_RAND_MAX = 1./x;
11855 init_os_extras(void)
11858 char* file = __FILE__;
11859 if (decc_disable_to_vms_logname_translation) {
11860 no_translate_barewords = TRUE;
11862 no_translate_barewords = FALSE;
11865 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
11866 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
11867 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
11868 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
11869 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
11870 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
11871 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
11872 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
11873 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
11874 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
11875 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
11877 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
11879 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11880 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
11883 store_pipelocs(aTHX); /* will redo any earlier attempts */
11890 #if __CRTL_VER == 80200000
11891 /* This missed getting in to the DECC SDK for 8.2 */
11892 char *realpath(const char *file_name, char * resolved_name, ...);
11895 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
11896 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
11897 * The perl fallback routine to provide realpath() is not as efficient
11901 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11903 return realpath(filespec, outbuf);
11907 /* External entry points */
11908 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11909 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
11911 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
11916 #if __CRTL_VER >= 70301000 && !defined(__VAX)
11917 /* case_tolerant */
11919 /*{{{int do_vms_case_tolerant(void)*/
11920 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
11921 * controlled by a process setting.
11923 int do_vms_case_tolerant(void)
11925 return vms_process_case_tolerant;
11928 /* External entry points */
11929 int Perl_vms_case_tolerant(void)
11930 { return do_vms_case_tolerant(); }
11932 int Perl_vms_case_tolerant(void)
11933 { return vms_process_case_tolerant; }
11937 /* Start of DECC RTL Feature handling */
11939 static int sys_trnlnm
11940 (const char * logname,
11944 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
11945 const unsigned long attr = LNM$M_CASE_BLIND;
11946 struct dsc$descriptor_s name_dsc;
11948 unsigned short result;
11949 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
11952 name_dsc.dsc$w_length = strlen(logname);
11953 name_dsc.dsc$a_pointer = (char *)logname;
11954 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11955 name_dsc.dsc$b_class = DSC$K_CLASS_S;
11957 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
11959 if ($VMS_STATUS_SUCCESS(status)) {
11961 /* Null terminate and return the string */
11962 /*--------------------------------------*/
11969 static int sys_crelnm
11970 (const char * logname,
11971 const char * value)
11974 const char * proc_table = "LNM$PROCESS_TABLE";
11975 struct dsc$descriptor_s proc_table_dsc;
11976 struct dsc$descriptor_s logname_dsc;
11977 struct itmlst_3 item_list[2];
11979 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
11980 proc_table_dsc.dsc$w_length = strlen(proc_table);
11981 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11982 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
11984 logname_dsc.dsc$a_pointer = (char *) logname;
11985 logname_dsc.dsc$w_length = strlen(logname);
11986 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
11987 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
11989 item_list[0].buflen = strlen(value);
11990 item_list[0].itmcode = LNM$_STRING;
11991 item_list[0].bufadr = (char *)value;
11992 item_list[0].retlen = NULL;
11994 item_list[1].buflen = 0;
11995 item_list[1].itmcode = 0;
11997 ret_val = sys$crelnm
11999 (const struct dsc$descriptor_s *)&proc_table_dsc,
12000 (const struct dsc$descriptor_s *)&logname_dsc,
12002 (const struct item_list_3 *) item_list);
12007 /* C RTL Feature settings */
12009 static int set_features
12010 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12011 int (* cli_routine)(void), /* Not documented */
12012 void *image_info) /* Not documented */
12019 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12020 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12021 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12022 unsigned long case_perm;
12023 unsigned long case_image;
12026 /* Allow an exception to bring Perl into the VMS debugger */
12027 vms_debug_on_exception = 0;
12028 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12029 if ($VMS_STATUS_SUCCESS(status)) {
12030 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12031 vms_debug_on_exception = 1;
12033 vms_debug_on_exception = 0;
12036 /* Create VTF-7 filenames from UNICODE instead of UTF-8 */
12037 vms_vtf7_filenames = 0;
12038 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12039 if ($VMS_STATUS_SUCCESS(status)) {
12040 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12041 vms_vtf7_filenames = 1;
12043 vms_vtf7_filenames = 0;
12046 /* Dectect running under GNV Bash or other UNIX like shell */
12047 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12048 gnv_unix_shell = 0;
12049 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12050 if ($VMS_STATUS_SUCCESS(status)) {
12051 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12052 gnv_unix_shell = 1;
12053 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12054 set_feature_default("DECC$EFS_CHARSET", 1);
12055 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12056 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12057 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12058 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12061 gnv_unix_shell = 0;
12065 /* hacks to see if known bugs are still present for testing */
12067 /* Readdir is returning filenames in VMS syntax always */
12068 decc_bug_readdir_efs1 = 1;
12069 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12070 if ($VMS_STATUS_SUCCESS(status)) {
12071 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12072 decc_bug_readdir_efs1 = 1;
12074 decc_bug_readdir_efs1 = 0;
12077 /* PCP mode requires creating /dev/null special device file */
12078 decc_bug_devnull = 0;
12079 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12080 if ($VMS_STATUS_SUCCESS(status)) {
12081 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12082 decc_bug_devnull = 1;
12084 decc_bug_devnull = 0;
12087 /* fgetname returning a VMS name in UNIX mode */
12088 decc_bug_fgetname = 1;
12089 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12090 if ($VMS_STATUS_SUCCESS(status)) {
12091 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12092 decc_bug_fgetname = 1;
12094 decc_bug_fgetname = 0;
12097 /* UNIX directory names with no paths are broken in a lot of places */
12098 decc_dir_barename = 1;
12099 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12100 if ($VMS_STATUS_SUCCESS(status)) {
12101 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12102 decc_dir_barename = 1;
12104 decc_dir_barename = 0;
12107 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12108 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12110 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12111 if (decc_disable_to_vms_logname_translation < 0)
12112 decc_disable_to_vms_logname_translation = 0;
12115 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12117 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12118 if (decc_efs_case_preserve < 0)
12119 decc_efs_case_preserve = 0;
12122 s = decc$feature_get_index("DECC$EFS_CHARSET");
12124 decc_efs_charset = decc$feature_get_value(s, 1);
12125 if (decc_efs_charset < 0)
12126 decc_efs_charset = 0;
12129 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12131 decc_filename_unix_report = decc$feature_get_value(s, 1);
12132 if (decc_filename_unix_report > 0)
12133 decc_filename_unix_report = 1;
12135 decc_filename_unix_report = 0;
12138 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12140 decc_filename_unix_only = decc$feature_get_value(s, 1);
12141 if (decc_filename_unix_only > 0) {
12142 decc_filename_unix_only = 1;
12145 decc_filename_unix_only = 0;
12149 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12151 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12152 if (decc_filename_unix_no_version < 0)
12153 decc_filename_unix_no_version = 0;
12156 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12158 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12159 if (decc_readdir_dropdotnotype < 0)
12160 decc_readdir_dropdotnotype = 0;
12163 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12164 if ($VMS_STATUS_SUCCESS(status)) {
12165 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12167 dflt = decc$feature_get_value(s, 4);
12169 decc_disable_posix_root = decc$feature_get_value(s, 1);
12170 if (decc_disable_posix_root <= 0) {
12171 decc$feature_set_value(s, 1, 1);
12172 decc_disable_posix_root = 1;
12176 /* Traditionally Perl assumes this is off */
12177 decc_disable_posix_root = 1;
12178 decc$feature_set_value(s, 1, 1);
12183 #if __CRTL_VER >= 80200000
12184 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12186 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12187 if (decc_posix_compliant_pathnames < 0)
12188 decc_posix_compliant_pathnames = 0;
12189 if (decc_posix_compliant_pathnames > 4)
12190 decc_posix_compliant_pathnames = 0;
12195 status = sys_trnlnm
12196 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12197 if ($VMS_STATUS_SUCCESS(status)) {
12198 val_str[0] = _toupper(val_str[0]);
12199 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12200 decc_disable_to_vms_logname_translation = 1;
12205 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12206 if ($VMS_STATUS_SUCCESS(status)) {
12207 val_str[0] = _toupper(val_str[0]);
12208 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12209 decc_efs_case_preserve = 1;
12214 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12215 if ($VMS_STATUS_SUCCESS(status)) {
12216 val_str[0] = _toupper(val_str[0]);
12217 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12218 decc_filename_unix_report = 1;
12221 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12222 if ($VMS_STATUS_SUCCESS(status)) {
12223 val_str[0] = _toupper(val_str[0]);
12224 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12225 decc_filename_unix_only = 1;
12226 decc_filename_unix_report = 1;
12229 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12230 if ($VMS_STATUS_SUCCESS(status)) {
12231 val_str[0] = _toupper(val_str[0]);
12232 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12233 decc_filename_unix_no_version = 1;
12236 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12237 if ($VMS_STATUS_SUCCESS(status)) {
12238 val_str[0] = _toupper(val_str[0]);
12239 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12240 decc_readdir_dropdotnotype = 1;
12245 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12247 /* Report true case tolerance */
12248 /*----------------------------*/
12249 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12250 if (!$VMS_STATUS_SUCCESS(status))
12251 case_perm = PPROP$K_CASE_BLIND;
12252 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12253 if (!$VMS_STATUS_SUCCESS(status))
12254 case_image = PPROP$K_CASE_BLIND;
12255 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12256 (case_image == PPROP$K_CASE_SENSITIVE))
12257 vms_process_case_tolerant = 0;
12262 /* CRTL can be initialized past this point, but not before. */
12263 /* DECC$CRTL_INIT(); */
12269 /* DECC dependent attributes */
12270 #if __DECC_VER < 60560002
12272 #define not_executable
12274 #define relative ,rel
12275 #define not_executable ,noexe
12278 #pragma extern_model save
12279 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12281 const __align (LONGWORD) int spare[8] = {0};
12282 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */
12285 #pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \
12286 nowrt,noshr relative not_executable
12288 const long vms_cc_features = (const long)set_features;
12291 ** Force a reference to LIB$INITIALIZE to ensure it
12292 ** exists in the image.
12294 int lib$initialize(void);
12296 #pragma extern_model strict_refdef
12298 int lib_init_ref = (int) lib$initialize;
12301 #pragma extern_model restore