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>
30 #include <libclidef.h>
32 #include <lib$routines.h>
35 #if __CRTL_VER >= 70301000 && !defined(__VAX)
45 #include <str$routines.h>
52 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
54 #define NO_EFN EFN$C_ENF
59 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
60 int decc$feature_get_index(const char *name);
61 char* decc$feature_get_name(int index);
62 int decc$feature_get_value(int index, int mode);
63 int decc$feature_set_value(int index, int mode, int value);
68 #pragma member_alignment save
69 #pragma nomember_alignment longword
74 unsigned short * retadr;
76 #pragma member_alignment restore
78 /* More specific prototype than in starlet_c.h makes programming errors
86 const struct dsc$descriptor_s * devnam,
87 const struct item_list_3 * itmlst,
89 void * (astadr)(unsigned long),
94 #ifdef lib$find_image_symbol
95 #undef lib$find_image_symbol
96 int lib$find_image_symbol
97 (const struct dsc$descriptor_s * imgname,
98 const struct dsc$descriptor_s * symname,
100 const struct dsc$descriptor_s * defspec,
105 #if __CRTL_VER >= 70300000 && !defined(__VAX)
107 static int set_feature_default(const char *name, int value)
112 index = decc$feature_get_index(name);
114 status = decc$feature_set_value(index, 1, value);
115 if (index == -1 || (status == -1)) {
119 status = decc$feature_get_value(index, 1);
120 if (status != value) {
128 /* Older versions of ssdef.h don't have these */
129 #ifndef SS$_INVFILFOROP
130 # define SS$_INVFILFOROP 3930
132 #ifndef SS$_NOSUCHOBJECT
133 # define SS$_NOSUCHOBJECT 2696
136 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
137 #define PERLIO_NOT_STDIO 0
139 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
140 * code below needs to get to the underlying CRTL routines. */
141 #define DONT_MASK_RTL_CALLS
145 /* Anticipating future expansion in lexical warnings . . . */
146 #ifndef WARN_INTERNAL
147 # define WARN_INTERNAL WARN_MISC
150 #ifdef VMS_LONGNAME_SUPPORT
151 #include <libfildef.h>
154 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
155 # define RTL_USES_UTC 1
158 /* Routine to create a decterm for use with the Perl debugger */
159 /* No headers, this information was found in the Programming Concepts Manual */
161 static int (*decw_term_port)
162 (const struct dsc$descriptor_s * display,
163 const struct dsc$descriptor_s * setup_file,
164 const struct dsc$descriptor_s * customization,
165 struct dsc$descriptor_s * result_device_name,
166 unsigned short * result_device_name_length,
169 void * char_change_buffer) = 0;
171 /* gcc's header files don't #define direct access macros
172 * corresponding to VAXC's variant structs */
174 # define uic$v_format uic$r_uic_form.uic$v_format
175 # define uic$v_group uic$r_uic_form.uic$v_group
176 # define uic$v_member uic$r_uic_form.uic$v_member
177 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
178 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
179 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
180 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
183 #if defined(NEED_AN_H_ERRNO)
188 #pragma message disable pragma
189 #pragma member_alignment save
190 #pragma nomember_alignment longword
192 #pragma message disable misalgndmem
195 unsigned short int buflen;
196 unsigned short int itmcode;
198 unsigned short int *retlen;
201 struct filescan_itmlst_2 {
202 unsigned short length;
203 unsigned short itmcode;
208 unsigned short length;
213 #pragma message restore
214 #pragma member_alignment restore
217 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
218 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
219 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
220 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
221 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
222 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
223 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
224 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
225 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
226 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
227 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
229 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
230 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
231 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
232 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
234 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
235 #define PERL_LNM_MAX_ALLOWED_INDEX 127
237 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
238 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
241 #define PERL_LNM_MAX_ITER 10
243 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
244 #if __CRTL_VER >= 70302000 && !defined(__VAX)
245 #define MAX_DCL_SYMBOL (8192)
246 #define MAX_DCL_LINE_LENGTH (4096 - 4)
248 #define MAX_DCL_SYMBOL (1024)
249 #define MAX_DCL_LINE_LENGTH (1024 - 4)
252 static char *__mystrtolower(char *str)
254 if (str) for (; *str; ++str) *str= tolower(*str);
258 static struct dsc$descriptor_s fildevdsc =
259 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
260 static struct dsc$descriptor_s crtlenvdsc =
261 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
262 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
263 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
264 static struct dsc$descriptor_s **env_tables = defenv;
265 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
267 /* True if we shouldn't treat barewords as logicals during directory */
269 static int no_translate_barewords;
272 static int tz_updated = 1;
275 /* DECC Features that may need to affect how Perl interprets
276 * displays filename information
278 static int decc_disable_to_vms_logname_translation = 1;
279 static int decc_disable_posix_root = 1;
280 int decc_efs_case_preserve = 0;
281 static int decc_efs_charset = 0;
282 static int decc_filename_unix_no_version = 0;
283 static int decc_filename_unix_only = 0;
284 int decc_filename_unix_report = 0;
285 int decc_posix_compliant_pathnames = 0;
286 int decc_readdir_dropdotnotype = 0;
287 static int vms_process_case_tolerant = 1;
288 int vms_vtf7_filenames = 0;
289 int gnv_unix_shell = 0;
290 static int vms_unlink_all_versions = 0;
292 /* bug workarounds if needed */
293 int decc_bug_readdir_efs1 = 0;
294 int decc_bug_devnull = 1;
295 int decc_bug_fgetname = 0;
296 int decc_dir_barename = 0;
298 static int vms_debug_on_exception = 0;
300 /* Is this a UNIX file specification?
301 * No longer a simple check with EFS file specs
302 * For now, not a full check, but need to
303 * handle POSIX ^UP^ specifications
304 * Fixing to handle ^/ cases would require
305 * changes to many other conversion routines.
308 static int is_unix_filespec(const char *path)
314 if (strncmp(path,"\"^UP^",5) != 0) {
315 pch1 = strchr(path, '/');
320 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
321 if (decc_filename_unix_report || decc_filename_unix_only) {
322 if (strcmp(path,".") == 0)
330 /* This routine converts a UCS-2 character to be VTF-7 encoded.
333 static void ucs2_to_vtf7
335 unsigned long ucs2_char,
338 unsigned char * ucs_ptr;
341 ucs_ptr = (unsigned char *)&ucs2_char;
345 hex = (ucs_ptr[1] >> 4) & 0xf;
347 outspec[2] = hex + '0';
349 outspec[2] = (hex - 9) + 'A';
350 hex = ucs_ptr[1] & 0xF;
352 outspec[3] = hex + '0';
354 outspec[3] = (hex - 9) + 'A';
356 hex = (ucs_ptr[0] >> 4) & 0xf;
358 outspec[4] = hex + '0';
360 outspec[4] = (hex - 9) + 'A';
361 hex = ucs_ptr[1] & 0xF;
363 outspec[5] = hex + '0';
365 outspec[5] = (hex - 9) + 'A';
371 /* This handles the conversion of a UNIX extended character set to a ^
372 * escaped VMS character.
373 * in a UNIX file specification.
375 * The output count variable contains the number of characters added
376 * to the output string.
378 * The return value is the number of characters read from the input string
380 static int copy_expand_unix_filename_escape
381 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
389 utf8_flag = *utf8_fl;
393 if (*inspec >= 0x80) {
394 if (utf8_fl && vms_vtf7_filenames) {
395 unsigned long ucs_char;
399 if ((*inspec & 0xE0) == 0xC0) {
401 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
402 if (ucs_char >= 0x80) {
403 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
406 } else if ((*inspec & 0xF0) == 0xE0) {
408 ucs_char = ((inspec[0] & 0xF) << 12) +
409 ((inspec[1] & 0x3f) << 6) +
411 if (ucs_char >= 0x800) {
412 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
416 #if 0 /* I do not see longer sequences supported by OpenVMS */
417 /* Maybe some one can fix this later */
418 } else if ((*inspec & 0xF8) == 0xF0) {
421 } else if ((*inspec & 0xFC) == 0xF8) {
424 } else if ((*inspec & 0xFE) == 0xFC) {
431 /* High bit set, but not a Unicode character! */
433 /* Non printing DECMCS or ISO Latin-1 character? */
434 if (*inspec <= 0x9F) {
438 hex = (*inspec >> 4) & 0xF;
440 outspec[1] = hex + '0';
442 outspec[1] = (hex - 9) + 'A';
446 outspec[2] = hex + '0';
448 outspec[2] = (hex - 9) + 'A';
452 } else if (*inspec == 0xA0) {
458 } else if (*inspec == 0xFF) {
470 /* Is this a macro that needs to be passed through?
471 * Macros start with $( and an alpha character, followed
472 * by a string of alpha numeric characters ending with a )
473 * If this does not match, then encode it as ODS-5.
475 if ((inspec[0] == '$') && (inspec[1] == '(')) {
478 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
480 outspec[0] = inspec[0];
481 outspec[1] = inspec[1];
482 outspec[2] = inspec[2];
484 while(isalnum(inspec[tcnt]) ||
485 (inspec[2] == '.') || (inspec[2] == '_')) {
486 outspec[tcnt] = inspec[tcnt];
489 if (inspec[tcnt] == ')') {
490 outspec[tcnt] = inspec[tcnt];
507 if (decc_efs_charset == 0)
533 /* Don't escape again if following character is
534 * already something we escape.
536 if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
542 /* But otherwise fall through and escape it. */
544 /* Assume that this is to be escaped */
546 outspec[1] = *inspec;
550 case ' ': /* space */
551 /* Assume that this is to be escaped */
566 /* This handles the expansion of a '^' prefix to the proper character
567 * in a UNIX file specification.
569 * The output count variable contains the number of characters added
570 * to the output string.
572 * The return value is the number of characters read from the input
575 static int copy_expand_vms_filename_escape
576 (char *outspec, const char *inspec, int *output_cnt)
583 if (*inspec == '^') {
586 /* Spaces and non-trailing dots should just be passed through,
587 * but eat the escape character.
594 case '_': /* space */
600 /* Hmm. Better leave the escape escaped. */
606 case 'U': /* Unicode - FIX-ME this is wrong. */
609 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
612 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
613 outspec[0] == c1 & 0xff;
614 outspec[1] == c2 & 0xff;
621 /* Error - do best we can to continue */
631 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
635 scnt = sscanf(inspec, "%2x", &c1);
636 outspec[0] = c1 & 0xff;
660 (const struct dsc$descriptor_s * srcstr,
661 struct filescan_itmlst_2 * valuelist,
662 unsigned long * fldflags,
663 struct dsc$descriptor_s *auxout,
664 unsigned short * retlen);
667 /* vms_split_path - Verify that the input file specification is a
668 * VMS format file specification, and provide pointers to the components of
669 * it. With EFS format filenames, this is virtually the only way to
670 * parse a VMS path specification into components.
672 * If the sum of the components do not add up to the length of the
673 * string, then the passed file specification is probably a UNIX style
676 static int vms_split_path
691 struct dsc$descriptor path_desc;
695 struct filescan_itmlst_2 item_list[9];
696 const int filespec = 0;
697 const int nodespec = 1;
698 const int devspec = 2;
699 const int rootspec = 3;
700 const int dirspec = 4;
701 const int namespec = 5;
702 const int typespec = 6;
703 const int verspec = 7;
705 /* Assume the worst for an easy exit */
720 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
721 path_desc.dsc$w_length = strlen(path);
722 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
723 path_desc.dsc$b_class = DSC$K_CLASS_S;
725 /* Get the total length, if it is shorter than the string passed
726 * then this was probably not a VMS formatted file specification
728 item_list[filespec].itmcode = FSCN$_FILESPEC;
729 item_list[filespec].length = 0;
730 item_list[filespec].component = NULL;
732 /* If the node is present, then it gets considered as part of the
733 * volume name to hopefully make things simple.
735 item_list[nodespec].itmcode = FSCN$_NODE;
736 item_list[nodespec].length = 0;
737 item_list[nodespec].component = NULL;
739 item_list[devspec].itmcode = FSCN$_DEVICE;
740 item_list[devspec].length = 0;
741 item_list[devspec].component = NULL;
743 /* root is a special case, adding it to either the directory or
744 * the device components will probalby complicate things for the
745 * callers of this routine, so leave it separate.
747 item_list[rootspec].itmcode = FSCN$_ROOT;
748 item_list[rootspec].length = 0;
749 item_list[rootspec].component = NULL;
751 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
752 item_list[dirspec].length = 0;
753 item_list[dirspec].component = NULL;
755 item_list[namespec].itmcode = FSCN$_NAME;
756 item_list[namespec].length = 0;
757 item_list[namespec].component = NULL;
759 item_list[typespec].itmcode = FSCN$_TYPE;
760 item_list[typespec].length = 0;
761 item_list[typespec].component = NULL;
763 item_list[verspec].itmcode = FSCN$_VERSION;
764 item_list[verspec].length = 0;
765 item_list[verspec].component = NULL;
767 item_list[8].itmcode = 0;
768 item_list[8].length = 0;
769 item_list[8].component = NULL;
771 status = sys$filescan
772 ((const struct dsc$descriptor_s *)&path_desc, item_list,
774 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
776 /* If we parsed it successfully these two lengths should be the same */
777 if (path_desc.dsc$w_length != item_list[filespec].length)
780 /* If we got here, then it is a VMS file specification */
783 /* set the volume name */
784 if (item_list[nodespec].length > 0) {
785 *volume = item_list[nodespec].component;
786 *vol_len = item_list[nodespec].length + item_list[devspec].length;
789 *volume = item_list[devspec].component;
790 *vol_len = item_list[devspec].length;
793 *root = item_list[rootspec].component;
794 *root_len = item_list[rootspec].length;
796 *dir = item_list[dirspec].component;
797 *dir_len = item_list[dirspec].length;
799 /* Now fun with versions and EFS file specifications
800 * The parser can not tell the difference when a "." is a version
801 * delimiter or a part of the file specification.
803 if ((decc_efs_charset) &&
804 (item_list[verspec].length > 0) &&
805 (item_list[verspec].component[0] == '.')) {
806 *name = item_list[namespec].component;
807 *name_len = item_list[namespec].length + item_list[typespec].length;
808 *ext = item_list[verspec].component;
809 *ext_len = item_list[verspec].length;
814 *name = item_list[namespec].component;
815 *name_len = item_list[namespec].length;
816 *ext = item_list[typespec].component;
817 *ext_len = item_list[typespec].length;
818 *version = item_list[verspec].component;
819 *ver_len = item_list[verspec].length;
826 * Routine to retrieve the maximum equivalence index for an input
827 * logical name. Some calls to this routine have no knowledge if
828 * the variable is a logical or not. So on error we return a max
831 /*{{{int my_maxidx(const char *lnm) */
833 my_maxidx(const char *lnm)
837 int attr = LNM$M_CASE_BLIND;
838 struct dsc$descriptor lnmdsc;
839 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
842 lnmdsc.dsc$w_length = strlen(lnm);
843 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
844 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
845 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
847 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
848 if ((status & 1) == 0)
855 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
857 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
858 struct dsc$descriptor_s **tabvec, unsigned long int flags)
861 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
862 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
863 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
865 unsigned char acmode;
866 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
867 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
868 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
869 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
871 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
872 #if defined(PERL_IMPLICIT_CONTEXT)
875 aTHX = PERL_GET_INTERP;
881 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
882 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
884 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
885 *cp2 = _toupper(*cp1);
886 if (cp1 - lnm > LNM$C_NAMLENGTH) {
887 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
891 lnmdsc.dsc$w_length = cp1 - lnm;
892 lnmdsc.dsc$a_pointer = uplnm;
893 uplnm[lnmdsc.dsc$w_length] = '\0';
894 secure = flags & PERL__TRNENV_SECURE;
895 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
896 if (!tabvec || !*tabvec) tabvec = env_tables;
898 for (curtab = 0; tabvec[curtab]; curtab++) {
899 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
900 if (!ivenv && !secure) {
905 Perl_warn(aTHX_ "Can't read CRTL environ\n");
908 retsts = SS$_NOLOGNAM;
909 for (i = 0; environ[i]; i++) {
910 if ((eq = strchr(environ[i],'=')) &&
911 lnmdsc.dsc$w_length == (eq - environ[i]) &&
912 !strncmp(environ[i],uplnm,eq - environ[i])) {
914 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
915 if (!eqvlen) continue;
920 if (retsts != SS$_NOLOGNAM) break;
923 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
924 !str$case_blind_compare(&tmpdsc,&clisym)) {
925 if (!ivsym && !secure) {
926 unsigned short int deflen = LNM$C_NAMLENGTH;
927 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
928 /* dynamic dsc to accomodate possible long value */
929 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
930 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
932 if (eqvlen > MAX_DCL_SYMBOL) {
933 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
934 eqvlen = MAX_DCL_SYMBOL;
935 /* Special hack--we might be called before the interpreter's */
936 /* fully initialized, in which case either thr or PL_curcop */
937 /* might be bogus. We have to check, since ckWARN needs them */
938 /* both to be valid if running threaded */
939 if (ckWARN(WARN_MISC)) {
940 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
943 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
945 _ckvmssts(lib$sfree1_dd(&eqvdsc));
946 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
947 if (retsts == LIB$_NOSUCHSYM) continue;
952 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
953 midx = my_maxidx(lnm);
954 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
955 lnmlst[1].bufadr = cp2;
957 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
958 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
959 if (retsts == SS$_NOLOGNAM) break;
960 /* PPFs have a prefix */
963 *((int *)uplnm) == *((int *)"SYS$") &&
965 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
966 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
967 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
968 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
969 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
970 memmove(eqv,eqv+4,eqvlen-4);
976 if ((retsts == SS$_IVLOGNAM) ||
977 (retsts == SS$_NOLOGNAM)) { continue; }
980 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
981 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
982 if (retsts == SS$_NOLOGNAM) continue;
985 eqvlen = strlen(eqv);
989 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
990 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
991 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
992 retsts == SS$_NOLOGNAM) {
993 set_errno(EINVAL); set_vaxc_errno(retsts);
995 else _ckvmssts(retsts);
997 } /* end of vmstrnenv */
1000 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1001 /* Define as a function so we can access statics. */
1002 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1004 return vmstrnenv(lnm,eqv,idx,fildev,
1005 #ifdef SECURE_INTERNAL_GETENV
1006 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1015 * Note: Uses Perl temp to store result so char * can be returned to
1016 * caller; this pointer will be invalidated at next Perl statement
1018 * We define this as a function rather than a macro in terms of my_getenv_len()
1019 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1022 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1024 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1027 static char *__my_getenv_eqv = NULL;
1028 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1029 unsigned long int idx = 0;
1030 int trnsuccess, success, secure, saverr, savvmserr;
1034 midx = my_maxidx(lnm) + 1;
1036 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1037 /* Set up a temporary buffer for the return value; Perl will
1038 * clean it up at the next statement transition */
1039 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1040 if (!tmpsv) return NULL;
1044 /* Assume no interpreter ==> single thread */
1045 if (__my_getenv_eqv != NULL) {
1046 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1049 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1051 eqv = __my_getenv_eqv;
1054 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1055 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1057 getcwd(eqv,LNM$C_NAMLENGTH);
1061 /* Get rid of "000000/ in rooted filespecs */
1064 zeros = strstr(eqv, "/000000/");
1065 if (zeros != NULL) {
1067 mlen = len - (zeros - eqv) - 7;
1068 memmove(zeros, &zeros[7], mlen);
1076 /* Impose security constraints only if tainting */
1078 /* Impose security constraints only if tainting */
1079 secure = PL_curinterp ? PL_tainting : will_taint;
1080 saverr = errno; savvmserr = vaxc$errno;
1087 #ifdef SECURE_INTERNAL_GETENV
1088 secure ? PERL__TRNENV_SECURE : 0
1094 /* For the getenv interface we combine all the equivalence names
1095 * of a search list logical into one value to acquire a maximum
1096 * value length of 255*128 (assuming %ENV is using logicals).
1098 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1100 /* If the name contains a semicolon-delimited index, parse it
1101 * off and make sure we only retrieve the equivalence name for
1103 if ((cp2 = strchr(lnm,';')) != NULL) {
1105 uplnm[cp2-lnm] = '\0';
1106 idx = strtoul(cp2+1,NULL,0);
1108 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1111 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1113 /* Discard NOLOGNAM on internal calls since we're often looking
1114 * for an optional name, and this "error" often shows up as the
1115 * (bogus) exit status for a die() call later on. */
1116 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1117 return success ? eqv : Nullch;
1120 } /* end of my_getenv() */
1124 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1126 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1130 unsigned long idx = 0;
1132 static char *__my_getenv_len_eqv = NULL;
1133 int secure, saverr, savvmserr;
1136 midx = my_maxidx(lnm) + 1;
1138 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1139 /* Set up a temporary buffer for the return value; Perl will
1140 * clean it up at the next statement transition */
1141 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1142 if (!tmpsv) return NULL;
1146 /* Assume no interpreter ==> single thread */
1147 if (__my_getenv_len_eqv != NULL) {
1148 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1151 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1153 buf = __my_getenv_len_eqv;
1156 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1157 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1160 getcwd(buf,LNM$C_NAMLENGTH);
1163 /* Get rid of "000000/ in rooted filespecs */
1165 zeros = strstr(buf, "/000000/");
1166 if (zeros != NULL) {
1168 mlen = *len - (zeros - buf) - 7;
1169 memmove(zeros, &zeros[7], mlen);
1178 /* Impose security constraints only if tainting */
1179 secure = PL_curinterp ? PL_tainting : will_taint;
1180 saverr = errno; savvmserr = vaxc$errno;
1187 #ifdef SECURE_INTERNAL_GETENV
1188 secure ? PERL__TRNENV_SECURE : 0
1194 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1196 if ((cp2 = strchr(lnm,';')) != NULL) {
1198 buf[cp2-lnm] = '\0';
1199 idx = strtoul(cp2+1,NULL,0);
1201 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1204 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1206 /* Get rid of "000000/ in rooted filespecs */
1209 zeros = strstr(buf, "/000000/");
1210 if (zeros != NULL) {
1212 mlen = *len - (zeros - buf) - 7;
1213 memmove(zeros, &zeros[7], mlen);
1219 /* Discard NOLOGNAM on internal calls since we're often looking
1220 * for an optional name, and this "error" often shows up as the
1221 * (bogus) exit status for a die() call later on. */
1222 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1223 return *len ? buf : Nullch;
1226 } /* end of my_getenv_len() */
1229 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1231 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1233 /*{{{ void prime_env_iter() */
1235 prime_env_iter(void)
1236 /* Fill the %ENV associative array with all logical names we can
1237 * find, in preparation for iterating over it.
1240 static int primed = 0;
1241 HV *seenhv = NULL, *envhv;
1243 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1244 unsigned short int chan;
1245 #ifndef CLI$M_TRUSTED
1246 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1248 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1249 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1251 bool have_sym = FALSE, have_lnm = FALSE;
1252 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1253 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1254 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1255 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1256 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1257 #if defined(PERL_IMPLICIT_CONTEXT)
1260 #if defined(USE_ITHREADS)
1261 static perl_mutex primenv_mutex;
1262 MUTEX_INIT(&primenv_mutex);
1265 #if defined(PERL_IMPLICIT_CONTEXT)
1266 /* We jump through these hoops because we can be called at */
1267 /* platform-specific initialization time, which is before anything is */
1268 /* set up--we can't even do a plain dTHX since that relies on the */
1269 /* interpreter structure to be initialized */
1271 aTHX = PERL_GET_INTERP;
1277 if (primed || !PL_envgv) return;
1278 MUTEX_LOCK(&primenv_mutex);
1279 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1280 envhv = GvHVn(PL_envgv);
1281 /* Perform a dummy fetch as an lval to insure that the hash table is
1282 * set up. Otherwise, the hv_store() will turn into a nullop. */
1283 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1285 for (i = 0; env_tables[i]; i++) {
1286 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1287 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1288 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1290 if (have_sym || have_lnm) {
1291 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1292 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1293 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1294 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1297 for (i--; i >= 0; i--) {
1298 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1301 for (j = 0; environ[j]; j++) {
1302 if (!(start = strchr(environ[j],'='))) {
1303 if (ckWARN(WARN_INTERNAL))
1304 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1308 sv = newSVpv(start,0);
1310 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1315 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1316 !str$case_blind_compare(&tmpdsc,&clisym)) {
1317 strcpy(cmd,"Show Symbol/Global *");
1318 cmddsc.dsc$w_length = 20;
1319 if (env_tables[i]->dsc$w_length == 12 &&
1320 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1321 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1322 flags = defflags | CLI$M_NOLOGNAM;
1325 strcpy(cmd,"Show Logical *");
1326 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1327 strcat(cmd," /Table=");
1328 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1329 cmddsc.dsc$w_length = strlen(cmd);
1331 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1332 flags = defflags | CLI$M_NOCLISYM;
1335 /* Create a new subprocess to execute each command, to exclude the
1336 * remote possibility that someone could subvert a mbx or file used
1337 * to write multiple commands to a single subprocess.
1340 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1341 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1342 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1343 defflags &= ~CLI$M_TRUSTED;
1344 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1346 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1347 if (seenhv) SvREFCNT_dec(seenhv);
1350 char *cp1, *cp2, *key;
1351 unsigned long int sts, iosb[2], retlen, keylen;
1354 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1355 if (sts & 1) sts = iosb[0] & 0xffff;
1356 if (sts == SS$_ENDOFFILE) {
1358 while (substs == 0) { sys$hiber(); wakect++;}
1359 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1364 retlen = iosb[0] >> 16;
1365 if (!retlen) continue; /* blank line */
1367 if (iosb[1] != subpid) {
1369 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1373 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1374 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1376 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1377 if (*cp1 == '(' || /* Logical name table name */
1378 *cp1 == '=' /* Next eqv of searchlist */) continue;
1379 if (*cp1 == '"') cp1++;
1380 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1381 key = cp1; keylen = cp2 - cp1;
1382 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1383 while (*cp2 && *cp2 != '=') cp2++;
1384 while (*cp2 && *cp2 == '=') cp2++;
1385 while (*cp2 && *cp2 == ' ') cp2++;
1386 if (*cp2 == '"') { /* String translation; may embed "" */
1387 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1388 cp2++; cp1--; /* Skip "" surrounding translation */
1390 else { /* Numeric translation */
1391 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1392 cp1--; /* stop on last non-space char */
1394 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1395 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1398 PERL_HASH(hash,key,keylen);
1400 if (cp1 == cp2 && *cp2 == '.') {
1401 /* A single dot usually means an unprintable character, such as a null
1402 * to indicate a zero-length value. Get the actual value to make sure.
1404 char lnm[LNM$C_NAMLENGTH+1];
1405 char eqv[MAX_DCL_SYMBOL+1];
1407 strncpy(lnm, key, keylen);
1408 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1409 sv = newSVpvn(eqv, strlen(eqv));
1412 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1416 hv_store(envhv,key,keylen,sv,hash);
1417 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1419 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1420 /* get the PPFs for this process, not the subprocess */
1421 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1422 char eqv[LNM$C_NAMLENGTH+1];
1424 for (i = 0; ppfs[i]; i++) {
1425 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1426 sv = newSVpv(eqv,trnlen);
1428 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1433 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1434 if (buf) Safefree(buf);
1435 if (seenhv) SvREFCNT_dec(seenhv);
1436 MUTEX_UNLOCK(&primenv_mutex);
1439 } /* end of prime_env_iter */
1443 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1444 /* Define or delete an element in the same "environment" as
1445 * vmstrnenv(). If an element is to be deleted, it's removed from
1446 * the first place it's found. If it's to be set, it's set in the
1447 * place designated by the first element of the table vector.
1448 * Like setenv() returns 0 for success, non-zero on error.
1451 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1454 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1455 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1457 unsigned long int retsts, usermode = PSL$C_USER;
1458 struct itmlst_3 *ile, *ilist;
1459 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1460 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1461 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1462 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1463 $DESCRIPTOR(local,"_LOCAL");
1466 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1467 return SS$_IVLOGNAM;
1470 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1471 *cp2 = _toupper(*cp1);
1472 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1473 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1474 return SS$_IVLOGNAM;
1477 lnmdsc.dsc$w_length = cp1 - lnm;
1478 if (!tabvec || !*tabvec) tabvec = env_tables;
1480 if (!eqv) { /* we're deleting n element */
1481 for (curtab = 0; tabvec[curtab]; curtab++) {
1482 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1484 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1485 if ((cp1 = strchr(environ[i],'=')) &&
1486 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1487 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1489 return setenv(lnm,"",1) ? vaxc$errno : 0;
1492 ivenv = 1; retsts = SS$_NOLOGNAM;
1494 if (ckWARN(WARN_INTERNAL))
1495 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1496 ivenv = 1; retsts = SS$_NOSUCHPGM;
1502 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1503 !str$case_blind_compare(&tmpdsc,&clisym)) {
1504 unsigned int symtype;
1505 if (tabvec[curtab]->dsc$w_length == 12 &&
1506 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1507 !str$case_blind_compare(&tmpdsc,&local))
1508 symtype = LIB$K_CLI_LOCAL_SYM;
1509 else symtype = LIB$K_CLI_GLOBAL_SYM;
1510 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1511 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1512 if (retsts == LIB$_NOSUCHSYM) continue;
1516 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1517 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1518 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1519 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1520 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1524 else { /* we're defining a value */
1525 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1527 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1529 if (ckWARN(WARN_INTERNAL))
1530 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1531 retsts = SS$_NOSUCHPGM;
1535 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1536 eqvdsc.dsc$w_length = strlen(eqv);
1537 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1538 !str$case_blind_compare(&tmpdsc,&clisym)) {
1539 unsigned int symtype;
1540 if (tabvec[0]->dsc$w_length == 12 &&
1541 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1542 !str$case_blind_compare(&tmpdsc,&local))
1543 symtype = LIB$K_CLI_LOCAL_SYM;
1544 else symtype = LIB$K_CLI_GLOBAL_SYM;
1545 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1548 if (!*eqv) eqvdsc.dsc$w_length = 1;
1549 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1551 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1552 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1553 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1554 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1555 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1556 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1559 Newx(ilist,nseg+1,struct itmlst_3);
1562 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1565 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1567 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1568 ile->itmcode = LNM$_STRING;
1570 if ((j+1) == nseg) {
1571 ile->buflen = strlen(c);
1572 /* in case we are truncating one that's too long */
1573 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1576 ile->buflen = LNM$C_NAMLENGTH;
1580 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1584 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1589 if (!(retsts & 1)) {
1591 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1592 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1593 set_errno(EVMSERR); break;
1594 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1595 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1596 set_errno(EINVAL); break;
1598 set_errno(EACCES); break;
1603 set_vaxc_errno(retsts);
1604 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1607 /* We reset error values on success because Perl does an hv_fetch()
1608 * before each hv_store(), and if the thing we're setting didn't
1609 * previously exist, we've got a leftover error message. (Of course,
1610 * this fails in the face of
1611 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1612 * in that the error reported in $! isn't spurious,
1613 * but it's right more often than not.)
1615 set_errno(0); set_vaxc_errno(retsts);
1619 } /* end of vmssetenv() */
1622 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1623 /* This has to be a function since there's a prototype for it in proto.h */
1625 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1628 int len = strlen(lnm);
1632 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1633 if (!strcmp(uplnm,"DEFAULT")) {
1634 if (eqv && *eqv) my_chdir(eqv);
1638 #ifndef RTL_USES_UTC
1639 if (len == 6 || len == 2) {
1642 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1644 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1645 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1649 (void) vmssetenv(lnm,eqv,NULL);
1653 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1655 * sets a user-mode logical in the process logical name table
1656 * used for redirection of sys$error
1659 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1661 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1662 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1663 unsigned long int iss, attr = LNM$M_CONFINE;
1664 unsigned char acmode = PSL$C_USER;
1665 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1667 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1668 d_name.dsc$w_length = strlen(name);
1670 lnmlst[0].buflen = strlen(eqv);
1671 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1673 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1674 if (!(iss&1)) lib$signal(iss);
1679 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1680 /* my_crypt - VMS password hashing
1681 * my_crypt() provides an interface compatible with the Unix crypt()
1682 * C library function, and uses sys$hash_password() to perform VMS
1683 * password hashing. The quadword hashed password value is returned
1684 * as a NUL-terminated 8 character string. my_crypt() does not change
1685 * the case of its string arguments; in order to match the behavior
1686 * of LOGINOUT et al., alphabetic characters in both arguments must
1687 * be upcased by the caller.
1689 * - fix me to call ACM services when available
1692 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1694 # ifndef UAI$C_PREFERRED_ALGORITHM
1695 # define UAI$C_PREFERRED_ALGORITHM 127
1697 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1698 unsigned short int salt = 0;
1699 unsigned long int sts;
1701 unsigned short int dsc$w_length;
1702 unsigned char dsc$b_type;
1703 unsigned char dsc$b_class;
1704 const char * dsc$a_pointer;
1705 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1706 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1707 struct itmlst_3 uailst[3] = {
1708 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1709 { sizeof salt, UAI$_SALT, &salt, 0},
1710 { 0, 0, NULL, NULL}};
1711 static char hash[9];
1713 usrdsc.dsc$w_length = strlen(usrname);
1714 usrdsc.dsc$a_pointer = usrname;
1715 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1717 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1721 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1726 set_vaxc_errno(sts);
1727 if (sts != RMS$_RNF) return NULL;
1730 txtdsc.dsc$w_length = strlen(textpasswd);
1731 txtdsc.dsc$a_pointer = textpasswd;
1732 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1733 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1736 return (char *) hash;
1738 } /* end of my_crypt() */
1742 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1743 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1744 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1746 /* fixup barenames that are directories for internal use.
1747 * There have been problems with the consistent handling of UNIX
1748 * style directory names when routines are presented with a name that
1749 * has no directory delimitors at all. So this routine will eventually
1752 static char * fixup_bare_dirnames(const char * name)
1754 if (decc_disable_to_vms_logname_translation) {
1760 /* 8.3, remove() is now broken on symbolic links */
1761 static int rms_erase(const char * vmsname);
1765 * A little hack to get around a bug in some implemenation of remove()
1766 * that do not know how to delete a directory
1768 * Delete any file to which user has control access, regardless of whether
1769 * delete access is explicitly allowed.
1770 * Limitations: User must have write access to parent directory.
1771 * Does not block signals or ASTs; if interrupted in midstream
1772 * may leave file with an altered ACL.
1775 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1777 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1781 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1782 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1783 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1785 unsigned char myace$b_length;
1786 unsigned char myace$b_type;
1787 unsigned short int myace$w_flags;
1788 unsigned long int myace$l_access;
1789 unsigned long int myace$l_ident;
1790 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1791 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1792 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1794 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1795 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1796 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1797 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1798 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1799 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1801 /* Expand the input spec using RMS, since the CRTL remove() and
1802 * system services won't do this by themselves, so we may miss
1803 * a file "hiding" behind a logical name or search list. */
1804 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1805 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1807 rslt = do_rmsexpand(name,
1811 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1815 PerlMem_free(vmsname);
1819 /* Erase the file */
1820 rmsts = rms_erase(vmsname);
1822 /* Did it succeed */
1823 if ($VMS_STATUS_SUCCESS(rmsts)) {
1824 PerlMem_free(vmsname);
1828 /* If not, can changing protections help? */
1829 if (rmsts != RMS$_PRV) {
1830 set_vaxc_errno(rmsts);
1831 PerlMem_free(vmsname);
1835 /* No, so we get our own UIC to use as a rights identifier,
1836 * and the insert an ACE at the head of the ACL which allows us
1837 * to delete the file.
1839 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1840 fildsc.dsc$w_length = strlen(vmsname);
1841 fildsc.dsc$a_pointer = vmsname;
1843 newace.myace$l_ident = oldace.myace$l_ident;
1845 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1847 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1848 set_errno(ENOENT); break;
1850 set_errno(ENOTDIR); break;
1852 set_errno(ENODEV); break;
1853 case RMS$_SYN: case SS$_INVFILFOROP:
1854 set_errno(EINVAL); break;
1856 set_errno(EACCES); break;
1860 set_vaxc_errno(aclsts);
1861 PerlMem_free(vmsname);
1864 /* Grab any existing ACEs with this identifier in case we fail */
1865 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1866 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1867 || fndsts == SS$_NOMOREACE ) {
1868 /* Add the new ACE . . . */
1869 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1872 rmsts = rms_erase(vmsname);
1873 if ($VMS_STATUS_SUCCESS(rmsts)) {
1878 /* We blew it - dir with files in it, no write priv for
1879 * parent directory, etc. Put things back the way they were. */
1880 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1883 addlst[0].bufadr = &oldace;
1884 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1891 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1892 /* We just deleted it, so of course it's not there. Some versions of
1893 * VMS seem to return success on the unlock operation anyhow (after all
1894 * the unlock is successful), but others don't.
1896 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1897 if (aclsts & 1) aclsts = fndsts;
1898 if (!(aclsts & 1)) {
1900 set_vaxc_errno(aclsts);
1903 PerlMem_free(vmsname);
1906 } /* end of kill_file() */
1910 /*{{{int do_rmdir(char *name)*/
1912 Perl_do_rmdir(pTHX_ const char *name)
1918 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1919 if (dirfile == NULL)
1920 _ckvmssts(SS$_INSFMEM);
1922 /* Force to a directory specification */
1923 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1924 PerlMem_free(dirfile);
1927 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1932 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1934 PerlMem_free(dirfile);
1937 } /* end of do_rmdir */
1941 * Delete any file to which user has control access, regardless of whether
1942 * delete access is explicitly allowed.
1943 * Limitations: User must have write access to parent directory.
1944 * Does not block signals or ASTs; if interrupted in midstream
1945 * may leave file with an altered ACL.
1948 /*{{{int kill_file(char *name)*/
1950 Perl_kill_file(pTHX_ const char *name)
1952 char rspec[NAM$C_MAXRSS+1];
1957 /* Remove() is allowed to delete directories, according to the X/Open
1959 * This needs special handling to work with the ACL hacks.
1961 if (flex_stat(name, &st) && S_ISDIR(st.st_mode)) {
1962 rmsts = Perl_do_rmdir(aTHX_ name);
1966 rmsts = mp_do_kill_file(aTHX_ name, 0);
1970 } /* end of kill_file() */
1974 /*{{{int my_mkdir(char *,Mode_t)*/
1976 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
1978 STRLEN dirlen = strlen(dir);
1980 /* zero length string sometimes gives ACCVIO */
1981 if (dirlen == 0) return -1;
1983 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
1984 * null file name/type. However, it's commonplace under Unix,
1985 * so we'll allow it for a gain in portability.
1987 if (dir[dirlen-1] == '/') {
1988 char *newdir = savepvn(dir,dirlen-1);
1989 int ret = mkdir(newdir,mode);
1993 else return mkdir(dir,mode);
1994 } /* end of my_mkdir */
1997 /*{{{int my_chdir(char *)*/
1999 Perl_my_chdir(pTHX_ const char *dir)
2001 STRLEN dirlen = strlen(dir);
2003 /* zero length string sometimes gives ACCVIO */
2004 if (dirlen == 0) return -1;
2007 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2008 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2009 * so that existing scripts do not need to be changed.
2012 while ((dirlen > 0) && (*dir1 == ' ')) {
2017 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2019 * null file name/type. However, it's commonplace under Unix,
2020 * so we'll allow it for a gain in portability.
2022 * - Preview- '/' will be valid soon on VMS
2024 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2025 char *newdir = savepvn(dir1,dirlen-1);
2026 int ret = chdir(newdir);
2030 else return chdir(dir1);
2031 } /* end of my_chdir */
2035 /*{{{FILE *my_tmpfile()*/
2042 if ((fp = tmpfile())) return fp;
2044 cp = PerlMem_malloc(L_tmpnam+24);
2045 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2047 if (decc_filename_unix_only == 0)
2048 strcpy(cp,"Sys$Scratch:");
2051 tmpnam(cp+strlen(cp));
2052 strcat(cp,".Perltmp");
2053 fp = fopen(cp,"w+","fop=dlt");
2060 #ifndef HOMEGROWN_POSIX_SIGNALS
2062 * The C RTL's sigaction fails to check for invalid signal numbers so we
2063 * help it out a bit. The docs are correct, but the actual routine doesn't
2064 * do what the docs say it will.
2066 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2068 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2069 struct sigaction* oact)
2071 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2072 SETERRNO(EINVAL, SS$_INVARG);
2075 return sigaction(sig, act, oact);
2080 #ifdef KILL_BY_SIGPRC
2081 #include <errnodef.h>
2083 /* We implement our own kill() using the undocumented system service
2084 sys$sigprc for one of two reasons:
2086 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2087 target process to do a sys$exit, which usually can't be handled
2088 gracefully...certainly not by Perl and the %SIG{} mechanism.
2090 2.) If the kill() in the CRTL can't be called from a signal
2091 handler without disappearing into the ether, i.e., the signal
2092 it purportedly sends is never trapped. Still true as of VMS 7.3.
2094 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2095 in the target process rather than calling sys$exit.
2097 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2098 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2099 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2100 with condition codes C$_SIG0+nsig*8, catching the exception on the
2101 target process and resignaling with appropriate arguments.
2103 But we don't have that VMS 7.0+ exception handler, so if you
2104 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2106 Also note that SIGTERM is listed in the docs as being "unimplemented",
2107 yet always seems to be signaled with a VMS condition code of 4 (and
2108 correctly handled for that code). So we hardwire it in.
2110 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2111 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2112 than signalling with an unrecognized (and unhandled by CRTL) code.
2115 #define _MY_SIG_MAX 28
2118 Perl_sig_to_vmscondition_int(int sig)
2120 static unsigned int sig_code[_MY_SIG_MAX+1] =
2123 SS$_HANGUP, /* 1 SIGHUP */
2124 SS$_CONTROLC, /* 2 SIGINT */
2125 SS$_CONTROLY, /* 3 SIGQUIT */
2126 SS$_RADRMOD, /* 4 SIGILL */
2127 SS$_BREAK, /* 5 SIGTRAP */
2128 SS$_OPCCUS, /* 6 SIGABRT */
2129 SS$_COMPAT, /* 7 SIGEMT */
2131 SS$_FLTOVF, /* 8 SIGFPE VAX */
2133 SS$_HPARITH, /* 8 SIGFPE AXP */
2135 SS$_ABORT, /* 9 SIGKILL */
2136 SS$_ACCVIO, /* 10 SIGBUS */
2137 SS$_ACCVIO, /* 11 SIGSEGV */
2138 SS$_BADPARAM, /* 12 SIGSYS */
2139 SS$_NOMBX, /* 13 SIGPIPE */
2140 SS$_ASTFLT, /* 14 SIGALRM */
2157 #if __VMS_VER >= 60200000
2158 static int initted = 0;
2161 sig_code[16] = C$_SIGUSR1;
2162 sig_code[17] = C$_SIGUSR2;
2163 #if __CRTL_VER >= 70000000
2164 sig_code[20] = C$_SIGCHLD;
2166 #if __CRTL_VER >= 70300000
2167 sig_code[28] = C$_SIGWINCH;
2172 if (sig < _SIG_MIN) return 0;
2173 if (sig > _MY_SIG_MAX) return 0;
2174 return sig_code[sig];
2178 Perl_sig_to_vmscondition(int sig)
2181 if (vms_debug_on_exception != 0)
2182 lib$signal(SS$_DEBUG);
2184 return Perl_sig_to_vmscondition_int(sig);
2189 Perl_my_kill(int pid, int sig)
2194 int sys$sigprc(unsigned int *pidadr,
2195 struct dsc$descriptor_s *prcname,
2198 /* sig 0 means validate the PID */
2199 /*------------------------------*/
2201 const unsigned long int jpicode = JPI$_PID;
2204 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2205 if ($VMS_STATUS_SUCCESS(status))
2208 case SS$_NOSUCHNODE:
2209 case SS$_UNREACHABLE:
2223 code = Perl_sig_to_vmscondition_int(sig);
2226 SETERRNO(EINVAL, SS$_BADPARAM);
2230 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2231 * signals are to be sent to multiple processes.
2232 * pid = 0 - all processes in group except ones that the system exempts
2233 * pid = -1 - all processes except ones that the system exempts
2234 * pid = -n - all processes in group (abs(n)) except ...
2235 * For now, just report as not supported.
2239 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2243 iss = sys$sigprc((unsigned int *)&pid,0,code);
2244 if (iss&1) return 0;
2248 set_errno(EPERM); break;
2250 case SS$_NOSUCHNODE:
2251 case SS$_UNREACHABLE:
2252 set_errno(ESRCH); break;
2254 set_errno(ENOMEM); break;
2259 set_vaxc_errno(iss);
2265 /* Routine to convert a VMS status code to a UNIX status code.
2266 ** More tricky than it appears because of conflicting conventions with
2269 ** VMS status codes are a bit mask, with the least significant bit set for
2272 ** Special UNIX status of EVMSERR indicates that no translation is currently
2273 ** available, and programs should check the VMS status code.
2275 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2279 #ifndef C_FACILITY_NO
2280 #define C_FACILITY_NO 0x350000
2283 #define DCL_IVVERB 0x38090
2286 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2294 /* Assume the best or the worst */
2295 if (vms_status & STS$M_SUCCESS)
2298 unix_status = EVMSERR;
2300 msg_status = vms_status & ~STS$M_CONTROL;
2302 facility = vms_status & STS$M_FAC_NO;
2303 fac_sp = vms_status & STS$M_FAC_SP;
2304 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2306 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2312 unix_status = EFAULT;
2314 case SS$_DEVOFFLINE:
2315 unix_status = EBUSY;
2318 unix_status = ENOTCONN;
2326 case SS$_INVFILFOROP:
2330 unix_status = EINVAL;
2332 case SS$_UNSUPPORTED:
2333 unix_status = ENOTSUP;
2338 unix_status = EACCES;
2340 case SS$_DEVICEFULL:
2341 unix_status = ENOSPC;
2344 unix_status = ENODEV;
2346 case SS$_NOSUCHFILE:
2347 case SS$_NOSUCHOBJECT:
2348 unix_status = ENOENT;
2350 case SS$_ABORT: /* Fatal case */
2351 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2352 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2353 unix_status = EINTR;
2356 unix_status = E2BIG;
2359 unix_status = ENOMEM;
2362 unix_status = EPERM;
2364 case SS$_NOSUCHNODE:
2365 case SS$_UNREACHABLE:
2366 unix_status = ESRCH;
2369 unix_status = ECHILD;
2372 if ((facility == 0) && (msg_no < 8)) {
2373 /* These are not real VMS status codes so assume that they are
2374 ** already UNIX status codes
2376 unix_status = msg_no;
2382 /* Translate a POSIX exit code to a UNIX exit code */
2383 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2384 unix_status = (msg_no & 0x07F8) >> 3;
2388 /* Documented traditional behavior for handling VMS child exits */
2389 /*--------------------------------------------------------------*/
2390 if (child_flag != 0) {
2392 /* Success / Informational return 0 */
2393 /*----------------------------------*/
2394 if (msg_no & STS$K_SUCCESS)
2397 /* Warning returns 1 */
2398 /*-------------------*/
2399 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2402 /* Everything else pass through the severity bits */
2403 /*------------------------------------------------*/
2404 return (msg_no & STS$M_SEVERITY);
2407 /* Normal VMS status to ERRNO mapping attempt */
2408 /*--------------------------------------------*/
2409 switch(msg_status) {
2410 /* case RMS$_EOF: */ /* End of File */
2411 case RMS$_FNF: /* File Not Found */
2412 case RMS$_DNF: /* Dir Not Found */
2413 unix_status = ENOENT;
2415 case RMS$_RNF: /* Record Not Found */
2416 unix_status = ESRCH;
2419 unix_status = ENOTDIR;
2422 unix_status = ENODEV;
2427 unix_status = EBADF;
2430 unix_status = EEXIST;
2434 case LIB$_INVSTRDES:
2436 case LIB$_NOSUCHSYM:
2437 case LIB$_INVSYMNAM:
2439 unix_status = EINVAL;
2445 unix_status = E2BIG;
2447 case RMS$_PRV: /* No privilege */
2448 case RMS$_ACC: /* ACP file access failed */
2449 case RMS$_WLK: /* Device write locked */
2450 unix_status = EACCES;
2452 /* case RMS$_NMF: */ /* No more files */
2460 /* Try to guess at what VMS error status should go with a UNIX errno
2461 * value. This is hard to do as there could be many possible VMS
2462 * error statuses that caused the errno value to be set.
2465 int Perl_unix_status_to_vms(int unix_status)
2467 int test_unix_status;
2469 /* Trivial cases first */
2470 /*---------------------*/
2471 if (unix_status == EVMSERR)
2474 /* Is vaxc$errno sane? */
2475 /*---------------------*/
2476 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2477 if (test_unix_status == unix_status)
2480 /* If way out of range, must be VMS code already */
2481 /*-----------------------------------------------*/
2482 if (unix_status > EVMSERR)
2485 /* If out of range, punt */
2486 /*-----------------------*/
2487 if (unix_status > __ERRNO_MAX)
2491 /* Ok, now we have to do it the hard way. */
2492 /*----------------------------------------*/
2493 switch(unix_status) {
2494 case 0: return SS$_NORMAL;
2495 case EPERM: return SS$_NOPRIV;
2496 case ENOENT: return SS$_NOSUCHOBJECT;
2497 case ESRCH: return SS$_UNREACHABLE;
2498 case EINTR: return SS$_ABORT;
2501 case E2BIG: return SS$_BUFFEROVF;
2503 case EBADF: return RMS$_IFI;
2504 case ECHILD: return SS$_NONEXPR;
2506 case ENOMEM: return SS$_INSFMEM;
2507 case EACCES: return SS$_FILACCERR;
2508 case EFAULT: return SS$_ACCVIO;
2510 case EBUSY: return SS$_DEVOFFLINE;
2511 case EEXIST: return RMS$_FEX;
2513 case ENODEV: return SS$_NOSUCHDEV;
2514 case ENOTDIR: return RMS$_DIR;
2516 case EINVAL: return SS$_INVARG;
2522 case ENOSPC: return SS$_DEVICEFULL;
2523 case ESPIPE: return LIB$_INVARG;
2528 case ERANGE: return LIB$_INVARG;
2529 /* case EWOULDBLOCK */
2530 /* case EINPROGRESS */
2533 /* case EDESTADDRREQ */
2535 /* case EPROTOTYPE */
2536 /* case ENOPROTOOPT */
2537 /* case EPROTONOSUPPORT */
2538 /* case ESOCKTNOSUPPORT */
2539 /* case EOPNOTSUPP */
2540 /* case EPFNOSUPPORT */
2541 /* case EAFNOSUPPORT */
2542 /* case EADDRINUSE */
2543 /* case EADDRNOTAVAIL */
2545 /* case ENETUNREACH */
2546 /* case ENETRESET */
2547 /* case ECONNABORTED */
2548 /* case ECONNRESET */
2551 case ENOTCONN: return SS$_CLEARED;
2552 /* case ESHUTDOWN */
2553 /* case ETOOMANYREFS */
2554 /* case ETIMEDOUT */
2555 /* case ECONNREFUSED */
2557 /* case ENAMETOOLONG */
2558 /* case EHOSTDOWN */
2559 /* case EHOSTUNREACH */
2560 /* case ENOTEMPTY */
2572 /* case ECANCELED */
2576 return SS$_UNSUPPORTED;
2582 /* case EABANDONED */
2584 return SS$_ABORT; /* punt */
2587 return SS$_ABORT; /* Should not get here */
2591 /* default piping mailbox size */
2592 #define PERL_BUFSIZ 512
2596 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2598 unsigned long int mbxbufsiz;
2599 static unsigned long int syssize = 0;
2600 unsigned long int dviitm = DVI$_DEVNAM;
2601 char csize[LNM$C_NAMLENGTH+1];
2605 unsigned long syiitm = SYI$_MAXBUF;
2607 * Get the SYSGEN parameter MAXBUF
2609 * If the logical 'PERL_MBX_SIZE' is defined
2610 * use the value of the logical instead of PERL_BUFSIZ, but
2611 * keep the size between 128 and MAXBUF.
2614 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2617 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2618 mbxbufsiz = atoi(csize);
2620 mbxbufsiz = PERL_BUFSIZ;
2622 if (mbxbufsiz < 128) mbxbufsiz = 128;
2623 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2625 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2627 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2628 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2630 } /* end of create_mbx() */
2633 /*{{{ my_popen and my_pclose*/
2635 typedef struct _iosb IOSB;
2636 typedef struct _iosb* pIOSB;
2637 typedef struct _pipe Pipe;
2638 typedef struct _pipe* pPipe;
2639 typedef struct pipe_details Info;
2640 typedef struct pipe_details* pInfo;
2641 typedef struct _srqp RQE;
2642 typedef struct _srqp* pRQE;
2643 typedef struct _tochildbuf CBuf;
2644 typedef struct _tochildbuf* pCBuf;
2647 unsigned short status;
2648 unsigned short count;
2649 unsigned long dvispec;
2652 #pragma member_alignment save
2653 #pragma nomember_alignment quadword
2654 struct _srqp { /* VMS self-relative queue entry */
2655 unsigned long qptr[2];
2657 #pragma member_alignment restore
2658 static RQE RQE_ZERO = {0,0};
2660 struct _tochildbuf {
2663 unsigned short size;
2671 unsigned short chan_in;
2672 unsigned short chan_out;
2674 unsigned int bufsize;
2686 #if defined(PERL_IMPLICIT_CONTEXT)
2687 void *thx; /* Either a thread or an interpreter */
2688 /* pointer, depending on how we're built */
2696 PerlIO *fp; /* file pointer to pipe mailbox */
2697 int useFILE; /* using stdio, not perlio */
2698 int pid; /* PID of subprocess */
2699 int mode; /* == 'r' if pipe open for reading */
2700 int done; /* subprocess has completed */
2701 int waiting; /* waiting for completion/closure */
2702 int closing; /* my_pclose is closing this pipe */
2703 unsigned long completion; /* termination status of subprocess */
2704 pPipe in; /* pipe in to sub */
2705 pPipe out; /* pipe out of sub */
2706 pPipe err; /* pipe of sub's sys$error */
2707 int in_done; /* true when in pipe finished */
2710 unsigned short xchan; /* channel to debug xterm */
2711 unsigned short xchan_valid; /* channel is assigned */
2714 struct exit_control_block
2716 struct exit_control_block *flink;
2717 unsigned long int (*exit_routine)();
2718 unsigned long int arg_count;
2719 unsigned long int *status_address;
2720 unsigned long int exit_status;
2723 typedef struct _closed_pipes Xpipe;
2724 typedef struct _closed_pipes* pXpipe;
2726 struct _closed_pipes {
2727 int pid; /* PID of subprocess */
2728 unsigned long completion; /* termination status of subprocess */
2730 #define NKEEPCLOSED 50
2731 static Xpipe closed_list[NKEEPCLOSED];
2732 static int closed_index = 0;
2733 static int closed_num = 0;
2735 #define RETRY_DELAY "0 ::0.20"
2736 #define MAX_RETRY 50
2738 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2739 static unsigned long mypid;
2740 static unsigned long delaytime[2];
2742 static pInfo open_pipes = NULL;
2743 static $DESCRIPTOR(nl_desc, "NL:");
2745 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2749 static unsigned long int
2750 pipe_exit_routine(pTHX)
2753 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2754 int sts, did_stuff, need_eof, j;
2757 * Flush any pending i/o, but since we are in process run-down, be
2758 * careful about referencing PerlIO structures that may already have
2759 * been deallocated. We may not even have an interpreter anymore.
2765 #if defined(USE_ITHREADS)
2768 && PL_perlio_fd_refcnt)
2769 PerlIO_flush(info->fp);
2771 fflush((FILE *)info->fp);
2777 next we try sending an EOF...ignore if doesn't work, make sure we
2785 _ckvmssts_noperl(sys$setast(0));
2786 if (info->in && !info->in->shut_on_empty) {
2787 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2792 _ckvmssts_noperl(sys$setast(1));
2796 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2798 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2803 _ckvmssts_noperl(sys$setast(0));
2804 if (info->waiting && info->done)
2806 nwait += info->waiting;
2807 _ckvmssts_noperl(sys$setast(1));
2817 _ckvmssts_noperl(sys$setast(0));
2818 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2819 sts = sys$forcex(&info->pid,0,&abort);
2820 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2823 _ckvmssts_noperl(sys$setast(1));
2827 /* again, wait for effect */
2829 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2834 _ckvmssts_noperl(sys$setast(0));
2835 if (info->waiting && info->done)
2837 nwait += info->waiting;
2838 _ckvmssts_noperl(sys$setast(1));
2847 _ckvmssts_noperl(sys$setast(0));
2848 if (!info->done) { /* We tried to be nice . . . */
2849 sts = sys$delprc(&info->pid,0);
2850 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2851 info->done = 1; /* sys$delprc is as done as we're going to get. */
2853 _ckvmssts_noperl(sys$setast(1));
2858 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2859 else if (!(sts & 1)) retsts = sts;
2864 static struct exit_control_block pipe_exitblock =
2865 {(struct exit_control_block *) 0,
2866 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2868 static void pipe_mbxtofd_ast(pPipe p);
2869 static void pipe_tochild1_ast(pPipe p);
2870 static void pipe_tochild2_ast(pPipe p);
2873 popen_completion_ast(pInfo info)
2875 pInfo i = open_pipes;
2880 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2881 closed_list[closed_index].pid = info->pid;
2882 closed_list[closed_index].completion = info->completion;
2884 if (closed_index == NKEEPCLOSED)
2889 if (i == info) break;
2892 if (!i) return; /* unlinked, probably freed too */
2897 Writing to subprocess ...
2898 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
2900 chan_out may be waiting for "done" flag, or hung waiting
2901 for i/o completion to child...cancel the i/o. This will
2902 put it into "snarf mode" (done but no EOF yet) that discards
2905 Output from subprocess (stdout, stderr) needs to be flushed and
2906 shut down. We try sending an EOF, but if the mbx is full the pipe
2907 routine should still catch the "shut_on_empty" flag, telling it to
2908 use immediate-style reads so that "mbx empty" -> EOF.
2912 if (info->in && !info->in_done) { /* only for mode=w */
2913 if (info->in->shut_on_empty && info->in->need_wake) {
2914 info->in->need_wake = FALSE;
2915 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
2917 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
2921 if (info->out && !info->out_done) { /* were we also piping output? */
2922 info->out->shut_on_empty = TRUE;
2923 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2924 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2925 _ckvmssts_noperl(iss);
2928 if (info->err && !info->err_done) { /* we were piping stderr */
2929 info->err->shut_on_empty = TRUE;
2930 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
2931 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
2932 _ckvmssts_noperl(iss);
2934 _ckvmssts_noperl(sys$setef(pipe_ef));
2938 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
2939 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
2942 we actually differ from vmstrnenv since we use this to
2943 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
2944 are pointing to the same thing
2947 static unsigned short
2948 popen_translate(pTHX_ char *logical, char *result)
2951 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
2952 $DESCRIPTOR(d_log,"");
2954 unsigned short length;
2955 unsigned short code;
2957 unsigned short *retlenaddr;
2959 unsigned short l, ifi;
2961 d_log.dsc$a_pointer = logical;
2962 d_log.dsc$w_length = strlen(logical);
2964 itmlst[0].code = LNM$_STRING;
2965 itmlst[0].length = 255;
2966 itmlst[0].buffer_addr = result;
2967 itmlst[0].retlenaddr = &l;
2970 itmlst[1].length = 0;
2971 itmlst[1].buffer_addr = 0;
2972 itmlst[1].retlenaddr = 0;
2974 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
2975 if (iss == SS$_NOLOGNAM) {
2979 if (!(iss&1)) lib$signal(iss);
2982 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
2983 strip it off and return the ifi, if any
2986 if (result[0] == 0x1b && result[1] == 0x00) {
2987 memmove(&ifi,result+2,2);
2988 strcpy(result,result+4);
2990 return ifi; /* this is the RMS internal file id */
2993 static void pipe_infromchild_ast(pPipe p);
2996 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
2997 inside an AST routine without worrying about reentrancy and which Perl
2998 memory allocator is being used.
3000 We read data and queue up the buffers, then spit them out one at a
3001 time to the output mailbox when the output mailbox is ready for one.
3004 #define INITIAL_TOCHILDQUEUE 2
3007 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3011 char mbx1[64], mbx2[64];
3012 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3013 DSC$K_CLASS_S, mbx1},
3014 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3015 DSC$K_CLASS_S, mbx2};
3016 unsigned int dviitm = DVI$_DEVBUFSIZ;
3020 _ckvmssts(lib$get_vm(&n, &p));
3022 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3023 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3024 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3027 p->shut_on_empty = FALSE;
3028 p->need_wake = FALSE;
3031 p->iosb.status = SS$_NORMAL;
3032 p->iosb2.status = SS$_NORMAL;
3038 #ifdef PERL_IMPLICIT_CONTEXT
3042 n = sizeof(CBuf) + p->bufsize;
3044 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3045 _ckvmssts(lib$get_vm(&n, &b));
3046 b->buf = (char *) b + sizeof(CBuf);
3047 _ckvmssts(lib$insqhi(b, &p->free));
3050 pipe_tochild2_ast(p);
3051 pipe_tochild1_ast(p);
3057 /* reads the MBX Perl is writing, and queues */
3060 pipe_tochild1_ast(pPipe p)
3063 int iss = p->iosb.status;
3064 int eof = (iss == SS$_ENDOFFILE);
3066 #ifdef PERL_IMPLICIT_CONTEXT
3072 p->shut_on_empty = TRUE;
3074 _ckvmssts(sys$dassgn(p->chan_in));
3080 b->size = p->iosb.count;
3081 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3083 p->need_wake = FALSE;
3084 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3087 p->retry = 1; /* initial call */
3090 if (eof) { /* flush the free queue, return when done */
3091 int n = sizeof(CBuf) + p->bufsize;
3093 iss = lib$remqti(&p->free, &b);
3094 if (iss == LIB$_QUEWASEMP) return;
3096 _ckvmssts(lib$free_vm(&n, &b));
3100 iss = lib$remqti(&p->free, &b);
3101 if (iss == LIB$_QUEWASEMP) {
3102 int n = sizeof(CBuf) + p->bufsize;
3103 _ckvmssts(lib$get_vm(&n, &b));
3104 b->buf = (char *) b + sizeof(CBuf);
3110 iss = sys$qio(0,p->chan_in,
3111 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3113 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3114 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3119 /* writes queued buffers to output, waits for each to complete before
3123 pipe_tochild2_ast(pPipe p)
3126 int iss = p->iosb2.status;
3127 int n = sizeof(CBuf) + p->bufsize;
3128 int done = (p->info && p->info->done) ||
3129 iss == SS$_CANCEL || iss == SS$_ABORT;
3130 #if defined(PERL_IMPLICIT_CONTEXT)
3135 if (p->type) { /* type=1 has old buffer, dispose */
3136 if (p->shut_on_empty) {
3137 _ckvmssts(lib$free_vm(&n, &b));
3139 _ckvmssts(lib$insqhi(b, &p->free));
3144 iss = lib$remqti(&p->wait, &b);
3145 if (iss == LIB$_QUEWASEMP) {
3146 if (p->shut_on_empty) {
3148 _ckvmssts(sys$dassgn(p->chan_out));
3149 *p->pipe_done = TRUE;
3150 _ckvmssts(sys$setef(pipe_ef));
3152 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3153 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3157 p->need_wake = TRUE;
3167 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3168 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3170 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3171 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3180 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3183 char mbx1[64], mbx2[64];
3184 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3185 DSC$K_CLASS_S, mbx1},
3186 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3187 DSC$K_CLASS_S, mbx2};
3188 unsigned int dviitm = DVI$_DEVBUFSIZ;
3190 int n = sizeof(Pipe);
3191 _ckvmssts(lib$get_vm(&n, &p));
3192 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3193 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3195 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3196 n = p->bufsize * sizeof(char);
3197 _ckvmssts(lib$get_vm(&n, &p->buf));
3198 p->shut_on_empty = FALSE;
3201 p->iosb.status = SS$_NORMAL;
3202 #if defined(PERL_IMPLICIT_CONTEXT)
3205 pipe_infromchild_ast(p);
3213 pipe_infromchild_ast(pPipe p)
3215 int iss = p->iosb.status;
3216 int eof = (iss == SS$_ENDOFFILE);
3217 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3218 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3219 #if defined(PERL_IMPLICIT_CONTEXT)
3223 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3224 _ckvmssts(sys$dassgn(p->chan_out));
3229 input shutdown if EOF from self (done or shut_on_empty)
3230 output shutdown if closing flag set (my_pclose)
3231 send data/eof from child or eof from self
3232 otherwise, re-read (snarf of data from child)
3237 if (myeof && p->chan_in) { /* input shutdown */
3238 _ckvmssts(sys$dassgn(p->chan_in));
3243 if (myeof || kideof) { /* pass EOF to parent */
3244 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3245 pipe_infromchild_ast, p,
3248 } else if (eof) { /* eat EOF --- fall through to read*/
3250 } else { /* transmit data */
3251 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3252 pipe_infromchild_ast,p,
3253 p->buf, p->iosb.count, 0, 0, 0, 0));
3259 /* everything shut? flag as done */
3261 if (!p->chan_in && !p->chan_out) {
3262 *p->pipe_done = TRUE;
3263 _ckvmssts(sys$setef(pipe_ef));
3267 /* write completed (or read, if snarfing from child)
3268 if still have input active,
3269 queue read...immediate mode if shut_on_empty so we get EOF if empty
3271 check if Perl reading, generate EOFs as needed
3277 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3278 pipe_infromchild_ast,p,
3279 p->buf, p->bufsize, 0, 0, 0, 0);
3280 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3282 } else { /* send EOFs for extra reads */
3283 p->iosb.status = SS$_ENDOFFILE;
3284 p->iosb.dvispec = 0;
3285 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3287 pipe_infromchild_ast, p, 0, 0, 0, 0));
3293 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3297 unsigned long dviitm = DVI$_DEVBUFSIZ;
3299 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3300 DSC$K_CLASS_S, mbx};
3301 int n = sizeof(Pipe);
3303 /* things like terminals and mbx's don't need this filter */
3304 if (fd && fstat(fd,&s) == 0) {
3305 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3307 unsigned short dev_len;
3308 struct dsc$descriptor_s d_dev;
3310 struct item_list_3 items[3];
3312 unsigned short dvi_iosb[4];
3314 cptr = getname(fd, out, 1);
3315 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3316 d_dev.dsc$a_pointer = out;
3317 d_dev.dsc$w_length = strlen(out);
3318 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3319 d_dev.dsc$b_class = DSC$K_CLASS_S;
3322 items[0].code = DVI$_DEVCHAR;
3323 items[0].bufadr = &devchar;
3324 items[0].retadr = NULL;
3326 items[1].code = DVI$_FULLDEVNAM;
3327 items[1].bufadr = device;
3328 items[1].retadr = &dev_len;
3332 status = sys$getdviw
3333 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3335 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3336 device[dev_len] = 0;
3338 if (!(devchar & DEV$M_DIR)) {
3339 strcpy(out, device);
3345 _ckvmssts(lib$get_vm(&n, &p));
3346 p->fd_out = dup(fd);
3347 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3348 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3349 n = (p->bufsize+1) * sizeof(char);
3350 _ckvmssts(lib$get_vm(&n, &p->buf));
3351 p->shut_on_empty = FALSE;
3356 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3357 pipe_mbxtofd_ast, p,
3358 p->buf, p->bufsize, 0, 0, 0, 0));
3364 pipe_mbxtofd_ast(pPipe p)
3366 int iss = p->iosb.status;
3367 int done = p->info->done;
3369 int eof = (iss == SS$_ENDOFFILE);
3370 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3371 int err = !(iss&1) && !eof;
3372 #if defined(PERL_IMPLICIT_CONTEXT)
3376 if (done && myeof) { /* end piping */
3378 sys$dassgn(p->chan_in);
3379 *p->pipe_done = TRUE;
3380 _ckvmssts(sys$setef(pipe_ef));
3384 if (!err && !eof) { /* good data to send to file */
3385 p->buf[p->iosb.count] = '\n';
3386 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3389 if (p->retry < MAX_RETRY) {
3390 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3400 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3401 pipe_mbxtofd_ast, p,
3402 p->buf, p->bufsize, 0, 0, 0, 0);
3403 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3408 typedef struct _pipeloc PLOC;
3409 typedef struct _pipeloc* pPLOC;
3413 char dir[NAM$C_MAXRSS+1];
3415 static pPLOC head_PLOC = 0;
3418 free_pipelocs(pTHX_ void *head)
3421 pPLOC *pHead = (pPLOC *)head;
3433 store_pipelocs(pTHX)
3442 char temp[NAM$C_MAXRSS+1];
3446 free_pipelocs(aTHX_ &head_PLOC);
3448 /* the . directory from @INC comes last */
3450 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3451 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3452 p->next = head_PLOC;
3454 strcpy(p->dir,"./");
3456 /* get the directory from $^X */
3458 unixdir = PerlMem_malloc(VMS_MAXRSS);
3459 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3461 #ifdef PERL_IMPLICIT_CONTEXT
3462 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3464 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3466 strcpy(temp, PL_origargv[0]);
3467 x = strrchr(temp,']');
3469 x = strrchr(temp,'>');
3471 /* It could be a UNIX path */
3472 x = strrchr(temp,'/');
3478 /* Got a bare name, so use default directory */
3483 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3484 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3485 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3486 p->next = head_PLOC;
3488 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3489 p->dir[NAM$C_MAXRSS] = '\0';
3493 /* reverse order of @INC entries, skip "." since entered above */
3495 #ifdef PERL_IMPLICIT_CONTEXT
3498 if (PL_incgv) av = GvAVn(PL_incgv);
3500 for (i = 0; av && i <= AvFILL(av); i++) {
3501 dirsv = *av_fetch(av,i,TRUE);
3503 if (SvROK(dirsv)) continue;
3504 dir = SvPVx(dirsv,n_a);
3505 if (strcmp(dir,".") == 0) continue;
3506 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3509 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3510 p->next = head_PLOC;
3512 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3513 p->dir[NAM$C_MAXRSS] = '\0';
3516 /* most likely spot (ARCHLIB) put first in the list */
3519 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3520 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3521 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3522 p->next = head_PLOC;
3524 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3525 p->dir[NAM$C_MAXRSS] = '\0';
3528 PerlMem_free(unixdir);
3532 Perl_cando_by_name_int
3533 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3534 #if !defined(PERL_IMPLICIT_CONTEXT)
3535 #define cando_by_name_int Perl_cando_by_name_int
3537 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3543 static int vmspipe_file_status = 0;
3544 static char vmspipe_file[NAM$C_MAXRSS+1];
3546 /* already found? Check and use ... need read+execute permission */
3548 if (vmspipe_file_status == 1) {
3549 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3550 && cando_by_name_int
3551 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3552 return vmspipe_file;
3554 vmspipe_file_status = 0;
3557 /* scan through stored @INC, $^X */
3559 if (vmspipe_file_status == 0) {
3560 char file[NAM$C_MAXRSS+1];
3561 pPLOC p = head_PLOC;
3566 strcpy(file, p->dir);
3567 dirlen = strlen(file);
3568 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3569 file[NAM$C_MAXRSS] = '\0';
3572 exp_res = do_rmsexpand
3573 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3574 if (!exp_res) continue;
3576 if (cando_by_name_int
3577 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3578 && cando_by_name_int
3579 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3580 vmspipe_file_status = 1;
3581 return vmspipe_file;
3584 vmspipe_file_status = -1; /* failed, use tempfiles */
3591 vmspipe_tempfile(pTHX)
3593 char file[NAM$C_MAXRSS+1];
3595 static int index = 0;
3599 /* create a tempfile */
3601 /* we can't go from W, shr=get to R, shr=get without
3602 an intermediate vulnerable state, so don't bother trying...
3604 and lib$spawn doesn't shr=put, so have to close the write
3606 So... match up the creation date/time and the FID to
3607 make sure we're dealing with the same file
3612 if (!decc_filename_unix_only) {
3613 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3614 fp = fopen(file,"w");
3616 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3617 fp = fopen(file,"w");
3619 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3620 fp = fopen(file,"w");
3625 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3626 fp = fopen(file,"w");
3628 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3629 fp = fopen(file,"w");
3631 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3632 fp = fopen(file,"w");
3636 if (!fp) return 0; /* we're hosed */
3638 fprintf(fp,"$! 'f$verify(0)'\n");
3639 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3640 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3641 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3642 fprintf(fp,"$ perl_on = \"set noon\"\n");
3643 fprintf(fp,"$ perl_exit = \"exit\"\n");
3644 fprintf(fp,"$ perl_del = \"delete\"\n");
3645 fprintf(fp,"$ pif = \"if\"\n");
3646 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3647 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3648 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3649 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3650 fprintf(fp,"$! --- build command line to get max possible length\n");
3651 fprintf(fp,"$c=perl_popen_cmd0\n");
3652 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3653 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3654 fprintf(fp,"$x=perl_popen_cmd3\n");
3655 fprintf(fp,"$c=c+x\n");
3656 fprintf(fp,"$ perl_on\n");
3657 fprintf(fp,"$ 'c'\n");
3658 fprintf(fp,"$ perl_status = $STATUS\n");
3659 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3660 fprintf(fp,"$ perl_exit 'perl_status'\n");
3663 fgetname(fp, file, 1);
3664 fstat(fileno(fp), (struct stat *)&s0);
3667 if (decc_filename_unix_only)
3668 do_tounixspec(file, file, 0, NULL);
3669 fp = fopen(file,"r","shr=get");
3671 fstat(fileno(fp), (struct stat *)&s1);
3673 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3674 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3683 static int vms_is_syscommand_xterm(void)
3685 const static struct dsc$descriptor_s syscommand_dsc =
3686 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3688 const static struct dsc$descriptor_s decwdisplay_dsc =
3689 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3691 struct item_list_3 items[2];
3692 unsigned short dvi_iosb[4];
3693 unsigned long devchar;
3694 unsigned long devclass;
3697 /* Very simple check to guess if sys$command is a decterm? */
3698 /* First see if the DECW$DISPLAY: device exists */
3700 items[0].code = DVI$_DEVCHAR;
3701 items[0].bufadr = &devchar;
3702 items[0].retadr = NULL;
3706 status = sys$getdviw
3707 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3709 if ($VMS_STATUS_SUCCESS(status)) {
3710 status = dvi_iosb[0];
3713 if (!$VMS_STATUS_SUCCESS(status)) {
3714 SETERRNO(EVMSERR, status);
3718 /* If it does, then for now assume that we are on a workstation */
3719 /* Now verify that SYS$COMMAND is a terminal */
3720 /* for creating the debugger DECTerm */
3723 items[0].code = DVI$_DEVCLASS;
3724 items[0].bufadr = &devclass;
3725 items[0].retadr = NULL;
3729 status = sys$getdviw
3730 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3732 if ($VMS_STATUS_SUCCESS(status)) {
3733 status = dvi_iosb[0];
3736 if (!$VMS_STATUS_SUCCESS(status)) {
3737 SETERRNO(EVMSERR, status);
3741 if (devclass == DC$_TERM) {
3748 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3749 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3754 char device_name[65];
3755 unsigned short device_name_len;
3756 struct dsc$descriptor_s customization_dsc;
3757 struct dsc$descriptor_s device_name_dsc;
3760 char customization[200];
3764 unsigned short p_chan;
3766 unsigned short iosb[4];
3767 struct item_list_3 items[2];
3768 const char * cust_str =
3769 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3770 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3771 DSC$K_CLASS_S, mbx1};
3773 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3774 /*---------------------------------------*/
3775 VAXC$ESTABLISH((__vms_handler)LIB$SIG_TO_RET);
3778 /* Make sure that this is from the Perl debugger */
3779 ret_char = strstr(cmd," xterm ");
3780 if (ret_char == NULL)
3782 cptr = ret_char + 7;
3783 ret_char = strstr(cmd,"tty");
3784 if (ret_char == NULL)
3786 ret_char = strstr(cmd,"sleep");
3787 if (ret_char == NULL)
3790 if (decw_term_port == 0) {
3791 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3792 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3793 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3795 status = LIB$FIND_IMAGE_SYMBOL
3797 &decw_term_port_dsc,
3798 (void *)&decw_term_port,
3802 /* Try again with the other image name */
3803 if (!$VMS_STATUS_SUCCESS(status)) {
3805 status = LIB$FIND_IMAGE_SYMBOL
3807 &decw_term_port_dsc,
3808 (void *)&decw_term_port,
3817 /* No decw$term_port, give it up */
3818 if (!$VMS_STATUS_SUCCESS(status))
3821 /* Are we on a workstation? */
3822 /* to do: capture the rows / columns and pass their properties */
3823 ret_stat = vms_is_syscommand_xterm();
3827 /* Make the title: */
3828 ret_char = strstr(cptr,"-title");
3829 if (ret_char != NULL) {
3830 while ((*cptr != 0) && (*cptr != '\"')) {
3836 while ((*cptr != 0) && (*cptr != '\"')) {
3849 strcpy(title,"Perl Debug DECTerm");
3851 sprintf(customization, cust_str, title);
3853 customization_dsc.dsc$a_pointer = customization;
3854 customization_dsc.dsc$w_length = strlen(customization);
3855 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3856 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3858 device_name_dsc.dsc$a_pointer = device_name;
3859 device_name_dsc.dsc$w_length = sizeof device_name -1;
3860 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3861 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3863 device_name_len = 0;
3865 /* Try to create the window */
3866 status = (*decw_term_port)
3875 if (!$VMS_STATUS_SUCCESS(status)) {
3876 SETERRNO(EVMSERR, status);
3880 device_name[device_name_len] = '\0';
3882 /* Need to set this up to look like a pipe for cleanup */
3884 status = lib$get_vm(&n, &info);
3885 if (!$VMS_STATUS_SUCCESS(status)) {
3886 SETERRNO(ENOMEM, status);
3892 info->completion = 0;
3893 info->closing = FALSE;
3900 info->in_done = TRUE;
3901 info->out_done = TRUE;
3902 info->err_done = TRUE;
3904 /* Assign a channel on this so that it will persist, and not login */
3905 /* We stash this channel in the info structure for reference. */
3906 /* The created xterm self destructs when the last channel is removed */
3907 /* and it appears that perl5db.pl (perl debugger) does this routinely */
3908 /* So leave this assigned. */
3909 device_name_dsc.dsc$w_length = device_name_len;
3910 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
3911 if (!$VMS_STATUS_SUCCESS(status)) {
3912 SETERRNO(EVMSERR, status);
3915 info->xchan_valid = 1;
3917 /* Now create a mailbox to be read by the application */
3919 create_mbx(aTHX_ &p_chan, &d_mbx1);
3921 /* write the name of the created terminal to the mailbox */
3922 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
3923 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
3925 if (!$VMS_STATUS_SUCCESS(status)) {
3926 SETERRNO(EVMSERR, status);
3930 info->fp = PerlIO_open(mbx1, mode);
3932 /* Done with this channel */
3935 /* If any errors, then clean up */
3938 _ckvmssts(lib$free_vm(&n, &info));
3947 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
3949 static int handler_set_up = FALSE;
3950 unsigned long int sts, flags = CLI$M_NOWAIT;
3951 /* The use of a GLOBAL table (as was done previously) rendered
3952 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
3953 * environment. Hence we've switched to LOCAL symbol table.
3955 unsigned int table = LIB$K_CLI_LOCAL_SYM;
3957 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
3958 char *in, *out, *err, mbx[512];
3960 char tfilebuf[NAM$C_MAXRSS+1];
3962 char cmd_sym_name[20];
3963 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
3964 DSC$K_CLASS_S, symbol};
3965 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
3967 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
3968 DSC$K_CLASS_S, cmd_sym_name};
3969 struct dsc$descriptor_s *vmscmd;
3970 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
3971 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
3972 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
3974 /* Check here for Xterm create request. This means looking for
3975 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
3976 * is possible to create an xterm.
3978 if (*in_mode == 'r') {
3981 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
3982 if (xterm_fd != Nullfp)
3986 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
3988 /* once-per-program initialization...
3989 note that the SETAST calls and the dual test of pipe_ef
3990 makes sure that only the FIRST thread through here does
3991 the initialization...all other threads wait until it's
3994 Yeah, uglier than a pthread call, it's got all the stuff inline
3995 rather than in a separate routine.
3999 _ckvmssts(sys$setast(0));
4001 unsigned long int pidcode = JPI$_PID;
4002 $DESCRIPTOR(d_delay, RETRY_DELAY);
4003 _ckvmssts(lib$get_ef(&pipe_ef));
4004 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4005 _ckvmssts(sys$bintim(&d_delay, delaytime));
4007 if (!handler_set_up) {
4008 _ckvmssts(sys$dclexh(&pipe_exitblock));
4009 handler_set_up = TRUE;
4011 _ckvmssts(sys$setast(1));
4014 /* see if we can find a VMSPIPE.COM */
4017 vmspipe = find_vmspipe(aTHX);
4019 strcpy(tfilebuf+1,vmspipe);
4020 } else { /* uh, oh...we're in tempfile hell */
4021 tpipe = vmspipe_tempfile(aTHX);
4022 if (!tpipe) { /* a fish popular in Boston */
4023 if (ckWARN(WARN_PIPE)) {
4024 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4028 fgetname(tpipe,tfilebuf+1,1);
4030 vmspipedsc.dsc$a_pointer = tfilebuf;
4031 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4033 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4036 case RMS$_FNF: case RMS$_DNF:
4037 set_errno(ENOENT); break;
4039 set_errno(ENOTDIR); break;
4041 set_errno(ENODEV); break;
4043 set_errno(EACCES); break;
4045 set_errno(EINVAL); break;
4046 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4047 set_errno(E2BIG); break;
4048 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4049 _ckvmssts(sts); /* fall through */
4050 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4053 set_vaxc_errno(sts);
4054 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4055 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4061 _ckvmssts(lib$get_vm(&n, &info));
4063 strcpy(mode,in_mode);
4066 info->completion = 0;
4067 info->closing = FALSE;
4074 info->in_done = TRUE;
4075 info->out_done = TRUE;
4076 info->err_done = TRUE;
4078 info->xchan_valid = 0;
4080 in = PerlMem_malloc(VMS_MAXRSS);
4081 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4082 out = PerlMem_malloc(VMS_MAXRSS);
4083 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4084 err = PerlMem_malloc(VMS_MAXRSS);
4085 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4087 in[0] = out[0] = err[0] = '\0';
4089 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4093 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4098 if (*mode == 'r') { /* piping from subroutine */
4100 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4102 info->out->pipe_done = &info->out_done;
4103 info->out_done = FALSE;
4104 info->out->info = info;
4106 if (!info->useFILE) {
4107 info->fp = PerlIO_open(mbx, mode);
4109 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4110 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4113 if (!info->fp && info->out) {
4114 sys$cancel(info->out->chan_out);
4116 while (!info->out_done) {
4118 _ckvmssts(sys$setast(0));
4119 done = info->out_done;
4120 if (!done) _ckvmssts(sys$clref(pipe_ef));
4121 _ckvmssts(sys$setast(1));
4122 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4125 if (info->out->buf) {
4126 n = info->out->bufsize * sizeof(char);
4127 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4130 _ckvmssts(lib$free_vm(&n, &info->out));
4132 _ckvmssts(lib$free_vm(&n, &info));
4137 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4139 info->err->pipe_done = &info->err_done;
4140 info->err_done = FALSE;
4141 info->err->info = info;
4144 } else if (*mode == 'w') { /* piping to subroutine */
4146 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4148 info->out->pipe_done = &info->out_done;
4149 info->out_done = FALSE;
4150 info->out->info = info;
4153 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4155 info->err->pipe_done = &info->err_done;
4156 info->err_done = FALSE;
4157 info->err->info = info;
4160 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4161 if (!info->useFILE) {
4162 info->fp = PerlIO_open(mbx, mode);
4164 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4165 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4169 info->in->pipe_done = &info->in_done;
4170 info->in_done = FALSE;
4171 info->in->info = info;
4175 if (!info->fp && info->in) {
4177 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4178 0, 0, 0, 0, 0, 0, 0, 0));
4180 while (!info->in_done) {
4182 _ckvmssts(sys$setast(0));
4183 done = info->in_done;
4184 if (!done) _ckvmssts(sys$clref(pipe_ef));
4185 _ckvmssts(sys$setast(1));
4186 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4189 if (info->in->buf) {
4190 n = info->in->bufsize * sizeof(char);
4191 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4194 _ckvmssts(lib$free_vm(&n, &info->in));
4196 _ckvmssts(lib$free_vm(&n, &info));
4202 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4203 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4205 info->out->pipe_done = &info->out_done;
4206 info->out_done = FALSE;
4207 info->out->info = info;
4210 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4212 info->err->pipe_done = &info->err_done;
4213 info->err_done = FALSE;
4214 info->err->info = info;
4218 symbol[MAX_DCL_SYMBOL] = '\0';
4220 strncpy(symbol, in, MAX_DCL_SYMBOL);
4221 d_symbol.dsc$w_length = strlen(symbol);
4222 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4224 strncpy(symbol, err, MAX_DCL_SYMBOL);
4225 d_symbol.dsc$w_length = strlen(symbol);
4226 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4228 strncpy(symbol, out, MAX_DCL_SYMBOL);
4229 d_symbol.dsc$w_length = strlen(symbol);
4230 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4232 /* Done with the names for the pipes */
4237 p = vmscmd->dsc$a_pointer;
4238 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4239 if (*p == '$') p++; /* remove leading $ */
4240 while (*p == ' ' || *p == '\t') p++;
4242 for (j = 0; j < 4; j++) {
4243 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4244 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4246 strncpy(symbol, p, MAX_DCL_SYMBOL);
4247 d_symbol.dsc$w_length = strlen(symbol);
4248 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4250 if (strlen(p) > MAX_DCL_SYMBOL) {
4251 p += MAX_DCL_SYMBOL;
4256 _ckvmssts(sys$setast(0));
4257 info->next=open_pipes; /* prepend to list */
4259 _ckvmssts(sys$setast(1));
4260 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4261 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4262 * have SYS$COMMAND if we need it.
4264 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4265 0, &info->pid, &info->completion,
4266 0, popen_completion_ast,info,0,0,0));
4268 /* if we were using a tempfile, close it now */
4270 if (tpipe) fclose(tpipe);
4272 /* once the subprocess is spawned, it has copied the symbols and
4273 we can get rid of ours */
4275 for (j = 0; j < 4; j++) {
4276 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4277 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4278 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4280 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4281 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4282 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4283 vms_execfree(vmscmd);
4285 #ifdef PERL_IMPLICIT_CONTEXT
4288 PL_forkprocess = info->pid;
4293 _ckvmssts(sys$setast(0));
4295 if (!done) _ckvmssts(sys$clref(pipe_ef));
4296 _ckvmssts(sys$setast(1));
4297 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4299 *psts = info->completion;
4300 /* Caller thinks it is open and tries to close it. */
4301 /* This causes some problems, as it changes the error status */
4302 /* my_pclose(info->fp); */
4307 } /* end of safe_popen */
4310 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4312 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4316 TAINT_PROPER("popen");
4317 PERL_FLUSHALL_FOR_CHILD;
4318 return safe_popen(aTHX_ cmd,mode,&sts);
4323 /*{{{ I32 my_pclose(PerlIO *fp)*/
4324 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4326 pInfo info, last = NULL;
4327 unsigned long int retsts;
4331 for (info = open_pipes; info != NULL; last = info, info = info->next)
4332 if (info->fp == fp) break;
4334 if (info == NULL) { /* no such pipe open */
4335 set_errno(ECHILD); /* quoth POSIX */
4336 set_vaxc_errno(SS$_NONEXPR);
4340 /* If we were writing to a subprocess, insure that someone reading from
4341 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4342 * produce an EOF record in the mailbox.
4344 * well, at least sometimes it *does*, so we have to watch out for
4345 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4349 #if defined(USE_ITHREADS)
4352 && PL_perlio_fd_refcnt)
4353 PerlIO_flush(info->fp);
4355 fflush((FILE *)info->fp);
4358 _ckvmssts(sys$setast(0));
4359 info->closing = TRUE;
4360 done = info->done && info->in_done && info->out_done && info->err_done;
4361 /* hanging on write to Perl's input? cancel it */
4362 if (info->mode == 'r' && info->out && !info->out_done) {
4363 if (info->out->chan_out) {
4364 _ckvmssts(sys$cancel(info->out->chan_out));
4365 if (!info->out->chan_in) { /* EOF generation, need AST */
4366 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4370 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4371 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4373 _ckvmssts(sys$setast(1));
4376 #if defined(USE_ITHREADS)
4379 && PL_perlio_fd_refcnt)
4380 PerlIO_close(info->fp);
4382 fclose((FILE *)info->fp);
4385 we have to wait until subprocess completes, but ALSO wait until all
4386 the i/o completes...otherwise we'll be freeing the "info" structure
4387 that the i/o ASTs could still be using...
4391 _ckvmssts(sys$setast(0));
4392 done = info->done && info->in_done && info->out_done && info->err_done;
4393 if (!done) _ckvmssts(sys$clref(pipe_ef));
4394 _ckvmssts(sys$setast(1));
4395 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4397 retsts = info->completion;
4399 /* remove from list of open pipes */
4400 _ckvmssts(sys$setast(0));
4401 if (last) last->next = info->next;
4402 else open_pipes = info->next;
4403 _ckvmssts(sys$setast(1));
4405 /* free buffers and structures */
4408 if (info->in->buf) {
4409 n = info->in->bufsize * sizeof(char);
4410 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4413 _ckvmssts(lib$free_vm(&n, &info->in));
4416 if (info->out->buf) {
4417 n = info->out->bufsize * sizeof(char);
4418 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4421 _ckvmssts(lib$free_vm(&n, &info->out));
4424 if (info->err->buf) {
4425 n = info->err->bufsize * sizeof(char);
4426 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4429 _ckvmssts(lib$free_vm(&n, &info->err));
4432 _ckvmssts(lib$free_vm(&n, &info));
4436 } /* end of my_pclose() */
4438 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4439 /* Roll our own prototype because we want this regardless of whether
4440 * _VMS_WAIT is defined.
4442 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4444 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4445 created with popen(); otherwise partially emulate waitpid() unless
4446 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4447 Also check processes not considered by the CRTL waitpid().
4449 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4451 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4458 if (statusp) *statusp = 0;
4460 for (info = open_pipes; info != NULL; info = info->next)
4461 if (info->pid == pid) break;
4463 if (info != NULL) { /* we know about this child */
4464 while (!info->done) {
4465 _ckvmssts(sys$setast(0));
4467 if (!done) _ckvmssts(sys$clref(pipe_ef));
4468 _ckvmssts(sys$setast(1));
4469 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4472 if (statusp) *statusp = info->completion;
4476 /* child that already terminated? */
4478 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4479 if (closed_list[j].pid == pid) {
4480 if (statusp) *statusp = closed_list[j].completion;
4485 /* fall through if this child is not one of our own pipe children */
4487 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4489 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4490 * in 7.2 did we get a version that fills in the VMS completion
4491 * status as Perl has always tried to do.
4494 sts = __vms_waitpid( pid, statusp, flags );
4496 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4499 /* If the real waitpid tells us the child does not exist, we
4500 * fall through here to implement waiting for a child that
4501 * was created by some means other than exec() (say, spawned
4502 * from DCL) or to wait for a process that is not a subprocess
4503 * of the current process.
4506 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4509 $DESCRIPTOR(intdsc,"0 00:00:01");
4510 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4511 unsigned long int pidcode = JPI$_PID, mypid;
4512 unsigned long int interval[2];
4513 unsigned int jpi_iosb[2];
4514 struct itmlst_3 jpilist[2] = {
4515 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4520 /* Sorry folks, we don't presently implement rooting around for
4521 the first child we can find, and we definitely don't want to
4522 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4528 /* Get the owner of the child so I can warn if it's not mine. If the
4529 * process doesn't exist or I don't have the privs to look at it,
4530 * I can go home early.
4532 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4533 if (sts & 1) sts = jpi_iosb[0];
4545 set_vaxc_errno(sts);
4549 if (ckWARN(WARN_EXEC)) {
4550 /* remind folks they are asking for non-standard waitpid behavior */
4551 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4552 if (ownerpid != mypid)
4553 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4554 "waitpid: process %x is not a child of process %x",
4558 /* simply check on it once a second until it's not there anymore. */
4560 _ckvmssts(sys$bintim(&intdsc,interval));
4561 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4562 _ckvmssts(sys$schdwk(0,0,interval,0));
4563 _ckvmssts(sys$hiber());
4565 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4570 } /* end of waitpid() */
4575 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4577 my_gconvert(double val, int ndig, int trail, char *buf)
4579 static char __gcvtbuf[DBL_DIG+1];
4582 loc = buf ? buf : __gcvtbuf;
4584 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4586 sprintf(loc,"%.*g",ndig,val);
4592 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4593 return gcvt(val,ndig,loc);
4596 loc[0] = '0'; loc[1] = '\0';
4603 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4604 static int rms_free_search_context(struct FAB * fab)
4608 nam = fab->fab$l_nam;
4609 nam->nam$b_nop |= NAM$M_SYNCHK;
4610 nam->nam$l_rlf = NULL;
4612 return sys$parse(fab, NULL, NULL);
4615 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4616 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4617 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4618 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4619 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4620 #define rms_nam_esll(nam) nam.nam$b_esl
4621 #define rms_nam_esl(nam) nam.nam$b_esl
4622 #define rms_nam_name(nam) nam.nam$l_name
4623 #define rms_nam_namel(nam) nam.nam$l_name
4624 #define rms_nam_type(nam) nam.nam$l_type
4625 #define rms_nam_typel(nam) nam.nam$l_type
4626 #define rms_nam_ver(nam) nam.nam$l_ver
4627 #define rms_nam_verl(nam) nam.nam$l_ver
4628 #define rms_nam_rsll(nam) nam.nam$b_rsl
4629 #define rms_nam_rsl(nam) nam.nam$b_rsl
4630 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4631 #define rms_set_fna(fab, nam, name, size) \
4632 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4633 #define rms_get_fna(fab, nam) fab.fab$l_fna
4634 #define rms_set_dna(fab, nam, name, size) \
4635 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4636 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4637 #define rms_set_esa(fab, nam, name, size) \
4638 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4639 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4640 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4641 #define rms_set_rsa(nam, name, size) \
4642 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4643 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4644 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4645 #define rms_nam_name_type_l_size(nam) \
4646 (nam.nam$b_name + nam.nam$b_type)
4648 static int rms_free_search_context(struct FAB * fab)
4652 nam = fab->fab$l_naml;
4653 nam->naml$b_nop |= NAM$M_SYNCHK;
4654 nam->naml$l_rlf = NULL;
4655 nam->naml$l_long_defname_size = 0;
4658 return sys$parse(fab, NULL, NULL);
4661 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4662 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4663 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4664 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4665 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4666 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4667 #define rms_nam_esl(nam) nam.naml$b_esl
4668 #define rms_nam_name(nam) nam.naml$l_name
4669 #define rms_nam_namel(nam) nam.naml$l_long_name
4670 #define rms_nam_type(nam) nam.naml$l_type
4671 #define rms_nam_typel(nam) nam.naml$l_long_type
4672 #define rms_nam_ver(nam) nam.naml$l_ver
4673 #define rms_nam_verl(nam) nam.naml$l_long_ver
4674 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4675 #define rms_nam_rsl(nam) nam.naml$b_rsl
4676 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4677 #define rms_set_fna(fab, nam, name, size) \
4678 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4679 nam.naml$l_long_filename_size = size; \
4680 nam.naml$l_long_filename = name;}
4681 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4682 #define rms_set_dna(fab, nam, name, size) \
4683 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4684 nam.naml$l_long_defname_size = size; \
4685 nam.naml$l_long_defname = name; }
4686 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4687 #define rms_set_esa(fab, nam, name, size) \
4688 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4689 nam.naml$l_long_expand_alloc = size; \
4690 nam.naml$l_long_expand = name; }
4691 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4692 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4693 nam.naml$l_long_expand = l_name; \
4694 nam.naml$l_long_expand_alloc = l_size; }
4695 #define rms_set_rsa(nam, name, size) \
4696 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4697 nam.naml$l_long_result = name; \
4698 nam.naml$l_long_result_alloc = size; }
4699 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4700 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4701 nam.naml$l_long_result = l_name; \
4702 nam.naml$l_long_result_alloc = l_size; }
4703 #define rms_nam_name_type_l_size(nam) \
4704 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4708 * The CRTL for 8.3 and later can create symbolic links in any mode,
4709 * however the unlink/remove/delete routines will only properly handle
4710 * them if one of the PCP modes is active.
4712 * Future: rename() routine will also need this when the unlink_all_versions
4715 static int rms_erase(const char * vmsname)
4718 struct FAB myfab = cc$rms_fab;
4719 rms_setup_nam(mynam);
4721 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4722 rms_bind_fab_nam(myfab, mynam);
4724 /* Are we removing all versions? */
4725 if (vms_unlink_all_versions == 1) {
4726 const char * defspec = ";*";
4727 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4730 #ifdef NAML$M_OPEN_SPECIAL
4731 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4734 status = SYS$ERASE(&myfab, 0, 0);
4740 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
4741 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
4742 * to expand file specification. Allows for a single default file
4743 * specification and a simple mask of options. If outbuf is non-NULL,
4744 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
4745 * the resultant file specification is placed. If outbuf is NULL, the
4746 * resultant file specification is placed into a static buffer.
4747 * The third argument, if non-NULL, is taken to be a default file
4748 * specification string. The fourth argument is unused at present.
4749 * rmesexpand() returns the address of the resultant string if
4750 * successful, and NULL on error.
4752 * New functionality for previously unused opts value:
4753 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
4754 * PERL_RMSEXPAND_M_LONG - Want output in long formst
4755 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
4756 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
4758 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
4762 (pTHX_ const char *filespec,
4765 const char *defspec,
4770 static char __rmsexpand_retbuf[VMS_MAXRSS];
4771 char * vmsfspec, *tmpfspec;
4772 char * esa, *cp, *out = NULL;
4776 struct FAB myfab = cc$rms_fab;
4777 rms_setup_nam(mynam);
4779 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
4782 /* temp hack until UTF8 is actually implemented */
4783 if (fs_utf8 != NULL)
4786 if (!filespec || !*filespec) {
4787 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
4791 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
4792 else outbuf = __rmsexpand_retbuf;
4800 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
4801 isunix = is_unix_filespec(filespec);
4803 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
4804 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
4805 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
4806 PerlMem_free(vmsfspec);
4811 filespec = vmsfspec;
4813 /* Unless we are forcing to VMS format, a UNIX input means
4814 * UNIX output, and that requires long names to be used
4816 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
4817 opts |= PERL_RMSEXPAND_M_LONG;
4824 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
4825 rms_bind_fab_nam(myfab, mynam);
4827 if (defspec && *defspec) {
4829 t_isunix = is_unix_filespec(defspec);
4831 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
4832 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
4833 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
4834 PerlMem_free(tmpfspec);
4835 if (vmsfspec != NULL)
4836 PerlMem_free(vmsfspec);
4843 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4846 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
4847 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
4848 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4849 esal = PerlMem_malloc(VMS_MAXRSS);
4850 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
4852 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
4854 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4855 rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1));
4858 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
4859 outbufl = PerlMem_malloc(VMS_MAXRSS);
4860 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
4861 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
4863 rms_set_rsa(mynam, outbuf, NAM$C_MAXRSS);
4867 #ifdef NAM$M_NO_SHORT_UPCASE
4868 if (decc_efs_case_preserve)
4869 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
4872 /* We may not want to follow symbolic links */
4873 #ifdef NAML$M_OPEN_SPECIAL
4874 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
4875 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4878 /* First attempt to parse as an existing file */
4879 retsts = sys$parse(&myfab,0,0);
4880 if (!(retsts & STS$K_SUCCESS)) {
4882 /* Could not find the file, try as syntax only if error is not fatal */
4883 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
4884 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
4885 retsts = sys$parse(&myfab,0,0);
4886 if (retsts & STS$K_SUCCESS) goto expanded;
4889 /* Still could not parse the file specification */
4890 /*----------------------------------------------*/
4891 sts = rms_free_search_context(&myfab); /* Free search context */
4892 if (out) Safefree(out);
4893 if (tmpfspec != NULL)
4894 PerlMem_free(tmpfspec);
4895 if (vmsfspec != NULL)
4896 PerlMem_free(vmsfspec);
4897 if (outbufl != NULL)
4898 PerlMem_free(outbufl);
4902 set_vaxc_errno(retsts);
4903 if (retsts == RMS$_PRV) set_errno(EACCES);
4904 else if (retsts == RMS$_DEV) set_errno(ENODEV);
4905 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
4906 else set_errno(EVMSERR);
4909 retsts = sys$search(&myfab,0,0);
4910 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
4911 sts = rms_free_search_context(&myfab); /* Free search context */
4912 if (out) Safefree(out);
4913 if (tmpfspec != NULL)
4914 PerlMem_free(tmpfspec);
4915 if (vmsfspec != NULL)
4916 PerlMem_free(vmsfspec);
4917 if (outbufl != NULL)
4918 PerlMem_free(outbufl);
4922 set_vaxc_errno(retsts);
4923 if (retsts == RMS$_PRV) set_errno(EACCES);
4924 else set_errno(EVMSERR);
4928 /* If the input filespec contained any lowercase characters,
4929 * downcase the result for compatibility with Unix-minded code. */
4931 if (!decc_efs_case_preserve) {
4932 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
4933 if (islower(*tbuf)) { haslower = 1; break; }
4936 /* Is a long or a short name expected */
4937 /*------------------------------------*/
4938 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4939 if (rms_nam_rsll(mynam)) {
4941 speclen = rms_nam_rsll(mynam);
4944 tbuf = esal; /* Not esa */
4945 speclen = rms_nam_esll(mynam);
4949 if (rms_nam_rsl(mynam)) {
4951 speclen = rms_nam_rsl(mynam);
4954 tbuf = esa; /* Not esal */
4955 speclen = rms_nam_esl(mynam);
4958 tbuf[speclen] = '\0';
4960 /* Trim off null fields added by $PARSE
4961 * If type > 1 char, must have been specified in original or default spec
4962 * (not true for version; $SEARCH may have added version of existing file).
4964 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
4965 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
4966 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4967 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
4970 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
4971 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
4973 if (trimver || trimtype) {
4974 if (defspec && *defspec) {
4975 char *defesal = NULL;
4976 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
4977 if (defesal != NULL) {
4978 struct FAB deffab = cc$rms_fab;
4979 rms_setup_nam(defnam);
4981 rms_bind_fab_nam(deffab, defnam);
4985 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
4987 rms_set_esa(deffab, defnam, defesal, VMS_MAXRSS - 1);
4989 rms_clear_nam_nop(defnam);
4990 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
4991 #ifdef NAM$M_NO_SHORT_UPCASE
4992 if (decc_efs_case_preserve)
4993 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
4995 #ifdef NAML$M_OPEN_SPECIAL
4996 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
4997 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4999 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5001 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5004 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5007 PerlMem_free(defesal);
5011 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5012 if (*(rms_nam_verl(mynam)) != '\"')
5013 speclen = rms_nam_verl(mynam) - tbuf;
5016 if (*(rms_nam_ver(mynam)) != '\"')
5017 speclen = rms_nam_ver(mynam) - tbuf;
5021 /* If we didn't already trim version, copy down */
5022 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5023 if (speclen > rms_nam_verl(mynam) - tbuf)
5025 (rms_nam_typel(mynam),
5026 rms_nam_verl(mynam),
5027 speclen - (rms_nam_verl(mynam) - tbuf));
5028 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5031 if (speclen > rms_nam_ver(mynam) - tbuf)
5033 (rms_nam_type(mynam),
5035 speclen - (rms_nam_ver(mynam) - tbuf));
5036 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5041 /* Done with these copies of the input files */
5042 /*-------------------------------------------*/
5043 if (vmsfspec != NULL)
5044 PerlMem_free(vmsfspec);
5045 if (tmpfspec != NULL)
5046 PerlMem_free(tmpfspec);
5048 /* If we just had a directory spec on input, $PARSE "helpfully"
5049 * adds an empty name and type for us */
5050 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5051 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5052 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5053 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5054 speclen = rms_nam_namel(mynam) - tbuf;
5057 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5058 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5059 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5060 speclen = rms_nam_name(mynam) - tbuf;
5063 /* Posix format specifications must have matching quotes */
5064 if (speclen < (VMS_MAXRSS - 1)) {
5065 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5066 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5067 tbuf[speclen] = '\"';
5072 tbuf[speclen] = '\0';
5073 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5075 /* Have we been working with an expanded, but not resultant, spec? */
5076 /* Also, convert back to Unix syntax if necessary. */
5078 if (!rms_nam_rsll(mynam)) {
5080 if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5081 if (out) Safefree(out);
5085 if (outbufl != NULL)
5086 PerlMem_free(outbufl);
5090 else strcpy(outbuf, tbuf);
5093 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5094 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5095 if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) {
5096 if (out) Safefree(out);
5100 PerlMem_free(tmpfspec);
5101 if (outbufl != NULL)
5102 PerlMem_free(outbufl);
5105 strcpy(outbuf,tmpfspec);
5106 PerlMem_free(tmpfspec);
5109 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5110 sts = rms_free_search_context(&myfab); /* Free search context */
5114 if (outbufl != NULL)
5115 PerlMem_free(outbufl);
5119 /* External entry points */
5120 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5121 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5122 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5123 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5124 char *Perl_rmsexpand_utf8
5125 (pTHX_ const char *spec, char *buf, const char *def,
5126 unsigned opt, int * fs_utf8, int * dfs_utf8)
5127 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5128 char *Perl_rmsexpand_utf8_ts
5129 (pTHX_ const char *spec, char *buf, const char *def,
5130 unsigned opt, int * fs_utf8, int * dfs_utf8)
5131 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5135 ** The following routines are provided to make life easier when
5136 ** converting among VMS-style and Unix-style directory specifications.
5137 ** All will take input specifications in either VMS or Unix syntax. On
5138 ** failure, all return NULL. If successful, the routines listed below
5139 ** return a pointer to a buffer containing the appropriately
5140 ** reformatted spec (and, therefore, subsequent calls to that routine
5141 ** will clobber the result), while the routines of the same names with
5142 ** a _ts suffix appended will return a pointer to a mallocd string
5143 ** containing the appropriately reformatted spec.
5144 ** In all cases, only explicit syntax is altered; no check is made that
5145 ** the resulting string is valid or that the directory in question
5148 ** fileify_dirspec() - convert a directory spec into the name of the
5149 ** directory file (i.e. what you can stat() to see if it's a dir).
5150 ** The style (VMS or Unix) of the result is the same as the style
5151 ** of the parameter passed in.
5152 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5153 ** what you prepend to a filename to indicate what directory it's in).
5154 ** The style (VMS or Unix) of the result is the same as the style
5155 ** of the parameter passed in.
5156 ** tounixpath() - convert a directory spec into a Unix-style path.
5157 ** tovmspath() - convert a directory spec into a VMS-style path.
5158 ** tounixspec() - convert any file spec into a Unix-style file spec.
5159 ** tovmsspec() - convert any file spec into a VMS-style spec.
5160 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5162 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5163 ** Permission is given to distribute this code as part of the Perl
5164 ** standard distribution under the terms of the GNU General Public
5165 ** License or the Perl Artistic License. Copies of each may be
5166 ** found in the Perl standard distribution.
5169 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5170 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5172 static char __fileify_retbuf[VMS_MAXRSS];
5173 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5174 char *retspec, *cp1, *cp2, *lastdir;
5175 char *trndir, *vmsdir;
5176 unsigned short int trnlnm_iter_count;
5178 if (utf8_fl != NULL)
5181 if (!dir || !*dir) {
5182 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5184 dirlen = strlen(dir);
5185 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5186 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5187 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5194 if (dirlen > (VMS_MAXRSS - 1)) {
5195 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5198 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5199 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5200 if (!strpbrk(dir+1,"/]>:") &&
5201 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5202 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5203 trnlnm_iter_count = 0;
5204 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5205 trnlnm_iter_count++;
5206 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5208 dirlen = strlen(trndir);
5211 strncpy(trndir,dir,dirlen);
5212 trndir[dirlen] = '\0';
5215 /* At this point we are done with *dir and use *trndir which is a
5216 * copy that can be modified. *dir must not be modified.
5219 /* If we were handed a rooted logical name or spec, treat it like a
5220 * simple directory, so that
5221 * $ Define myroot dev:[dir.]
5222 * ... do_fileify_dirspec("myroot",buf,1) ...
5223 * does something useful.
5225 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5226 trndir[--dirlen] = '\0';
5227 trndir[dirlen-1] = ']';
5229 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5230 trndir[--dirlen] = '\0';
5231 trndir[dirlen-1] = '>';
5234 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5235 /* If we've got an explicit filename, we can just shuffle the string. */
5236 if (*(cp1+1)) hasfilename = 1;
5237 /* Similarly, we can just back up a level if we've got multiple levels
5238 of explicit directories in a VMS spec which ends with directories. */
5240 for (cp2 = cp1; cp2 > trndir; cp2--) {
5242 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5243 /* fix-me, can not scan EFS file specs backward like this */
5244 *cp2 = *cp1; *cp1 = '\0';
5249 if (*cp2 == '[' || *cp2 == '<') break;
5254 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5255 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5256 cp1 = strpbrk(trndir,"]:>");
5257 if (hasfilename || !cp1) { /* Unix-style path or filename */
5258 if (trndir[0] == '.') {
5259 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5260 PerlMem_free(trndir);
5261 PerlMem_free(vmsdir);
5262 return do_fileify_dirspec("[]",buf,ts,NULL);
5264 else if (trndir[1] == '.' &&
5265 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5266 PerlMem_free(trndir);
5267 PerlMem_free(vmsdir);
5268 return do_fileify_dirspec("[-]",buf,ts,NULL);
5271 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5272 dirlen -= 1; /* to last element */
5273 lastdir = strrchr(trndir,'/');
5275 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5276 /* If we have "/." or "/..", VMSify it and let the VMS code
5277 * below expand it, rather than repeating the code to handle
5278 * relative components of a filespec here */
5280 if (*(cp1+2) == '.') cp1++;
5281 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5283 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5284 PerlMem_free(trndir);
5285 PerlMem_free(vmsdir);
5288 if (strchr(vmsdir,'/') != NULL) {
5289 /* If do_tovmsspec() returned it, it must have VMS syntax
5290 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5291 * the time to check this here only so we avoid a recursion
5292 * loop; otherwise, gigo.
5294 PerlMem_free(trndir);
5295 PerlMem_free(vmsdir);
5296 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5299 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5300 PerlMem_free(trndir);
5301 PerlMem_free(vmsdir);
5304 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5305 PerlMem_free(trndir);
5306 PerlMem_free(vmsdir);
5310 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5311 lastdir = strrchr(trndir,'/');
5313 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5315 /* Ditto for specs that end in an MFD -- let the VMS code
5316 * figure out whether it's a real device or a rooted logical. */
5318 /* This should not happen any more. Allowing the fake /000000
5319 * in a UNIX pathname causes all sorts of problems when trying
5320 * to run in UNIX emulation. So the VMS to UNIX conversions
5321 * now remove the fake /000000 directories.
5324 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5325 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5326 PerlMem_free(trndir);
5327 PerlMem_free(vmsdir);
5330 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5331 PerlMem_free(trndir);
5332 PerlMem_free(vmsdir);
5335 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5336 PerlMem_free(trndir);
5337 PerlMem_free(vmsdir);
5342 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5343 !(lastdir = cp1 = strrchr(trndir,']')) &&
5344 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5345 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5348 /* For EFS or ODS-5 look for the last dot */
5349 if (decc_efs_charset) {
5350 cp2 = strrchr(cp1,'.');
5352 if (vms_process_case_tolerant) {
5353 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5354 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5355 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5356 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5357 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5358 (ver || *cp3)))))) {
5359 PerlMem_free(trndir);
5360 PerlMem_free(vmsdir);
5362 set_vaxc_errno(RMS$_DIR);
5367 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5368 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5369 !*(cp2+3) || *(cp2+3) != 'R' ||
5370 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5371 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5372 (ver || *cp3)))))) {
5373 PerlMem_free(trndir);
5374 PerlMem_free(vmsdir);
5376 set_vaxc_errno(RMS$_DIR);
5380 dirlen = cp2 - trndir;
5384 retlen = dirlen + 6;
5385 if (buf) retspec = buf;
5386 else if (ts) Newx(retspec,retlen+1,char);
5387 else retspec = __fileify_retbuf;
5388 memcpy(retspec,trndir,dirlen);
5389 retspec[dirlen] = '\0';
5391 /* We've picked up everything up to the directory file name.
5392 Now just add the type and version, and we're set. */
5393 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5394 strcat(retspec,".dir;1");
5396 strcat(retspec,".DIR;1");
5397 PerlMem_free(trndir);
5398 PerlMem_free(vmsdir);
5401 else { /* VMS-style directory spec */
5403 char *esa, term, *cp;
5404 unsigned long int sts, cmplen, haslower = 0;
5405 unsigned int nam_fnb;
5407 struct FAB dirfab = cc$rms_fab;
5408 rms_setup_nam(savnam);
5409 rms_setup_nam(dirnam);
5411 esa = PerlMem_malloc(VMS_MAXRSS + 1);
5412 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5413 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5414 rms_bind_fab_nam(dirfab, dirnam);
5415 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5416 rms_set_esa(dirfab, dirnam, esa, (VMS_MAXRSS - 1));
5417 #ifdef NAM$M_NO_SHORT_UPCASE
5418 if (decc_efs_case_preserve)
5419 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5422 for (cp = trndir; *cp; cp++)
5423 if (islower(*cp)) { haslower = 1; break; }
5424 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5425 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5426 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5427 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5431 PerlMem_free(trndir);
5432 PerlMem_free(vmsdir);
5434 set_vaxc_errno(dirfab.fab$l_sts);
5440 /* Does the file really exist? */
5441 if (sys$search(&dirfab)& STS$K_SUCCESS) {
5442 /* Yes; fake the fnb bits so we'll check type below */
5443 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
5445 else { /* No; just work with potential name */
5446 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
5449 fab_sts = dirfab.fab$l_sts;
5450 sts = rms_free_search_context(&dirfab);
5452 PerlMem_free(trndir);
5453 PerlMem_free(vmsdir);
5454 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
5459 esa[rms_nam_esll(dirnam)] = '\0';
5460 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
5461 cp1 = strchr(esa,']');
5462 if (!cp1) cp1 = strchr(esa,'>');
5463 if (cp1) { /* Should always be true */
5464 rms_nam_esll(dirnam) -= cp1 - esa - 1;
5465 memmove(esa,cp1 + 1, rms_nam_esll(dirnam));
5468 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5469 /* Yep; check version while we're at it, if it's there. */
5470 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5471 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
5472 /* Something other than .DIR[;1]. Bzzt. */
5473 sts = rms_free_search_context(&dirfab);
5475 PerlMem_free(trndir);
5476 PerlMem_free(vmsdir);
5478 set_vaxc_errno(RMS$_DIR);
5483 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
5484 /* They provided at least the name; we added the type, if necessary, */
5485 if (buf) retspec = buf; /* in sys$parse() */
5486 else if (ts) Newx(retspec, rms_nam_esll(dirnam)+1, char);
5487 else retspec = __fileify_retbuf;
5488 strcpy(retspec,esa);
5489 sts = rms_free_search_context(&dirfab);
5490 PerlMem_free(trndir);
5492 PerlMem_free(vmsdir);
5495 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
5496 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
5498 rms_nam_esll(dirnam) -= 9;
5500 if ((cp1 = strrchr(esa,']')) == NULL) cp1 = strrchr(esa,'>');
5501 if (cp1 == NULL) { /* should never happen */
5502 sts = rms_free_search_context(&dirfab);
5503 PerlMem_free(trndir);
5505 PerlMem_free(vmsdir);
5510 retlen = strlen(esa);
5511 cp1 = strrchr(esa,'.');
5512 /* ODS-5 directory specifications can have extra "." in them. */
5513 /* Fix-me, can not scan EFS file specifications backwards */
5514 while (cp1 != NULL) {
5515 if ((cp1-1 == esa) || (*(cp1-1) != '^'))
5519 while ((cp1 > esa) && (*cp1 != '.'))
5526 if ((cp1) != NULL) {
5527 /* There's more than one directory in the path. Just roll back. */
5529 if (buf) retspec = buf;
5530 else if (ts) Newx(retspec,retlen+7,char);
5531 else retspec = __fileify_retbuf;
5532 strcpy(retspec,esa);
5535 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
5536 /* Go back and expand rooted logical name */
5537 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
5538 #ifdef NAM$M_NO_SHORT_UPCASE
5539 if (decc_efs_case_preserve)
5540 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5542 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
5543 sts = rms_free_search_context(&dirfab);
5545 PerlMem_free(trndir);
5546 PerlMem_free(vmsdir);
5548 set_vaxc_errno(dirfab.fab$l_sts);
5551 retlen = rms_nam_esll(dirnam) - 9; /* esa - '][' - '].DIR;1' */
5552 if (buf) retspec = buf;
5553 else if (ts) Newx(retspec,retlen+16,char);
5554 else retspec = __fileify_retbuf;
5555 cp1 = strstr(esa,"][");
5556 if (!cp1) cp1 = strstr(esa,"]<");
5558 memcpy(retspec,esa,dirlen);
5559 if (!strncmp(cp1+2,"000000]",7)) {
5560 retspec[dirlen-1] = '\0';
5561 /* fix-me Not full ODS-5, just extra dots in directories for now */
5562 cp1 = retspec + dirlen - 1;
5563 while (cp1 > retspec)
5568 if (*(cp1-1) != '^')
5573 if (*cp1 == '.') *cp1 = ']';
5575 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5576 memmove(cp1+1,"000000]",7);
5580 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
5581 retspec[retlen] = '\0';
5582 /* Convert last '.' to ']' */
5583 cp1 = retspec+retlen-1;
5584 while (*cp != '[') {
5587 /* Do not trip on extra dots in ODS-5 directories */
5588 if ((cp1 == retspec) || (*(cp1-1) != '^'))
5592 if (*cp1 == '.') *cp1 = ']';
5594 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
5595 memmove(cp1+1,"000000]",7);
5599 else { /* This is a top-level dir. Add the MFD to the path. */
5600 if (buf) retspec = buf;
5601 else if (ts) Newx(retspec,retlen+16,char);
5602 else retspec = __fileify_retbuf;
5605 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
5606 strcpy(cp2,":[000000]");
5611 sts = rms_free_search_context(&dirfab);
5612 /* We've set up the string up through the filename. Add the
5613 type and version, and we're done. */
5614 strcat(retspec,".DIR;1");
5616 /* $PARSE may have upcased filespec, so convert output to lower
5617 * case if input contained any lowercase characters. */
5618 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
5619 PerlMem_free(trndir);
5621 PerlMem_free(vmsdir);
5624 } /* end of do_fileify_dirspec() */
5626 /* External entry points */
5627 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
5628 { return do_fileify_dirspec(dir,buf,0,NULL); }
5629 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
5630 { return do_fileify_dirspec(dir,buf,1,NULL); }
5631 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
5632 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
5633 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
5634 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
5636 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
5637 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
5639 static char __pathify_retbuf[VMS_MAXRSS];
5640 unsigned long int retlen;
5641 char *retpath, *cp1, *cp2, *trndir;
5642 unsigned short int trnlnm_iter_count;
5645 if (utf8_fl != NULL)
5648 if (!dir || !*dir) {
5649 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5652 trndir = PerlMem_malloc(VMS_MAXRSS);
5653 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5654 if (*dir) strcpy(trndir,dir);
5655 else getcwd(trndir,VMS_MAXRSS - 1);
5657 trnlnm_iter_count = 0;
5658 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
5659 && my_trnlnm(trndir,trndir,0)) {
5660 trnlnm_iter_count++;
5661 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5662 trnlen = strlen(trndir);
5664 /* Trap simple rooted lnms, and return lnm:[000000] */
5665 if (!strcmp(trndir+trnlen-2,".]")) {
5666 if (buf) retpath = buf;
5667 else if (ts) Newx(retpath,strlen(dir)+10,char);
5668 else retpath = __pathify_retbuf;
5669 strcpy(retpath,dir);
5670 strcat(retpath,":[000000]");
5671 PerlMem_free(trndir);
5676 /* At this point we do not work with *dir, but the copy in
5677 * *trndir that is modifiable.
5680 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
5681 if (*trndir == '.' && (*(trndir+1) == '\0' ||
5682 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
5683 retlen = 2 + (*(trndir+1) != '\0');
5685 if ( !(cp1 = strrchr(trndir,'/')) &&
5686 !(cp1 = strrchr(trndir,']')) &&
5687 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
5688 if ((cp2 = strchr(cp1,'.')) != NULL &&
5689 (*(cp2-1) != '/' || /* Trailing '.', '..', */
5690 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
5691 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
5692 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
5695 /* For EFS or ODS-5 look for the last dot */
5696 if (decc_efs_charset) {
5697 cp2 = strrchr(cp1,'.');
5699 if (vms_process_case_tolerant) {
5700 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5701 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5702 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5703 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5704 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5705 (ver || *cp3)))))) {
5706 PerlMem_free(trndir);
5708 set_vaxc_errno(RMS$_DIR);
5713 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5714 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5715 !*(cp2+3) || *(cp2+3) != 'R' ||
5716 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5717 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5718 (ver || *cp3)))))) {
5719 PerlMem_free(trndir);
5721 set_vaxc_errno(RMS$_DIR);
5725 retlen = cp2 - trndir + 1;
5727 else { /* No file type present. Treat the filename as a directory. */
5728 retlen = strlen(trndir) + 1;
5731 if (buf) retpath = buf;
5732 else if (ts) Newx(retpath,retlen+1,char);
5733 else retpath = __pathify_retbuf;
5734 strncpy(retpath, trndir, retlen-1);
5735 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
5736 retpath[retlen-1] = '/'; /* with '/', add it. */
5737 retpath[retlen] = '\0';
5739 else retpath[retlen-1] = '\0';
5741 else { /* VMS-style directory spec */
5743 unsigned long int sts, cmplen, haslower;
5744 struct FAB dirfab = cc$rms_fab;
5746 rms_setup_nam(savnam);
5747 rms_setup_nam(dirnam);
5749 /* If we've got an explicit filename, we can just shuffle the string. */
5750 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
5751 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
5752 if ((cp2 = strchr(cp1,'.')) != NULL) {
5754 if (vms_process_case_tolerant) {
5755 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5756 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5757 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5758 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5759 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5760 (ver || *cp3)))))) {
5761 PerlMem_free(trndir);
5763 set_vaxc_errno(RMS$_DIR);
5768 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5769 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5770 !*(cp2+3) || *(cp2+3) != 'R' ||
5771 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5772 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5773 (ver || *cp3)))))) {
5774 PerlMem_free(trndir);
5776 set_vaxc_errno(RMS$_DIR);
5781 else { /* No file type, so just draw name into directory part */
5782 for (cp2 = cp1; *cp2; cp2++) ;
5785 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
5787 /* We've now got a VMS 'path'; fall through */
5790 dirlen = strlen(trndir);
5791 if (trndir[dirlen-1] == ']' ||
5792 trndir[dirlen-1] == '>' ||
5793 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
5794 if (buf) retpath = buf;
5795 else if (ts) Newx(retpath,strlen(trndir)+1,char);
5796 else retpath = __pathify_retbuf;
5797 strcpy(retpath,trndir);
5798 PerlMem_free(trndir);
5801 rms_set_fna(dirfab, dirnam, trndir, dirlen);
5802 esa = PerlMem_malloc(VMS_MAXRSS);
5803 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5804 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5805 rms_bind_fab_nam(dirfab, dirnam);
5806 rms_set_esa(dirfab, dirnam, esa, VMS_MAXRSS - 1);
5807 #ifdef NAM$M_NO_SHORT_UPCASE
5808 if (decc_efs_case_preserve)
5809 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5812 for (cp = trndir; *cp; cp++)
5813 if (islower(*cp)) { haslower = 1; break; }
5815 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
5816 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5817 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5818 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5821 PerlMem_free(trndir);
5824 set_vaxc_errno(dirfab.fab$l_sts);
5830 /* Does the file really exist? */
5831 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
5832 if (dirfab.fab$l_sts != RMS$_FNF) {
5834 sts1 = rms_free_search_context(&dirfab);
5835 PerlMem_free(trndir);
5838 set_vaxc_errno(dirfab.fab$l_sts);
5841 dirnam = savnam; /* No; just work with potential name */
5844 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
5845 /* Yep; check version while we're at it, if it's there. */
5846 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
5847 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
5849 /* Something other than .DIR[;1]. Bzzt. */
5850 sts2 = rms_free_search_context(&dirfab);
5851 PerlMem_free(trndir);
5854 set_vaxc_errno(RMS$_DIR);
5858 /* OK, the type was fine. Now pull any file name into the
5860 if ((cp1 = strrchr(esa,']'))) *(rms_nam_typel(dirnam)) = ']';
5862 cp1 = strrchr(esa,'>');
5863 *(rms_nam_typel(dirnam)) = '>';
5866 *(rms_nam_typel(dirnam) + 1) = '\0';
5867 retlen = (rms_nam_typel(dirnam)) - esa + 2;
5868 if (buf) retpath = buf;
5869 else if (ts) Newx(retpath,retlen,char);
5870 else retpath = __pathify_retbuf;
5871 strcpy(retpath,esa);
5873 sts = rms_free_search_context(&dirfab);
5874 /* $PARSE may have upcased filespec, so convert output to lower
5875 * case if input contained any lowercase characters. */
5876 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
5879 PerlMem_free(trndir);
5881 } /* end of do_pathify_dirspec() */
5883 /* External entry points */
5884 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
5885 { return do_pathify_dirspec(dir,buf,0,NULL); }
5886 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
5887 { return do_pathify_dirspec(dir,buf,1,NULL); }
5888 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
5889 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
5890 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
5891 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
5893 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
5894 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
5896 static char __tounixspec_retbuf[VMS_MAXRSS];
5897 char *dirend, *rslt, *cp1, *cp3, *tmp;
5899 int devlen, dirlen, retlen = VMS_MAXRSS;
5900 int expand = 1; /* guarantee room for leading and trailing slashes */
5901 unsigned short int trnlnm_iter_count;
5903 if (utf8_fl != NULL)
5906 if (spec == NULL) return NULL;
5907 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
5908 if (buf) rslt = buf;
5910 Newx(rslt, VMS_MAXRSS, char);
5912 else rslt = __tounixspec_retbuf;
5914 /* New VMS specific format needs translation
5915 * glob passes filenames with trailing '\n' and expects this preserved.
5917 if (decc_posix_compliant_pathnames) {
5918 if (strncmp(spec, "\"^UP^", 5) == 0) {
5924 tunix = PerlMem_malloc(VMS_MAXRSS);
5925 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
5926 strcpy(tunix, spec);
5927 tunix_len = strlen(tunix);
5929 if (tunix[tunix_len - 1] == '\n') {
5930 tunix[tunix_len - 1] = '\"';
5931 tunix[tunix_len] = '\0';
5935 uspec = decc$translate_vms(tunix);
5936 PerlMem_free(tunix);
5937 if ((int)uspec > 0) {
5943 /* If we can not translate it, makemaker wants as-is */
5951 cmp_rslt = 0; /* Presume VMS */
5952 cp1 = strchr(spec, '/');
5956 /* Look for EFS ^/ */
5957 if (decc_efs_charset) {
5958 while (cp1 != NULL) {
5961 /* Found illegal VMS, assume UNIX */
5966 cp1 = strchr(cp1, '/');
5970 /* Look for "." and ".." */
5971 if (decc_filename_unix_report) {
5972 if (spec[0] == '.') {
5973 if ((spec[1] == '\0') || (spec[1] == '\n')) {
5977 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
5983 /* This is already UNIX or at least nothing VMS understands */
5991 dirend = strrchr(spec,']');
5992 if (dirend == NULL) dirend = strrchr(spec,'>');
5993 if (dirend == NULL) dirend = strchr(spec,':');
5994 if (dirend == NULL) {
5999 /* Special case 1 - sys$posix_root = / */
6000 #if __CRTL_VER >= 70000000
6001 if (!decc_disable_posix_root) {
6002 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6010 /* Special case 2 - Convert NLA0: to /dev/null */
6011 #if __CRTL_VER < 70000000
6012 cmp_rslt = strncmp(spec,"NLA0:", 5);
6014 cmp_rslt = strncmp(spec,"nla0:", 5);
6016 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6018 if (cmp_rslt == 0) {
6019 strcpy(rslt, "/dev/null");
6022 if (spec[6] != '\0') {
6029 /* Also handle special case "SYS$SCRATCH:" */
6030 #if __CRTL_VER < 70000000
6031 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6033 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6035 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6037 tmp = PerlMem_malloc(VMS_MAXRSS);
6038 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6039 if (cmp_rslt == 0) {
6042 islnm = my_trnlnm(tmp, "TMP", 0);
6044 strcpy(rslt, "/tmp");
6047 if (spec[12] != '\0') {
6055 if (*cp2 != '[' && *cp2 != '<') {
6058 else { /* the VMS spec begins with directories */
6060 if (*cp2 == ']' || *cp2 == '>') {
6061 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6065 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6066 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6067 if (ts) Safefree(rslt);
6071 trnlnm_iter_count = 0;
6074 while (*cp3 != ':' && *cp3) cp3++;
6076 if (strchr(cp3,']') != NULL) break;
6077 trnlnm_iter_count++;
6078 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6079 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6081 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6082 retlen = devlen + dirlen;
6083 Renew(rslt,retlen+1+2*expand,char);
6089 *(cp1++) = *(cp3++);
6090 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6092 return NULL; /* No room */
6097 if ((*cp2 == '^')) {
6098 /* EFS file escape, pass the next character as is */
6099 /* Fix me: HEX encoding for Unicode not implemented */
6102 else if ( *cp2 == '.') {
6103 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6104 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6111 for (; cp2 <= dirend; cp2++) {
6112 if ((*cp2 == '^')) {
6113 /* EFS file escape, pass the next character as is */
6114 /* Fix me: HEX encoding for Unicode not implemented */
6115 *(cp1++) = *(++cp2);
6116 /* An escaped dot stays as is -- don't convert to slash */
6117 if (*cp2 == '.') cp2++;
6121 if (*(cp2+1) == '[') cp2++;
6123 else if (*cp2 == ']' || *cp2 == '>') {
6124 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6126 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6128 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6129 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6130 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6131 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6132 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6134 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6135 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6139 else if (*cp2 == '-') {
6140 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6141 while (*cp2 == '-') {
6143 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6145 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6146 if (ts) Safefree(rslt); /* filespecs like */
6147 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6151 else *(cp1++) = *cp2;
6153 else *(cp1++) = *cp2;
6156 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6157 *(cp1++) = *(cp2++);
6161 /* This still leaves /000000/ when working with a
6162 * VMS device root or concealed root.
6168 ulen = strlen(rslt);
6170 /* Get rid of "000000/ in rooted filespecs */
6172 zeros = strstr(rslt, "/000000/");
6173 if (zeros != NULL) {
6175 mlen = ulen - (zeros - rslt) - 7;
6176 memmove(zeros, &zeros[7], mlen);
6185 } /* end of do_tounixspec() */
6187 /* External entry points */
6188 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6189 { return do_tounixspec(spec,buf,0, NULL); }
6190 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6191 { return do_tounixspec(spec,buf,1, NULL); }
6192 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6193 { return do_tounixspec(spec,buf,0, utf8_fl); }
6194 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6195 { return do_tounixspec(spec,buf,1, utf8_fl); }
6197 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6200 This procedure is used to identify if a path is based in either
6201 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6202 it returns the OpenVMS format directory for it.
6204 It is expecting specifications of only '/' or '/xxxx/'
6206 If a posix root does not exist, or 'xxxx' is not a directory
6207 in the posix root, it returns a failure.
6209 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6211 It is used only internally by posix_to_vmsspec_hardway().
6214 static int posix_root_to_vms
6215 (char *vmspath, int vmspath_len,
6216 const char *unixpath,
6217 const int * utf8_fl) {
6219 struct FAB myfab = cc$rms_fab;
6220 struct NAML mynam = cc$rms_naml;
6221 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6222 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6229 unixlen = strlen(unixpath);
6235 #if __CRTL_VER >= 80200000
6236 /* If not a posix spec already, convert it */
6237 if (decc_posix_compliant_pathnames) {
6238 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6239 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6242 /* This is already a VMS specification, no conversion */
6244 strncpy(vmspath,unixpath, vmspath_len);
6253 /* Check to see if this is under the POSIX root */
6254 if (decc_disable_posix_root) {
6258 /* Skip leading / */
6259 if (unixpath[0] == '/') {
6265 strcpy(vmspath,"SYS$POSIX_ROOT:");
6267 /* If this is only the / , or blank, then... */
6268 if (unixpath[0] == '\0') {
6269 /* by definition, this is the answer */
6273 /* Need to look up a directory */
6277 /* Copy and add '^' escape characters as needed */
6280 while (unixpath[i] != 0) {
6283 j += copy_expand_unix_filename_escape
6284 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6288 path_len = strlen(vmspath);
6289 if (vmspath[path_len - 1] == '/')
6291 vmspath[path_len] = ']';
6293 vmspath[path_len] = '\0';
6296 vmspath[vmspath_len] = 0;
6297 if (unixpath[unixlen - 1] == '/')
6299 esa = PerlMem_malloc(VMS_MAXRSS);
6300 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6301 myfab.fab$l_fna = vmspath;
6302 myfab.fab$b_fns = strlen(vmspath);
6303 myfab.fab$l_naml = &mynam;
6304 mynam.naml$l_esa = NULL;
6305 mynam.naml$b_ess = 0;
6306 mynam.naml$l_long_expand = esa;
6307 mynam.naml$l_long_expand_alloc = (unsigned char) VMS_MAXRSS - 1;
6308 mynam.naml$l_rsa = NULL;
6309 mynam.naml$b_rss = 0;
6310 if (decc_efs_case_preserve)
6311 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6312 #ifdef NAML$M_OPEN_SPECIAL
6313 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6316 /* Set up the remaining naml fields */
6317 sts = sys$parse(&myfab);
6319 /* It failed! Try again as a UNIX filespec */
6325 /* get the Device ID and the FID */
6326 sts = sys$search(&myfab);
6327 /* on any failure, returned the POSIX ^UP^ filespec */
6332 specdsc.dsc$a_pointer = vmspath;
6333 specdsc.dsc$w_length = vmspath_len;
6335 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6336 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6337 sts = lib$fid_to_name
6338 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6340 /* on any failure, returned the POSIX ^UP^ filespec */
6342 /* This can happen if user does not have permission to read directories */
6343 if (strncmp(unixpath,"\"^UP^",5) != 0)
6344 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6346 strcpy(vmspath, unixpath);
6349 vmspath[specdsc.dsc$w_length] = 0;
6351 /* Are we expecting a directory? */
6352 if (dir_flag != 0) {
6358 i = specdsc.dsc$w_length - 1;
6362 /* Version must be '1' */
6363 if (vmspath[i--] != '1')
6365 /* Version delimiter is one of ".;" */
6366 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6369 if (vmspath[i--] != 'R')
6371 if (vmspath[i--] != 'I')
6373 if (vmspath[i--] != 'D')
6375 if (vmspath[i--] != '.')
6377 eptr = &vmspath[i+1];
6379 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
6380 if (vmspath[i-1] != '^') {
6388 /* Get rid of 6 imaginary zero directory filename */
6389 vmspath[i+1] = '\0';
6393 if (vmspath[i] == '0')
6407 /* /dev/mumble needs to be handled special.
6408 /dev/null becomes NLA0:, And there is the potential for other stuff
6409 like /dev/tty which may need to be mapped to something.
6413 slash_dev_special_to_vms
6414 (const char * unixptr,
6424 nextslash = strchr(unixptr, '/');
6425 len = strlen(unixptr);
6426 if (nextslash != NULL)
6427 len = nextslash - unixptr;
6428 cmp = strncmp("null", unixptr, 5);
6430 if (vmspath_len >= 6) {
6431 strcpy(vmspath, "_NLA0:");
6438 /* The built in routines do not understand perl's special needs, so
6439 doing a manual conversion from UNIX to VMS
6441 If the utf8_fl is not null and points to a non-zero value, then
6442 treat 8 bit characters as UTF-8.
6444 The sequence starting with '$(' and ending with ')' will be passed
6445 through with out interpretation instead of being escaped.
6448 static int posix_to_vmsspec_hardway
6449 (char *vmspath, int vmspath_len,
6450 const char *unixpath,
6455 const char *unixptr;
6456 const char *unixend;
6458 const char *lastslash;
6459 const char *lastdot;
6465 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6466 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6468 if (utf8_fl != NULL)
6474 /* Ignore leading "/" characters */
6475 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
6478 unixlen = strlen(unixptr);
6480 /* Do nothing with blank paths */
6487 /* This could have a "^UP^ on the front */
6488 if (strncmp(unixptr,"\"^UP^",5) == 0) {
6494 lastslash = strrchr(unixptr,'/');
6495 lastdot = strrchr(unixptr,'.');
6496 unixend = strrchr(unixptr,'\"');
6497 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
6498 unixend = unixptr + unixlen;
6501 /* last dot is last dot or past end of string */
6502 if (lastdot == NULL)
6503 lastdot = unixptr + unixlen;
6505 /* if no directories, set last slash to beginning of string */
6506 if (lastslash == NULL) {
6507 lastslash = unixptr;
6510 /* Watch out for trailing "." after last slash, still a directory */
6511 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
6512 lastslash = unixptr + unixlen;
6515 /* Watch out for traiing ".." after last slash, still a directory */
6516 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
6517 lastslash = unixptr + unixlen;
6520 /* dots in directories are aways escaped */
6521 if (lastdot < lastslash)
6522 lastdot = unixptr + unixlen;
6525 /* if (unixptr < lastslash) then we are in a directory */
6532 /* Start with the UNIX path */
6533 if (*unixptr != '/') {
6534 /* relative paths */
6536 /* If allowing logical names on relative pathnames, then handle here */
6537 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
6538 !decc_posix_compliant_pathnames) {
6544 /* Find the next slash */
6545 nextslash = strchr(unixptr,'/');
6547 esa = PerlMem_malloc(vmspath_len);
6548 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6550 trn = PerlMem_malloc(VMS_MAXRSS);
6551 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6553 if (nextslash != NULL) {
6555 seg_len = nextslash - unixptr;
6556 strncpy(esa, unixptr, seg_len);
6560 strcpy(esa, unixptr);
6561 seg_len = strlen(unixptr);
6563 /* trnlnm(section) */
6564 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
6567 /* Now fix up the directory */
6569 /* Split up the path to find the components */
6570 sts = vms_split_path
6589 /* A logical name must be a directory or the full
6590 specification. It is only a full specification if
6591 it is the only component */
6592 if ((unixptr[seg_len] == '\0') ||
6593 (unixptr[seg_len+1] == '\0')) {
6595 /* Is a directory being required? */
6596 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
6597 /* Not a logical name */
6602 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
6603 /* This must be a directory */
6604 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
6605 strcpy(vmsptr, esa);
6606 vmslen=strlen(vmsptr);
6607 vmsptr[vmslen] = ':';
6609 vmsptr[vmslen] = '\0';
6617 /* must be dev/directory - ignore version */
6618 if ((n_len + e_len) != 0)
6621 /* transfer the volume */
6622 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
6623 strncpy(vmsptr, v_spec, v_len);
6629 /* unroot the rooted directory */
6630 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
6632 r_spec[r_len - 1] = ']';
6634 /* This should not be there, but nothing is perfect */
6636 cmp = strcmp(&r_spec[1], "000000.");
6646 strncpy(vmsptr, r_spec, r_len);
6652 /* Bring over the directory. */
6654 ((d_len + vmslen) < vmspath_len)) {
6656 d_spec[d_len - 1] = ']';
6658 cmp = strcmp(&d_spec[1], "000000.");
6669 /* Remove the redundant root */
6677 strncpy(vmsptr, d_spec, d_len);
6691 if (lastslash > unixptr) {
6694 /* skip leading ./ */
6696 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
6702 /* Are we still in a directory? */
6703 if (unixptr <= lastslash) {
6708 /* if not backing up, then it is relative forward. */
6709 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
6710 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
6718 /* Perl wants an empty directory here to tell the difference
6719 * between a DCL commmand and a filename
6728 /* Handle two special files . and .. */
6729 if (unixptr[0] == '.') {
6730 if (&unixptr[1] == unixend) {
6737 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
6748 else { /* Absolute PATH handling */
6752 /* Need to find out where root is */
6754 /* In theory, this procedure should never get an absolute POSIX pathname
6755 * that can not be found on the POSIX root.
6756 * In practice, that can not be relied on, and things will show up
6757 * here that are a VMS device name or concealed logical name instead.
6758 * So to make things work, this procedure must be tolerant.
6760 esa = PerlMem_malloc(vmspath_len);
6761 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6764 nextslash = strchr(&unixptr[1],'/');
6766 if (nextslash != NULL) {
6768 seg_len = nextslash - &unixptr[1];
6769 strncpy(vmspath, unixptr, seg_len + 1);
6770 vmspath[seg_len+1] = 0;
6773 cmp = strncmp(vmspath, "dev", 4);
6775 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
6776 if (sts = SS$_NORMAL)
6780 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
6783 if ($VMS_STATUS_SUCCESS(sts)) {
6784 /* This is verified to be a real path */
6786 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
6787 if ($VMS_STATUS_SUCCESS(sts)) {
6788 strcpy(vmspath, esa);
6789 vmslen = strlen(vmspath);
6790 vmsptr = vmspath + vmslen;
6792 if (unixptr < lastslash) {
6801 cmp = strcmp(rptr,"000000.");
6806 } /* removing 6 zeros */
6807 } /* vmslen < 7, no 6 zeros possible */
6808 } /* Not in a directory */
6809 } /* Posix root found */
6811 /* No posix root, fall back to default directory */
6812 strcpy(vmspath, "SYS$DISK:[");
6813 vmsptr = &vmspath[10];
6815 if (unixptr > lastslash) {
6824 } /* end of verified real path handling */
6829 /* Ok, we have a device or a concealed root that is not in POSIX
6830 * or we have garbage. Make the best of it.
6833 /* Posix to VMS destroyed this, so copy it again */
6834 strncpy(vmspath, &unixptr[1], seg_len);
6835 vmspath[seg_len] = 0;
6837 vmsptr = &vmsptr[vmslen];
6840 /* Now do we need to add the fake 6 zero directory to it? */
6842 if ((*lastslash == '/') && (nextslash < lastslash)) {
6843 /* No there is another directory */
6850 /* now we have foo:bar or foo:[000000]bar to decide from */
6851 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
6853 if (!islnm && !decc_posix_compliant_pathnames) {
6855 cmp = strncmp("bin", vmspath, 4);
6857 /* bin => SYS$SYSTEM: */
6858 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
6861 /* tmp => SYS$SCRATCH: */
6862 cmp = strncmp("tmp", vmspath, 4);
6864 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
6869 trnend = islnm ? islnm - 1 : 0;
6871 /* if this was a logical name, ']' or '>' must be present */
6872 /* if not a logical name, then assume a device and hope. */
6873 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
6875 /* if log name and trailing '.' then rooted - treat as device */
6876 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
6878 /* Fix me, if not a logical name, a device lookup should be
6879 * done to see if the device is file structured. If the device
6880 * is not file structured, the 6 zeros should not be put on.
6882 * As it is, perl is occasionally looking for dev:[000000]tty.
6883 * which looks a little strange.
6885 * Not that easy to detect as "/dev" may be file structured with
6886 * special device files.
6889 if ((add_6zero == 0) && (*nextslash == '/') &&
6890 (&nextslash[1] == unixend)) {
6891 /* No real directory present */
6896 /* Put the device delimiter on */
6899 unixptr = nextslash;
6902 /* Start directory if needed */
6903 if (!islnm || add_6zero) {
6909 /* add fake 000000] if needed */
6922 } /* non-POSIX translation */
6924 } /* End of relative/absolute path handling */
6926 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
6933 if (dir_start != 0) {
6935 /* First characters in a directory are handled special */
6936 while ((*unixptr == '/') ||
6937 ((*unixptr == '.') &&
6938 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
6939 (&unixptr[1]==unixend)))) {
6944 /* Skip redundant / in specification */
6945 while ((*unixptr == '/') && (dir_start != 0)) {
6948 if (unixptr == lastslash)
6951 if (unixptr == lastslash)
6954 /* Skip redundant ./ characters */
6955 while ((*unixptr == '.') &&
6956 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
6959 if (unixptr == lastslash)
6961 if (*unixptr == '/')
6964 if (unixptr == lastslash)
6967 /* Skip redundant ../ characters */
6968 while ((*unixptr == '.') && (unixptr[1] == '.') &&
6969 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
6970 /* Set the backing up flag */
6976 unixptr++; /* first . */
6977 unixptr++; /* second . */
6978 if (unixptr == lastslash)
6980 if (*unixptr == '/') /* The slash */
6983 if (unixptr == lastslash)
6986 /* To do: Perl expects /.../ to be translated to [...] on VMS */
6987 /* Not needed when VMS is pretending to be UNIX. */
6989 /* Is this loop stuck because of too many dots? */
6990 if (loop_flag == 0) {
6991 /* Exit the loop and pass the rest through */
6996 /* Are we done with directories yet? */
6997 if (unixptr >= lastslash) {
6999 /* Watch out for trailing dots */
7008 if (*unixptr == '/')
7012 /* Have we stopped backing up? */
7017 /* dir_start continues to be = 1 */
7019 if (*unixptr == '-') {
7021 *vmsptr++ = *unixptr++;
7025 /* Now are we done with directories yet? */
7026 if (unixptr >= lastslash) {
7028 /* Watch out for trailing dots */
7044 if (unixptr >= unixend)
7047 /* Normal characters - More EFS work probably needed */
7053 /* remove multiple / */
7054 while (unixptr[1] == '/') {
7057 if (unixptr == lastslash) {
7058 /* Watch out for trailing dots */
7070 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7071 /* Not needed when VMS is pretending to be UNIX. */
7075 if (unixptr != unixend)
7080 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7081 (&unixptr[1] == unixend)) {
7087 /* trailing dot ==> '^..' on VMS */
7088 if (unixptr == unixend) {
7096 *vmsptr++ = *unixptr++;
7100 if (quoted && (&unixptr[1] == unixend)) {
7104 in_cnt = copy_expand_unix_filename_escape
7105 (vmsptr, unixptr, &out_cnt, utf8_fl);
7115 in_cnt = copy_expand_unix_filename_escape
7116 (vmsptr, unixptr, &out_cnt, utf8_fl);
7123 /* Make sure directory is closed */
7124 if (unixptr == lastslash) {
7126 vmsptr2 = vmsptr - 1;
7128 if (*vmsptr2 != ']') {
7131 /* directories do not end in a dot bracket */
7132 if (*vmsptr2 == '.') {
7136 if (*vmsptr2 != '^') {
7137 vmsptr--; /* back up over the dot */
7145 /* Add a trailing dot if a file with no extension */
7146 vmsptr2 = vmsptr - 1;
7148 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7149 (*vmsptr2 != ')') && (*lastdot != '.')) {
7160 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7161 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7166 /* If a UTF8 flag is being passed, honor it */
7168 if (utf8_fl != NULL) {
7169 utf8_flag = *utf8_fl;
7174 /* If there is a possibility of UTF8, then if any UTF8 characters
7175 are present, then they must be converted to VTF-7
7177 result = strcpy(rslt, path); /* FIX-ME */
7180 result = strcpy(rslt, path);
7186 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7187 static char *mp_do_tovmsspec
7188 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7189 static char __tovmsspec_retbuf[VMS_MAXRSS];
7190 char *rslt, *dirend;
7195 unsigned long int infront = 0, hasdir = 1;
7198 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7199 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7201 if (path == NULL) return NULL;
7202 rslt_len = VMS_MAXRSS-1;
7203 if (buf) rslt = buf;
7204 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7205 else rslt = __tovmsspec_retbuf;
7207 /* '.' and '..' are "[]" and "[-]" for a quick check */
7208 if (path[0] == '.') {
7209 if (path[1] == '\0') {
7211 if (utf8_flag != NULL)
7216 if (path[1] == '.' && path[2] == '\0') {
7218 if (utf8_flag != NULL)
7225 /* Posix specifications are now a native VMS format */
7226 /*--------------------------------------------------*/
7227 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7228 if (decc_posix_compliant_pathnames) {
7229 if (strncmp(path,"\"^UP^",5) == 0) {
7230 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7236 /* This is really the only way to see if this is already in VMS format */
7237 sts = vms_split_path
7252 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7253 replacement, because the above parse just took care of most of
7254 what is needed to do vmspath when the specification is already
7257 And if it is not already, it is easier to do the conversion as
7258 part of this routine than to call this routine and then work on
7262 /* If VMS punctuation was found, it is already VMS format */
7263 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7264 if (utf8_flag != NULL)
7269 /* Now, what to do with trailing "." cases where there is no
7270 extension? If this is a UNIX specification, and EFS characters
7271 are enabled, then the trailing "." should be converted to a "^.".
7272 But if this was already a VMS specification, then it should be
7275 So in the case of ambiguity, leave the specification alone.
7279 /* If there is a possibility of UTF8, then if any UTF8 characters
7280 are present, then they must be converted to VTF-7
7282 if (utf8_flag != NULL)
7288 dirend = strrchr(path,'/');
7290 if (dirend == NULL) {
7291 /* If we get here with no UNIX directory delimiters, then this is
7292 not a complete file specification, either garbage a UNIX glob
7293 specification that can not be converted to a VMS wildcard, or
7294 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7295 so apparently other programs expect this also.
7297 utf8 flag setting needs to be preserved.
7303 /* If POSIX mode active, handle the conversion */
7304 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7305 if (decc_efs_charset) {
7306 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7311 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7312 if (!*(dirend+2)) dirend +=2;
7313 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7314 if (decc_efs_charset == 0) {
7315 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7321 lastdot = strrchr(cp2,'.');
7327 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7329 if (decc_disable_posix_root) {
7330 strcpy(rslt,"sys$disk:[000000]");
7333 strcpy(rslt,"sys$posix_root:[000000]");
7335 if (utf8_flag != NULL)
7339 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7341 trndev = PerlMem_malloc(VMS_MAXRSS);
7342 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7343 islnm = my_trnlnm(rslt,trndev,0);
7345 /* DECC special handling */
7347 if (strcmp(rslt,"bin") == 0) {
7348 strcpy(rslt,"sys$system");
7351 islnm = my_trnlnm(rslt,trndev,0);
7353 else if (strcmp(rslt,"tmp") == 0) {
7354 strcpy(rslt,"sys$scratch");
7357 islnm = my_trnlnm(rslt,trndev,0);
7359 else if (!decc_disable_posix_root) {
7360 strcpy(rslt, "sys$posix_root");
7364 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7365 islnm = my_trnlnm(rslt,trndev,0);
7367 else if (strcmp(rslt,"dev") == 0) {
7368 if (strncmp(cp2,"/null", 5) == 0) {
7369 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7370 strcpy(rslt,"NLA0");
7374 islnm = my_trnlnm(rslt,trndev,0);
7380 trnend = islnm ? strlen(trndev) - 1 : 0;
7381 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
7382 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
7383 /* If the first element of the path is a logical name, determine
7384 * whether it has to be translated so we can add more directories. */
7385 if (!islnm || rooted) {
7388 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
7392 if (cp2 != dirend) {
7393 strcpy(rslt,trndev);
7394 cp1 = rslt + trnend;
7401 if (decc_disable_posix_root) {
7407 PerlMem_free(trndev);
7412 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
7413 cp2 += 2; /* skip over "./" - it's redundant */
7414 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
7416 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7417 *(cp1++) = '-'; /* "../" --> "-" */
7420 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
7421 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
7422 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7423 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
7426 else if ((cp2 != lastdot) || (lastdot < dirend)) {
7427 /* Escape the extra dots in EFS file specifications */
7430 if (cp2 > dirend) cp2 = dirend;
7432 else *(cp1++) = '.';
7434 for (; cp2 < dirend; cp2++) {
7436 if (*(cp2-1) == '/') continue;
7437 if (*(cp1-1) != '.') *(cp1++) = '.';
7440 else if (!infront && *cp2 == '.') {
7441 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
7442 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
7443 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
7444 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
7445 else if (*(cp1-2) == '[') *(cp1-1) = '-';
7446 else { /* back up over previous directory name */
7448 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
7449 if (*(cp1-1) == '[') {
7450 memcpy(cp1,"000000.",7);
7455 if (cp2 == dirend) break;
7457 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
7458 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
7459 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
7460 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
7462 *(cp1++) = '.'; /* Simulate trailing '/' */
7463 cp2 += 2; /* for loop will incr this to == dirend */
7465 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
7468 if (decc_efs_charset == 0)
7469 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
7471 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
7477 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
7479 if (decc_efs_charset == 0)
7486 else *(cp1++) = *cp2;
7490 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
7491 if (hasdir) *(cp1++) = ']';
7492 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
7493 /* fixme for ODS5 */
7500 if (decc_efs_charset == 0)
7511 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
7512 decc_readdir_dropdotnotype) {
7517 /* trailing dot ==> '^..' on VMS */
7524 *(cp1++) = *(cp2++);
7529 /* This could be a macro to be passed through */
7530 *(cp1++) = *(cp2++);
7532 const char * save_cp2;
7536 /* paranoid check */
7542 *(cp1++) = *(cp2++);
7543 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7544 *(cp1++) = *(cp2++);
7545 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
7546 *(cp1++) = *(cp2++);
7549 *(cp1++) = *(cp2++);
7553 if (is_macro == 0) {
7554 /* Not really a macro - never mind */
7567 /* Don't escape again if following character is
7568 * already something we escape.
7570 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
7571 *(cp1++) = *(cp2++);
7574 /* But otherwise fall through and escape it. */
7592 *(cp1++) = *(cp2++);
7595 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
7596 * which is wrong. UNIX notation should be ".dir." unless
7597 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
7598 * changing this behavior could break more things at this time.
7599 * efs character set effectively does not allow "." to be a version
7600 * delimiter as a further complication about changing this.
7602 if (decc_filename_unix_report != 0) {
7605 *(cp1++) = *(cp2++);
7608 *(cp1++) = *(cp2++);
7611 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
7615 /* Fix me for "^]", but that requires making sure that you do
7616 * not back up past the start of the filename
7618 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
7623 if (utf8_flag != NULL)
7627 } /* end of do_tovmsspec() */
7629 /* External entry points */
7630 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
7631 { return do_tovmsspec(path,buf,0,NULL); }
7632 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
7633 { return do_tovmsspec(path,buf,1,NULL); }
7634 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7635 { return do_tovmsspec(path,buf,0,utf8_fl); }
7636 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7637 { return do_tovmsspec(path,buf,1,utf8_fl); }
7639 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
7640 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7641 static char __tovmspath_retbuf[VMS_MAXRSS];
7643 char *pathified, *vmsified, *cp;
7645 if (path == NULL) return NULL;
7646 pathified = PerlMem_malloc(VMS_MAXRSS);
7647 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7648 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7649 PerlMem_free(pathified);
7655 Newx(vmsified, VMS_MAXRSS, char);
7656 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
7657 PerlMem_free(pathified);
7658 if (vmsified) Safefree(vmsified);
7661 PerlMem_free(pathified);
7666 vmslen = strlen(vmsified);
7667 Newx(cp,vmslen+1,char);
7668 memcpy(cp,vmsified,vmslen);
7674 strcpy(__tovmspath_retbuf,vmsified);
7676 return __tovmspath_retbuf;
7679 } /* end of do_tovmspath() */
7681 /* External entry points */
7682 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
7683 { return do_tovmspath(path,buf,0, NULL); }
7684 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
7685 { return do_tovmspath(path,buf,1, NULL); }
7686 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
7687 { return do_tovmspath(path,buf,0,utf8_fl); }
7688 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
7689 { return do_tovmspath(path,buf,1,utf8_fl); }
7692 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
7693 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
7694 static char __tounixpath_retbuf[VMS_MAXRSS];
7696 char *pathified, *unixified, *cp;
7698 if (path == NULL) return NULL;
7699 pathified = PerlMem_malloc(VMS_MAXRSS);
7700 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
7701 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
7702 PerlMem_free(pathified);
7708 Newx(unixified, VMS_MAXRSS, char);
7710 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
7711 PerlMem_free(pathified);
7712 if (unixified) Safefree(unixified);
7715 PerlMem_free(pathified);
7720 unixlen = strlen(unixified);
7721 Newx(cp,unixlen+1,char);
7722 memcpy(cp,unixified,unixlen);
7724 Safefree(unixified);
7728 strcpy(__tounixpath_retbuf,unixified);
7729 Safefree(unixified);
7730 return __tounixpath_retbuf;
7733 } /* end of do_tounixpath() */
7735 /* External entry points */
7736 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
7737 { return do_tounixpath(path,buf,0,NULL); }
7738 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
7739 { return do_tounixpath(path,buf,1,NULL); }
7740 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
7741 { return do_tounixpath(path,buf,0,utf8_fl); }
7742 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
7743 { return do_tounixpath(path,buf,1,utf8_fl); }
7746 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
7748 *****************************************************************************
7750 * Copyright (C) 1989-1994, 2007 by *
7751 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
7753 * Permission is hereby granted for the reproduction of this software *
7754 * on condition that this copyright notice is included in source *
7755 * distributions of the software. The code may be modified and *
7756 * distributed under the same terms as Perl itself. *
7758 * 27-Aug-1994 Modified for inclusion in perl5 *
7759 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
7760 *****************************************************************************
7764 * getredirection() is intended to aid in porting C programs
7765 * to VMS (Vax-11 C). The native VMS environment does not support
7766 * '>' and '<' I/O redirection, or command line wild card expansion,
7767 * or a command line pipe mechanism using the '|' AND background
7768 * command execution '&'. All of these capabilities are provided to any
7769 * C program which calls this procedure as the first thing in the
7771 * The piping mechanism will probably work with almost any 'filter' type
7772 * of program. With suitable modification, it may useful for other
7773 * portability problems as well.
7775 * Author: Mark Pizzolato (mark AT infocomm DOT com)
7779 struct list_item *next;
7783 static void add_item(struct list_item **head,
7784 struct list_item **tail,
7788 static void mp_expand_wild_cards(pTHX_ char *item,
7789 struct list_item **head,
7790 struct list_item **tail,
7793 static int background_process(pTHX_ int argc, char **argv);
7795 static void pipe_and_fork(pTHX_ char **cmargv);
7797 /*{{{ void getredirection(int *ac, char ***av)*/
7799 mp_getredirection(pTHX_ int *ac, char ***av)
7801 * Process vms redirection arg's. Exit if any error is seen.
7802 * If getredirection() processes an argument, it is erased
7803 * from the vector. getredirection() returns a new argc and argv value.
7804 * In the event that a background command is requested (by a trailing "&"),
7805 * this routine creates a background subprocess, and simply exits the program.
7807 * Warning: do not try to simplify the code for vms. The code
7808 * presupposes that getredirection() is called before any data is
7809 * read from stdin or written to stdout.
7811 * Normal usage is as follows:
7817 * getredirection(&argc, &argv);
7821 int argc = *ac; /* Argument Count */
7822 char **argv = *av; /* Argument Vector */
7823 char *ap; /* Argument pointer */
7824 int j; /* argv[] index */
7825 int item_count = 0; /* Count of Items in List */
7826 struct list_item *list_head = 0; /* First Item in List */
7827 struct list_item *list_tail; /* Last Item in List */
7828 char *in = NULL; /* Input File Name */
7829 char *out = NULL; /* Output File Name */
7830 char *outmode = "w"; /* Mode to Open Output File */
7831 char *err = NULL; /* Error File Name */
7832 char *errmode = "w"; /* Mode to Open Error File */
7833 int cmargc = 0; /* Piped Command Arg Count */
7834 char **cmargv = NULL;/* Piped Command Arg Vector */
7837 * First handle the case where the last thing on the line ends with
7838 * a '&'. This indicates the desire for the command to be run in a
7839 * subprocess, so we satisfy that desire.
7842 if (0 == strcmp("&", ap))
7843 exit(background_process(aTHX_ --argc, argv));
7844 if (*ap && '&' == ap[strlen(ap)-1])
7846 ap[strlen(ap)-1] = '\0';
7847 exit(background_process(aTHX_ argc, argv));
7850 * Now we handle the general redirection cases that involve '>', '>>',
7851 * '<', and pipes '|'.
7853 for (j = 0; j < argc; ++j)
7855 if (0 == strcmp("<", argv[j]))
7859 fprintf(stderr,"No input file after < on command line");
7860 exit(LIB$_WRONUMARG);
7865 if ('<' == *(ap = argv[j]))
7870 if (0 == strcmp(">", ap))
7874 fprintf(stderr,"No output file after > on command line");
7875 exit(LIB$_WRONUMARG);
7894 fprintf(stderr,"No output file after > or >> on command line");
7895 exit(LIB$_WRONUMARG);
7899 if (('2' == *ap) && ('>' == ap[1]))
7916 fprintf(stderr,"No output file after 2> or 2>> on command line");
7917 exit(LIB$_WRONUMARG);
7921 if (0 == strcmp("|", argv[j]))
7925 fprintf(stderr,"No command into which to pipe on command line");
7926 exit(LIB$_WRONUMARG);
7928 cmargc = argc-(j+1);
7929 cmargv = &argv[j+1];
7933 if ('|' == *(ap = argv[j]))
7941 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
7944 * Allocate and fill in the new argument vector, Some Unix's terminate
7945 * the list with an extra null pointer.
7947 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
7948 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7950 for (j = 0; j < item_count; ++j, list_head = list_head->next)
7951 argv[j] = list_head->value;
7957 fprintf(stderr,"'|' and '>' may not both be specified on command line");
7958 exit(LIB$_INVARGORD);
7960 pipe_and_fork(aTHX_ cmargv);
7963 /* Check for input from a pipe (mailbox) */
7965 if (in == NULL && 1 == isapipe(0))
7967 char mbxname[L_tmpnam];
7969 long int dvi_item = DVI$_DEVBUFSIZ;
7970 $DESCRIPTOR(mbxnam, "");
7971 $DESCRIPTOR(mbxdevnam, "");
7973 /* Input from a pipe, reopen it in binary mode to disable */
7974 /* carriage control processing. */
7976 fgetname(stdin, mbxname);
7977 mbxnam.dsc$a_pointer = mbxname;
7978 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
7979 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
7980 mbxdevnam.dsc$a_pointer = mbxname;
7981 mbxdevnam.dsc$w_length = sizeof(mbxname);
7982 dvi_item = DVI$_DEVNAM;
7983 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
7984 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
7987 freopen(mbxname, "rb", stdin);
7990 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
7994 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
7996 fprintf(stderr,"Can't open input file %s as stdin",in);
7999 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8001 fprintf(stderr,"Can't open output file %s as stdout",out);
8004 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8007 if (strcmp(err,"&1") == 0) {
8008 dup2(fileno(stdout), fileno(stderr));
8009 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8012 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8014 fprintf(stderr,"Can't open error file %s as stderr",err);
8018 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8022 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8025 #ifdef ARGPROC_DEBUG
8026 PerlIO_printf(Perl_debug_log, "Arglist:\n");
8027 for (j = 0; j < *ac; ++j)
8028 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8030 /* Clear errors we may have hit expanding wildcards, so they don't
8031 show up in Perl's $! later */
8032 set_errno(0); set_vaxc_errno(1);
8033 } /* end of getredirection() */
8036 static void add_item(struct list_item **head,
8037 struct list_item **tail,
8043 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8044 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8048 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8049 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8050 *tail = (*tail)->next;
8052 (*tail)->value = value;
8056 static void mp_expand_wild_cards(pTHX_ char *item,
8057 struct list_item **head,
8058 struct list_item **tail,
8062 unsigned long int context = 0;
8070 $DESCRIPTOR(filespec, "");
8071 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8072 $DESCRIPTOR(resultspec, "");
8073 unsigned long int lff_flags = 0;
8077 #ifdef VMS_LONGNAME_SUPPORT
8078 lff_flags = LIB$M_FIL_LONG_NAMES;
8081 for (cp = item; *cp; cp++) {
8082 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8083 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8085 if (!*cp || isspace(*cp))
8087 add_item(head, tail, item, count);
8092 /* "double quoted" wild card expressions pass as is */
8093 /* From DCL that means using e.g.: */
8094 /* perl program """perl.*""" */
8095 item_len = strlen(item);
8096 if ( '"' == *item && '"' == item[item_len-1] )
8099 item[item_len-2] = '\0';
8100 add_item(head, tail, item, count);
8104 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8105 resultspec.dsc$b_class = DSC$K_CLASS_D;
8106 resultspec.dsc$a_pointer = NULL;
8107 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8108 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8109 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8110 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8111 if (!isunix || !filespec.dsc$a_pointer)
8112 filespec.dsc$a_pointer = item;
8113 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8115 * Only return version specs, if the caller specified a version
8117 had_version = strchr(item, ';');
8119 * Only return device and directory specs, if the caller specifed either.
8121 had_device = strchr(item, ':');
8122 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8124 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8125 (&filespec, &resultspec, &context,
8126 &defaultspec, 0, &rms_sts, &lff_flags)))
8131 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8132 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8133 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8134 string[resultspec.dsc$w_length] = '\0';
8135 if (NULL == had_version)
8136 *(strrchr(string, ';')) = '\0';
8137 if ((!had_directory) && (had_device == NULL))
8139 if (NULL == (devdir = strrchr(string, ']')))
8140 devdir = strrchr(string, '>');
8141 strcpy(string, devdir + 1);
8144 * Be consistent with what the C RTL has already done to the rest of
8145 * the argv items and lowercase all of these names.
8147 if (!decc_efs_case_preserve) {
8148 for (c = string; *c; ++c)
8152 if (isunix) trim_unixpath(string,item,1);
8153 add_item(head, tail, string, count);
8156 PerlMem_free(vmsspec);
8157 if (sts != RMS$_NMF)
8159 set_vaxc_errno(sts);
8162 case RMS$_FNF: case RMS$_DNF:
8163 set_errno(ENOENT); break;
8165 set_errno(ENOTDIR); break;
8167 set_errno(ENODEV); break;
8168 case RMS$_FNM: case RMS$_SYN:
8169 set_errno(EINVAL); break;
8171 set_errno(EACCES); break;
8173 _ckvmssts_noperl(sts);
8177 add_item(head, tail, item, count);
8178 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8179 _ckvmssts_noperl(lib$find_file_end(&context));
8182 static int child_st[2];/* Event Flag set when child process completes */
8184 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8186 static unsigned long int exit_handler(int *status)
8190 if (0 == child_st[0])
8192 #ifdef ARGPROC_DEBUG
8193 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8195 fflush(stdout); /* Have to flush pipe for binary data to */
8196 /* terminate properly -- <tp@mccall.com> */
8197 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8198 sys$dassgn(child_chan);
8200 sys$synch(0, child_st);
8205 static void sig_child(int chan)
8207 #ifdef ARGPROC_DEBUG
8208 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8210 if (child_st[0] == 0)
8214 static struct exit_control_block exit_block =
8219 &exit_block.exit_status,
8224 pipe_and_fork(pTHX_ char **cmargv)
8227 struct dsc$descriptor_s *vmscmd;
8228 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8229 int sts, j, l, ismcr, quote, tquote = 0;
8231 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8232 vms_execfree(vmscmd);
8237 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8238 && toupper(*(q+2)) == 'R' && !*(q+3);
8240 while (q && l < MAX_DCL_LINE_LENGTH) {
8242 if (j > 0 && quote) {
8248 if (ismcr && j > 1) quote = 1;
8249 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8252 if (quote || tquote) {
8258 if ((quote||tquote) && *q == '"') {
8268 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8270 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8274 static int background_process(pTHX_ int argc, char **argv)
8276 char command[MAX_DCL_SYMBOL + 1] = "$";
8277 $DESCRIPTOR(value, "");
8278 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8279 static $DESCRIPTOR(null, "NLA0:");
8280 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8282 $DESCRIPTOR(pidstr, "");
8284 unsigned long int flags = 17, one = 1, retsts;
8287 strcat(command, argv[0]);
8288 len = strlen(command);
8289 while (--argc && (len < MAX_DCL_SYMBOL))
8291 strcat(command, " \"");
8292 strcat(command, *(++argv));
8293 strcat(command, "\"");
8294 len = strlen(command);
8296 value.dsc$a_pointer = command;
8297 value.dsc$w_length = strlen(value.dsc$a_pointer);
8298 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8299 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8300 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8301 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8304 _ckvmssts_noperl(retsts);
8306 #ifdef ARGPROC_DEBUG
8307 PerlIO_printf(Perl_debug_log, "%s\n", command);
8309 sprintf(pidstring, "%08X", pid);
8310 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8311 pidstr.dsc$a_pointer = pidstring;
8312 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8313 lib$set_symbol(&pidsymbol, &pidstr);
8317 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8320 /* OS-specific initialization at image activation (not thread startup) */
8321 /* Older VAXC header files lack these constants */
8322 #ifndef JPI$_RIGHTS_SIZE
8323 # define JPI$_RIGHTS_SIZE 817
8325 #ifndef KGB$M_SUBSYSTEM
8326 # define KGB$M_SUBSYSTEM 0x8
8329 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8331 /*{{{void vms_image_init(int *, char ***)*/
8333 vms_image_init(int *argcp, char ***argvp)
8335 char eqv[LNM$C_NAMLENGTH+1] = "";
8336 unsigned int len, tabct = 8, tabidx = 0;
8337 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8338 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8339 unsigned short int dummy, rlen;
8340 struct dsc$descriptor_s **tabvec;
8341 #if defined(PERL_IMPLICIT_CONTEXT)
8344 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8345 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8346 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8349 #ifdef KILL_BY_SIGPRC
8350 Perl_csighandler_init();
8353 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8354 _ckvmssts_noperl(iosb[0]);
8355 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8356 if (iprv[i]) { /* Running image installed with privs? */
8357 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8362 /* Rights identifiers might trigger tainting as well. */
8363 if (!will_taint && (rlen || rsz)) {
8364 while (rlen < rsz) {
8365 /* We didn't get all the identifiers on the first pass. Allocate a
8366 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8367 * were needed to hold all identifiers at time of last call; we'll
8368 * allocate that many unsigned long ints), and go back and get 'em.
8369 * If it gave us less than it wanted to despite ample buffer space,
8370 * something's broken. Is your system missing a system identifier?
8372 if (rsz <= jpilist[1].buflen) {
8373 /* Perl_croak accvios when used this early in startup. */
8374 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
8375 rsz, (unsigned long) jpilist[1].buflen,
8376 "Check your rights database for corruption.\n");
8379 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
8380 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
8381 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8382 jpilist[1].buflen = rsz * sizeof(unsigned long int);
8383 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
8384 _ckvmssts_noperl(iosb[0]);
8386 mask = jpilist[1].bufadr;
8387 /* Check attribute flags for each identifier (2nd longword); protected
8388 * subsystem identifiers trigger tainting.
8390 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
8391 if (mask[i] & KGB$M_SUBSYSTEM) {
8396 if (mask != rlst) PerlMem_free(mask);
8399 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
8400 * logical, some versions of the CRTL will add a phanthom /000000/
8401 * directory. This needs to be removed.
8403 if (decc_filename_unix_report) {
8406 ulen = strlen(argvp[0][0]);
8408 zeros = strstr(argvp[0][0], "/000000/");
8409 if (zeros != NULL) {
8411 mlen = ulen - (zeros - argvp[0][0]) - 7;
8412 memmove(zeros, &zeros[7], mlen);
8414 argvp[0][0][ulen] = '\0';
8417 /* It also may have a trailing dot that needs to be removed otherwise
8418 * it will be converted to VMS mode incorrectly.
8421 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
8422 argvp[0][0][ulen] = '\0';
8425 /* We need to use this hack to tell Perl it should run with tainting,
8426 * since its tainting flag may be part of the PL_curinterp struct, which
8427 * hasn't been allocated when vms_image_init() is called.
8430 char **newargv, **oldargv;
8432 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
8433 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8434 newargv[0] = oldargv[0];
8435 newargv[1] = PerlMem_malloc(3 * sizeof(char));
8436 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8437 strcpy(newargv[1], "-T");
8438 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
8440 newargv[*argcp] = NULL;
8441 /* We orphan the old argv, since we don't know where it's come from,
8442 * so we don't know how to free it.
8446 else { /* Did user explicitly request tainting? */
8448 char *cp, **av = *argvp;
8449 for (i = 1; i < *argcp; i++) {
8450 if (*av[i] != '-') break;
8451 for (cp = av[i]+1; *cp; cp++) {
8452 if (*cp == 'T') { will_taint = 1; break; }
8453 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
8454 strchr("DFIiMmx",*cp)) break;
8456 if (will_taint) break;
8461 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
8464 tabvec = (struct dsc$descriptor_s **)
8465 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
8466 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8468 else if (tabidx >= tabct) {
8470 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
8471 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8473 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
8474 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8475 tabvec[tabidx]->dsc$w_length = 0;
8476 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
8477 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
8478 tabvec[tabidx]->dsc$a_pointer = NULL;
8479 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
8481 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
8483 getredirection(argcp,argvp);
8484 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
8486 # include <reentrancy.h>
8487 decc$set_reentrancy(C$C_MULTITHREAD);
8496 * Trim Unix-style prefix off filespec, so it looks like what a shell
8497 * glob expansion would return (i.e. from specified prefix on, not
8498 * full path). Note that returned filespec is Unix-style, regardless
8499 * of whether input filespec was VMS-style or Unix-style.
8501 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
8502 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
8503 * vector of options; at present, only bit 0 is used, and if set tells
8504 * trim unixpath to try the current default directory as a prefix when
8505 * presented with a possibly ambiguous ... wildcard.
8507 * Returns !=0 on success, with trimmed filespec replacing contents of
8508 * fspec, and 0 on failure, with contents of fpsec unchanged.
8510 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
8512 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
8514 char *unixified, *unixwild,
8515 *template, *base, *end, *cp1, *cp2;
8516 register int tmplen, reslen = 0, dirs = 0;
8518 unixwild = PerlMem_malloc(VMS_MAXRSS);
8519 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
8520 if (!wildspec || !fspec) return 0;
8521 template = unixwild;
8522 if (strpbrk(wildspec,"]>:") != NULL) {
8523 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
8524 PerlMem_free(unixwild);
8529 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
8530 unixwild[VMS_MAXRSS-1] = 0;
8532 unixified = PerlMem_malloc(VMS_MAXRSS);
8533 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
8534 if (strpbrk(fspec,"]>:") != NULL) {
8535 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
8536 PerlMem_free(unixwild);
8537 PerlMem_free(unixified);
8540 else base = unixified;
8541 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
8542 * check to see that final result fits into (isn't longer than) fspec */
8543 reslen = strlen(fspec);
8547 /* No prefix or absolute path on wildcard, so nothing to remove */
8548 if (!*template || *template == '/') {
8549 PerlMem_free(unixwild);
8550 if (base == fspec) {
8551 PerlMem_free(unixified);
8554 tmplen = strlen(unixified);
8555 if (tmplen > reslen) {
8556 PerlMem_free(unixified);
8557 return 0; /* not enough space */
8559 /* Copy unixified resultant, including trailing NUL */
8560 memmove(fspec,unixified,tmplen+1);
8561 PerlMem_free(unixified);
8565 for (end = base; *end; end++) ; /* Find end of resultant filespec */
8566 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
8567 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
8568 for (cp1 = end ;cp1 >= base; cp1--)
8569 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
8571 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
8572 PerlMem_free(unixified);
8573 PerlMem_free(unixwild);
8578 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
8579 int ells = 1, totells, segdirs, match;
8580 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
8581 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
8583 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
8585 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
8586 tpl = PerlMem_malloc(VMS_MAXRSS);
8587 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
8588 if (ellipsis == template && opts & 1) {
8589 /* Template begins with an ellipsis. Since we can't tell how many
8590 * directory names at the front of the resultant to keep for an
8591 * arbitrary starting point, we arbitrarily choose the current
8592 * default directory as a starting point. If it's there as a prefix,
8593 * clip it off. If not, fall through and act as if the leading
8594 * ellipsis weren't there (i.e. return shortest possible path that
8595 * could match template).
8597 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
8599 PerlMem_free(unixified);
8600 PerlMem_free(unixwild);
8603 if (!decc_efs_case_preserve) {
8604 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8605 if (_tolower(*cp1) != _tolower(*cp2)) break;
8607 segdirs = dirs - totells; /* Min # of dirs we must have left */
8608 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
8609 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
8610 memmove(fspec,cp2+1,end - cp2);
8612 PerlMem_free(unixified);
8613 PerlMem_free(unixwild);
8617 /* First off, back up over constant elements at end of path */
8619 for (front = end ; front >= base; front--)
8620 if (*front == '/' && !dirs--) { front++; break; }
8622 lcres = PerlMem_malloc(VMS_MAXRSS);
8623 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
8624 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
8626 if (!decc_efs_case_preserve) {
8627 *cp2 = _tolower(*cp1); /* Make lc copy for match */
8635 PerlMem_free(unixified);
8636 PerlMem_free(unixwild);
8637 PerlMem_free(lcres);
8638 return 0; /* Path too long. */
8641 *cp2 = '\0'; /* Pick up with memcpy later */
8642 lcfront = lcres + (front - base);
8643 /* Now skip over each ellipsis and try to match the path in front of it. */
8645 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
8646 if (*(cp1) == '.' && *(cp1+1) == '.' &&
8647 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
8648 if (cp1 < template) break; /* template started with an ellipsis */
8649 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
8650 ellipsis = cp1; continue;
8652 wilddsc.dsc$a_pointer = tpl;
8653 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
8655 for (segdirs = 0, cp2 = tpl;
8656 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
8658 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
8660 if (!decc_efs_case_preserve) {
8661 *cp2 = _tolower(*cp1); /* else lowercase for match */
8664 *cp2 = *cp1; /* else preserve case for match */
8667 if (*cp2 == '/') segdirs++;
8669 if (cp1 != ellipsis - 1) {
8671 PerlMem_free(unixified);
8672 PerlMem_free(unixwild);
8673 PerlMem_free(lcres);
8674 return 0; /* Path too long */
8676 /* Back up at least as many dirs as in template before matching */
8677 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
8678 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
8679 for (match = 0; cp1 > lcres;) {
8680 resdsc.dsc$a_pointer = cp1;
8681 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
8683 if (match == 1) lcfront = cp1;
8685 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
8689 PerlMem_free(unixified);
8690 PerlMem_free(unixwild);
8691 PerlMem_free(lcres);
8692 return 0; /* Can't find prefix ??? */
8694 if (match > 1 && opts & 1) {
8695 /* This ... wildcard could cover more than one set of dirs (i.e.
8696 * a set of similar dir names is repeated). If the template
8697 * contains more than 1 ..., upstream elements could resolve the
8698 * ambiguity, but it's not worth a full backtracking setup here.
8699 * As a quick heuristic, clip off the current default directory
8700 * if it's present to find the trimmed spec, else use the
8701 * shortest string that this ... could cover.
8703 char def[NAM$C_MAXRSS+1], *st;
8705 if (getcwd(def, sizeof def,0) == NULL) {
8706 Safefree(unixified);
8712 if (!decc_efs_case_preserve) {
8713 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
8714 if (_tolower(*cp1) != _tolower(*cp2)) break;
8716 segdirs = dirs - totells; /* Min # of dirs we must have left */
8717 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
8718 if (*cp1 == '\0' && *cp2 == '/') {
8719 memmove(fspec,cp2+1,end - cp2);
8721 PerlMem_free(unixified);
8722 PerlMem_free(unixwild);
8723 PerlMem_free(lcres);
8726 /* Nope -- stick with lcfront from above and keep going. */
8729 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
8731 PerlMem_free(unixified);
8732 PerlMem_free(unixwild);
8733 PerlMem_free(lcres);
8738 } /* end of trim_unixpath() */
8743 * VMS readdir() routines.
8744 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
8746 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
8747 * Minor modifications to original routines.
8750 /* readdir may have been redefined by reentr.h, so make sure we get
8751 * the local version for what we do here.
8756 #if !defined(PERL_IMPLICIT_CONTEXT)
8757 # define readdir Perl_readdir
8759 # define readdir(a) Perl_readdir(aTHX_ a)
8762 /* Number of elements in vms_versions array */
8763 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
8766 * Open a directory, return a handle for later use.
8768 /*{{{ DIR *opendir(char*name) */
8770 Perl_opendir(pTHX_ const char *name)
8776 Newx(dir, VMS_MAXRSS, char);
8777 if (do_tovmspath(name,dir,0,NULL) == NULL) {
8781 /* Check access before stat; otherwise stat does not
8782 * accurately report whether it's a directory.
8784 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
8785 /* cando_by_name has already set errno */
8789 if (flex_stat(dir,&sb) == -1) return NULL;
8790 if (!S_ISDIR(sb.st_mode)) {
8792 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
8795 /* Get memory for the handle, and the pattern. */
8797 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
8799 /* Fill in the fields; mainly playing with the descriptor. */
8800 sprintf(dd->pattern, "%s*.*",dir);
8805 /* By saying we always want the result of readdir() in unix format, we
8806 * are really saying we want all the escapes removed. Otherwise the caller,
8807 * having no way to know whether it's already in VMS format, might send it
8808 * through tovmsspec again, thus double escaping.
8810 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
8811 dd->pat.dsc$a_pointer = dd->pattern;
8812 dd->pat.dsc$w_length = strlen(dd->pattern);
8813 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
8814 dd->pat.dsc$b_class = DSC$K_CLASS_S;
8815 #if defined(USE_ITHREADS)
8816 Newx(dd->mutex,1,perl_mutex);
8817 MUTEX_INIT( (perl_mutex *) dd->mutex );
8823 } /* end of opendir() */
8827 * Set the flag to indicate we want versions or not.
8829 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
8831 vmsreaddirversions(DIR *dd, int flag)
8834 dd->flags |= PERL_VMSDIR_M_VERSIONS;
8836 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
8841 * Free up an opened directory.
8843 /*{{{ void closedir(DIR *dd)*/
8845 Perl_closedir(DIR *dd)
8849 sts = lib$find_file_end(&dd->context);
8850 Safefree(dd->pattern);
8851 #if defined(USE_ITHREADS)
8852 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
8853 Safefree(dd->mutex);
8860 * Collect all the version numbers for the current file.
8863 collectversions(pTHX_ DIR *dd)
8865 struct dsc$descriptor_s pat;
8866 struct dsc$descriptor_s res;
8868 char *p, *text, *buff;
8870 unsigned long context, tmpsts;
8872 /* Convenient shorthand. */
8875 /* Add the version wildcard, ignoring the "*.*" put on before */
8876 i = strlen(dd->pattern);
8877 Newx(text,i + e->d_namlen + 3,char);
8878 strcpy(text, dd->pattern);
8879 sprintf(&text[i - 3], "%s;*", e->d_name);
8881 /* Set up the pattern descriptor. */
8882 pat.dsc$a_pointer = text;
8883 pat.dsc$w_length = i + e->d_namlen - 1;
8884 pat.dsc$b_dtype = DSC$K_DTYPE_T;
8885 pat.dsc$b_class = DSC$K_CLASS_S;
8887 /* Set up result descriptor. */
8888 Newx(buff, VMS_MAXRSS, char);
8889 res.dsc$a_pointer = buff;
8890 res.dsc$w_length = VMS_MAXRSS - 1;
8891 res.dsc$b_dtype = DSC$K_DTYPE_T;
8892 res.dsc$b_class = DSC$K_CLASS_S;
8894 /* Read files, collecting versions. */
8895 for (context = 0, e->vms_verscount = 0;
8896 e->vms_verscount < VERSIZE(e);
8897 e->vms_verscount++) {
8899 unsigned long flags = 0;
8901 #ifdef VMS_LONGNAME_SUPPORT
8902 flags = LIB$M_FIL_LONG_NAMES;
8904 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
8905 if (tmpsts == RMS$_NMF || context == 0) break;
8907 buff[VMS_MAXRSS - 1] = '\0';
8908 if ((p = strchr(buff, ';')))
8909 e->vms_versions[e->vms_verscount] = atoi(p + 1);
8911 e->vms_versions[e->vms_verscount] = -1;
8914 _ckvmssts(lib$find_file_end(&context));
8918 } /* end of collectversions() */
8921 * Read the next entry from the directory.
8923 /*{{{ struct dirent *readdir(DIR *dd)*/
8925 Perl_readdir(pTHX_ DIR *dd)
8927 struct dsc$descriptor_s res;
8929 unsigned long int tmpsts;
8931 unsigned long flags = 0;
8932 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8933 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8935 /* Set up result descriptor, and get next file. */
8936 Newx(buff, VMS_MAXRSS, char);
8937 res.dsc$a_pointer = buff;
8938 res.dsc$w_length = VMS_MAXRSS - 1;
8939 res.dsc$b_dtype = DSC$K_DTYPE_T;
8940 res.dsc$b_class = DSC$K_CLASS_S;
8942 #ifdef VMS_LONGNAME_SUPPORT
8943 flags = LIB$M_FIL_LONG_NAMES;
8946 tmpsts = lib$find_file
8947 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
8948 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
8949 if (!(tmpsts & 1)) {
8950 set_vaxc_errno(tmpsts);
8953 set_errno(EACCES); break;
8955 set_errno(ENODEV); break;
8957 set_errno(ENOTDIR); break;
8958 case RMS$_FNF: case RMS$_DNF:
8959 set_errno(ENOENT); break;
8967 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
8968 if (!decc_efs_case_preserve) {
8969 buff[VMS_MAXRSS - 1] = '\0';
8970 for (p = buff; *p; p++) *p = _tolower(*p);
8973 /* we don't want to force to lowercase, just null terminate */
8974 buff[res.dsc$w_length] = '\0';
8976 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
8979 /* Skip any directory component and just copy the name. */
8980 sts = vms_split_path
8995 /* Drop NULL extensions on UNIX file specification */
8996 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
8997 (e_len == 1) && decc_readdir_dropdotnotype)) {
9002 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9003 dd->entry.d_name[n_len + e_len] = '\0';
9004 dd->entry.d_namlen = strlen(dd->entry.d_name);
9006 /* Convert the filename to UNIX format if needed */
9007 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9009 /* Translate the encoded characters. */
9010 /* Fixme: Unicode handling could result in embedded 0 characters */
9011 if (strchr(dd->entry.d_name, '^') != NULL) {
9014 p = dd->entry.d_name;
9017 int inchars_read, outchars_added;
9018 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9020 q += outchars_added;
9022 /* if outchars_added > 1, then this is a wide file specification */
9023 /* Wide file specifications need to be passed in Perl */
9024 /* counted strings apparently with a Unicode flag */
9027 strcpy(dd->entry.d_name, new_name);
9028 dd->entry.d_namlen = strlen(dd->entry.d_name);
9032 dd->entry.vms_verscount = 0;
9033 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9037 } /* end of readdir() */
9041 * Read the next entry from the directory -- thread-safe version.
9043 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9045 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9049 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9051 entry = readdir(dd);
9053 retval = ( *result == NULL ? errno : 0 );
9055 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9059 } /* end of readdir_r() */
9063 * Return something that can be used in a seekdir later.
9065 /*{{{ long telldir(DIR *dd)*/
9067 Perl_telldir(DIR *dd)
9074 * Return to a spot where we used to be. Brute force.
9076 /*{{{ void seekdir(DIR *dd,long count)*/
9078 Perl_seekdir(pTHX_ DIR *dd, long count)
9082 /* If we haven't done anything yet... */
9086 /* Remember some state, and clear it. */
9087 old_flags = dd->flags;
9088 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9089 _ckvmssts(lib$find_file_end(&dd->context));
9092 /* The increment is in readdir(). */
9093 for (dd->count = 0; dd->count < count; )
9096 dd->flags = old_flags;
9098 } /* end of seekdir() */
9101 /* VMS subprocess management
9103 * my_vfork() - just a vfork(), after setting a flag to record that
9104 * the current script is trying a Unix-style fork/exec.
9106 * vms_do_aexec() and vms_do_exec() are called in response to the
9107 * perl 'exec' function. If this follows a vfork call, then they
9108 * call out the regular perl routines in doio.c which do an
9109 * execvp (for those who really want to try this under VMS).
9110 * Otherwise, they do exactly what the perl docs say exec should
9111 * do - terminate the current script and invoke a new command
9112 * (See below for notes on command syntax.)
9114 * do_aspawn() and do_spawn() implement the VMS side of the perl
9115 * 'system' function.
9117 * Note on command arguments to perl 'exec' and 'system': When handled
9118 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9119 * are concatenated to form a DCL command string. If the first arg
9120 * begins with '$' (i.e. the perl script had "\$ Type" or some such),
9121 * the command string is handed off to DCL directly. Otherwise,
9122 * the first token of the command is taken as the filespec of an image
9123 * to run. The filespec is expanded using a default type of '.EXE' and
9124 * the process defaults for device, directory, etc., and if found, the resultant
9125 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9126 * the command string as parameters. This is perhaps a bit complicated,
9127 * but I hope it will form a happy medium between what VMS folks expect
9128 * from lib$spawn and what Unix folks expect from exec.
9131 static int vfork_called;
9133 /*{{{int my_vfork()*/
9144 vms_execfree(struct dsc$descriptor_s *vmscmd)
9147 if (vmscmd->dsc$a_pointer) {
9148 PerlMem_free(vmscmd->dsc$a_pointer);
9150 PerlMem_free(vmscmd);
9155 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9157 char *junk, *tmps = Nullch;
9158 register size_t cmdlen = 0;
9165 tmps = SvPV(really,rlen);
9172 for (idx++; idx <= sp; idx++) {
9174 junk = SvPVx(*idx,rlen);
9175 cmdlen += rlen ? rlen + 1 : 0;
9178 Newx(PL_Cmd, cmdlen+1, char);
9180 if (tmps && *tmps) {
9181 strcpy(PL_Cmd,tmps);
9184 else *PL_Cmd = '\0';
9185 while (++mark <= sp) {
9187 char *s = SvPVx(*mark,n_a);
9189 if (*PL_Cmd) strcat(PL_Cmd," ");
9195 } /* end of setup_argstr() */
9198 static unsigned long int
9199 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9200 struct dsc$descriptor_s **pvmscmd)
9202 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9203 char image_name[NAM$C_MAXRSS+1];
9204 char image_argv[NAM$C_MAXRSS+1];
9205 $DESCRIPTOR(defdsc,".EXE");
9206 $DESCRIPTOR(defdsc2,".");
9207 $DESCRIPTOR(resdsc,resspec);
9208 struct dsc$descriptor_s *vmscmd;
9209 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9210 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9211 register char *s, *rest, *cp, *wordbreak;
9216 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9217 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9219 /* Make a copy for modification */
9220 cmdlen = strlen(incmd);
9221 cmd = PerlMem_malloc(cmdlen+1);
9222 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9223 strncpy(cmd, incmd, cmdlen);
9228 vmscmd->dsc$a_pointer = NULL;
9229 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9230 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9231 vmscmd->dsc$w_length = 0;
9232 if (pvmscmd) *pvmscmd = vmscmd;
9234 if (suggest_quote) *suggest_quote = 0;
9236 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9238 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9243 while (*s && isspace(*s)) s++;
9245 if (*s == '@' || *s == '$') {
9246 vmsspec[0] = *s; rest = s + 1;
9247 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9249 else { cp = vmsspec; rest = s; }
9250 if (*rest == '.' || *rest == '/') {
9253 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9254 rest++, cp2++) *cp2 = *rest;
9256 if (do_tovmsspec(resspec,cp,0,NULL)) {
9259 for (cp2 = vmsspec + strlen(vmsspec);
9260 *rest && cp2 - vmsspec < sizeof vmsspec;
9261 rest++, cp2++) *cp2 = *rest;
9266 /* Intuit whether verb (first word of cmd) is a DCL command:
9267 * - if first nonspace char is '@', it's a DCL indirection
9269 * - if verb contains a filespec separator, it's not a DCL command
9270 * - if it doesn't, caller tells us whether to default to a DCL
9271 * command, or to a local image unless told it's DCL (by leading '$')
9275 if (suggest_quote) *suggest_quote = 1;
9277 register char *filespec = strpbrk(s,":<[.;");
9278 rest = wordbreak = strpbrk(s," \"\t/");
9279 if (!wordbreak) wordbreak = s + strlen(s);
9280 if (*s == '$') check_img = 0;
9281 if (filespec && (filespec < wordbreak)) isdcl = 0;
9282 else isdcl = !check_img;
9287 imgdsc.dsc$a_pointer = s;
9288 imgdsc.dsc$w_length = wordbreak - s;
9289 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9291 _ckvmssts(lib$find_file_end(&cxt));
9292 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9293 if (!(retsts & 1) && *s == '$') {
9294 _ckvmssts(lib$find_file_end(&cxt));
9295 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9296 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9298 _ckvmssts(lib$find_file_end(&cxt));
9299 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9303 _ckvmssts(lib$find_file_end(&cxt));
9308 while (*s && !isspace(*s)) s++;
9311 /* check that it's really not DCL with no file extension */
9312 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9314 char b[256] = {0,0,0,0};
9315 read(fileno(fp), b, 256);
9316 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9320 /* Check for script */
9322 if ((b[0] == '#') && (b[1] == '!'))
9324 #ifdef ALTERNATE_SHEBANG
9326 shebang_len = strlen(ALTERNATE_SHEBANG);
9327 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9329 perlstr = strstr("perl",b);
9330 if (perlstr == NULL)
9338 if (shebang_len > 0) {
9341 char tmpspec[NAM$C_MAXRSS + 1];
9344 /* Image is following after white space */
9345 /*--------------------------------------*/
9346 while (isprint(b[i]) && isspace(b[i]))
9350 while (isprint(b[i]) && !isspace(b[i])) {
9351 tmpspec[j++] = b[i++];
9352 if (j >= NAM$C_MAXRSS)
9357 /* There may be some default parameters to the image */
9358 /*---------------------------------------------------*/
9360 while (isprint(b[i])) {
9361 image_argv[j++] = b[i++];
9362 if (j >= NAM$C_MAXRSS)
9365 while ((j > 0) && !isprint(image_argv[j-1]))
9369 /* It will need to be converted to VMS format and validated */
9370 if (tmpspec[0] != '\0') {
9373 /* Try to find the exact program requested to be run */
9374 /*---------------------------------------------------*/
9375 iname = do_rmsexpand
9376 (tmpspec, image_name, 0, ".exe",
9377 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9378 if (iname != NULL) {
9379 if (cando_by_name_int
9380 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
9381 /* MCR prefix needed */
9385 /* Try again with a null type */
9386 /*----------------------------*/
9387 iname = do_rmsexpand
9388 (tmpspec, image_name, 0, ".",
9389 PERL_RMSEXPAND_M_VMS, NULL, NULL);
9390 if (iname != NULL) {
9391 if (cando_by_name_int
9392 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
9393 /* MCR prefix needed */
9399 /* Did we find the image to run the script? */
9400 /*------------------------------------------*/
9404 /* Assume DCL or foreign command exists */
9405 /*--------------------------------------*/
9406 tchr = strrchr(tmpspec, '/');
9413 strcpy(image_name, tchr);
9421 if (check_img && isdcl) return RMS$_FNF;
9423 if (cando_by_name(S_IXUSR,0,resspec)) {
9424 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
9425 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
9427 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
9428 if (image_name[0] != 0) {
9429 strcat(vmscmd->dsc$a_pointer, image_name);
9430 strcat(vmscmd->dsc$a_pointer, " ");
9432 } else if (image_name[0] != 0) {
9433 strcpy(vmscmd->dsc$a_pointer, image_name);
9434 strcat(vmscmd->dsc$a_pointer, " ");
9436 strcpy(vmscmd->dsc$a_pointer,"@");
9438 if (suggest_quote) *suggest_quote = 1;
9440 /* If there is an image name, use original command */
9441 if (image_name[0] == 0)
9442 strcat(vmscmd->dsc$a_pointer,resspec);
9445 while (*rest && isspace(*rest)) rest++;
9448 if (image_argv[0] != 0) {
9449 strcat(vmscmd->dsc$a_pointer,image_argv);
9450 strcat(vmscmd->dsc$a_pointer, " ");
9456 rest_len = strlen(rest);
9457 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
9458 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
9459 strcat(vmscmd->dsc$a_pointer,rest);
9461 retsts = CLI$_BUFOVF;
9463 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
9465 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9471 /* It's either a DCL command or we couldn't find a suitable image */
9472 vmscmd->dsc$w_length = strlen(cmd);
9474 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
9475 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
9476 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
9480 /* check if it's a symbol (for quoting purposes) */
9481 if (suggest_quote && !*suggest_quote) {
9483 char equiv[LNM$C_NAMLENGTH];
9484 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9485 eqvdsc.dsc$a_pointer = equiv;
9487 iss = lib$get_symbol(vmscmd,&eqvdsc);
9488 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
9490 if (!(retsts & 1)) {
9491 /* just hand off status values likely to be due to user error */
9492 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
9493 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
9494 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
9495 else { _ckvmssts(retsts); }
9498 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
9500 } /* end of setup_cmddsc() */
9503 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
9505 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
9511 if (vfork_called) { /* this follows a vfork - act Unixish */
9513 if (vfork_called < 0) {
9514 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9517 else return do_aexec(really,mark,sp);
9519 /* no vfork - act VMSish */
9520 cmd = setup_argstr(aTHX_ really,mark,sp);
9521 exec_sts = vms_do_exec(cmd);
9522 Safefree(cmd); /* Clean up from setup_argstr() */
9527 } /* end of vms_do_aexec() */
9530 /* {{{bool vms_do_exec(char *cmd) */
9532 Perl_vms_do_exec(pTHX_ const char *cmd)
9534 struct dsc$descriptor_s *vmscmd;
9536 if (vfork_called) { /* this follows a vfork - act Unixish */
9538 if (vfork_called < 0) {
9539 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
9542 else return do_exec(cmd);
9545 { /* no vfork - act VMSish */
9546 unsigned long int retsts;
9549 TAINT_PROPER("exec");
9550 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
9551 retsts = lib$do_command(vmscmd);
9554 case RMS$_FNF: case RMS$_DNF:
9555 set_errno(ENOENT); break;
9557 set_errno(ENOTDIR); break;
9559 set_errno(ENODEV); break;
9561 set_errno(EACCES); break;
9563 set_errno(EINVAL); break;
9564 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9565 set_errno(E2BIG); break;
9566 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9567 _ckvmssts(retsts); /* fall through */
9568 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9571 set_vaxc_errno(retsts);
9572 if (ckWARN(WARN_EXEC)) {
9573 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
9574 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
9576 vms_execfree(vmscmd);
9581 } /* end of vms_do_exec() */
9584 unsigned long int Perl_do_spawn(pTHX_ const char *);
9586 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
9588 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
9590 unsigned long int sts;
9594 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
9595 sts = do_spawn(cmd);
9596 /* pp_sys will clean up cmd */
9600 } /* end of do_aspawn() */
9603 /* {{{unsigned long int do_spawn(char *cmd) */
9605 Perl_do_spawn(pTHX_ const char *cmd)
9607 unsigned long int sts, substs;
9609 /* The caller of this routine expects to Safefree(PL_Cmd) */
9610 Newx(PL_Cmd,10,char);
9613 TAINT_PROPER("spawn");
9614 if (!cmd || !*cmd) {
9615 sts = lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0);
9618 case RMS$_FNF: case RMS$_DNF:
9619 set_errno(ENOENT); break;
9621 set_errno(ENOTDIR); break;
9623 set_errno(ENODEV); break;
9625 set_errno(EACCES); break;
9627 set_errno(EINVAL); break;
9628 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
9629 set_errno(E2BIG); break;
9630 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
9631 _ckvmssts(sts); /* fall through */
9632 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
9635 set_vaxc_errno(sts);
9636 if (ckWARN(WARN_EXEC)) {
9637 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
9645 fp = safe_popen(aTHX_ cmd, "nW", (int *)&sts);
9650 } /* end of do_spawn() */
9654 static unsigned int *sockflags, sockflagsize;
9657 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
9658 * routines found in some versions of the CRTL can't deal with sockets.
9659 * We don't shim the other file open routines since a socket isn't
9660 * likely to be opened by a name.
9662 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
9663 FILE *my_fdopen(int fd, const char *mode)
9665 FILE *fp = fdopen(fd, mode);
9668 unsigned int fdoff = fd / sizeof(unsigned int);
9669 Stat_t sbuf; /* native stat; we don't need flex_stat */
9670 if (!sockflagsize || fdoff > sockflagsize) {
9671 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
9672 else Newx (sockflags,fdoff+2,unsigned int);
9673 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
9674 sockflagsize = fdoff + 2;
9676 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
9677 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
9686 * Clear the corresponding bit when the (possibly) socket stream is closed.
9687 * There still a small hole: we miss an implicit close which might occur
9688 * via freopen(). >> Todo
9690 /*{{{ int my_fclose(FILE *fp)*/
9691 int my_fclose(FILE *fp) {
9693 unsigned int fd = fileno(fp);
9694 unsigned int fdoff = fd / sizeof(unsigned int);
9696 if (sockflagsize && fdoff <= sockflagsize)
9697 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
9705 * A simple fwrite replacement which outputs itmsz*nitm chars without
9706 * introducing record boundaries every itmsz chars.
9707 * We are using fputs, which depends on a terminating null. We may
9708 * well be writing binary data, so we need to accommodate not only
9709 * data with nulls sprinkled in the middle but also data with no null
9712 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
9714 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
9716 register char *cp, *end, *cpd, *data;
9717 register unsigned int fd = fileno(dest);
9718 register unsigned int fdoff = fd / sizeof(unsigned int);
9720 int bufsize = itmsz * nitm + 1;
9722 if (fdoff < sockflagsize &&
9723 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
9724 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
9728 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
9729 memcpy( data, src, itmsz*nitm );
9730 data[itmsz*nitm] = '\0';
9732 end = data + itmsz * nitm;
9733 retval = (int) nitm; /* on success return # items written */
9736 while (cpd <= end) {
9737 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
9738 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
9740 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
9744 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
9747 } /* end of my_fwrite() */
9750 /*{{{ int my_flush(FILE *fp)*/
9752 Perl_my_flush(pTHX_ FILE *fp)
9755 if ((res = fflush(fp)) == 0 && fp) {
9756 #ifdef VMS_DO_SOCKETS
9758 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
9760 res = fsync(fileno(fp));
9763 * If the flush succeeded but set end-of-file, we need to clear
9764 * the error because our caller may check ferror(). BTW, this
9765 * probably means we just flushed an empty file.
9767 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
9774 * Here are replacements for the following Unix routines in the VMS environment:
9775 * getpwuid Get information for a particular UIC or UID
9776 * getpwnam Get information for a named user
9777 * getpwent Get information for each user in the rights database
9778 * setpwent Reset search to the start of the rights database
9779 * endpwent Finish searching for users in the rights database
9781 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
9782 * (defined in pwd.h), which contains the following fields:-
9784 * char *pw_name; Username (in lower case)
9785 * char *pw_passwd; Hashed password
9786 * unsigned int pw_uid; UIC
9787 * unsigned int pw_gid; UIC group number
9788 * char *pw_unixdir; Default device/directory (VMS-style)
9789 * char *pw_gecos; Owner name
9790 * char *pw_dir; Default device/directory (Unix-style)
9791 * char *pw_shell; Default CLI name (eg. DCL)
9793 * If the specified user does not exist, getpwuid and getpwnam return NULL.
9795 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
9796 * not the UIC member number (eg. what's returned by getuid()),
9797 * getpwuid() can accept either as input (if uid is specified, the caller's
9798 * UIC group is used), though it won't recognise gid=0.
9800 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
9801 * information about other users in your group or in other groups, respectively.
9802 * If the required privilege is not available, then these routines fill only
9803 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
9806 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
9809 /* sizes of various UAF record fields */
9810 #define UAI$S_USERNAME 12
9811 #define UAI$S_IDENT 31
9812 #define UAI$S_OWNER 31
9813 #define UAI$S_DEFDEV 31
9814 #define UAI$S_DEFDIR 63
9815 #define UAI$S_DEFCLI 31
9818 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
9819 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
9820 (uic).uic$v_group != UIC$K_WILD_GROUP)
9822 static char __empty[]= "";
9823 static struct passwd __passwd_empty=
9824 {(char *) __empty, (char *) __empty, 0, 0,
9825 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
9826 static int contxt= 0;
9827 static struct passwd __pwdcache;
9828 static char __pw_namecache[UAI$S_IDENT+1];
9831 * This routine does most of the work extracting the user information.
9833 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
9836 unsigned char length;
9837 char pw_gecos[UAI$S_OWNER+1];
9839 static union uicdef uic;
9841 unsigned char length;
9842 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
9845 unsigned char length;
9846 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
9849 unsigned char length;
9850 char pw_shell[UAI$S_DEFCLI+1];
9852 static char pw_passwd[UAI$S_PWD+1];
9854 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
9855 struct dsc$descriptor_s name_desc;
9856 unsigned long int sts;
9858 static struct itmlst_3 itmlst[]= {
9859 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
9860 {sizeof(uic), UAI$_UIC, &uic, &luic},
9861 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
9862 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
9863 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
9864 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
9865 {0, 0, NULL, NULL}};
9867 name_desc.dsc$w_length= strlen(name);
9868 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9869 name_desc.dsc$b_class= DSC$K_CLASS_S;
9870 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
9872 /* Note that sys$getuai returns many fields as counted strings. */
9873 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
9874 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
9875 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
9877 else { _ckvmssts(sts); }
9878 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
9880 if ((int) owner.length < lowner) lowner= (int) owner.length;
9881 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
9882 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
9883 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
9884 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
9885 owner.pw_gecos[lowner]= '\0';
9886 defdev.pw_dir[ldefdev+ldefdir]= '\0';
9887 defcli.pw_shell[ldefcli]= '\0';
9888 if (valid_uic(uic)) {
9889 pwd->pw_uid= uic.uic$l_uic;
9890 pwd->pw_gid= uic.uic$v_group;
9893 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
9894 pwd->pw_passwd= pw_passwd;
9895 pwd->pw_gecos= owner.pw_gecos;
9896 pwd->pw_dir= defdev.pw_dir;
9897 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
9898 pwd->pw_shell= defcli.pw_shell;
9899 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
9901 ldir= strlen(pwd->pw_unixdir) - 1;
9902 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
9905 strcpy(pwd->pw_unixdir, pwd->pw_dir);
9906 if (!decc_efs_case_preserve)
9907 __mystrtolower(pwd->pw_unixdir);
9912 * Get information for a named user.
9914 /*{{{struct passwd *getpwnam(char *name)*/
9915 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
9917 struct dsc$descriptor_s name_desc;
9919 unsigned long int status, sts;
9921 __pwdcache = __passwd_empty;
9922 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
9923 /* We still may be able to determine pw_uid and pw_gid */
9924 name_desc.dsc$w_length= strlen(name);
9925 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
9926 name_desc.dsc$b_class= DSC$K_CLASS_S;
9927 name_desc.dsc$a_pointer= (char *) name;
9928 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
9929 __pwdcache.pw_uid= uic.uic$l_uic;
9930 __pwdcache.pw_gid= uic.uic$v_group;
9933 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
9934 set_vaxc_errno(sts);
9935 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
9938 else { _ckvmssts(sts); }
9941 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
9942 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
9943 __pwdcache.pw_name= __pw_namecache;
9945 } /* end of my_getpwnam() */
9949 * Get information for a particular UIC or UID.
9950 * Called by my_getpwent with uid=-1 to list all users.
9952 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
9953 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
9955 const $DESCRIPTOR(name_desc,__pw_namecache);
9956 unsigned short lname;
9958 unsigned long int status;
9960 if (uid == (unsigned int) -1) {
9962 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
9963 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
9964 set_vaxc_errno(status);
9965 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9969 else { _ckvmssts(status); }
9970 } while (!valid_uic (uic));
9974 if (!uic.uic$v_group)
9975 uic.uic$v_group= PerlProc_getgid();
9977 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
9978 else status = SS$_IVIDENT;
9979 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
9980 status == RMS$_PRV) {
9981 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
9984 else { _ckvmssts(status); }
9986 __pw_namecache[lname]= '\0';
9987 __mystrtolower(__pw_namecache);
9989 __pwdcache = __passwd_empty;
9990 __pwdcache.pw_name = __pw_namecache;
9992 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
9993 The identifier's value is usually the UIC, but it doesn't have to be,
9994 so if we can, we let fillpasswd update this. */
9995 __pwdcache.pw_uid = uic.uic$l_uic;
9996 __pwdcache.pw_gid = uic.uic$v_group;
9998 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10001 } /* end of my_getpwuid() */
10005 * Get information for next user.
10007 /*{{{struct passwd *my_getpwent()*/
10008 struct passwd *Perl_my_getpwent(pTHX)
10010 return (my_getpwuid((unsigned int) -1));
10015 * Finish searching rights database for users.
10017 /*{{{void my_endpwent()*/
10018 void Perl_my_endpwent(pTHX)
10021 _ckvmssts(sys$finish_rdb(&contxt));
10027 #ifdef HOMEGROWN_POSIX_SIGNALS
10028 /* Signal handling routines, pulled into the core from POSIX.xs.
10030 * We need these for threads, so they've been rolled into the core,
10031 * rather than left in POSIX.xs.
10033 * (DRS, Oct 23, 1997)
10036 /* sigset_t is atomic under VMS, so these routines are easy */
10037 /*{{{int my_sigemptyset(sigset_t *) */
10038 int my_sigemptyset(sigset_t *set) {
10039 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10040 *set = 0; return 0;
10045 /*{{{int my_sigfillset(sigset_t *)*/
10046 int my_sigfillset(sigset_t *set) {
10048 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10049 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10055 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10056 int my_sigaddset(sigset_t *set, int sig) {
10057 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10058 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10059 *set |= (1 << (sig - 1));
10065 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10066 int my_sigdelset(sigset_t *set, int sig) {
10067 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10068 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10069 *set &= ~(1 << (sig - 1));
10075 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10076 int my_sigismember(sigset_t *set, int sig) {
10077 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10078 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10079 return *set & (1 << (sig - 1));
10084 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10085 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10088 /* If set and oset are both null, then things are badly wrong. Bail out. */
10089 if ((oset == NULL) && (set == NULL)) {
10090 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10094 /* If set's null, then we're just handling a fetch. */
10096 tempmask = sigblock(0);
10101 tempmask = sigsetmask(*set);
10104 tempmask = sigblock(*set);
10107 tempmask = sigblock(0);
10108 sigsetmask(*oset & ~tempmask);
10111 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10116 /* Did they pass us an oset? If so, stick our holding mask into it */
10123 #endif /* HOMEGROWN_POSIX_SIGNALS */
10126 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10127 * my_utime(), and flex_stat(), all of which operate on UTC unless
10128 * VMSISH_TIMES is true.
10130 /* method used to handle UTC conversions:
10131 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10133 static int gmtime_emulation_type;
10134 /* number of secs to add to UTC POSIX-style time to get local time */
10135 static long int utc_offset_secs;
10137 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10138 * in vmsish.h. #undef them here so we can call the CRTL routines
10147 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10148 * qualifier with the extern prefix pragma. This provisional
10149 * hack circumvents this prefix pragma problem in previous
10152 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10153 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10154 # pragma __extern_prefix save
10155 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10156 # define gmtime decc$__utctz_gmtime
10157 # define localtime decc$__utctz_localtime
10158 # define time decc$__utc_time
10159 # pragma __extern_prefix restore
10161 struct tm *gmtime(), *localtime();
10167 static time_t toutc_dst(time_t loc) {
10170 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10171 loc -= utc_offset_secs;
10172 if (rsltmp->tm_isdst) loc -= 3600;
10175 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10176 ((gmtime_emulation_type || my_time(NULL)), \
10177 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10178 ((secs) - utc_offset_secs))))
10180 static time_t toloc_dst(time_t utc) {
10183 utc += utc_offset_secs;
10184 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10185 if (rsltmp->tm_isdst) utc += 3600;
10188 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10189 ((gmtime_emulation_type || my_time(NULL)), \
10190 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10191 ((secs) + utc_offset_secs))))
10193 #ifndef RTL_USES_UTC
10196 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10197 DST starts on 1st sun of april at 02:00 std time
10198 ends on last sun of october at 02:00 dst time
10199 see the UCX management command reference, SET CONFIG TIMEZONE
10200 for formatting info.
10202 No, it's not as general as it should be, but then again, NOTHING
10203 will handle UK times in a sensible way.
10208 parse the DST start/end info:
10209 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10213 tz_parse_startend(char *s, struct tm *w, int *past)
10215 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10216 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10221 if (!past) return 0;
10224 if (w->tm_year % 4 == 0) ly = 1;
10225 if (w->tm_year % 100 == 0) ly = 0;
10226 if (w->tm_year+1900 % 400 == 0) ly = 1;
10229 dozjd = isdigit(*s);
10230 if (*s == 'J' || *s == 'j' || dozjd) {
10231 if (!dozjd && !isdigit(*++s)) return 0;
10234 d = d*10 + *s++ - '0';
10236 d = d*10 + *s++ - '0';
10239 if (d == 0) return 0;
10240 if (d > 366) return 0;
10242 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10245 } else if (*s == 'M' || *s == 'm') {
10246 if (!isdigit(*++s)) return 0;
10248 if (isdigit(*s)) m = 10*m + *s++ - '0';
10249 if (*s != '.') return 0;
10250 if (!isdigit(*++s)) return 0;
10252 if (n < 1 || n > 5) return 0;
10253 if (*s != '.') return 0;
10254 if (!isdigit(*++s)) return 0;
10256 if (d > 6) return 0;
10260 if (!isdigit(*++s)) return 0;
10262 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10264 if (!isdigit(*++s)) return 0;
10266 if (isdigit(*s)) min = 10*min + *s++ - '0';
10268 if (!isdigit(*++s)) return 0;
10270 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10280 if (w->tm_yday < d) goto before;
10281 if (w->tm_yday > d) goto after;
10283 if (w->tm_mon+1 < m) goto before;
10284 if (w->tm_mon+1 > m) goto after;
10286 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10287 k = d - j; /* mday of first d */
10288 if (k <= 0) k += 7;
10289 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10290 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10291 if (w->tm_mday < k) goto before;
10292 if (w->tm_mday > k) goto after;
10295 if (w->tm_hour < hour) goto before;
10296 if (w->tm_hour > hour) goto after;
10297 if (w->tm_min < min) goto before;
10298 if (w->tm_min > min) goto after;
10299 if (w->tm_sec < sec) goto before;
10313 /* parse the offset: (+|-)hh[:mm[:ss]] */
10316 tz_parse_offset(char *s, int *offset)
10318 int hour = 0, min = 0, sec = 0;
10321 if (!offset) return 0;
10323 if (*s == '-') {neg++; s++;}
10324 if (*s == '+') s++;
10325 if (!isdigit(*s)) return 0;
10327 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10328 if (hour > 24) return 0;
10330 if (!isdigit(*++s)) return 0;
10332 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10333 if (min > 59) return 0;
10335 if (!isdigit(*++s)) return 0;
10337 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10338 if (sec > 59) return 0;
10342 *offset = (hour*60+min)*60 + sec;
10343 if (neg) *offset = -*offset;
10348 input time is w, whatever type of time the CRTL localtime() uses.
10349 sets dst, the zone, and the gmtoff (seconds)
10351 caches the value of TZ and UCX$TZ env variables; note that
10352 my_setenv looks for these and sets a flag if they're changed
10355 We have to watch out for the "australian" case (dst starts in
10356 october, ends in april)...flagged by "reverse" and checked by
10357 scanning through the months of the previous year.
10362 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
10367 char *dstzone, *tz, *s_start, *s_end;
10368 int std_off, dst_off, isdst;
10369 int y, dststart, dstend;
10370 static char envtz[1025]; /* longer than any logical, symbol, ... */
10371 static char ucxtz[1025];
10372 static char reversed = 0;
10378 reversed = -1; /* flag need to check */
10379 envtz[0] = ucxtz[0] = '\0';
10380 tz = my_getenv("TZ",0);
10381 if (tz) strcpy(envtz, tz);
10382 tz = my_getenv("UCX$TZ",0);
10383 if (tz) strcpy(ucxtz, tz);
10384 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
10387 if (!*tz) tz = ucxtz;
10390 while (isalpha(*s)) s++;
10391 s = tz_parse_offset(s, &std_off);
10393 if (!*s) { /* no DST, hurray we're done! */
10399 while (isalpha(*s)) s++;
10400 s2 = tz_parse_offset(s, &dst_off);
10404 dst_off = std_off - 3600;
10407 if (!*s) { /* default dst start/end?? */
10408 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
10409 s = strchr(ucxtz,',');
10411 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
10413 if (*s != ',') return 0;
10416 when = _toutc(when); /* convert to utc */
10417 when = when - std_off; /* convert to pseudolocal time*/
10419 w2 = localtime(&when);
10422 s = tz_parse_startend(s_start,w2,&dststart);
10424 if (*s != ',') return 0;
10427 when = _toutc(when); /* convert to utc */
10428 when = when - dst_off; /* convert to pseudolocal time*/
10429 w2 = localtime(&when);
10430 if (w2->tm_year != y) { /* spans a year, just check one time */
10431 when += dst_off - std_off;
10432 w2 = localtime(&when);
10435 s = tz_parse_startend(s_end,w2,&dstend);
10438 if (reversed == -1) { /* need to check if start later than end */
10442 if (when < 2*365*86400) {
10443 when += 2*365*86400;
10447 w2 =localtime(&when);
10448 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
10450 for (j = 0; j < 12; j++) {
10451 w2 =localtime(&when);
10452 tz_parse_startend(s_start,w2,&ds);
10453 tz_parse_startend(s_end,w2,&de);
10454 if (ds != de) break;
10458 if (de && !ds) reversed = 1;
10461 isdst = dststart && !dstend;
10462 if (reversed) isdst = dststart || !dstend;
10465 if (dst) *dst = isdst;
10466 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
10467 if (isdst) tz = dstzone;
10469 while(isalpha(*tz)) *zone++ = *tz++;
10475 #endif /* !RTL_USES_UTC */
10477 /* my_time(), my_localtime(), my_gmtime()
10478 * By default traffic in UTC time values, using CRTL gmtime() or
10479 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
10480 * Note: We need to use these functions even when the CRTL has working
10481 * UTC support, since they also handle C<use vmsish qw(times);>
10483 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
10484 * Modified by Charles Bailey <bailey@newman.upenn.edu>
10487 /*{{{time_t my_time(time_t *timep)*/
10488 time_t Perl_my_time(pTHX_ time_t *timep)
10493 if (gmtime_emulation_type == 0) {
10495 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
10496 /* results of calls to gmtime() and localtime() */
10497 /* for same &base */
10499 gmtime_emulation_type++;
10500 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
10501 char off[LNM$C_NAMLENGTH+1];;
10503 gmtime_emulation_type++;
10504 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
10505 gmtime_emulation_type++;
10506 utc_offset_secs = 0;
10507 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
10509 else { utc_offset_secs = atol(off); }
10511 else { /* We've got a working gmtime() */
10512 struct tm gmt, local;
10515 tm_p = localtime(&base);
10517 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
10518 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
10519 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
10520 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
10525 # ifdef VMSISH_TIME
10526 # ifdef RTL_USES_UTC
10527 if (VMSISH_TIME) when = _toloc(when);
10529 if (!VMSISH_TIME) when = _toutc(when);
10532 if (timep != NULL) *timep = when;
10535 } /* end of my_time() */
10539 /*{{{struct tm *my_gmtime(const time_t *timep)*/
10541 Perl_my_gmtime(pTHX_ const time_t *timep)
10547 if (timep == NULL) {
10548 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10551 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10554 # ifdef VMSISH_TIME
10555 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
10557 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
10558 return gmtime(&when);
10560 /* CRTL localtime() wants local time as input, so does no tz correction */
10561 rsltmp = localtime(&when);
10562 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
10565 } /* end of my_gmtime() */
10569 /*{{{struct tm *my_localtime(const time_t *timep)*/
10571 Perl_my_localtime(pTHX_ const time_t *timep)
10573 time_t when, whenutc;
10577 if (timep == NULL) {
10578 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10581 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
10582 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
10585 # ifdef RTL_USES_UTC
10586 # ifdef VMSISH_TIME
10587 if (VMSISH_TIME) when = _toutc(when);
10589 /* CRTL localtime() wants UTC as input, does tz correction itself */
10590 return localtime(&when);
10592 # else /* !RTL_USES_UTC */
10594 # ifdef VMSISH_TIME
10595 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
10596 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
10599 #ifndef RTL_USES_UTC
10600 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
10601 when = whenutc - offset; /* pseudolocal time*/
10604 /* CRTL localtime() wants local time as input, so does no tz correction */
10605 rsltmp = localtime(&when);
10606 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
10610 } /* end of my_localtime() */
10613 /* Reset definitions for later calls */
10614 #define gmtime(t) my_gmtime(t)
10615 #define localtime(t) my_localtime(t)
10616 #define time(t) my_time(t)
10619 /* my_utime - update modification/access time of a file
10621 * VMS 7.3 and later implementation
10622 * Only the UTC translation is home-grown. The rest is handled by the
10623 * CRTL utime(), which will take into account the relevant feature
10624 * logicals and ODS-5 volume characteristics for true access times.
10626 * pre VMS 7.3 implementation:
10627 * The calling sequence is identical to POSIX utime(), but under
10628 * VMS with ODS-2, only the modification time is changed; ODS-2 does
10629 * not maintain access times. Restrictions differ from the POSIX
10630 * definition in that the time can be changed as long as the
10631 * caller has permission to execute the necessary IO$_MODIFY $QIO;
10632 * no separate checks are made to insure that the caller is the
10633 * owner of the file or has special privs enabled.
10634 * Code here is based on Joe Meadows' FILE utility.
10638 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
10639 * to VMS epoch (01-JAN-1858 00:00:00.00)
10640 * in 100 ns intervals.
10642 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
10644 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
10645 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
10647 #if __CRTL_VER >= 70300000
10648 struct utimbuf utc_utimes, *utc_utimesp;
10650 if (utimes != NULL) {
10651 utc_utimes.actime = utimes->actime;
10652 utc_utimes.modtime = utimes->modtime;
10653 # ifdef VMSISH_TIME
10654 /* If input was local; convert to UTC for sys svc */
10656 utc_utimes.actime = _toutc(utimes->actime);
10657 utc_utimes.modtime = _toutc(utimes->modtime);
10660 utc_utimesp = &utc_utimes;
10663 utc_utimesp = NULL;
10666 return utime(file, utc_utimesp);
10668 #else /* __CRTL_VER < 70300000 */
10672 long int bintime[2], len = 2, lowbit, unixtime,
10673 secscale = 10000000; /* seconds --> 100 ns intervals */
10674 unsigned long int chan, iosb[2], retsts;
10675 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
10676 struct FAB myfab = cc$rms_fab;
10677 struct NAM mynam = cc$rms_nam;
10678 #if defined (__DECC) && defined (__VAX)
10679 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
10680 * at least through VMS V6.1, which causes a type-conversion warning.
10682 # pragma message save
10683 # pragma message disable cvtdiftypes
10685 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
10686 struct fibdef myfib;
10687 #if defined (__DECC) && defined (__VAX)
10688 /* This should be right after the declaration of myatr, but due
10689 * to a bug in VAX DEC C, this takes effect a statement early.
10691 # pragma message restore
10693 /* cast ok for read only parameter */
10694 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
10695 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
10696 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
10698 if (file == NULL || *file == '\0') {
10699 SETERRNO(ENOENT, LIB$_INVARG);
10703 /* Convert to VMS format ensuring that it will fit in 255 characters */
10704 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
10705 SETERRNO(ENOENT, LIB$_INVARG);
10708 if (utimes != NULL) {
10709 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
10710 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
10711 * Since time_t is unsigned long int, and lib$emul takes a signed long int
10712 * as input, we force the sign bit to be clear by shifting unixtime right
10713 * one bit, then multiplying by an extra factor of 2 in lib$emul().
10715 lowbit = (utimes->modtime & 1) ? secscale : 0;
10716 unixtime = (long int) utimes->modtime;
10717 # ifdef VMSISH_TIME
10718 /* If input was UTC; convert to local for sys svc */
10719 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
10721 unixtime >>= 1; secscale <<= 1;
10722 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
10723 if (!(retsts & 1)) {
10724 SETERRNO(EVMSERR, retsts);
10727 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
10728 if (!(retsts & 1)) {
10729 SETERRNO(EVMSERR, retsts);
10734 /* Just get the current time in VMS format directly */
10735 retsts = sys$gettim(bintime);
10736 if (!(retsts & 1)) {
10737 SETERRNO(EVMSERR, retsts);
10742 myfab.fab$l_fna = vmsspec;
10743 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
10744 myfab.fab$l_nam = &mynam;
10745 mynam.nam$l_esa = esa;
10746 mynam.nam$b_ess = (unsigned char) sizeof esa;
10747 mynam.nam$l_rsa = rsa;
10748 mynam.nam$b_rss = (unsigned char) sizeof rsa;
10749 if (decc_efs_case_preserve)
10750 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
10752 /* Look for the file to be affected, letting RMS parse the file
10753 * specification for us as well. I have set errno using only
10754 * values documented in the utime() man page for VMS POSIX.
10756 retsts = sys$parse(&myfab,0,0);
10757 if (!(retsts & 1)) {
10758 set_vaxc_errno(retsts);
10759 if (retsts == RMS$_PRV) set_errno(EACCES);
10760 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
10761 else set_errno(EVMSERR);
10764 retsts = sys$search(&myfab,0,0);
10765 if (!(retsts & 1)) {
10766 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10767 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10768 set_vaxc_errno(retsts);
10769 if (retsts == RMS$_PRV) set_errno(EACCES);
10770 else if (retsts == RMS$_FNF) set_errno(ENOENT);
10771 else set_errno(EVMSERR);
10775 devdsc.dsc$w_length = mynam.nam$b_dev;
10776 /* cast ok for read only parameter */
10777 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
10779 retsts = sys$assign(&devdsc,&chan,0,0);
10780 if (!(retsts & 1)) {
10781 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10782 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10783 set_vaxc_errno(retsts);
10784 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
10785 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
10786 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
10787 else set_errno(EVMSERR);
10791 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
10792 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
10794 memset((void *) &myfib, 0, sizeof myfib);
10795 #if defined(__DECC) || defined(__DECCXX)
10796 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
10797 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
10798 /* This prevents the revision time of the file being reset to the current
10799 * time as a result of our IO$_MODIFY $QIO. */
10800 myfib.fib$l_acctl = FIB$M_NORECORD;
10802 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
10803 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
10804 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
10806 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
10807 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
10808 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
10809 _ckvmssts(sys$dassgn(chan));
10810 if (retsts & 1) retsts = iosb[0];
10811 if (!(retsts & 1)) {
10812 set_vaxc_errno(retsts);
10813 if (retsts == SS$_NOPRIV) set_errno(EACCES);
10814 else set_errno(EVMSERR);
10820 #endif /* #if __CRTL_VER >= 70300000 */
10822 } /* end of my_utime() */
10826 * flex_stat, flex_lstat, flex_fstat
10827 * basic stat, but gets it right when asked to stat
10828 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
10831 #ifndef _USE_STD_STAT
10832 /* encode_dev packs a VMS device name string into an integer to allow
10833 * simple comparisons. This can be used, for example, to check whether two
10834 * files are located on the same device, by comparing their encoded device
10835 * names. Even a string comparison would not do, because stat() reuses the
10836 * device name buffer for each call; so without encode_dev, it would be
10837 * necessary to save the buffer and use strcmp (this would mean a number of
10838 * changes to the standard Perl code, to say nothing of what a Perl script
10839 * would have to do.
10841 * The device lock id, if it exists, should be unique (unless perhaps compared
10842 * with lock ids transferred from other nodes). We have a lock id if the disk is
10843 * mounted cluster-wide, which is when we tend to get long (host-qualified)
10844 * device names. Thus we use the lock id in preference, and only if that isn't
10845 * available, do we try to pack the device name into an integer (flagged by
10846 * the sign bit (LOCKID_MASK) being set).
10848 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
10849 * name and its encoded form, but it seems very unlikely that we will find
10850 * two files on different disks that share the same encoded device names,
10851 * and even more remote that they will share the same file id (if the test
10852 * is to check for the same file).
10854 * A better method might be to use sys$device_scan on the first call, and to
10855 * search for the device, returning an index into the cached array.
10856 * The number returned would be more intelligible.
10857 * This is probably not worth it, and anyway would take quite a bit longer
10858 * on the first call.
10860 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
10861 static mydev_t encode_dev (pTHX_ const char *dev)
10864 unsigned long int f;
10869 if (!dev || !dev[0]) return 0;
10873 struct dsc$descriptor_s dev_desc;
10874 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
10876 /* For cluster-mounted disks, the disk lock identifier is unique, so we
10877 can try that first. */
10878 dev_desc.dsc$w_length = strlen (dev);
10879 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
10880 dev_desc.dsc$b_class = DSC$K_CLASS_S;
10881 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
10882 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
10883 if (!$VMS_STATUS_SUCCESS(status)) {
10885 case SS$_NOSUCHDEV:
10886 SETERRNO(ENODEV, status);
10892 if (lockid) return (lockid & ~LOCKID_MASK);
10896 /* Otherwise we try to encode the device name */
10900 for (q = dev + strlen(dev); q--; q >= dev) {
10905 else if (isalpha (toupper (*q)))
10906 c= toupper (*q) - 'A' + (char)10;
10908 continue; /* Skip '$'s */
10910 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
10912 enc += f * (unsigned long int) c;
10914 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
10916 } /* end of encode_dev() */
10917 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10918 device_no = encode_dev(aTHX_ devname)
10920 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
10921 device_no = new_dev_no
10925 is_null_device(name)
10928 if (decc_bug_devnull != 0) {
10929 if (strncmp("/dev/null", name, 9) == 0)
10932 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
10933 The underscore prefix, controller letter, and unit number are
10934 independently optional; for our purposes, the colon punctuation
10935 is not. The colon can be trailed by optional directory and/or
10936 filename, but two consecutive colons indicates a nodename rather
10937 than a device. [pr] */
10938 if (*name == '_') ++name;
10939 if (tolower(*name++) != 'n') return 0;
10940 if (tolower(*name++) != 'l') return 0;
10941 if (tolower(*name) == 'a') ++name;
10942 if (*name == '0') ++name;
10943 return (*name++ == ':') && (*name != ':');
10948 Perl_cando_by_name_int
10949 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
10951 char usrname[L_cuserid];
10952 struct dsc$descriptor_s usrdsc =
10953 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
10954 char *vmsname = NULL, *fileified = NULL;
10955 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
10956 unsigned short int retlen, trnlnm_iter_count;
10957 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10958 union prvdef curprv;
10959 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
10960 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
10961 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
10962 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
10963 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
10965 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
10967 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10969 static int profile_context = -1;
10971 if (!fname || !*fname) return FALSE;
10973 /* Make sure we expand logical names, since sys$check_access doesn't */
10974 fileified = PerlMem_malloc(VMS_MAXRSS);
10975 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
10976 if (!strpbrk(fname,"/]>:")) {
10977 strcpy(fileified,fname);
10978 trnlnm_iter_count = 0;
10979 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
10980 trnlnm_iter_count++;
10981 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
10986 vmsname = PerlMem_malloc(VMS_MAXRSS);
10987 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
10988 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
10989 /* Don't know if already in VMS format, so make sure */
10990 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
10991 PerlMem_free(fileified);
10992 PerlMem_free(vmsname);
10997 strcpy(vmsname,fname);
11000 /* sys$check_access needs a file spec, not a directory spec.
11001 * Don't use flex_stat here, as that depends on thread context
11002 * having been initialized, and we may get here during startup.
11005 retlen = namdsc.dsc$w_length = strlen(vmsname);
11006 if (vmsname[retlen-1] == ']'
11007 || vmsname[retlen-1] == '>'
11008 || vmsname[retlen-1] == ':'
11009 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11011 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11012 PerlMem_free(fileified);
11013 PerlMem_free(vmsname);
11022 retlen = namdsc.dsc$w_length = strlen(fname);
11023 namdsc.dsc$a_pointer = (char *)fname;
11026 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11027 access = ARM$M_EXECUTE;
11028 flags = CHP$M_READ;
11030 case S_IRUSR: case S_IRGRP: case S_IROTH:
11031 access = ARM$M_READ;
11032 flags = CHP$M_READ | CHP$M_USEREADALL;
11034 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11035 access = ARM$M_WRITE;
11036 flags = CHP$M_READ | CHP$M_WRITE;
11038 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11039 access = ARM$M_DELETE;
11040 flags = CHP$M_READ | CHP$M_WRITE;
11043 if (fileified != NULL)
11044 PerlMem_free(fileified);
11045 if (vmsname != NULL)
11046 PerlMem_free(vmsname);
11050 /* Before we call $check_access, create a user profile with the current
11051 * process privs since otherwise it just uses the default privs from the
11052 * UAF and might give false positives or negatives. This only works on
11053 * VMS versions v6.0 and later since that's when sys$create_user_profile
11054 * became available.
11057 /* get current process privs and username */
11058 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11059 _ckvmssts(iosb[0]);
11061 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11063 /* find out the space required for the profile */
11064 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11065 &usrprodsc.dsc$w_length,&profile_context));
11067 /* allocate space for the profile and get it filled in */
11068 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11069 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11070 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11071 &usrprodsc.dsc$w_length,&profile_context));
11073 /* use the profile to check access to the file; free profile & analyze results */
11074 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11075 PerlMem_free(usrprodsc.dsc$a_pointer);
11076 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11080 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11084 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11085 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11086 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11087 set_vaxc_errno(retsts);
11088 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11089 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11090 else set_errno(ENOENT);
11091 if (fileified != NULL)
11092 PerlMem_free(fileified);
11093 if (vmsname != NULL)
11094 PerlMem_free(vmsname);
11097 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11098 if (fileified != NULL)
11099 PerlMem_free(fileified);
11100 if (vmsname != NULL)
11101 PerlMem_free(vmsname);
11106 if (fileified != NULL)
11107 PerlMem_free(fileified);
11108 if (vmsname != NULL)
11109 PerlMem_free(vmsname);
11110 return FALSE; /* Should never get here */
11114 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11115 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11116 * subset of the applicable information.
11119 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11121 return cando_by_name_int
11122 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11123 } /* end of cando() */
11127 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11129 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11131 return cando_by_name_int(bit, effective, fname, 0);
11133 } /* end of cando_by_name() */
11137 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11139 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11141 if (!fstat(fd,(stat_t *) statbufp)) {
11143 char *vms_filename;
11144 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11145 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11147 /* Save name for cando by name in VMS format */
11148 cptr = getname(fd, vms_filename, 1);
11150 /* This should not happen, but just in case */
11151 if (cptr == NULL) {
11152 statbufp->st_devnam[0] = 0;
11155 /* Make sure that the saved name fits in 255 characters */
11156 cptr = do_rmsexpand
11158 statbufp->st_devnam,
11161 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11165 statbufp->st_devnam[0] = 0;
11167 PerlMem_free(vms_filename);
11169 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11171 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11173 # ifdef RTL_USES_UTC
11174 # ifdef VMSISH_TIME
11176 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11177 statbufp->st_atime = _toloc(statbufp->st_atime);
11178 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11182 # ifdef VMSISH_TIME
11183 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11187 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11188 statbufp->st_atime = _toutc(statbufp->st_atime);
11189 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11196 } /* end of flex_fstat() */
11199 #if !defined(__VAX) && __CRTL_VER >= 80200000
11207 #define lstat(_x, _y) stat(_x, _y)
11210 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11213 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11215 char fileified[VMS_MAXRSS];
11216 char temp_fspec[VMS_MAXRSS];
11219 int saved_errno, saved_vaxc_errno;
11221 if (!fspec) return retval;
11222 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11223 strcpy(temp_fspec, fspec);
11225 if (decc_bug_devnull != 0) {
11226 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11227 memset(statbufp,0,sizeof *statbufp);
11228 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11229 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11230 statbufp->st_uid = 0x00010001;
11231 statbufp->st_gid = 0x0001;
11232 time((time_t *)&statbufp->st_mtime);
11233 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11238 /* Try for a directory name first. If fspec contains a filename without
11239 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11240 * and sea:[wine.dark]water. exist, we prefer the directory here.
11241 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11242 * not sea:[wine.dark]., if the latter exists. If the intended target is
11243 * the file with null type, specify this by calling flex_stat() with
11244 * a '.' at the end of fspec.
11246 * If we are in Posix filespec mode, accept the filename as is.
11250 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11251 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11252 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11254 if (!decc_efs_charset)
11255 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11258 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11259 if (decc_posix_compliant_pathnames == 0) {
11261 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11262 if (lstat_flag == 0)
11263 retval = stat(fileified,(stat_t *) statbufp);
11265 retval = lstat(fileified,(stat_t *) statbufp);
11266 save_spec = fileified;
11269 if (lstat_flag == 0)
11270 retval = stat(temp_fspec,(stat_t *) statbufp);
11272 retval = lstat(temp_fspec,(stat_t *) statbufp);
11273 save_spec = temp_fspec;
11275 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11277 if (lstat_flag == 0)
11278 retval = stat(temp_fspec,(stat_t *) statbufp);
11280 retval = lstat(temp_fspec,(stat_t *) statbufp);
11281 save_spec = temp_fspec;
11285 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11286 /* As you were... */
11287 if (!decc_efs_charset)
11288 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11293 cptr = do_rmsexpand
11294 (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
11296 statbufp->st_devnam[0] = 0;
11298 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11300 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11301 # ifdef RTL_USES_UTC
11302 # ifdef VMSISH_TIME
11304 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11305 statbufp->st_atime = _toloc(statbufp->st_atime);
11306 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11310 # ifdef VMSISH_TIME
11311 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11315 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11316 statbufp->st_atime = _toutc(statbufp->st_atime);
11317 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11321 /* If we were successful, leave errno where we found it */
11322 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
11325 } /* end of flex_stat_int() */
11328 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
11330 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
11332 return flex_stat_int(fspec, statbufp, 0);
11336 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
11338 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
11340 return flex_stat_int(fspec, statbufp, 1);
11345 /*{{{char *my_getlogin()*/
11346 /* VMS cuserid == Unix getlogin, except calling sequence */
11350 static char user[L_cuserid];
11351 return cuserid(user);
11356 /* rmscopy - copy a file using VMS RMS routines
11358 * Copies contents and attributes of spec_in to spec_out, except owner
11359 * and protection information. Name and type of spec_in are used as
11360 * defaults for spec_out. The third parameter specifies whether rmscopy()
11361 * should try to propagate timestamps from the input file to the output file.
11362 * If it is less than 0, no timestamps are preserved. If it is 0, then
11363 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
11364 * propagated to the output file at creation iff the output file specification
11365 * did not contain an explicit name or type, and the revision date is always
11366 * updated at the end of the copy operation. If it is greater than 0, then
11367 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
11368 * other than the revision date should be propagated, and bit 1 indicates
11369 * that the revision date should be propagated.
11371 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
11373 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
11374 * Incorporates, with permission, some code from EZCOPY by Tim Adye
11375 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
11376 * as part of the Perl standard distribution under the terms of the
11377 * GNU General Public License or the Perl Artistic License. Copies
11378 * of each may be found in the Perl standard distribution.
11380 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
11382 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
11384 char *vmsin, * vmsout, *esa, *esa_out,
11386 unsigned long int i, sts, sts2;
11388 struct FAB fab_in, fab_out;
11389 struct RAB rab_in, rab_out;
11390 rms_setup_nam(nam);
11391 rms_setup_nam(nam_out);
11392 struct XABDAT xabdat;
11393 struct XABFHC xabfhc;
11394 struct XABRDT xabrdt;
11395 struct XABSUM xabsum;
11397 vmsin = PerlMem_malloc(VMS_MAXRSS);
11398 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
11399 vmsout = PerlMem_malloc(VMS_MAXRSS);
11400 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
11401 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
11402 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
11403 PerlMem_free(vmsin);
11404 PerlMem_free(vmsout);
11405 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11409 esa = PerlMem_malloc(VMS_MAXRSS);
11410 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
11411 fab_in = cc$rms_fab;
11412 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
11413 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
11414 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
11415 fab_in.fab$l_fop = FAB$M_SQO;
11416 rms_bind_fab_nam(fab_in, nam);
11417 fab_in.fab$l_xab = (void *) &xabdat;
11419 rsa = PerlMem_malloc(VMS_MAXRSS);
11420 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
11421 rms_set_rsa(nam, rsa, (VMS_MAXRSS-1));
11422 rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1));
11423 rms_nam_esl(nam) = 0;
11424 rms_nam_rsl(nam) = 0;
11425 rms_nam_esll(nam) = 0;
11426 rms_nam_rsll(nam) = 0;
11427 #ifdef NAM$M_NO_SHORT_UPCASE
11428 if (decc_efs_case_preserve)
11429 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
11432 xabdat = cc$rms_xabdat; /* To get creation date */
11433 xabdat.xab$l_nxt = (void *) &xabfhc;
11435 xabfhc = cc$rms_xabfhc; /* To get record length */
11436 xabfhc.xab$l_nxt = (void *) &xabsum;
11438 xabsum = cc$rms_xabsum; /* To get key and area information */
11440 if (!((sts = sys$open(&fab_in)) & 1)) {
11441 PerlMem_free(vmsin);
11442 PerlMem_free(vmsout);
11445 set_vaxc_errno(sts);
11447 case RMS$_FNF: case RMS$_DNF:
11448 set_errno(ENOENT); break;
11450 set_errno(ENOTDIR); break;
11452 set_errno(ENODEV); break;
11454 set_errno(EINVAL); break;
11456 set_errno(EACCES); break;
11458 set_errno(EVMSERR);
11465 fab_out.fab$w_ifi = 0;
11466 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
11467 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
11468 fab_out.fab$l_fop = FAB$M_SQO;
11469 rms_bind_fab_nam(fab_out, nam_out);
11470 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
11471 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
11472 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
11473 esa_out = PerlMem_malloc(VMS_MAXRSS);
11474 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
11475 rms_set_rsa(nam_out, NULL, 0);
11476 rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1));
11478 if (preserve_dates == 0) { /* Act like DCL COPY */
11479 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
11480 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
11481 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
11482 PerlMem_free(vmsin);
11483 PerlMem_free(vmsout);
11486 PerlMem_free(esa_out);
11487 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
11488 set_vaxc_errno(sts);
11491 fab_out.fab$l_xab = (void *) &xabdat;
11492 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
11493 preserve_dates = 1;
11495 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
11496 preserve_dates =0; /* bitmask from this point forward */
11498 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
11499 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
11500 PerlMem_free(vmsin);
11501 PerlMem_free(vmsout);
11504 PerlMem_free(esa_out);
11505 set_vaxc_errno(sts);
11508 set_errno(ENOENT); break;
11510 set_errno(ENOTDIR); break;
11512 set_errno(ENODEV); break;
11514 set_errno(EINVAL); break;
11516 set_errno(EACCES); break;
11518 set_errno(EVMSERR);
11522 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
11523 if (preserve_dates & 2) {
11524 /* sys$close() will process xabrdt, not xabdat */
11525 xabrdt = cc$rms_xabrdt;
11527 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
11529 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
11530 * is unsigned long[2], while DECC & VAXC use a struct */
11531 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
11533 fab_out.fab$l_xab = (void *) &xabrdt;
11536 ubf = PerlMem_malloc(32256);
11537 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
11538 rab_in = cc$rms_rab;
11539 rab_in.rab$l_fab = &fab_in;
11540 rab_in.rab$l_rop = RAB$M_BIO;
11541 rab_in.rab$l_ubf = ubf;
11542 rab_in.rab$w_usz = 32256;
11543 if (!((sts = sys$connect(&rab_in)) & 1)) {
11544 sys$close(&fab_in); sys$close(&fab_out);
11545 PerlMem_free(vmsin);
11546 PerlMem_free(vmsout);
11550 PerlMem_free(esa_out);
11551 set_errno(EVMSERR); set_vaxc_errno(sts);
11555 rab_out = cc$rms_rab;
11556 rab_out.rab$l_fab = &fab_out;
11557 rab_out.rab$l_rbf = ubf;
11558 if (!((sts = sys$connect(&rab_out)) & 1)) {
11559 sys$close(&fab_in); sys$close(&fab_out);
11560 PerlMem_free(vmsin);
11561 PerlMem_free(vmsout);
11565 PerlMem_free(esa_out);
11566 set_errno(EVMSERR); set_vaxc_errno(sts);
11570 while ((sts = sys$read(&rab_in))) { /* always true */
11571 if (sts == RMS$_EOF) break;
11572 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
11573 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
11574 sys$close(&fab_in); sys$close(&fab_out);
11575 PerlMem_free(vmsin);
11576 PerlMem_free(vmsout);
11580 PerlMem_free(esa_out);
11581 set_errno(EVMSERR); set_vaxc_errno(sts);
11587 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
11588 sys$close(&fab_in); sys$close(&fab_out);
11589 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
11591 PerlMem_free(vmsin);
11592 PerlMem_free(vmsout);
11596 PerlMem_free(esa_out);
11597 set_errno(EVMSERR); set_vaxc_errno(sts);
11601 PerlMem_free(vmsin);
11602 PerlMem_free(vmsout);
11606 PerlMem_free(esa_out);
11609 } /* end of rmscopy() */
11613 /*** The following glue provides 'hooks' to make some of the routines
11614 * from this file available from Perl. These routines are sufficiently
11615 * basic, and are required sufficiently early in the build process,
11616 * that's it's nice to have them available to miniperl as well as the
11617 * full Perl, so they're set up here instead of in an extension. The
11618 * Perl code which handles importation of these names into a given
11619 * package lives in [.VMS]Filespec.pm in @INC.
11623 rmsexpand_fromperl(pTHX_ CV *cv)
11626 char *fspec, *defspec = NULL, *rslt;
11628 int fs_utf8, dfs_utf8;
11632 if (!items || items > 2)
11633 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
11634 fspec = SvPV(ST(0),n_a);
11635 fs_utf8 = SvUTF8(ST(0));
11636 if (!fspec || !*fspec) XSRETURN_UNDEF;
11638 defspec = SvPV(ST(1),n_a);
11639 dfs_utf8 = SvUTF8(ST(1));
11641 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
11642 ST(0) = sv_newmortal();
11643 if (rslt != NULL) {
11644 sv_usepvn(ST(0),rslt,strlen(rslt));
11653 vmsify_fromperl(pTHX_ CV *cv)
11660 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
11661 utf8_fl = SvUTF8(ST(0));
11662 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11663 ST(0) = sv_newmortal();
11664 if (vmsified != NULL) {
11665 sv_usepvn(ST(0),vmsified,strlen(vmsified));
11674 unixify_fromperl(pTHX_ CV *cv)
11681 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
11682 utf8_fl = SvUTF8(ST(0));
11683 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11684 ST(0) = sv_newmortal();
11685 if (unixified != NULL) {
11686 sv_usepvn(ST(0),unixified,strlen(unixified));
11695 fileify_fromperl(pTHX_ CV *cv)
11702 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
11703 utf8_fl = SvUTF8(ST(0));
11704 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11705 ST(0) = sv_newmortal();
11706 if (fileified != NULL) {
11707 sv_usepvn(ST(0),fileified,strlen(fileified));
11716 pathify_fromperl(pTHX_ CV *cv)
11723 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
11724 utf8_fl = SvUTF8(ST(0));
11725 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11726 ST(0) = sv_newmortal();
11727 if (pathified != NULL) {
11728 sv_usepvn(ST(0),pathified,strlen(pathified));
11737 vmspath_fromperl(pTHX_ CV *cv)
11744 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
11745 utf8_fl = SvUTF8(ST(0));
11746 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11747 ST(0) = sv_newmortal();
11748 if (vmspath != NULL) {
11749 sv_usepvn(ST(0),vmspath,strlen(vmspath));
11758 unixpath_fromperl(pTHX_ CV *cv)
11765 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
11766 utf8_fl = SvUTF8(ST(0));
11767 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
11768 ST(0) = sv_newmortal();
11769 if (unixpath != NULL) {
11770 sv_usepvn(ST(0),unixpath,strlen(unixpath));
11779 candelete_fromperl(pTHX_ CV *cv)
11787 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
11789 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11790 Newx(fspec, VMS_MAXRSS, char);
11791 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
11792 if (SvTYPE(mysv) == SVt_PVGV) {
11793 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
11794 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11802 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
11803 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11810 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
11816 rmscopy_fromperl(pTHX_ CV *cv)
11819 char *inspec, *outspec, *inp, *outp;
11821 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
11822 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11823 unsigned long int sts;
11828 if (items < 2 || items > 3)
11829 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
11831 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
11832 Newx(inspec, VMS_MAXRSS, char);
11833 if (SvTYPE(mysv) == SVt_PVGV) {
11834 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
11835 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11843 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
11844 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11850 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
11851 Newx(outspec, VMS_MAXRSS, char);
11852 if (SvTYPE(mysv) == SVt_PVGV) {
11853 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
11854 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11863 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
11864 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11871 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
11873 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
11879 /* The mod2fname is limited to shorter filenames by design, so it should
11880 * not be modified to support longer EFS pathnames
11883 mod2fname(pTHX_ CV *cv)
11886 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
11887 workbuff[NAM$C_MAXRSS*1 + 1];
11888 int total_namelen = 3, counter, num_entries;
11889 /* ODS-5 ups this, but we want to be consistent, so... */
11890 int max_name_len = 39;
11891 AV *in_array = (AV *)SvRV(ST(0));
11893 num_entries = av_len(in_array);
11895 /* All the names start with PL_. */
11896 strcpy(ultimate_name, "PL_");
11898 /* Clean up our working buffer */
11899 Zero(work_name, sizeof(work_name), char);
11901 /* Run through the entries and build up a working name */
11902 for(counter = 0; counter <= num_entries; counter++) {
11903 /* If it's not the first name then tack on a __ */
11905 strcat(work_name, "__");
11907 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
11911 /* Check to see if we actually have to bother...*/
11912 if (strlen(work_name) + 3 <= max_name_len) {
11913 strcat(ultimate_name, work_name);
11915 /* It's too darned big, so we need to go strip. We use the same */
11916 /* algorithm as xsubpp does. First, strip out doubled __ */
11917 char *source, *dest, last;
11920 for (source = work_name; *source; source++) {
11921 if (last == *source && last == '_') {
11927 /* Go put it back */
11928 strcpy(work_name, workbuff);
11929 /* Is it still too big? */
11930 if (strlen(work_name) + 3 > max_name_len) {
11931 /* Strip duplicate letters */
11934 for (source = work_name; *source; source++) {
11935 if (last == toupper(*source)) {
11939 last = toupper(*source);
11941 strcpy(work_name, workbuff);
11944 /* Is it *still* too big? */
11945 if (strlen(work_name) + 3 > max_name_len) {
11946 /* Too bad, we truncate */
11947 work_name[max_name_len - 2] = 0;
11949 strcat(ultimate_name, work_name);
11952 /* Okay, return it */
11953 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
11958 hushexit_fromperl(pTHX_ CV *cv)
11963 VMSISH_HUSHED = SvTRUE(ST(0));
11965 ST(0) = boolSV(VMSISH_HUSHED);
11971 Perl_vms_start_glob
11972 (pTHX_ SV *tmpglob,
11976 struct vs_str_st *rslt;
11980 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
11983 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11984 struct dsc$descriptor_vs rsdsc;
11985 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
11986 unsigned long hasver = 0, isunix = 0;
11987 unsigned long int lff_flags = 0;
11990 #ifdef VMS_LONGNAME_SUPPORT
11991 lff_flags = LIB$M_FIL_LONG_NAMES;
11993 /* The Newx macro will not allow me to assign a smaller array
11994 * to the rslt pointer, so we will assign it to the begin char pointer
11995 * and then copy the value into the rslt pointer.
11997 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
11998 rslt = (struct vs_str_st *)begin;
12000 rstr = &rslt->str[0];
12001 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12002 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12003 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12004 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12006 Newx(vmsspec, VMS_MAXRSS, char);
12008 /* We could find out if there's an explicit dev/dir or version
12009 by peeking into lib$find_file's internal context at
12010 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12011 but that's unsupported, so I don't want to do it now and
12012 have it bite someone in the future. */
12013 /* Fix-me: vms_split_path() is the only way to do this, the
12014 existing method will fail with many legal EFS or UNIX specifications
12017 cp = SvPV(tmpglob,i);
12020 if (cp[i] == ';') hasver = 1;
12021 if (cp[i] == '.') {
12022 if (sts) hasver = 1;
12025 if (cp[i] == '/') {
12026 hasdir = isunix = 1;
12029 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12034 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12038 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12039 if (!stat_sts && S_ISDIR(st.st_mode)) {
12040 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12041 ok = (wilddsc.dsc$a_pointer != NULL);
12042 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12046 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12047 ok = (wilddsc.dsc$a_pointer != NULL);
12050 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12052 /* If not extended character set, replace ? with % */
12053 /* With extended character set, ? is a wildcard single character */
12054 if (!decc_efs_case_preserve) {
12055 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12056 if (*cp == '?') *cp = '%';
12059 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12060 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12061 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12063 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12064 &dfltdsc,NULL,&rms_sts,&lff_flags);
12065 if (!$VMS_STATUS_SUCCESS(sts))
12070 /* with varying string, 1st word of buffer contains result length */
12071 rstr[rslt->length] = '\0';
12073 /* Find where all the components are */
12074 v_sts = vms_split_path
12089 /* If no version on input, truncate the version on output */
12090 if (!hasver && (vs_len > 0)) {
12094 /* No version & a null extension on UNIX handling */
12095 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12101 if (!decc_efs_case_preserve) {
12102 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12106 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12110 /* Start with the name */
12113 strcat(begin,"\n");
12114 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12116 if (cxt) (void)lib$find_file_end(&cxt);
12119 /* Be POSIXish: return the input pattern when no matches */
12120 begin = SvPVX(tmpglob);
12121 strcat(begin,"\n");
12122 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12125 if (ok && sts != RMS$_NMF &&
12126 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12129 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12131 PerlIO_close(tmpfp);
12135 PerlIO_rewind(tmpfp);
12136 IoTYPE(io) = IoTYPE_RDONLY;
12137 IoIFP(io) = fp = tmpfp;
12138 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12149 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12150 const int *utf8_fl);
12153 vms_realpath_fromperl(pTHX_ CV *cv)
12156 char *fspec, *rslt_spec, *rslt;
12159 if (!items || items != 1)
12160 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12162 fspec = SvPV(ST(0),n_a);
12163 if (!fspec || !*fspec) XSRETURN_UNDEF;
12165 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12166 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12167 ST(0) = sv_newmortal();
12169 sv_usepvn(ST(0),rslt,strlen(rslt));
12171 Safefree(rslt_spec);
12176 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12177 int do_vms_case_tolerant(void);
12180 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12183 ST(0) = boolSV(do_vms_case_tolerant());
12189 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12190 struct interp_intern *dst)
12192 memcpy(dst,src,sizeof(struct interp_intern));
12196 Perl_sys_intern_clear(pTHX)
12201 Perl_sys_intern_init(pTHX)
12203 unsigned int ix = RAND_MAX;
12208 /* fix me later to track running under GNV */
12209 /* this allows some limited testing */
12210 MY_POSIX_EXIT = decc_filename_unix_report;
12213 MY_INV_RAND_MAX = 1./x;
12217 init_os_extras(void)
12220 char* file = __FILE__;
12221 if (decc_disable_to_vms_logname_translation) {
12222 no_translate_barewords = TRUE;
12224 no_translate_barewords = FALSE;
12227 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
12228 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
12229 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
12230 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
12231 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
12232 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
12233 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
12234 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
12235 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
12236 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
12237 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
12239 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
12241 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12242 newXSproto("VMS::Filespec::case_tolerant",vms_case_tolerant_fromperl,file,"$;$");
12245 store_pipelocs(aTHX); /* will redo any earlier attempts */
12252 #if __CRTL_VER == 80200000
12253 /* This missed getting in to the DECC SDK for 8.2 */
12254 char *realpath(const char *file_name, char * resolved_name, ...);
12257 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
12258 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
12259 * The perl fallback routine to provide realpath() is not as efficient
12263 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
12264 const int *utf8_fl)
12266 return realpath(filespec, outbuf);
12270 /* External entry points */
12271 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12272 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
12274 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
12279 #if __CRTL_VER >= 70301000 && !defined(__VAX)
12280 /* case_tolerant */
12282 /*{{{int do_vms_case_tolerant(void)*/
12283 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
12284 * controlled by a process setting.
12286 int do_vms_case_tolerant(void)
12288 return vms_process_case_tolerant;
12291 /* External entry points */
12292 int Perl_vms_case_tolerant(void)
12293 { return do_vms_case_tolerant(); }
12295 int Perl_vms_case_tolerant(void)
12296 { return vms_process_case_tolerant; }
12300 /* Start of DECC RTL Feature handling */
12302 static int sys_trnlnm
12303 (const char * logname,
12307 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
12308 const unsigned long attr = LNM$M_CASE_BLIND;
12309 struct dsc$descriptor_s name_dsc;
12311 unsigned short result;
12312 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
12315 name_dsc.dsc$w_length = strlen(logname);
12316 name_dsc.dsc$a_pointer = (char *)logname;
12317 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12318 name_dsc.dsc$b_class = DSC$K_CLASS_S;
12320 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
12322 if ($VMS_STATUS_SUCCESS(status)) {
12324 /* Null terminate and return the string */
12325 /*--------------------------------------*/
12332 static int sys_crelnm
12333 (const char * logname,
12334 const char * value)
12337 const char * proc_table = "LNM$PROCESS_TABLE";
12338 struct dsc$descriptor_s proc_table_dsc;
12339 struct dsc$descriptor_s logname_dsc;
12340 struct itmlst_3 item_list[2];
12342 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
12343 proc_table_dsc.dsc$w_length = strlen(proc_table);
12344 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12345 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
12347 logname_dsc.dsc$a_pointer = (char *) logname;
12348 logname_dsc.dsc$w_length = strlen(logname);
12349 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
12350 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
12352 item_list[0].buflen = strlen(value);
12353 item_list[0].itmcode = LNM$_STRING;
12354 item_list[0].bufadr = (char *)value;
12355 item_list[0].retlen = NULL;
12357 item_list[1].buflen = 0;
12358 item_list[1].itmcode = 0;
12360 ret_val = sys$crelnm
12362 (const struct dsc$descriptor_s *)&proc_table_dsc,
12363 (const struct dsc$descriptor_s *)&logname_dsc,
12365 (const struct item_list_3 *) item_list);
12370 /* C RTL Feature settings */
12372 static int set_features
12373 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
12374 int (* cli_routine)(void), /* Not documented */
12375 void *image_info) /* Not documented */
12382 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12383 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
12384 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
12385 unsigned long case_perm;
12386 unsigned long case_image;
12389 /* Allow an exception to bring Perl into the VMS debugger */
12390 vms_debug_on_exception = 0;
12391 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
12392 if ($VMS_STATUS_SUCCESS(status)) {
12393 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12394 vms_debug_on_exception = 1;
12396 vms_debug_on_exception = 0;
12399 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
12400 vms_vtf7_filenames = 0;
12401 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
12402 if ($VMS_STATUS_SUCCESS(status)) {
12403 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12404 vms_vtf7_filenames = 1;
12406 vms_vtf7_filenames = 0;
12410 /* unlink all versions on unlink() or rename() */
12411 vms_vtf7_filenames = 0;
12412 status = sys_trnlnm
12413 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
12414 if ($VMS_STATUS_SUCCESS(status)) {
12415 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12416 vms_unlink_all_versions = 1;
12418 vms_unlink_all_versions = 0;
12421 /* Dectect running under GNV Bash or other UNIX like shell */
12422 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12423 gnv_unix_shell = 0;
12424 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
12425 if ($VMS_STATUS_SUCCESS(status)) {
12426 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12427 gnv_unix_shell = 1;
12428 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
12429 set_feature_default("DECC$EFS_CHARSET", 1);
12430 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
12431 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
12432 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
12433 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
12434 vms_unlink_all_versions = 1;
12437 gnv_unix_shell = 0;
12441 /* hacks to see if known bugs are still present for testing */
12443 /* Readdir is returning filenames in VMS syntax always */
12444 decc_bug_readdir_efs1 = 1;
12445 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
12446 if ($VMS_STATUS_SUCCESS(status)) {
12447 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12448 decc_bug_readdir_efs1 = 1;
12450 decc_bug_readdir_efs1 = 0;
12453 /* PCP mode requires creating /dev/null special device file */
12454 decc_bug_devnull = 0;
12455 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
12456 if ($VMS_STATUS_SUCCESS(status)) {
12457 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12458 decc_bug_devnull = 1;
12460 decc_bug_devnull = 0;
12463 /* fgetname returning a VMS name in UNIX mode */
12464 decc_bug_fgetname = 1;
12465 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
12466 if ($VMS_STATUS_SUCCESS(status)) {
12467 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12468 decc_bug_fgetname = 1;
12470 decc_bug_fgetname = 0;
12473 /* UNIX directory names with no paths are broken in a lot of places */
12474 decc_dir_barename = 1;
12475 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
12476 if ($VMS_STATUS_SUCCESS(status)) {
12477 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
12478 decc_dir_barename = 1;
12480 decc_dir_barename = 0;
12483 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12484 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
12486 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
12487 if (decc_disable_to_vms_logname_translation < 0)
12488 decc_disable_to_vms_logname_translation = 0;
12491 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
12493 decc_efs_case_preserve = decc$feature_get_value(s, 1);
12494 if (decc_efs_case_preserve < 0)
12495 decc_efs_case_preserve = 0;
12498 s = decc$feature_get_index("DECC$EFS_CHARSET");
12500 decc_efs_charset = decc$feature_get_value(s, 1);
12501 if (decc_efs_charset < 0)
12502 decc_efs_charset = 0;
12505 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
12507 decc_filename_unix_report = decc$feature_get_value(s, 1);
12508 if (decc_filename_unix_report > 0)
12509 decc_filename_unix_report = 1;
12511 decc_filename_unix_report = 0;
12514 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
12516 decc_filename_unix_only = decc$feature_get_value(s, 1);
12517 if (decc_filename_unix_only > 0) {
12518 decc_filename_unix_only = 1;
12521 decc_filename_unix_only = 0;
12525 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
12527 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
12528 if (decc_filename_unix_no_version < 0)
12529 decc_filename_unix_no_version = 0;
12532 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
12534 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
12535 if (decc_readdir_dropdotnotype < 0)
12536 decc_readdir_dropdotnotype = 0;
12539 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
12540 if ($VMS_STATUS_SUCCESS(status)) {
12541 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
12543 dflt = decc$feature_get_value(s, 4);
12545 decc_disable_posix_root = decc$feature_get_value(s, 1);
12546 if (decc_disable_posix_root <= 0) {
12547 decc$feature_set_value(s, 1, 1);
12548 decc_disable_posix_root = 1;
12552 /* Traditionally Perl assumes this is off */
12553 decc_disable_posix_root = 1;
12554 decc$feature_set_value(s, 1, 1);
12559 #if __CRTL_VER >= 80200000
12560 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
12562 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
12563 if (decc_posix_compliant_pathnames < 0)
12564 decc_posix_compliant_pathnames = 0;
12565 if (decc_posix_compliant_pathnames > 4)
12566 decc_posix_compliant_pathnames = 0;
12571 status = sys_trnlnm
12572 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
12573 if ($VMS_STATUS_SUCCESS(status)) {
12574 val_str[0] = _toupper(val_str[0]);
12575 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12576 decc_disable_to_vms_logname_translation = 1;
12581 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
12582 if ($VMS_STATUS_SUCCESS(status)) {
12583 val_str[0] = _toupper(val_str[0]);
12584 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12585 decc_efs_case_preserve = 1;
12590 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
12591 if ($VMS_STATUS_SUCCESS(status)) {
12592 val_str[0] = _toupper(val_str[0]);
12593 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12594 decc_filename_unix_report = 1;
12597 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
12598 if ($VMS_STATUS_SUCCESS(status)) {
12599 val_str[0] = _toupper(val_str[0]);
12600 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12601 decc_filename_unix_only = 1;
12602 decc_filename_unix_report = 1;
12605 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
12606 if ($VMS_STATUS_SUCCESS(status)) {
12607 val_str[0] = _toupper(val_str[0]);
12608 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12609 decc_filename_unix_no_version = 1;
12612 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
12613 if ($VMS_STATUS_SUCCESS(status)) {
12614 val_str[0] = _toupper(val_str[0]);
12615 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
12616 decc_readdir_dropdotnotype = 1;
12621 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
12623 /* Report true case tolerance */
12624 /*----------------------------*/
12625 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
12626 if (!$VMS_STATUS_SUCCESS(status))
12627 case_perm = PPROP$K_CASE_BLIND;
12628 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
12629 if (!$VMS_STATUS_SUCCESS(status))
12630 case_image = PPROP$K_CASE_BLIND;
12631 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
12632 (case_image == PPROP$K_CASE_SENSITIVE))
12633 vms_process_case_tolerant = 0;
12638 /* CRTL can be initialized past this point, but not before. */
12639 /* DECC$CRTL_INIT(); */
12646 #pragma extern_model save
12647 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
12648 const __align (LONGWORD) int spare[8] = {0};
12650 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
12651 #if __DECC_VER >= 60560002
12652 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
12654 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
12656 #endif /* __DECC */
12658 const long vms_cc_features = (const long)set_features;
12661 ** Force a reference to LIB$INITIALIZE to ensure it
12662 ** exists in the image.
12664 int lib$initialize(void);
12666 #pragma extern_model strict_refdef
12668 int lib_init_ref = (int) lib$initialize;
12671 #pragma extern_model restore