3 * VMS-specific routines for perl5
5 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
11 * Please see Changes*.* or the Perl Repository Browser for revision history.
20 #include <climsgdef.h>
31 #include <libclidef.h>
33 #include <lib$routines.h>
37 #if __CRTL_VER >= 70301000 && !defined(__VAX)
47 #include <str$routines.h>
54 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
56 #define NO_EFN EFN$C_ENF
61 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
62 int decc$feature_get_index(const char *name);
63 char* decc$feature_get_name(int index);
64 int decc$feature_get_value(int index, int mode);
65 int decc$feature_set_value(int index, int mode, int value);
70 #pragma member_alignment save
71 #pragma nomember_alignment longword
76 unsigned short * retadr;
78 #pragma member_alignment restore
80 /* More specific prototype than in starlet_c.h makes programming errors
88 const struct dsc$descriptor_s * devnam,
89 const struct item_list_3 * itmlst,
91 void * (astadr)(unsigned long),
96 #ifdef sys$get_security
97 #undef sys$get_security
99 (const struct dsc$descriptor_s * clsnam,
100 const struct dsc$descriptor_s * objnam,
101 const unsigned int *objhan,
103 const struct item_list_3 * itmlst,
104 unsigned int * contxt,
105 const unsigned int * acmode);
108 #ifdef sys$set_security
109 #undef sys$set_security
111 (const struct dsc$descriptor_s * clsnam,
112 const struct dsc$descriptor_s * objnam,
113 const unsigned int *objhan,
115 const struct item_list_3 * itmlst,
116 unsigned int * contxt,
117 const unsigned int * acmode);
120 #ifdef lib$find_image_symbol
121 #undef lib$find_image_symbol
122 int lib$find_image_symbol
123 (const struct dsc$descriptor_s * imgname,
124 const struct dsc$descriptor_s * symname,
126 const struct dsc$descriptor_s * defspec,
130 #ifdef lib$rename_file
131 #undef lib$rename_file
133 (const struct dsc$descriptor_s * old_file_dsc,
134 const struct dsc$descriptor_s * new_file_dsc,
135 const struct dsc$descriptor_s * default_file_dsc,
136 const struct dsc$descriptor_s * related_file_dsc,
137 const unsigned long * flags,
138 void * (success)(const struct dsc$descriptor_s * old_dsc,
139 const struct dsc$descriptor_s * new_dsc,
141 void * (error)(const struct dsc$descriptor_s * old_dsc,
142 const struct dsc$descriptor_s * new_dsc,
145 const int * error_src,
146 const void * usr_arg),
147 int (confirm)(const struct dsc$descriptor_s * old_dsc,
148 const struct dsc$descriptor_s * new_dsc,
149 const void * old_fab,
150 const void * usr_arg),
152 struct dsc$descriptor_s * old_result_name_dsc,
153 struct dsc$descriptor_s * new_result_name_dsc,
154 unsigned long * file_scan_context);
157 #if __CRTL_VER >= 70300000 && !defined(__VAX)
159 static int set_feature_default(const char *name, int value)
164 index = decc$feature_get_index(name);
166 status = decc$feature_set_value(index, 1, value);
167 if (index == -1 || (status == -1)) {
171 status = decc$feature_get_value(index, 1);
172 if (status != value) {
180 /* Older versions of ssdef.h don't have these */
181 #ifndef SS$_INVFILFOROP
182 # define SS$_INVFILFOROP 3930
184 #ifndef SS$_NOSUCHOBJECT
185 # define SS$_NOSUCHOBJECT 2696
188 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
189 #define PERLIO_NOT_STDIO 0
191 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
192 * code below needs to get to the underlying CRTL routines. */
193 #define DONT_MASK_RTL_CALLS
197 /* Anticipating future expansion in lexical warnings . . . */
198 #ifndef WARN_INTERNAL
199 # define WARN_INTERNAL WARN_MISC
202 #ifdef VMS_LONGNAME_SUPPORT
203 #include <libfildef.h>
206 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
207 # define RTL_USES_UTC 1
210 /* Routine to create a decterm for use with the Perl debugger */
211 /* No headers, this information was found in the Programming Concepts Manual */
213 static int (*decw_term_port)
214 (const struct dsc$descriptor_s * display,
215 const struct dsc$descriptor_s * setup_file,
216 const struct dsc$descriptor_s * customization,
217 struct dsc$descriptor_s * result_device_name,
218 unsigned short * result_device_name_length,
221 void * char_change_buffer) = 0;
223 /* gcc's header files don't #define direct access macros
224 * corresponding to VAXC's variant structs */
226 # define uic$v_format uic$r_uic_form.uic$v_format
227 # define uic$v_group uic$r_uic_form.uic$v_group
228 # define uic$v_member uic$r_uic_form.uic$v_member
229 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
230 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
231 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
232 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
235 #if defined(NEED_AN_H_ERRNO)
240 #pragma message disable pragma
241 #pragma member_alignment save
242 #pragma nomember_alignment longword
244 #pragma message disable misalgndmem
247 unsigned short int buflen;
248 unsigned short int itmcode;
250 unsigned short int *retlen;
253 struct filescan_itmlst_2 {
254 unsigned short length;
255 unsigned short itmcode;
260 unsigned short length;
265 #pragma message restore
266 #pragma member_alignment restore
269 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
270 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
271 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
272 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
273 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
274 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
275 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
276 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
277 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
278 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
279 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
280 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
282 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
283 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
284 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
285 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
287 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
288 #define PERL_LNM_MAX_ALLOWED_INDEX 127
290 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
291 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
294 #define PERL_LNM_MAX_ITER 10
296 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
297 #if __CRTL_VER >= 70302000 && !defined(__VAX)
298 #define MAX_DCL_SYMBOL (8192)
299 #define MAX_DCL_LINE_LENGTH (4096 - 4)
301 #define MAX_DCL_SYMBOL (1024)
302 #define MAX_DCL_LINE_LENGTH (1024 - 4)
305 static char *__mystrtolower(char *str)
307 if (str) for (; *str; ++str) *str= tolower(*str);
311 static struct dsc$descriptor_s fildevdsc =
312 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
313 static struct dsc$descriptor_s crtlenvdsc =
314 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
315 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
316 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
317 static struct dsc$descriptor_s **env_tables = defenv;
318 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
320 /* True if we shouldn't treat barewords as logicals during directory */
322 static int no_translate_barewords;
325 static int tz_updated = 1;
328 /* DECC Features that may need to affect how Perl interprets
329 * displays filename information
331 static int decc_disable_to_vms_logname_translation = 1;
332 static int decc_disable_posix_root = 1;
333 int decc_efs_case_preserve = 0;
334 static int decc_efs_charset = 0;
335 static int decc_filename_unix_no_version = 0;
336 static int decc_filename_unix_only = 0;
337 int decc_filename_unix_report = 0;
338 int decc_posix_compliant_pathnames = 0;
339 int decc_readdir_dropdotnotype = 0;
340 static int vms_process_case_tolerant = 1;
341 int vms_vtf7_filenames = 0;
342 int gnv_unix_shell = 0;
343 static int vms_unlink_all_versions = 0;
345 /* bug workarounds if needed */
346 int decc_bug_readdir_efs1 = 0;
347 int decc_bug_devnull = 1;
348 int decc_bug_fgetname = 0;
349 int decc_dir_barename = 0;
351 static int vms_debug_on_exception = 0;
353 /* Is this a UNIX file specification?
354 * No longer a simple check with EFS file specs
355 * For now, not a full check, but need to
356 * handle POSIX ^UP^ specifications
357 * Fixing to handle ^/ cases would require
358 * changes to many other conversion routines.
361 static int is_unix_filespec(const char *path)
367 if (strncmp(path,"\"^UP^",5) != 0) {
368 pch1 = strchr(path, '/');
373 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
374 if (decc_filename_unix_report || decc_filename_unix_only) {
375 if (strcmp(path,".") == 0)
383 /* This routine converts a UCS-2 character to be VTF-7 encoded.
386 static void ucs2_to_vtf7
388 unsigned long ucs2_char,
391 unsigned char * ucs_ptr;
394 ucs_ptr = (unsigned char *)&ucs2_char;
398 hex = (ucs_ptr[1] >> 4) & 0xf;
400 outspec[2] = hex + '0';
402 outspec[2] = (hex - 9) + 'A';
403 hex = ucs_ptr[1] & 0xF;
405 outspec[3] = hex + '0';
407 outspec[3] = (hex - 9) + 'A';
409 hex = (ucs_ptr[0] >> 4) & 0xf;
411 outspec[4] = hex + '0';
413 outspec[4] = (hex - 9) + 'A';
414 hex = ucs_ptr[1] & 0xF;
416 outspec[5] = hex + '0';
418 outspec[5] = (hex - 9) + 'A';
424 /* This handles the conversion of a UNIX extended character set to a ^
425 * escaped VMS character.
426 * in a UNIX file specification.
428 * The output count variable contains the number of characters added
429 * to the output string.
431 * The return value is the number of characters read from the input string
433 static int copy_expand_unix_filename_escape
434 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
442 utf8_flag = *utf8_fl;
446 if (*inspec >= 0x80) {
447 if (utf8_fl && vms_vtf7_filenames) {
448 unsigned long ucs_char;
452 if ((*inspec & 0xE0) == 0xC0) {
454 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
455 if (ucs_char >= 0x80) {
456 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
459 } else if ((*inspec & 0xF0) == 0xE0) {
461 ucs_char = ((inspec[0] & 0xF) << 12) +
462 ((inspec[1] & 0x3f) << 6) +
464 if (ucs_char >= 0x800) {
465 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
469 #if 0 /* I do not see longer sequences supported by OpenVMS */
470 /* Maybe some one can fix this later */
471 } else if ((*inspec & 0xF8) == 0xF0) {
474 } else if ((*inspec & 0xFC) == 0xF8) {
477 } else if ((*inspec & 0xFE) == 0xFC) {
484 /* High bit set, but not a Unicode character! */
486 /* Non printing DECMCS or ISO Latin-1 character? */
487 if (*inspec <= 0x9F) {
491 hex = (*inspec >> 4) & 0xF;
493 outspec[1] = hex + '0';
495 outspec[1] = (hex - 9) + 'A';
499 outspec[2] = hex + '0';
501 outspec[2] = (hex - 9) + 'A';
505 } else if (*inspec == 0xA0) {
511 } else if (*inspec == 0xFF) {
523 /* Is this a macro that needs to be passed through?
524 * Macros start with $( and an alpha character, followed
525 * by a string of alpha numeric characters ending with a )
526 * If this does not match, then encode it as ODS-5.
528 if ((inspec[0] == '$') && (inspec[1] == '(')) {
531 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
533 outspec[0] = inspec[0];
534 outspec[1] = inspec[1];
535 outspec[2] = inspec[2];
537 while(isalnum(inspec[tcnt]) ||
538 (inspec[2] == '.') || (inspec[2] == '_')) {
539 outspec[tcnt] = inspec[tcnt];
542 if (inspec[tcnt] == ')') {
543 outspec[tcnt] = inspec[tcnt];
560 if (decc_efs_charset == 0)
586 /* Don't escape again if following character is
587 * already something we escape.
589 if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
595 /* But otherwise fall through and escape it. */
597 /* Assume that this is to be escaped */
599 outspec[1] = *inspec;
603 case ' ': /* space */
604 /* Assume that this is to be escaped */
619 /* This handles the expansion of a '^' prefix to the proper character
620 * in a UNIX file specification.
622 * The output count variable contains the number of characters added
623 * to the output string.
625 * The return value is the number of characters read from the input
628 static int copy_expand_vms_filename_escape
629 (char *outspec, const char *inspec, int *output_cnt)
636 if (*inspec == '^') {
639 /* Spaces and non-trailing dots should just be passed through,
640 * but eat the escape character.
647 case '_': /* space */
653 /* Hmm. Better leave the escape escaped. */
659 case 'U': /* Unicode - FIX-ME this is wrong. */
662 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
665 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
666 outspec[0] == c1 & 0xff;
667 outspec[1] == c2 & 0xff;
674 /* Error - do best we can to continue */
684 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
688 scnt = sscanf(inspec, "%2x", &c1);
689 outspec[0] = c1 & 0xff;
713 (const struct dsc$descriptor_s * srcstr,
714 struct filescan_itmlst_2 * valuelist,
715 unsigned long * fldflags,
716 struct dsc$descriptor_s *auxout,
717 unsigned short * retlen);
720 /* vms_split_path - Verify that the input file specification is a
721 * VMS format file specification, and provide pointers to the components of
722 * it. With EFS format filenames, this is virtually the only way to
723 * parse a VMS path specification into components.
725 * If the sum of the components do not add up to the length of the
726 * string, then the passed file specification is probably a UNIX style
729 static int vms_split_path
744 struct dsc$descriptor path_desc;
748 struct filescan_itmlst_2 item_list[9];
749 const int filespec = 0;
750 const int nodespec = 1;
751 const int devspec = 2;
752 const int rootspec = 3;
753 const int dirspec = 4;
754 const int namespec = 5;
755 const int typespec = 6;
756 const int verspec = 7;
758 /* Assume the worst for an easy exit */
773 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
774 path_desc.dsc$w_length = strlen(path);
775 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
776 path_desc.dsc$b_class = DSC$K_CLASS_S;
778 /* Get the total length, if it is shorter than the string passed
779 * then this was probably not a VMS formatted file specification
781 item_list[filespec].itmcode = FSCN$_FILESPEC;
782 item_list[filespec].length = 0;
783 item_list[filespec].component = NULL;
785 /* If the node is present, then it gets considered as part of the
786 * volume name to hopefully make things simple.
788 item_list[nodespec].itmcode = FSCN$_NODE;
789 item_list[nodespec].length = 0;
790 item_list[nodespec].component = NULL;
792 item_list[devspec].itmcode = FSCN$_DEVICE;
793 item_list[devspec].length = 0;
794 item_list[devspec].component = NULL;
796 /* root is a special case, adding it to either the directory or
797 * the device components will probalby complicate things for the
798 * callers of this routine, so leave it separate.
800 item_list[rootspec].itmcode = FSCN$_ROOT;
801 item_list[rootspec].length = 0;
802 item_list[rootspec].component = NULL;
804 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
805 item_list[dirspec].length = 0;
806 item_list[dirspec].component = NULL;
808 item_list[namespec].itmcode = FSCN$_NAME;
809 item_list[namespec].length = 0;
810 item_list[namespec].component = NULL;
812 item_list[typespec].itmcode = FSCN$_TYPE;
813 item_list[typespec].length = 0;
814 item_list[typespec].component = NULL;
816 item_list[verspec].itmcode = FSCN$_VERSION;
817 item_list[verspec].length = 0;
818 item_list[verspec].component = NULL;
820 item_list[8].itmcode = 0;
821 item_list[8].length = 0;
822 item_list[8].component = NULL;
824 status = sys$filescan
825 ((const struct dsc$descriptor_s *)&path_desc, item_list,
827 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
829 /* If we parsed it successfully these two lengths should be the same */
830 if (path_desc.dsc$w_length != item_list[filespec].length)
833 /* If we got here, then it is a VMS file specification */
836 /* set the volume name */
837 if (item_list[nodespec].length > 0) {
838 *volume = item_list[nodespec].component;
839 *vol_len = item_list[nodespec].length + item_list[devspec].length;
842 *volume = item_list[devspec].component;
843 *vol_len = item_list[devspec].length;
846 *root = item_list[rootspec].component;
847 *root_len = item_list[rootspec].length;
849 *dir = item_list[dirspec].component;
850 *dir_len = item_list[dirspec].length;
852 /* Now fun with versions and EFS file specifications
853 * The parser can not tell the difference when a "." is a version
854 * delimiter or a part of the file specification.
856 if ((decc_efs_charset) &&
857 (item_list[verspec].length > 0) &&
858 (item_list[verspec].component[0] == '.')) {
859 *name = item_list[namespec].component;
860 *name_len = item_list[namespec].length + item_list[typespec].length;
861 *ext = item_list[verspec].component;
862 *ext_len = item_list[verspec].length;
867 *name = item_list[namespec].component;
868 *name_len = item_list[namespec].length;
869 *ext = item_list[typespec].component;
870 *ext_len = item_list[typespec].length;
871 *version = item_list[verspec].component;
872 *ver_len = item_list[verspec].length;
879 * Routine to retrieve the maximum equivalence index for an input
880 * logical name. Some calls to this routine have no knowledge if
881 * the variable is a logical or not. So on error we return a max
884 /*{{{int my_maxidx(const char *lnm) */
886 my_maxidx(const char *lnm)
890 int attr = LNM$M_CASE_BLIND;
891 struct dsc$descriptor lnmdsc;
892 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
895 lnmdsc.dsc$w_length = strlen(lnm);
896 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
897 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
898 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
900 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
901 if ((status & 1) == 0)
908 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
910 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
911 struct dsc$descriptor_s **tabvec, unsigned long int flags)
914 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
915 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
916 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
918 unsigned char acmode;
919 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
920 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
921 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
922 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
924 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
925 #if defined(PERL_IMPLICIT_CONTEXT)
928 aTHX = PERL_GET_INTERP;
934 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
935 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
937 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
938 *cp2 = _toupper(*cp1);
939 if (cp1 - lnm > LNM$C_NAMLENGTH) {
940 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
944 lnmdsc.dsc$w_length = cp1 - lnm;
945 lnmdsc.dsc$a_pointer = uplnm;
946 uplnm[lnmdsc.dsc$w_length] = '\0';
947 secure = flags & PERL__TRNENV_SECURE;
948 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
949 if (!tabvec || !*tabvec) tabvec = env_tables;
951 for (curtab = 0; tabvec[curtab]; curtab++) {
952 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
953 if (!ivenv && !secure) {
958 Perl_warn(aTHX_ "Can't read CRTL environ\n");
961 retsts = SS$_NOLOGNAM;
962 for (i = 0; environ[i]; i++) {
963 if ((eq = strchr(environ[i],'=')) &&
964 lnmdsc.dsc$w_length == (eq - environ[i]) &&
965 !strncmp(environ[i],uplnm,eq - environ[i])) {
967 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
968 if (!eqvlen) continue;
973 if (retsts != SS$_NOLOGNAM) break;
976 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
977 !str$case_blind_compare(&tmpdsc,&clisym)) {
978 if (!ivsym && !secure) {
979 unsigned short int deflen = LNM$C_NAMLENGTH;
980 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
981 /* dynamic dsc to accomodate possible long value */
982 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
983 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
985 if (eqvlen > MAX_DCL_SYMBOL) {
986 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
987 eqvlen = MAX_DCL_SYMBOL;
988 /* Special hack--we might be called before the interpreter's */
989 /* fully initialized, in which case either thr or PL_curcop */
990 /* might be bogus. We have to check, since ckWARN needs them */
991 /* both to be valid if running threaded */
992 if (ckWARN(WARN_MISC)) {
993 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
996 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
998 _ckvmssts(lib$sfree1_dd(&eqvdsc));
999 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1000 if (retsts == LIB$_NOSUCHSYM) continue;
1005 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1006 midx = my_maxidx(lnm);
1007 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1008 lnmlst[1].bufadr = cp2;
1010 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1011 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1012 if (retsts == SS$_NOLOGNAM) break;
1013 /* PPFs have a prefix */
1016 *((int *)uplnm) == *((int *)"SYS$") &&
1018 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1019 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1020 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1021 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1022 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1023 memmove(eqv,eqv+4,eqvlen-4);
1029 if ((retsts == SS$_IVLOGNAM) ||
1030 (retsts == SS$_NOLOGNAM)) { continue; }
1033 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1034 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1035 if (retsts == SS$_NOLOGNAM) continue;
1038 eqvlen = strlen(eqv);
1042 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1043 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1044 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1045 retsts == SS$_NOLOGNAM) {
1046 set_errno(EINVAL); set_vaxc_errno(retsts);
1048 else _ckvmssts(retsts);
1050 } /* end of vmstrnenv */
1053 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1054 /* Define as a function so we can access statics. */
1055 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1057 return vmstrnenv(lnm,eqv,idx,fildev,
1058 #ifdef SECURE_INTERNAL_GETENV
1059 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1068 * Note: Uses Perl temp to store result so char * can be returned to
1069 * caller; this pointer will be invalidated at next Perl statement
1071 * We define this as a function rather than a macro in terms of my_getenv_len()
1072 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1075 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1077 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1080 static char *__my_getenv_eqv = NULL;
1081 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1082 unsigned long int idx = 0;
1083 int trnsuccess, success, secure, saverr, savvmserr;
1087 midx = my_maxidx(lnm) + 1;
1089 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1090 /* Set up a temporary buffer for the return value; Perl will
1091 * clean it up at the next statement transition */
1092 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1093 if (!tmpsv) return NULL;
1097 /* Assume no interpreter ==> single thread */
1098 if (__my_getenv_eqv != NULL) {
1099 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1102 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1104 eqv = __my_getenv_eqv;
1107 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1108 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1110 getcwd(eqv,LNM$C_NAMLENGTH);
1114 /* Get rid of "000000/ in rooted filespecs */
1117 zeros = strstr(eqv, "/000000/");
1118 if (zeros != NULL) {
1120 mlen = len - (zeros - eqv) - 7;
1121 memmove(zeros, &zeros[7], mlen);
1129 /* Impose security constraints only if tainting */
1131 /* Impose security constraints only if tainting */
1132 secure = PL_curinterp ? PL_tainting : will_taint;
1133 saverr = errno; savvmserr = vaxc$errno;
1140 #ifdef SECURE_INTERNAL_GETENV
1141 secure ? PERL__TRNENV_SECURE : 0
1147 /* For the getenv interface we combine all the equivalence names
1148 * of a search list logical into one value to acquire a maximum
1149 * value length of 255*128 (assuming %ENV is using logicals).
1151 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1153 /* If the name contains a semicolon-delimited index, parse it
1154 * off and make sure we only retrieve the equivalence name for
1156 if ((cp2 = strchr(lnm,';')) != NULL) {
1158 uplnm[cp2-lnm] = '\0';
1159 idx = strtoul(cp2+1,NULL,0);
1161 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1164 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1166 /* Discard NOLOGNAM on internal calls since we're often looking
1167 * for an optional name, and this "error" often shows up as the
1168 * (bogus) exit status for a die() call later on. */
1169 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1170 return success ? eqv : Nullch;
1173 } /* end of my_getenv() */
1177 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1179 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1183 unsigned long idx = 0;
1185 static char *__my_getenv_len_eqv = NULL;
1186 int secure, saverr, savvmserr;
1189 midx = my_maxidx(lnm) + 1;
1191 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1192 /* Set up a temporary buffer for the return value; Perl will
1193 * clean it up at the next statement transition */
1194 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1195 if (!tmpsv) return NULL;
1199 /* Assume no interpreter ==> single thread */
1200 if (__my_getenv_len_eqv != NULL) {
1201 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1204 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1206 buf = __my_getenv_len_eqv;
1209 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1210 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1213 getcwd(buf,LNM$C_NAMLENGTH);
1216 /* Get rid of "000000/ in rooted filespecs */
1218 zeros = strstr(buf, "/000000/");
1219 if (zeros != NULL) {
1221 mlen = *len - (zeros - buf) - 7;
1222 memmove(zeros, &zeros[7], mlen);
1231 /* Impose security constraints only if tainting */
1232 secure = PL_curinterp ? PL_tainting : will_taint;
1233 saverr = errno; savvmserr = vaxc$errno;
1240 #ifdef SECURE_INTERNAL_GETENV
1241 secure ? PERL__TRNENV_SECURE : 0
1247 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1249 if ((cp2 = strchr(lnm,';')) != NULL) {
1251 buf[cp2-lnm] = '\0';
1252 idx = strtoul(cp2+1,NULL,0);
1254 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1257 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1259 /* Get rid of "000000/ in rooted filespecs */
1262 zeros = strstr(buf, "/000000/");
1263 if (zeros != NULL) {
1265 mlen = *len - (zeros - buf) - 7;
1266 memmove(zeros, &zeros[7], mlen);
1272 /* Discard NOLOGNAM on internal calls since we're often looking
1273 * for an optional name, and this "error" often shows up as the
1274 * (bogus) exit status for a die() call later on. */
1275 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1276 return *len ? buf : Nullch;
1279 } /* end of my_getenv_len() */
1282 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1284 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1286 /*{{{ void prime_env_iter() */
1288 prime_env_iter(void)
1289 /* Fill the %ENV associative array with all logical names we can
1290 * find, in preparation for iterating over it.
1293 static int primed = 0;
1294 HV *seenhv = NULL, *envhv;
1296 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = Nullch;
1297 unsigned short int chan;
1298 #ifndef CLI$M_TRUSTED
1299 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1301 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1302 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1304 bool have_sym = FALSE, have_lnm = FALSE;
1305 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1306 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1307 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1308 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1309 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1310 #if defined(PERL_IMPLICIT_CONTEXT)
1313 #if defined(USE_ITHREADS)
1314 static perl_mutex primenv_mutex;
1315 MUTEX_INIT(&primenv_mutex);
1318 #if defined(PERL_IMPLICIT_CONTEXT)
1319 /* We jump through these hoops because we can be called at */
1320 /* platform-specific initialization time, which is before anything is */
1321 /* set up--we can't even do a plain dTHX since that relies on the */
1322 /* interpreter structure to be initialized */
1324 aTHX = PERL_GET_INTERP;
1330 if (primed || !PL_envgv) return;
1331 MUTEX_LOCK(&primenv_mutex);
1332 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1333 envhv = GvHVn(PL_envgv);
1334 /* Perform a dummy fetch as an lval to insure that the hash table is
1335 * set up. Otherwise, the hv_store() will turn into a nullop. */
1336 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1338 for (i = 0; env_tables[i]; i++) {
1339 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1340 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1341 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1343 if (have_sym || have_lnm) {
1344 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1345 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1346 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1347 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1350 for (i--; i >= 0; i--) {
1351 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1354 for (j = 0; environ[j]; j++) {
1355 if (!(start = strchr(environ[j],'='))) {
1356 if (ckWARN(WARN_INTERNAL))
1357 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1361 sv = newSVpv(start,0);
1363 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1368 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1369 !str$case_blind_compare(&tmpdsc,&clisym)) {
1370 strcpy(cmd,"Show Symbol/Global *");
1371 cmddsc.dsc$w_length = 20;
1372 if (env_tables[i]->dsc$w_length == 12 &&
1373 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1374 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1375 flags = defflags | CLI$M_NOLOGNAM;
1378 strcpy(cmd,"Show Logical *");
1379 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1380 strcat(cmd," /Table=");
1381 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1382 cmddsc.dsc$w_length = strlen(cmd);
1384 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1385 flags = defflags | CLI$M_NOCLISYM;
1388 /* Create a new subprocess to execute each command, to exclude the
1389 * remote possibility that someone could subvert a mbx or file used
1390 * to write multiple commands to a single subprocess.
1393 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1394 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1395 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1396 defflags &= ~CLI$M_TRUSTED;
1397 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1399 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1400 if (seenhv) SvREFCNT_dec(seenhv);
1403 char *cp1, *cp2, *key;
1404 unsigned long int sts, iosb[2], retlen, keylen;
1407 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1408 if (sts & 1) sts = iosb[0] & 0xffff;
1409 if (sts == SS$_ENDOFFILE) {
1411 while (substs == 0) { sys$hiber(); wakect++;}
1412 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1417 retlen = iosb[0] >> 16;
1418 if (!retlen) continue; /* blank line */
1420 if (iosb[1] != subpid) {
1422 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1426 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1427 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1429 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1430 if (*cp1 == '(' || /* Logical name table name */
1431 *cp1 == '=' /* Next eqv of searchlist */) continue;
1432 if (*cp1 == '"') cp1++;
1433 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1434 key = cp1; keylen = cp2 - cp1;
1435 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1436 while (*cp2 && *cp2 != '=') cp2++;
1437 while (*cp2 && *cp2 == '=') cp2++;
1438 while (*cp2 && *cp2 == ' ') cp2++;
1439 if (*cp2 == '"') { /* String translation; may embed "" */
1440 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1441 cp2++; cp1--; /* Skip "" surrounding translation */
1443 else { /* Numeric translation */
1444 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1445 cp1--; /* stop on last non-space char */
1447 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1448 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1451 PERL_HASH(hash,key,keylen);
1453 if (cp1 == cp2 && *cp2 == '.') {
1454 /* A single dot usually means an unprintable character, such as a null
1455 * to indicate a zero-length value. Get the actual value to make sure.
1457 char lnm[LNM$C_NAMLENGTH+1];
1458 char eqv[MAX_DCL_SYMBOL+1];
1460 strncpy(lnm, key, keylen);
1461 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1462 sv = newSVpvn(eqv, strlen(eqv));
1465 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1469 hv_store(envhv,key,keylen,sv,hash);
1470 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1472 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1473 /* get the PPFs for this process, not the subprocess */
1474 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1475 char eqv[LNM$C_NAMLENGTH+1];
1477 for (i = 0; ppfs[i]; i++) {
1478 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1479 sv = newSVpv(eqv,trnlen);
1481 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1486 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1487 if (buf) Safefree(buf);
1488 if (seenhv) SvREFCNT_dec(seenhv);
1489 MUTEX_UNLOCK(&primenv_mutex);
1492 } /* end of prime_env_iter */
1496 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1497 /* Define or delete an element in the same "environment" as
1498 * vmstrnenv(). If an element is to be deleted, it's removed from
1499 * the first place it's found. If it's to be set, it's set in the
1500 * place designated by the first element of the table vector.
1501 * Like setenv() returns 0 for success, non-zero on error.
1504 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1507 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1508 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1510 unsigned long int retsts, usermode = PSL$C_USER;
1511 struct itmlst_3 *ile, *ilist;
1512 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1513 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1514 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1515 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1516 $DESCRIPTOR(local,"_LOCAL");
1519 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1520 return SS$_IVLOGNAM;
1523 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1524 *cp2 = _toupper(*cp1);
1525 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1526 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1527 return SS$_IVLOGNAM;
1530 lnmdsc.dsc$w_length = cp1 - lnm;
1531 if (!tabvec || !*tabvec) tabvec = env_tables;
1533 if (!eqv) { /* we're deleting n element */
1534 for (curtab = 0; tabvec[curtab]; curtab++) {
1535 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1537 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1538 if ((cp1 = strchr(environ[i],'=')) &&
1539 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1540 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1542 return setenv(lnm,"",1) ? vaxc$errno : 0;
1545 ivenv = 1; retsts = SS$_NOLOGNAM;
1547 if (ckWARN(WARN_INTERNAL))
1548 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1549 ivenv = 1; retsts = SS$_NOSUCHPGM;
1555 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1556 !str$case_blind_compare(&tmpdsc,&clisym)) {
1557 unsigned int symtype;
1558 if (tabvec[curtab]->dsc$w_length == 12 &&
1559 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1560 !str$case_blind_compare(&tmpdsc,&local))
1561 symtype = LIB$K_CLI_LOCAL_SYM;
1562 else symtype = LIB$K_CLI_GLOBAL_SYM;
1563 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1564 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1565 if (retsts == LIB$_NOSUCHSYM) continue;
1569 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1570 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1571 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1572 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1573 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1577 else { /* we're defining a value */
1578 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1580 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1582 if (ckWARN(WARN_INTERNAL))
1583 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1584 retsts = SS$_NOSUCHPGM;
1588 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1589 eqvdsc.dsc$w_length = strlen(eqv);
1590 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1591 !str$case_blind_compare(&tmpdsc,&clisym)) {
1592 unsigned int symtype;
1593 if (tabvec[0]->dsc$w_length == 12 &&
1594 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1595 !str$case_blind_compare(&tmpdsc,&local))
1596 symtype = LIB$K_CLI_LOCAL_SYM;
1597 else symtype = LIB$K_CLI_GLOBAL_SYM;
1598 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1601 if (!*eqv) eqvdsc.dsc$w_length = 1;
1602 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1604 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1605 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1606 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1607 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1608 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1609 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1612 Newx(ilist,nseg+1,struct itmlst_3);
1615 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1618 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1620 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1621 ile->itmcode = LNM$_STRING;
1623 if ((j+1) == nseg) {
1624 ile->buflen = strlen(c);
1625 /* in case we are truncating one that's too long */
1626 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1629 ile->buflen = LNM$C_NAMLENGTH;
1633 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1637 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1642 if (!(retsts & 1)) {
1644 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1645 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1646 set_errno(EVMSERR); break;
1647 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1648 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1649 set_errno(EINVAL); break;
1651 set_errno(EACCES); break;
1656 set_vaxc_errno(retsts);
1657 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1660 /* We reset error values on success because Perl does an hv_fetch()
1661 * before each hv_store(), and if the thing we're setting didn't
1662 * previously exist, we've got a leftover error message. (Of course,
1663 * this fails in the face of
1664 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1665 * in that the error reported in $! isn't spurious,
1666 * but it's right more often than not.)
1668 set_errno(0); set_vaxc_errno(retsts);
1672 } /* end of vmssetenv() */
1675 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1676 /* This has to be a function since there's a prototype for it in proto.h */
1678 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1681 int len = strlen(lnm);
1685 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1686 if (!strcmp(uplnm,"DEFAULT")) {
1687 if (eqv && *eqv) my_chdir(eqv);
1691 #ifndef RTL_USES_UTC
1692 if (len == 6 || len == 2) {
1695 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1697 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1698 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1702 (void) vmssetenv(lnm,eqv,NULL);
1706 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1708 * sets a user-mode logical in the process logical name table
1709 * used for redirection of sys$error
1712 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1714 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1715 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1716 unsigned long int iss, attr = LNM$M_CONFINE;
1717 unsigned char acmode = PSL$C_USER;
1718 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1720 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1721 d_name.dsc$w_length = strlen(name);
1723 lnmlst[0].buflen = strlen(eqv);
1724 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1726 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1727 if (!(iss&1)) lib$signal(iss);
1732 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1733 /* my_crypt - VMS password hashing
1734 * my_crypt() provides an interface compatible with the Unix crypt()
1735 * C library function, and uses sys$hash_password() to perform VMS
1736 * password hashing. The quadword hashed password value is returned
1737 * as a NUL-terminated 8 character string. my_crypt() does not change
1738 * the case of its string arguments; in order to match the behavior
1739 * of LOGINOUT et al., alphabetic characters in both arguments must
1740 * be upcased by the caller.
1742 * - fix me to call ACM services when available
1745 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1747 # ifndef UAI$C_PREFERRED_ALGORITHM
1748 # define UAI$C_PREFERRED_ALGORITHM 127
1750 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1751 unsigned short int salt = 0;
1752 unsigned long int sts;
1754 unsigned short int dsc$w_length;
1755 unsigned char dsc$b_type;
1756 unsigned char dsc$b_class;
1757 const char * dsc$a_pointer;
1758 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1759 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1760 struct itmlst_3 uailst[3] = {
1761 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1762 { sizeof salt, UAI$_SALT, &salt, 0},
1763 { 0, 0, NULL, NULL}};
1764 static char hash[9];
1766 usrdsc.dsc$w_length = strlen(usrname);
1767 usrdsc.dsc$a_pointer = usrname;
1768 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1770 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1774 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1779 set_vaxc_errno(sts);
1780 if (sts != RMS$_RNF) return NULL;
1783 txtdsc.dsc$w_length = strlen(textpasswd);
1784 txtdsc.dsc$a_pointer = textpasswd;
1785 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1786 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1789 return (char *) hash;
1791 } /* end of my_crypt() */
1795 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1796 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1797 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1799 /* fixup barenames that are directories for internal use.
1800 * There have been problems with the consistent handling of UNIX
1801 * style directory names when routines are presented with a name that
1802 * has no directory delimitors at all. So this routine will eventually
1805 static char * fixup_bare_dirnames(const char * name)
1807 if (decc_disable_to_vms_logname_translation) {
1813 /* 8.3, remove() is now broken on symbolic links */
1814 static int rms_erase(const char * vmsname);
1818 * A little hack to get around a bug in some implemenation of remove()
1819 * that do not know how to delete a directory
1821 * Delete any file to which user has control access, regardless of whether
1822 * delete access is explicitly allowed.
1823 * Limitations: User must have write access to parent directory.
1824 * Does not block signals or ASTs; if interrupted in midstream
1825 * may leave file with an altered ACL.
1828 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1830 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1834 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1835 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1836 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1838 unsigned char myace$b_length;
1839 unsigned char myace$b_type;
1840 unsigned short int myace$w_flags;
1841 unsigned long int myace$l_access;
1842 unsigned long int myace$l_ident;
1843 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1844 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1845 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1847 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1848 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1849 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1850 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1851 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1852 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1854 /* Expand the input spec using RMS, since the CRTL remove() and
1855 * system services won't do this by themselves, so we may miss
1856 * a file "hiding" behind a logical name or search list. */
1857 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1858 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1860 rslt = do_rmsexpand(name,
1864 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1868 PerlMem_free(vmsname);
1872 /* Erase the file */
1873 rmsts = rms_erase(vmsname);
1875 /* Did it succeed */
1876 if ($VMS_STATUS_SUCCESS(rmsts)) {
1877 PerlMem_free(vmsname);
1881 /* If not, can changing protections help? */
1882 if (rmsts != RMS$_PRV) {
1883 set_vaxc_errno(rmsts);
1884 PerlMem_free(vmsname);
1888 /* No, so we get our own UIC to use as a rights identifier,
1889 * and the insert an ACE at the head of the ACL which allows us
1890 * to delete the file.
1892 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1893 fildsc.dsc$w_length = strlen(vmsname);
1894 fildsc.dsc$a_pointer = vmsname;
1896 newace.myace$l_ident = oldace.myace$l_ident;
1898 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1900 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1901 set_errno(ENOENT); break;
1903 set_errno(ENOTDIR); break;
1905 set_errno(ENODEV); break;
1906 case RMS$_SYN: case SS$_INVFILFOROP:
1907 set_errno(EINVAL); break;
1909 set_errno(EACCES); break;
1913 set_vaxc_errno(aclsts);
1914 PerlMem_free(vmsname);
1917 /* Grab any existing ACEs with this identifier in case we fail */
1918 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1919 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1920 || fndsts == SS$_NOMOREACE ) {
1921 /* Add the new ACE . . . */
1922 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1925 rmsts = rms_erase(vmsname);
1926 if ($VMS_STATUS_SUCCESS(rmsts)) {
1931 /* We blew it - dir with files in it, no write priv for
1932 * parent directory, etc. Put things back the way they were. */
1933 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1936 addlst[0].bufadr = &oldace;
1937 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1944 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1945 /* We just deleted it, so of course it's not there. Some versions of
1946 * VMS seem to return success on the unlock operation anyhow (after all
1947 * the unlock is successful), but others don't.
1949 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1950 if (aclsts & 1) aclsts = fndsts;
1951 if (!(aclsts & 1)) {
1953 set_vaxc_errno(aclsts);
1956 PerlMem_free(vmsname);
1959 } /* end of kill_file() */
1963 /*{{{int do_rmdir(char *name)*/
1965 Perl_do_rmdir(pTHX_ const char *name)
1971 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1972 if (dirfile == NULL)
1973 _ckvmssts(SS$_INSFMEM);
1975 /* Force to a directory specification */
1976 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1977 PerlMem_free(dirfile);
1980 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1985 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1987 PerlMem_free(dirfile);
1990 } /* end of do_rmdir */
1994 * Delete any file to which user has control access, regardless of whether
1995 * delete access is explicitly allowed.
1996 * Limitations: User must have write access to parent directory.
1997 * Does not block signals or ASTs; if interrupted in midstream
1998 * may leave file with an altered ACL.
2001 /*{{{int kill_file(char *name)*/
2003 Perl_kill_file(pTHX_ const char *name)
2005 char rspec[NAM$C_MAXRSS+1];
2010 /* Remove() is allowed to delete directories, according to the X/Open
2012 * This may need special handling to work with the ACL hacks.
2014 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2015 rmsts = Perl_do_rmdir(aTHX_ name);
2019 rmsts = mp_do_kill_file(aTHX_ name, 0);
2023 } /* end of kill_file() */
2027 /*{{{int my_mkdir(char *,Mode_t)*/
2029 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2031 STRLEN dirlen = strlen(dir);
2033 /* zero length string sometimes gives ACCVIO */
2034 if (dirlen == 0) return -1;
2036 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2037 * null file name/type. However, it's commonplace under Unix,
2038 * so we'll allow it for a gain in portability.
2040 if (dir[dirlen-1] == '/') {
2041 char *newdir = savepvn(dir,dirlen-1);
2042 int ret = mkdir(newdir,mode);
2046 else return mkdir(dir,mode);
2047 } /* end of my_mkdir */
2050 /*{{{int my_chdir(char *)*/
2052 Perl_my_chdir(pTHX_ const char *dir)
2054 STRLEN dirlen = strlen(dir);
2056 /* zero length string sometimes gives ACCVIO */
2057 if (dirlen == 0) return -1;
2060 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2061 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2062 * so that existing scripts do not need to be changed.
2065 while ((dirlen > 0) && (*dir1 == ' ')) {
2070 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2072 * null file name/type. However, it's commonplace under Unix,
2073 * so we'll allow it for a gain in portability.
2075 * - Preview- '/' will be valid soon on VMS
2077 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2078 char *newdir = savepvn(dir1,dirlen-1);
2079 int ret = chdir(newdir);
2083 else return chdir(dir1);
2084 } /* end of my_chdir */
2088 /*{{{int my_chmod(char *, mode_t)*/
2090 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2092 STRLEN speclen = strlen(file_spec);
2094 /* zero length string sometimes gives ACCVIO */
2095 if (speclen == 0) return -1;
2097 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2098 * that implies null file name/type. However, it's commonplace under Unix,
2099 * so we'll allow it for a gain in portability.
2101 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2102 * in VMS file.dir notation.
2104 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2105 char *vms_src, *vms_dir, *rslt;
2109 /* First convert this to a VMS format specification */
2110 vms_src = PerlMem_malloc(VMS_MAXRSS);
2111 if (vms_src == NULL)
2112 _ckvmssts(SS$_INSFMEM);
2114 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2116 /* If we fail, then not a file specification */
2117 PerlMem_free(vms_src);
2122 /* Now make it a directory spec so chmod is happy */
2123 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2124 if (vms_dir == NULL)
2125 _ckvmssts(SS$_INSFMEM);
2126 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2127 PerlMem_free(vms_src);
2131 ret = chmod(vms_dir, mode);
2135 PerlMem_free(vms_dir);
2138 else return chmod(file_spec, mode);
2139 } /* end of my_chmod */
2143 /*{{{FILE *my_tmpfile()*/
2150 if ((fp = tmpfile())) return fp;
2152 cp = PerlMem_malloc(L_tmpnam+24);
2153 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2155 if (decc_filename_unix_only == 0)
2156 strcpy(cp,"Sys$Scratch:");
2159 tmpnam(cp+strlen(cp));
2160 strcat(cp,".Perltmp");
2161 fp = fopen(cp,"w+","fop=dlt");
2168 #ifndef HOMEGROWN_POSIX_SIGNALS
2170 * The C RTL's sigaction fails to check for invalid signal numbers so we
2171 * help it out a bit. The docs are correct, but the actual routine doesn't
2172 * do what the docs say it will.
2174 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2176 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2177 struct sigaction* oact)
2179 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2180 SETERRNO(EINVAL, SS$_INVARG);
2183 return sigaction(sig, act, oact);
2188 #ifdef KILL_BY_SIGPRC
2189 #include <errnodef.h>
2191 /* We implement our own kill() using the undocumented system service
2192 sys$sigprc for one of two reasons:
2194 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2195 target process to do a sys$exit, which usually can't be handled
2196 gracefully...certainly not by Perl and the %SIG{} mechanism.
2198 2.) If the kill() in the CRTL can't be called from a signal
2199 handler without disappearing into the ether, i.e., the signal
2200 it purportedly sends is never trapped. Still true as of VMS 7.3.
2202 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2203 in the target process rather than calling sys$exit.
2205 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2206 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2207 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2208 with condition codes C$_SIG0+nsig*8, catching the exception on the
2209 target process and resignaling with appropriate arguments.
2211 But we don't have that VMS 7.0+ exception handler, so if you
2212 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2214 Also note that SIGTERM is listed in the docs as being "unimplemented",
2215 yet always seems to be signaled with a VMS condition code of 4 (and
2216 correctly handled for that code). So we hardwire it in.
2218 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2219 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2220 than signalling with an unrecognized (and unhandled by CRTL) code.
2223 #define _MY_SIG_MAX 28
2226 Perl_sig_to_vmscondition_int(int sig)
2228 static unsigned int sig_code[_MY_SIG_MAX+1] =
2231 SS$_HANGUP, /* 1 SIGHUP */
2232 SS$_CONTROLC, /* 2 SIGINT */
2233 SS$_CONTROLY, /* 3 SIGQUIT */
2234 SS$_RADRMOD, /* 4 SIGILL */
2235 SS$_BREAK, /* 5 SIGTRAP */
2236 SS$_OPCCUS, /* 6 SIGABRT */
2237 SS$_COMPAT, /* 7 SIGEMT */
2239 SS$_FLTOVF, /* 8 SIGFPE VAX */
2241 SS$_HPARITH, /* 8 SIGFPE AXP */
2243 SS$_ABORT, /* 9 SIGKILL */
2244 SS$_ACCVIO, /* 10 SIGBUS */
2245 SS$_ACCVIO, /* 11 SIGSEGV */
2246 SS$_BADPARAM, /* 12 SIGSYS */
2247 SS$_NOMBX, /* 13 SIGPIPE */
2248 SS$_ASTFLT, /* 14 SIGALRM */
2265 #if __VMS_VER >= 60200000
2266 static int initted = 0;
2269 sig_code[16] = C$_SIGUSR1;
2270 sig_code[17] = C$_SIGUSR2;
2271 #if __CRTL_VER >= 70000000
2272 sig_code[20] = C$_SIGCHLD;
2274 #if __CRTL_VER >= 70300000
2275 sig_code[28] = C$_SIGWINCH;
2280 if (sig < _SIG_MIN) return 0;
2281 if (sig > _MY_SIG_MAX) return 0;
2282 return sig_code[sig];
2286 Perl_sig_to_vmscondition(int sig)
2289 if (vms_debug_on_exception != 0)
2290 lib$signal(SS$_DEBUG);
2292 return Perl_sig_to_vmscondition_int(sig);
2297 Perl_my_kill(int pid, int sig)
2302 int sys$sigprc(unsigned int *pidadr,
2303 struct dsc$descriptor_s *prcname,
2306 /* sig 0 means validate the PID */
2307 /*------------------------------*/
2309 const unsigned long int jpicode = JPI$_PID;
2312 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2313 if ($VMS_STATUS_SUCCESS(status))
2316 case SS$_NOSUCHNODE:
2317 case SS$_UNREACHABLE:
2331 code = Perl_sig_to_vmscondition_int(sig);
2334 SETERRNO(EINVAL, SS$_BADPARAM);
2338 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2339 * signals are to be sent to multiple processes.
2340 * pid = 0 - all processes in group except ones that the system exempts
2341 * pid = -1 - all processes except ones that the system exempts
2342 * pid = -n - all processes in group (abs(n)) except ...
2343 * For now, just report as not supported.
2347 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2351 iss = sys$sigprc((unsigned int *)&pid,0,code);
2352 if (iss&1) return 0;
2356 set_errno(EPERM); break;
2358 case SS$_NOSUCHNODE:
2359 case SS$_UNREACHABLE:
2360 set_errno(ESRCH); break;
2362 set_errno(ENOMEM); break;
2367 set_vaxc_errno(iss);
2373 /* Routine to convert a VMS status code to a UNIX status code.
2374 ** More tricky than it appears because of conflicting conventions with
2377 ** VMS status codes are a bit mask, with the least significant bit set for
2380 ** Special UNIX status of EVMSERR indicates that no translation is currently
2381 ** available, and programs should check the VMS status code.
2383 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2387 #ifndef C_FACILITY_NO
2388 #define C_FACILITY_NO 0x350000
2391 #define DCL_IVVERB 0x38090
2394 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2402 /* Assume the best or the worst */
2403 if (vms_status & STS$M_SUCCESS)
2406 unix_status = EVMSERR;
2408 msg_status = vms_status & ~STS$M_CONTROL;
2410 facility = vms_status & STS$M_FAC_NO;
2411 fac_sp = vms_status & STS$M_FAC_SP;
2412 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2414 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2420 unix_status = EFAULT;
2422 case SS$_DEVOFFLINE:
2423 unix_status = EBUSY;
2426 unix_status = ENOTCONN;
2434 case SS$_INVFILFOROP:
2438 unix_status = EINVAL;
2440 case SS$_UNSUPPORTED:
2441 unix_status = ENOTSUP;
2446 unix_status = EACCES;
2448 case SS$_DEVICEFULL:
2449 unix_status = ENOSPC;
2452 unix_status = ENODEV;
2454 case SS$_NOSUCHFILE:
2455 case SS$_NOSUCHOBJECT:
2456 unix_status = ENOENT;
2458 case SS$_ABORT: /* Fatal case */
2459 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2460 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2461 unix_status = EINTR;
2464 unix_status = E2BIG;
2467 unix_status = ENOMEM;
2470 unix_status = EPERM;
2472 case SS$_NOSUCHNODE:
2473 case SS$_UNREACHABLE:
2474 unix_status = ESRCH;
2477 unix_status = ECHILD;
2480 if ((facility == 0) && (msg_no < 8)) {
2481 /* These are not real VMS status codes so assume that they are
2482 ** already UNIX status codes
2484 unix_status = msg_no;
2490 /* Translate a POSIX exit code to a UNIX exit code */
2491 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2492 unix_status = (msg_no & 0x07F8) >> 3;
2496 /* Documented traditional behavior for handling VMS child exits */
2497 /*--------------------------------------------------------------*/
2498 if (child_flag != 0) {
2500 /* Success / Informational return 0 */
2501 /*----------------------------------*/
2502 if (msg_no & STS$K_SUCCESS)
2505 /* Warning returns 1 */
2506 /*-------------------*/
2507 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2510 /* Everything else pass through the severity bits */
2511 /*------------------------------------------------*/
2512 return (msg_no & STS$M_SEVERITY);
2515 /* Normal VMS status to ERRNO mapping attempt */
2516 /*--------------------------------------------*/
2517 switch(msg_status) {
2518 /* case RMS$_EOF: */ /* End of File */
2519 case RMS$_FNF: /* File Not Found */
2520 case RMS$_DNF: /* Dir Not Found */
2521 unix_status = ENOENT;
2523 case RMS$_RNF: /* Record Not Found */
2524 unix_status = ESRCH;
2527 unix_status = ENOTDIR;
2530 unix_status = ENODEV;
2535 unix_status = EBADF;
2538 unix_status = EEXIST;
2542 case LIB$_INVSTRDES:
2544 case LIB$_NOSUCHSYM:
2545 case LIB$_INVSYMNAM:
2547 unix_status = EINVAL;
2553 unix_status = E2BIG;
2555 case RMS$_PRV: /* No privilege */
2556 case RMS$_ACC: /* ACP file access failed */
2557 case RMS$_WLK: /* Device write locked */
2558 unix_status = EACCES;
2560 /* case RMS$_NMF: */ /* No more files */
2568 /* Try to guess at what VMS error status should go with a UNIX errno
2569 * value. This is hard to do as there could be many possible VMS
2570 * error statuses that caused the errno value to be set.
2573 int Perl_unix_status_to_vms(int unix_status)
2575 int test_unix_status;
2577 /* Trivial cases first */
2578 /*---------------------*/
2579 if (unix_status == EVMSERR)
2582 /* Is vaxc$errno sane? */
2583 /*---------------------*/
2584 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2585 if (test_unix_status == unix_status)
2588 /* If way out of range, must be VMS code already */
2589 /*-----------------------------------------------*/
2590 if (unix_status > EVMSERR)
2593 /* If out of range, punt */
2594 /*-----------------------*/
2595 if (unix_status > __ERRNO_MAX)
2599 /* Ok, now we have to do it the hard way. */
2600 /*----------------------------------------*/
2601 switch(unix_status) {
2602 case 0: return SS$_NORMAL;
2603 case EPERM: return SS$_NOPRIV;
2604 case ENOENT: return SS$_NOSUCHOBJECT;
2605 case ESRCH: return SS$_UNREACHABLE;
2606 case EINTR: return SS$_ABORT;
2609 case E2BIG: return SS$_BUFFEROVF;
2611 case EBADF: return RMS$_IFI;
2612 case ECHILD: return SS$_NONEXPR;
2614 case ENOMEM: return SS$_INSFMEM;
2615 case EACCES: return SS$_FILACCERR;
2616 case EFAULT: return SS$_ACCVIO;
2618 case EBUSY: return SS$_DEVOFFLINE;
2619 case EEXIST: return RMS$_FEX;
2621 case ENODEV: return SS$_NOSUCHDEV;
2622 case ENOTDIR: return RMS$_DIR;
2624 case EINVAL: return SS$_INVARG;
2630 case ENOSPC: return SS$_DEVICEFULL;
2631 case ESPIPE: return LIB$_INVARG;
2636 case ERANGE: return LIB$_INVARG;
2637 /* case EWOULDBLOCK */
2638 /* case EINPROGRESS */
2641 /* case EDESTADDRREQ */
2643 /* case EPROTOTYPE */
2644 /* case ENOPROTOOPT */
2645 /* case EPROTONOSUPPORT */
2646 /* case ESOCKTNOSUPPORT */
2647 /* case EOPNOTSUPP */
2648 /* case EPFNOSUPPORT */
2649 /* case EAFNOSUPPORT */
2650 /* case EADDRINUSE */
2651 /* case EADDRNOTAVAIL */
2653 /* case ENETUNREACH */
2654 /* case ENETRESET */
2655 /* case ECONNABORTED */
2656 /* case ECONNRESET */
2659 case ENOTCONN: return SS$_CLEARED;
2660 /* case ESHUTDOWN */
2661 /* case ETOOMANYREFS */
2662 /* case ETIMEDOUT */
2663 /* case ECONNREFUSED */
2665 /* case ENAMETOOLONG */
2666 /* case EHOSTDOWN */
2667 /* case EHOSTUNREACH */
2668 /* case ENOTEMPTY */
2680 /* case ECANCELED */
2684 return SS$_UNSUPPORTED;
2690 /* case EABANDONED */
2692 return SS$_ABORT; /* punt */
2695 return SS$_ABORT; /* Should not get here */
2699 /* default piping mailbox size */
2700 #define PERL_BUFSIZ 512
2704 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2706 unsigned long int mbxbufsiz;
2707 static unsigned long int syssize = 0;
2708 unsigned long int dviitm = DVI$_DEVNAM;
2709 char csize[LNM$C_NAMLENGTH+1];
2713 unsigned long syiitm = SYI$_MAXBUF;
2715 * Get the SYSGEN parameter MAXBUF
2717 * If the logical 'PERL_MBX_SIZE' is defined
2718 * use the value of the logical instead of PERL_BUFSIZ, but
2719 * keep the size between 128 and MAXBUF.
2722 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2725 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2726 mbxbufsiz = atoi(csize);
2728 mbxbufsiz = PERL_BUFSIZ;
2730 if (mbxbufsiz < 128) mbxbufsiz = 128;
2731 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2733 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2735 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2736 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2738 } /* end of create_mbx() */
2741 /*{{{ my_popen and my_pclose*/
2743 typedef struct _iosb IOSB;
2744 typedef struct _iosb* pIOSB;
2745 typedef struct _pipe Pipe;
2746 typedef struct _pipe* pPipe;
2747 typedef struct pipe_details Info;
2748 typedef struct pipe_details* pInfo;
2749 typedef struct _srqp RQE;
2750 typedef struct _srqp* pRQE;
2751 typedef struct _tochildbuf CBuf;
2752 typedef struct _tochildbuf* pCBuf;
2755 unsigned short status;
2756 unsigned short count;
2757 unsigned long dvispec;
2760 #pragma member_alignment save
2761 #pragma nomember_alignment quadword
2762 struct _srqp { /* VMS self-relative queue entry */
2763 unsigned long qptr[2];
2765 #pragma member_alignment restore
2766 static RQE RQE_ZERO = {0,0};
2768 struct _tochildbuf {
2771 unsigned short size;
2779 unsigned short chan_in;
2780 unsigned short chan_out;
2782 unsigned int bufsize;
2794 #if defined(PERL_IMPLICIT_CONTEXT)
2795 void *thx; /* Either a thread or an interpreter */
2796 /* pointer, depending on how we're built */
2804 PerlIO *fp; /* file pointer to pipe mailbox */
2805 int useFILE; /* using stdio, not perlio */
2806 int pid; /* PID of subprocess */
2807 int mode; /* == 'r' if pipe open for reading */
2808 int done; /* subprocess has completed */
2809 int waiting; /* waiting for completion/closure */
2810 int closing; /* my_pclose is closing this pipe */
2811 unsigned long completion; /* termination status of subprocess */
2812 pPipe in; /* pipe in to sub */
2813 pPipe out; /* pipe out of sub */
2814 pPipe err; /* pipe of sub's sys$error */
2815 int in_done; /* true when in pipe finished */
2818 unsigned short xchan; /* channel to debug xterm */
2819 unsigned short xchan_valid; /* channel is assigned */
2822 struct exit_control_block
2824 struct exit_control_block *flink;
2825 unsigned long int (*exit_routine)();
2826 unsigned long int arg_count;
2827 unsigned long int *status_address;
2828 unsigned long int exit_status;
2831 typedef struct _closed_pipes Xpipe;
2832 typedef struct _closed_pipes* pXpipe;
2834 struct _closed_pipes {
2835 int pid; /* PID of subprocess */
2836 unsigned long completion; /* termination status of subprocess */
2838 #define NKEEPCLOSED 50
2839 static Xpipe closed_list[NKEEPCLOSED];
2840 static int closed_index = 0;
2841 static int closed_num = 0;
2843 #define RETRY_DELAY "0 ::0.20"
2844 #define MAX_RETRY 50
2846 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2847 static unsigned long mypid;
2848 static unsigned long delaytime[2];
2850 static pInfo open_pipes = NULL;
2851 static $DESCRIPTOR(nl_desc, "NL:");
2853 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2857 static unsigned long int
2858 pipe_exit_routine(pTHX)
2861 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2862 int sts, did_stuff, need_eof, j;
2865 * Flush any pending i/o, but since we are in process run-down, be
2866 * careful about referencing PerlIO structures that may already have
2867 * been deallocated. We may not even have an interpreter anymore.
2873 #if defined(USE_ITHREADS)
2876 && PL_perlio_fd_refcnt)
2877 PerlIO_flush(info->fp);
2879 fflush((FILE *)info->fp);
2885 next we try sending an EOF...ignore if doesn't work, make sure we
2893 _ckvmssts_noperl(sys$setast(0));
2894 if (info->in && !info->in->shut_on_empty) {
2895 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2900 _ckvmssts_noperl(sys$setast(1));
2904 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2906 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2911 _ckvmssts_noperl(sys$setast(0));
2912 if (info->waiting && info->done)
2914 nwait += info->waiting;
2915 _ckvmssts_noperl(sys$setast(1));
2925 _ckvmssts_noperl(sys$setast(0));
2926 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2927 sts = sys$forcex(&info->pid,0,&abort);
2928 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2931 _ckvmssts_noperl(sys$setast(1));
2935 /* again, wait for effect */
2937 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2942 _ckvmssts_noperl(sys$setast(0));
2943 if (info->waiting && info->done)
2945 nwait += info->waiting;
2946 _ckvmssts_noperl(sys$setast(1));
2955 _ckvmssts_noperl(sys$setast(0));
2956 if (!info->done) { /* We tried to be nice . . . */
2957 sts = sys$delprc(&info->pid,0);
2958 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2959 info->done = 1; /* sys$delprc is as done as we're going to get. */
2961 _ckvmssts_noperl(sys$setast(1));
2966 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2967 else if (!(sts & 1)) retsts = sts;
2972 static struct exit_control_block pipe_exitblock =
2973 {(struct exit_control_block *) 0,
2974 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2976 static void pipe_mbxtofd_ast(pPipe p);
2977 static void pipe_tochild1_ast(pPipe p);
2978 static void pipe_tochild2_ast(pPipe p);
2981 popen_completion_ast(pInfo info)
2983 pInfo i = open_pipes;
2988 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
2989 closed_list[closed_index].pid = info->pid;
2990 closed_list[closed_index].completion = info->completion;
2992 if (closed_index == NKEEPCLOSED)
2997 if (i == info) break;
3000 if (!i) return; /* unlinked, probably freed too */
3005 Writing to subprocess ...
3006 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3008 chan_out may be waiting for "done" flag, or hung waiting
3009 for i/o completion to child...cancel the i/o. This will
3010 put it into "snarf mode" (done but no EOF yet) that discards
3013 Output from subprocess (stdout, stderr) needs to be flushed and
3014 shut down. We try sending an EOF, but if the mbx is full the pipe
3015 routine should still catch the "shut_on_empty" flag, telling it to
3016 use immediate-style reads so that "mbx empty" -> EOF.
3020 if (info->in && !info->in_done) { /* only for mode=w */
3021 if (info->in->shut_on_empty && info->in->need_wake) {
3022 info->in->need_wake = FALSE;
3023 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3025 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3029 if (info->out && !info->out_done) { /* were we also piping output? */
3030 info->out->shut_on_empty = TRUE;
3031 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3032 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3033 _ckvmssts_noperl(iss);
3036 if (info->err && !info->err_done) { /* we were piping stderr */
3037 info->err->shut_on_empty = TRUE;
3038 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3039 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3040 _ckvmssts_noperl(iss);
3042 _ckvmssts_noperl(sys$setef(pipe_ef));
3046 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3047 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3050 we actually differ from vmstrnenv since we use this to
3051 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3052 are pointing to the same thing
3055 static unsigned short
3056 popen_translate(pTHX_ char *logical, char *result)
3059 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3060 $DESCRIPTOR(d_log,"");
3062 unsigned short length;
3063 unsigned short code;
3065 unsigned short *retlenaddr;
3067 unsigned short l, ifi;
3069 d_log.dsc$a_pointer = logical;
3070 d_log.dsc$w_length = strlen(logical);
3072 itmlst[0].code = LNM$_STRING;
3073 itmlst[0].length = 255;
3074 itmlst[0].buffer_addr = result;
3075 itmlst[0].retlenaddr = &l;
3078 itmlst[1].length = 0;
3079 itmlst[1].buffer_addr = 0;
3080 itmlst[1].retlenaddr = 0;
3082 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3083 if (iss == SS$_NOLOGNAM) {
3087 if (!(iss&1)) lib$signal(iss);
3090 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3091 strip it off and return the ifi, if any
3094 if (result[0] == 0x1b && result[1] == 0x00) {
3095 memmove(&ifi,result+2,2);
3096 strcpy(result,result+4);
3098 return ifi; /* this is the RMS internal file id */
3101 static void pipe_infromchild_ast(pPipe p);
3104 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3105 inside an AST routine without worrying about reentrancy and which Perl
3106 memory allocator is being used.
3108 We read data and queue up the buffers, then spit them out one at a
3109 time to the output mailbox when the output mailbox is ready for one.
3112 #define INITIAL_TOCHILDQUEUE 2
3115 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3119 char mbx1[64], mbx2[64];
3120 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3121 DSC$K_CLASS_S, mbx1},
3122 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3123 DSC$K_CLASS_S, mbx2};
3124 unsigned int dviitm = DVI$_DEVBUFSIZ;
3128 _ckvmssts(lib$get_vm(&n, &p));
3130 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3131 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3132 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3135 p->shut_on_empty = FALSE;
3136 p->need_wake = FALSE;
3139 p->iosb.status = SS$_NORMAL;
3140 p->iosb2.status = SS$_NORMAL;
3146 #ifdef PERL_IMPLICIT_CONTEXT
3150 n = sizeof(CBuf) + p->bufsize;
3152 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3153 _ckvmssts(lib$get_vm(&n, &b));
3154 b->buf = (char *) b + sizeof(CBuf);
3155 _ckvmssts(lib$insqhi(b, &p->free));
3158 pipe_tochild2_ast(p);
3159 pipe_tochild1_ast(p);
3165 /* reads the MBX Perl is writing, and queues */
3168 pipe_tochild1_ast(pPipe p)
3171 int iss = p->iosb.status;
3172 int eof = (iss == SS$_ENDOFFILE);
3174 #ifdef PERL_IMPLICIT_CONTEXT
3180 p->shut_on_empty = TRUE;
3182 _ckvmssts(sys$dassgn(p->chan_in));
3188 b->size = p->iosb.count;
3189 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3191 p->need_wake = FALSE;
3192 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3195 p->retry = 1; /* initial call */
3198 if (eof) { /* flush the free queue, return when done */
3199 int n = sizeof(CBuf) + p->bufsize;
3201 iss = lib$remqti(&p->free, &b);
3202 if (iss == LIB$_QUEWASEMP) return;
3204 _ckvmssts(lib$free_vm(&n, &b));
3208 iss = lib$remqti(&p->free, &b);
3209 if (iss == LIB$_QUEWASEMP) {
3210 int n = sizeof(CBuf) + p->bufsize;
3211 _ckvmssts(lib$get_vm(&n, &b));
3212 b->buf = (char *) b + sizeof(CBuf);
3218 iss = sys$qio(0,p->chan_in,
3219 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3221 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3222 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3227 /* writes queued buffers to output, waits for each to complete before
3231 pipe_tochild2_ast(pPipe p)
3234 int iss = p->iosb2.status;
3235 int n = sizeof(CBuf) + p->bufsize;
3236 int done = (p->info && p->info->done) ||
3237 iss == SS$_CANCEL || iss == SS$_ABORT;
3238 #if defined(PERL_IMPLICIT_CONTEXT)
3243 if (p->type) { /* type=1 has old buffer, dispose */
3244 if (p->shut_on_empty) {
3245 _ckvmssts(lib$free_vm(&n, &b));
3247 _ckvmssts(lib$insqhi(b, &p->free));
3252 iss = lib$remqti(&p->wait, &b);
3253 if (iss == LIB$_QUEWASEMP) {
3254 if (p->shut_on_empty) {
3256 _ckvmssts(sys$dassgn(p->chan_out));
3257 *p->pipe_done = TRUE;
3258 _ckvmssts(sys$setef(pipe_ef));
3260 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3261 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3265 p->need_wake = TRUE;
3275 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3276 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3278 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3279 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3288 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3291 char mbx1[64], mbx2[64];
3292 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3293 DSC$K_CLASS_S, mbx1},
3294 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3295 DSC$K_CLASS_S, mbx2};
3296 unsigned int dviitm = DVI$_DEVBUFSIZ;
3298 int n = sizeof(Pipe);
3299 _ckvmssts(lib$get_vm(&n, &p));
3300 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3301 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3303 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3304 n = p->bufsize * sizeof(char);
3305 _ckvmssts(lib$get_vm(&n, &p->buf));
3306 p->shut_on_empty = FALSE;
3309 p->iosb.status = SS$_NORMAL;
3310 #if defined(PERL_IMPLICIT_CONTEXT)
3313 pipe_infromchild_ast(p);
3321 pipe_infromchild_ast(pPipe p)
3323 int iss = p->iosb.status;
3324 int eof = (iss == SS$_ENDOFFILE);
3325 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3326 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3327 #if defined(PERL_IMPLICIT_CONTEXT)
3331 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3332 _ckvmssts(sys$dassgn(p->chan_out));
3337 input shutdown if EOF from self (done or shut_on_empty)
3338 output shutdown if closing flag set (my_pclose)
3339 send data/eof from child or eof from self
3340 otherwise, re-read (snarf of data from child)
3345 if (myeof && p->chan_in) { /* input shutdown */
3346 _ckvmssts(sys$dassgn(p->chan_in));
3351 if (myeof || kideof) { /* pass EOF to parent */
3352 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3353 pipe_infromchild_ast, p,
3356 } else if (eof) { /* eat EOF --- fall through to read*/
3358 } else { /* transmit data */
3359 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3360 pipe_infromchild_ast,p,
3361 p->buf, p->iosb.count, 0, 0, 0, 0));
3367 /* everything shut? flag as done */
3369 if (!p->chan_in && !p->chan_out) {
3370 *p->pipe_done = TRUE;
3371 _ckvmssts(sys$setef(pipe_ef));
3375 /* write completed (or read, if snarfing from child)
3376 if still have input active,
3377 queue read...immediate mode if shut_on_empty so we get EOF if empty
3379 check if Perl reading, generate EOFs as needed
3385 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3386 pipe_infromchild_ast,p,
3387 p->buf, p->bufsize, 0, 0, 0, 0);
3388 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3390 } else { /* send EOFs for extra reads */
3391 p->iosb.status = SS$_ENDOFFILE;
3392 p->iosb.dvispec = 0;
3393 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3395 pipe_infromchild_ast, p, 0, 0, 0, 0));
3401 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3405 unsigned long dviitm = DVI$_DEVBUFSIZ;
3407 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3408 DSC$K_CLASS_S, mbx};
3409 int n = sizeof(Pipe);
3411 /* things like terminals and mbx's don't need this filter */
3412 if (fd && fstat(fd,&s) == 0) {
3413 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3415 unsigned short dev_len;
3416 struct dsc$descriptor_s d_dev;
3418 struct item_list_3 items[3];
3420 unsigned short dvi_iosb[4];
3422 cptr = getname(fd, out, 1);
3423 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3424 d_dev.dsc$a_pointer = out;
3425 d_dev.dsc$w_length = strlen(out);
3426 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3427 d_dev.dsc$b_class = DSC$K_CLASS_S;
3430 items[0].code = DVI$_DEVCHAR;
3431 items[0].bufadr = &devchar;
3432 items[0].retadr = NULL;
3434 items[1].code = DVI$_FULLDEVNAM;
3435 items[1].bufadr = device;
3436 items[1].retadr = &dev_len;
3440 status = sys$getdviw
3441 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3443 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3444 device[dev_len] = 0;
3446 if (!(devchar & DEV$M_DIR)) {
3447 strcpy(out, device);
3453 _ckvmssts(lib$get_vm(&n, &p));
3454 p->fd_out = dup(fd);
3455 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3456 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3457 n = (p->bufsize+1) * sizeof(char);
3458 _ckvmssts(lib$get_vm(&n, &p->buf));
3459 p->shut_on_empty = FALSE;
3464 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3465 pipe_mbxtofd_ast, p,
3466 p->buf, p->bufsize, 0, 0, 0, 0));
3472 pipe_mbxtofd_ast(pPipe p)
3474 int iss = p->iosb.status;
3475 int done = p->info->done;
3477 int eof = (iss == SS$_ENDOFFILE);
3478 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3479 int err = !(iss&1) && !eof;
3480 #if defined(PERL_IMPLICIT_CONTEXT)
3484 if (done && myeof) { /* end piping */
3486 sys$dassgn(p->chan_in);
3487 *p->pipe_done = TRUE;
3488 _ckvmssts(sys$setef(pipe_ef));
3492 if (!err && !eof) { /* good data to send to file */
3493 p->buf[p->iosb.count] = '\n';
3494 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3497 if (p->retry < MAX_RETRY) {
3498 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3508 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3509 pipe_mbxtofd_ast, p,
3510 p->buf, p->bufsize, 0, 0, 0, 0);
3511 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3516 typedef struct _pipeloc PLOC;
3517 typedef struct _pipeloc* pPLOC;
3521 char dir[NAM$C_MAXRSS+1];
3523 static pPLOC head_PLOC = 0;
3526 free_pipelocs(pTHX_ void *head)
3529 pPLOC *pHead = (pPLOC *)head;
3541 store_pipelocs(pTHX)
3550 char temp[NAM$C_MAXRSS+1];
3554 free_pipelocs(aTHX_ &head_PLOC);
3556 /* the . directory from @INC comes last */
3558 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3559 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3560 p->next = head_PLOC;
3562 strcpy(p->dir,"./");
3564 /* get the directory from $^X */
3566 unixdir = PerlMem_malloc(VMS_MAXRSS);
3567 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3569 #ifdef PERL_IMPLICIT_CONTEXT
3570 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3572 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3574 strcpy(temp, PL_origargv[0]);
3575 x = strrchr(temp,']');
3577 x = strrchr(temp,'>');
3579 /* It could be a UNIX path */
3580 x = strrchr(temp,'/');
3586 /* Got a bare name, so use default directory */
3591 if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) {
3592 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3593 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3594 p->next = head_PLOC;
3596 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3597 p->dir[NAM$C_MAXRSS] = '\0';
3601 /* reverse order of @INC entries, skip "." since entered above */
3603 #ifdef PERL_IMPLICIT_CONTEXT
3606 if (PL_incgv) av = GvAVn(PL_incgv);
3608 for (i = 0; av && i <= AvFILL(av); i++) {
3609 dirsv = *av_fetch(av,i,TRUE);
3611 if (SvROK(dirsv)) continue;
3612 dir = SvPVx(dirsv,n_a);
3613 if (strcmp(dir,".") == 0) continue;
3614 if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch)
3617 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3618 p->next = head_PLOC;
3620 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3621 p->dir[NAM$C_MAXRSS] = '\0';
3624 /* most likely spot (ARCHLIB) put first in the list */
3627 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) {
3628 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3629 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3630 p->next = head_PLOC;
3632 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3633 p->dir[NAM$C_MAXRSS] = '\0';
3636 PerlMem_free(unixdir);
3640 Perl_cando_by_name_int
3641 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3642 #if !defined(PERL_IMPLICIT_CONTEXT)
3643 #define cando_by_name_int Perl_cando_by_name_int
3645 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3651 static int vmspipe_file_status = 0;
3652 static char vmspipe_file[NAM$C_MAXRSS+1];
3654 /* already found? Check and use ... need read+execute permission */
3656 if (vmspipe_file_status == 1) {
3657 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3658 && cando_by_name_int
3659 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3660 return vmspipe_file;
3662 vmspipe_file_status = 0;
3665 /* scan through stored @INC, $^X */
3667 if (vmspipe_file_status == 0) {
3668 char file[NAM$C_MAXRSS+1];
3669 pPLOC p = head_PLOC;
3674 strcpy(file, p->dir);
3675 dirlen = strlen(file);
3676 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3677 file[NAM$C_MAXRSS] = '\0';
3680 exp_res = do_rmsexpand
3681 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3682 if (!exp_res) continue;
3684 if (cando_by_name_int
3685 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3686 && cando_by_name_int
3687 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3688 vmspipe_file_status = 1;
3689 return vmspipe_file;
3692 vmspipe_file_status = -1; /* failed, use tempfiles */
3699 vmspipe_tempfile(pTHX)
3701 char file[NAM$C_MAXRSS+1];
3703 static int index = 0;
3707 /* create a tempfile */
3709 /* we can't go from W, shr=get to R, shr=get without
3710 an intermediate vulnerable state, so don't bother trying...
3712 and lib$spawn doesn't shr=put, so have to close the write
3714 So... match up the creation date/time and the FID to
3715 make sure we're dealing with the same file
3720 if (!decc_filename_unix_only) {
3721 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3722 fp = fopen(file,"w");
3724 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3725 fp = fopen(file,"w");
3727 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3728 fp = fopen(file,"w");
3733 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3734 fp = fopen(file,"w");
3736 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3737 fp = fopen(file,"w");
3739 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3740 fp = fopen(file,"w");
3744 if (!fp) return 0; /* we're hosed */
3746 fprintf(fp,"$! 'f$verify(0)'\n");
3747 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3748 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3749 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3750 fprintf(fp,"$ perl_on = \"set noon\"\n");
3751 fprintf(fp,"$ perl_exit = \"exit\"\n");
3752 fprintf(fp,"$ perl_del = \"delete\"\n");
3753 fprintf(fp,"$ pif = \"if\"\n");
3754 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3755 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3756 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3757 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3758 fprintf(fp,"$! --- build command line to get max possible length\n");
3759 fprintf(fp,"$c=perl_popen_cmd0\n");
3760 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3761 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3762 fprintf(fp,"$x=perl_popen_cmd3\n");
3763 fprintf(fp,"$c=c+x\n");
3764 fprintf(fp,"$ perl_on\n");
3765 fprintf(fp,"$ 'c'\n");
3766 fprintf(fp,"$ perl_status = $STATUS\n");
3767 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3768 fprintf(fp,"$ perl_exit 'perl_status'\n");
3771 fgetname(fp, file, 1);
3772 fstat(fileno(fp), (struct stat *)&s0);
3775 if (decc_filename_unix_only)
3776 do_tounixspec(file, file, 0, NULL);
3777 fp = fopen(file,"r","shr=get");
3779 fstat(fileno(fp), (struct stat *)&s1);
3781 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3782 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3791 static int vms_is_syscommand_xterm(void)
3793 const static struct dsc$descriptor_s syscommand_dsc =
3794 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3796 const static struct dsc$descriptor_s decwdisplay_dsc =
3797 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3799 struct item_list_3 items[2];
3800 unsigned short dvi_iosb[4];
3801 unsigned long devchar;
3802 unsigned long devclass;
3805 /* Very simple check to guess if sys$command is a decterm? */
3806 /* First see if the DECW$DISPLAY: device exists */
3808 items[0].code = DVI$_DEVCHAR;
3809 items[0].bufadr = &devchar;
3810 items[0].retadr = NULL;
3814 status = sys$getdviw
3815 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3817 if ($VMS_STATUS_SUCCESS(status)) {
3818 status = dvi_iosb[0];
3821 if (!$VMS_STATUS_SUCCESS(status)) {
3822 SETERRNO(EVMSERR, status);
3826 /* If it does, then for now assume that we are on a workstation */
3827 /* Now verify that SYS$COMMAND is a terminal */
3828 /* for creating the debugger DECTerm */
3831 items[0].code = DVI$_DEVCLASS;
3832 items[0].bufadr = &devclass;
3833 items[0].retadr = NULL;
3837 status = sys$getdviw
3838 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3840 if ($VMS_STATUS_SUCCESS(status)) {
3841 status = dvi_iosb[0];
3844 if (!$VMS_STATUS_SUCCESS(status)) {
3845 SETERRNO(EVMSERR, status);
3849 if (devclass == DC$_TERM) {
3856 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3857 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3862 char device_name[65];
3863 unsigned short device_name_len;
3864 struct dsc$descriptor_s customization_dsc;
3865 struct dsc$descriptor_s device_name_dsc;
3868 char customization[200];
3872 unsigned short p_chan;
3874 unsigned short iosb[4];
3875 struct item_list_3 items[2];
3876 const char * cust_str =
3877 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3878 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3879 DSC$K_CLASS_S, mbx1};
3881 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3882 /*---------------------------------------*/
3883 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3886 /* Make sure that this is from the Perl debugger */
3887 ret_char = strstr(cmd," xterm ");
3888 if (ret_char == NULL)
3890 cptr = ret_char + 7;
3891 ret_char = strstr(cmd,"tty");
3892 if (ret_char == NULL)
3894 ret_char = strstr(cmd,"sleep");
3895 if (ret_char == NULL)
3898 if (decw_term_port == 0) {
3899 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3900 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3901 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3903 status = lib$find_image_symbol
3905 &decw_term_port_dsc,
3906 (void *)&decw_term_port,
3910 /* Try again with the other image name */
3911 if (!$VMS_STATUS_SUCCESS(status)) {
3913 status = lib$find_image_symbol
3915 &decw_term_port_dsc,
3916 (void *)&decw_term_port,
3925 /* No decw$term_port, give it up */
3926 if (!$VMS_STATUS_SUCCESS(status))
3929 /* Are we on a workstation? */
3930 /* to do: capture the rows / columns and pass their properties */
3931 ret_stat = vms_is_syscommand_xterm();
3935 /* Make the title: */
3936 ret_char = strstr(cptr,"-title");
3937 if (ret_char != NULL) {
3938 while ((*cptr != 0) && (*cptr != '\"')) {
3944 while ((*cptr != 0) && (*cptr != '\"')) {
3957 strcpy(title,"Perl Debug DECTerm");
3959 sprintf(customization, cust_str, title);
3961 customization_dsc.dsc$a_pointer = customization;
3962 customization_dsc.dsc$w_length = strlen(customization);
3963 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3964 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3966 device_name_dsc.dsc$a_pointer = device_name;
3967 device_name_dsc.dsc$w_length = sizeof device_name -1;
3968 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3969 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3971 device_name_len = 0;
3973 /* Try to create the window */
3974 status = (*decw_term_port)
3983 if (!$VMS_STATUS_SUCCESS(status)) {
3984 SETERRNO(EVMSERR, status);
3988 device_name[device_name_len] = '\0';
3990 /* Need to set this up to look like a pipe for cleanup */
3992 status = lib$get_vm(&n, &info);
3993 if (!$VMS_STATUS_SUCCESS(status)) {
3994 SETERRNO(ENOMEM, status);
4000 info->completion = 0;
4001 info->closing = FALSE;
4008 info->in_done = TRUE;
4009 info->out_done = TRUE;
4010 info->err_done = TRUE;
4012 /* Assign a channel on this so that it will persist, and not login */
4013 /* We stash this channel in the info structure for reference. */
4014 /* The created xterm self destructs when the last channel is removed */
4015 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4016 /* So leave this assigned. */
4017 device_name_dsc.dsc$w_length = device_name_len;
4018 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4019 if (!$VMS_STATUS_SUCCESS(status)) {
4020 SETERRNO(EVMSERR, status);
4023 info->xchan_valid = 1;
4025 /* Now create a mailbox to be read by the application */
4027 create_mbx(aTHX_ &p_chan, &d_mbx1);
4029 /* write the name of the created terminal to the mailbox */
4030 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4031 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4033 if (!$VMS_STATUS_SUCCESS(status)) {
4034 SETERRNO(EVMSERR, status);
4038 info->fp = PerlIO_open(mbx1, mode);
4040 /* Done with this channel */
4043 /* If any errors, then clean up */
4046 _ckvmssts(lib$free_vm(&n, &info));
4055 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4057 static int handler_set_up = FALSE;
4058 unsigned long int sts, flags = CLI$M_NOWAIT;
4059 /* The use of a GLOBAL table (as was done previously) rendered
4060 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4061 * environment. Hence we've switched to LOCAL symbol table.
4063 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4065 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4066 char *in, *out, *err, mbx[512];
4068 char tfilebuf[NAM$C_MAXRSS+1];
4070 char cmd_sym_name[20];
4071 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4072 DSC$K_CLASS_S, symbol};
4073 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4075 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4076 DSC$K_CLASS_S, cmd_sym_name};
4077 struct dsc$descriptor_s *vmscmd;
4078 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4079 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4080 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4082 /* Check here for Xterm create request. This means looking for
4083 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4084 * is possible to create an xterm.
4086 if (*in_mode == 'r') {
4089 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4090 if (xterm_fd != Nullfp)
4094 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4096 /* once-per-program initialization...
4097 note that the SETAST calls and the dual test of pipe_ef
4098 makes sure that only the FIRST thread through here does
4099 the initialization...all other threads wait until it's
4102 Yeah, uglier than a pthread call, it's got all the stuff inline
4103 rather than in a separate routine.
4107 _ckvmssts(sys$setast(0));
4109 unsigned long int pidcode = JPI$_PID;
4110 $DESCRIPTOR(d_delay, RETRY_DELAY);
4111 _ckvmssts(lib$get_ef(&pipe_ef));
4112 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4113 _ckvmssts(sys$bintim(&d_delay, delaytime));
4115 if (!handler_set_up) {
4116 _ckvmssts(sys$dclexh(&pipe_exitblock));
4117 handler_set_up = TRUE;
4119 _ckvmssts(sys$setast(1));
4122 /* see if we can find a VMSPIPE.COM */
4125 vmspipe = find_vmspipe(aTHX);
4127 strcpy(tfilebuf+1,vmspipe);
4128 } else { /* uh, oh...we're in tempfile hell */
4129 tpipe = vmspipe_tempfile(aTHX);
4130 if (!tpipe) { /* a fish popular in Boston */
4131 if (ckWARN(WARN_PIPE)) {
4132 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4136 fgetname(tpipe,tfilebuf+1,1);
4138 vmspipedsc.dsc$a_pointer = tfilebuf;
4139 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4141 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4144 case RMS$_FNF: case RMS$_DNF:
4145 set_errno(ENOENT); break;
4147 set_errno(ENOTDIR); break;
4149 set_errno(ENODEV); break;
4151 set_errno(EACCES); break;
4153 set_errno(EINVAL); break;
4154 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4155 set_errno(E2BIG); break;
4156 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4157 _ckvmssts(sts); /* fall through */
4158 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4161 set_vaxc_errno(sts);
4162 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4163 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4169 _ckvmssts(lib$get_vm(&n, &info));
4171 strcpy(mode,in_mode);
4174 info->completion = 0;
4175 info->closing = FALSE;
4182 info->in_done = TRUE;
4183 info->out_done = TRUE;
4184 info->err_done = TRUE;
4186 info->xchan_valid = 0;
4188 in = PerlMem_malloc(VMS_MAXRSS);
4189 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4190 out = PerlMem_malloc(VMS_MAXRSS);
4191 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4192 err = PerlMem_malloc(VMS_MAXRSS);
4193 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4195 in[0] = out[0] = err[0] = '\0';
4197 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4201 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4206 if (*mode == 'r') { /* piping from subroutine */
4208 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4210 info->out->pipe_done = &info->out_done;
4211 info->out_done = FALSE;
4212 info->out->info = info;
4214 if (!info->useFILE) {
4215 info->fp = PerlIO_open(mbx, mode);
4217 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4218 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4221 if (!info->fp && info->out) {
4222 sys$cancel(info->out->chan_out);
4224 while (!info->out_done) {
4226 _ckvmssts(sys$setast(0));
4227 done = info->out_done;
4228 if (!done) _ckvmssts(sys$clref(pipe_ef));
4229 _ckvmssts(sys$setast(1));
4230 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4233 if (info->out->buf) {
4234 n = info->out->bufsize * sizeof(char);
4235 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4238 _ckvmssts(lib$free_vm(&n, &info->out));
4240 _ckvmssts(lib$free_vm(&n, &info));
4245 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4247 info->err->pipe_done = &info->err_done;
4248 info->err_done = FALSE;
4249 info->err->info = info;
4252 } else if (*mode == 'w') { /* piping to subroutine */
4254 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4256 info->out->pipe_done = &info->out_done;
4257 info->out_done = FALSE;
4258 info->out->info = info;
4261 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4263 info->err->pipe_done = &info->err_done;
4264 info->err_done = FALSE;
4265 info->err->info = info;
4268 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4269 if (!info->useFILE) {
4270 info->fp = PerlIO_open(mbx, mode);
4272 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4273 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4277 info->in->pipe_done = &info->in_done;
4278 info->in_done = FALSE;
4279 info->in->info = info;
4283 if (!info->fp && info->in) {
4285 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4286 0, 0, 0, 0, 0, 0, 0, 0));
4288 while (!info->in_done) {
4290 _ckvmssts(sys$setast(0));
4291 done = info->in_done;
4292 if (!done) _ckvmssts(sys$clref(pipe_ef));
4293 _ckvmssts(sys$setast(1));
4294 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4297 if (info->in->buf) {
4298 n = info->in->bufsize * sizeof(char);
4299 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4302 _ckvmssts(lib$free_vm(&n, &info->in));
4304 _ckvmssts(lib$free_vm(&n, &info));
4310 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4311 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4313 info->out->pipe_done = &info->out_done;
4314 info->out_done = FALSE;
4315 info->out->info = info;
4318 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4320 info->err->pipe_done = &info->err_done;
4321 info->err_done = FALSE;
4322 info->err->info = info;
4326 symbol[MAX_DCL_SYMBOL] = '\0';
4328 strncpy(symbol, in, MAX_DCL_SYMBOL);
4329 d_symbol.dsc$w_length = strlen(symbol);
4330 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4332 strncpy(symbol, err, MAX_DCL_SYMBOL);
4333 d_symbol.dsc$w_length = strlen(symbol);
4334 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4336 strncpy(symbol, out, MAX_DCL_SYMBOL);
4337 d_symbol.dsc$w_length = strlen(symbol);
4338 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4340 /* Done with the names for the pipes */
4345 p = vmscmd->dsc$a_pointer;
4346 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4347 if (*p == '$') p++; /* remove leading $ */
4348 while (*p == ' ' || *p == '\t') p++;
4350 for (j = 0; j < 4; j++) {
4351 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4352 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4354 strncpy(symbol, p, MAX_DCL_SYMBOL);
4355 d_symbol.dsc$w_length = strlen(symbol);
4356 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4358 if (strlen(p) > MAX_DCL_SYMBOL) {
4359 p += MAX_DCL_SYMBOL;
4364 _ckvmssts(sys$setast(0));
4365 info->next=open_pipes; /* prepend to list */
4367 _ckvmssts(sys$setast(1));
4368 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4369 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4370 * have SYS$COMMAND if we need it.
4372 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4373 0, &info->pid, &info->completion,
4374 0, popen_completion_ast,info,0,0,0));
4376 /* if we were using a tempfile, close it now */
4378 if (tpipe) fclose(tpipe);
4380 /* once the subprocess is spawned, it has copied the symbols and
4381 we can get rid of ours */
4383 for (j = 0; j < 4; j++) {
4384 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4385 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4386 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4388 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4389 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4390 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4391 vms_execfree(vmscmd);
4393 #ifdef PERL_IMPLICIT_CONTEXT
4396 PL_forkprocess = info->pid;
4401 _ckvmssts(sys$setast(0));
4403 if (!done) _ckvmssts(sys$clref(pipe_ef));
4404 _ckvmssts(sys$setast(1));
4405 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4407 *psts = info->completion;
4408 /* Caller thinks it is open and tries to close it. */
4409 /* This causes some problems, as it changes the error status */
4410 /* my_pclose(info->fp); */
4415 } /* end of safe_popen */
4418 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4420 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4424 TAINT_PROPER("popen");
4425 PERL_FLUSHALL_FOR_CHILD;
4426 return safe_popen(aTHX_ cmd,mode,&sts);
4431 /*{{{ I32 my_pclose(PerlIO *fp)*/
4432 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4434 pInfo info, last = NULL;
4435 unsigned long int retsts;
4439 for (info = open_pipes; info != NULL; last = info, info = info->next)
4440 if (info->fp == fp) break;
4442 if (info == NULL) { /* no such pipe open */
4443 set_errno(ECHILD); /* quoth POSIX */
4444 set_vaxc_errno(SS$_NONEXPR);
4448 /* If we were writing to a subprocess, insure that someone reading from
4449 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4450 * produce an EOF record in the mailbox.
4452 * well, at least sometimes it *does*, so we have to watch out for
4453 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4457 #if defined(USE_ITHREADS)
4460 && PL_perlio_fd_refcnt)
4461 PerlIO_flush(info->fp);
4463 fflush((FILE *)info->fp);
4466 _ckvmssts(sys$setast(0));
4467 info->closing = TRUE;
4468 done = info->done && info->in_done && info->out_done && info->err_done;
4469 /* hanging on write to Perl's input? cancel it */
4470 if (info->mode == 'r' && info->out && !info->out_done) {
4471 if (info->out->chan_out) {
4472 _ckvmssts(sys$cancel(info->out->chan_out));
4473 if (!info->out->chan_in) { /* EOF generation, need AST */
4474 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4478 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4479 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4481 _ckvmssts(sys$setast(1));
4484 #if defined(USE_ITHREADS)
4487 && PL_perlio_fd_refcnt)
4488 PerlIO_close(info->fp);
4490 fclose((FILE *)info->fp);
4493 we have to wait until subprocess completes, but ALSO wait until all
4494 the i/o completes...otherwise we'll be freeing the "info" structure
4495 that the i/o ASTs could still be using...
4499 _ckvmssts(sys$setast(0));
4500 done = info->done && info->in_done && info->out_done && info->err_done;
4501 if (!done) _ckvmssts(sys$clref(pipe_ef));
4502 _ckvmssts(sys$setast(1));
4503 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4505 retsts = info->completion;
4507 /* remove from list of open pipes */
4508 _ckvmssts(sys$setast(0));
4509 if (last) last->next = info->next;
4510 else open_pipes = info->next;
4511 _ckvmssts(sys$setast(1));
4513 /* free buffers and structures */
4516 if (info->in->buf) {
4517 n = info->in->bufsize * sizeof(char);
4518 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4521 _ckvmssts(lib$free_vm(&n, &info->in));
4524 if (info->out->buf) {
4525 n = info->out->bufsize * sizeof(char);
4526 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4529 _ckvmssts(lib$free_vm(&n, &info->out));
4532 if (info->err->buf) {
4533 n = info->err->bufsize * sizeof(char);
4534 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4537 _ckvmssts(lib$free_vm(&n, &info->err));
4540 _ckvmssts(lib$free_vm(&n, &info));
4544 } /* end of my_pclose() */
4546 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4547 /* Roll our own prototype because we want this regardless of whether
4548 * _VMS_WAIT is defined.
4550 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4552 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4553 created with popen(); otherwise partially emulate waitpid() unless
4554 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4555 Also check processes not considered by the CRTL waitpid().
4557 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4559 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4566 if (statusp) *statusp = 0;
4568 for (info = open_pipes; info != NULL; info = info->next)
4569 if (info->pid == pid) break;
4571 if (info != NULL) { /* we know about this child */
4572 while (!info->done) {
4573 _ckvmssts(sys$setast(0));
4575 if (!done) _ckvmssts(sys$clref(pipe_ef));
4576 _ckvmssts(sys$setast(1));
4577 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4580 if (statusp) *statusp = info->completion;
4584 /* child that already terminated? */
4586 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4587 if (closed_list[j].pid == pid) {
4588 if (statusp) *statusp = closed_list[j].completion;
4593 /* fall through if this child is not one of our own pipe children */
4595 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4597 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4598 * in 7.2 did we get a version that fills in the VMS completion
4599 * status as Perl has always tried to do.
4602 sts = __vms_waitpid( pid, statusp, flags );
4604 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4607 /* If the real waitpid tells us the child does not exist, we
4608 * fall through here to implement waiting for a child that
4609 * was created by some means other than exec() (say, spawned
4610 * from DCL) or to wait for a process that is not a subprocess
4611 * of the current process.
4614 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4617 $DESCRIPTOR(intdsc,"0 00:00:01");
4618 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4619 unsigned long int pidcode = JPI$_PID, mypid;
4620 unsigned long int interval[2];
4621 unsigned int jpi_iosb[2];
4622 struct itmlst_3 jpilist[2] = {
4623 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4628 /* Sorry folks, we don't presently implement rooting around for
4629 the first child we can find, and we definitely don't want to
4630 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4636 /* Get the owner of the child so I can warn if it's not mine. If the
4637 * process doesn't exist or I don't have the privs to look at it,
4638 * I can go home early.
4640 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4641 if (sts & 1) sts = jpi_iosb[0];
4653 set_vaxc_errno(sts);
4657 if (ckWARN(WARN_EXEC)) {
4658 /* remind folks they are asking for non-standard waitpid behavior */
4659 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4660 if (ownerpid != mypid)
4661 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4662 "waitpid: process %x is not a child of process %x",
4666 /* simply check on it once a second until it's not there anymore. */
4668 _ckvmssts(sys$bintim(&intdsc,interval));
4669 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4670 _ckvmssts(sys$schdwk(0,0,interval,0));
4671 _ckvmssts(sys$hiber());
4673 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4678 } /* end of waitpid() */
4683 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4685 my_gconvert(double val, int ndig, int trail, char *buf)
4687 static char __gcvtbuf[DBL_DIG+1];
4690 loc = buf ? buf : __gcvtbuf;
4692 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4694 sprintf(loc,"%.*g",ndig,val);
4700 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4701 return gcvt(val,ndig,loc);
4704 loc[0] = '0'; loc[1] = '\0';
4711 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4712 static int rms_free_search_context(struct FAB * fab)
4716 nam = fab->fab$l_nam;
4717 nam->nam$b_nop |= NAM$M_SYNCHK;
4718 nam->nam$l_rlf = NULL;
4720 return sys$parse(fab, NULL, NULL);
4723 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4724 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4725 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4726 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4727 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4728 #define rms_nam_esll(nam) nam.nam$b_esl
4729 #define rms_nam_esl(nam) nam.nam$b_esl
4730 #define rms_nam_name(nam) nam.nam$l_name
4731 #define rms_nam_namel(nam) nam.nam$l_name
4732 #define rms_nam_type(nam) nam.nam$l_type
4733 #define rms_nam_typel(nam) nam.nam$l_type
4734 #define rms_nam_ver(nam) nam.nam$l_ver
4735 #define rms_nam_verl(nam) nam.nam$l_ver
4736 #define rms_nam_rsll(nam) nam.nam$b_rsl
4737 #define rms_nam_rsl(nam) nam.nam$b_rsl
4738 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4739 #define rms_set_fna(fab, nam, name, size) \
4740 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4741 #define rms_get_fna(fab, nam) fab.fab$l_fna
4742 #define rms_set_dna(fab, nam, name, size) \
4743 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4744 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4745 #define rms_set_esa(nam, name, size) \
4746 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4747 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4748 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4749 #define rms_set_rsa(nam, name, size) \
4750 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4751 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4752 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4753 #define rms_nam_name_type_l_size(nam) \
4754 (nam.nam$b_name + nam.nam$b_type)
4756 static int rms_free_search_context(struct FAB * fab)
4760 nam = fab->fab$l_naml;
4761 nam->naml$b_nop |= NAM$M_SYNCHK;
4762 nam->naml$l_rlf = NULL;
4763 nam->naml$l_long_defname_size = 0;
4766 return sys$parse(fab, NULL, NULL);
4769 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4770 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4771 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4772 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4773 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4774 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4775 #define rms_nam_esl(nam) nam.naml$b_esl
4776 #define rms_nam_name(nam) nam.naml$l_name
4777 #define rms_nam_namel(nam) nam.naml$l_long_name
4778 #define rms_nam_type(nam) nam.naml$l_type
4779 #define rms_nam_typel(nam) nam.naml$l_long_type
4780 #define rms_nam_ver(nam) nam.naml$l_ver
4781 #define rms_nam_verl(nam) nam.naml$l_long_ver
4782 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4783 #define rms_nam_rsl(nam) nam.naml$b_rsl
4784 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4785 #define rms_set_fna(fab, nam, name, size) \
4786 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4787 nam.naml$l_long_filename_size = size; \
4788 nam.naml$l_long_filename = name;}
4789 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4790 #define rms_set_dna(fab, nam, name, size) \
4791 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4792 nam.naml$l_long_defname_size = size; \
4793 nam.naml$l_long_defname = name; }
4794 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4795 #define rms_set_esa(nam, name, size) \
4796 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4797 nam.naml$l_long_expand_alloc = size; \
4798 nam.naml$l_long_expand = name; }
4799 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4800 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4801 nam.naml$l_long_expand = l_name; \
4802 nam.naml$l_long_expand_alloc = l_size; }
4803 #define rms_set_rsa(nam, name, size) \
4804 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4805 nam.naml$l_long_result = name; \
4806 nam.naml$l_long_result_alloc = size; }
4807 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4808 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4809 nam.naml$l_long_result = l_name; \
4810 nam.naml$l_long_result_alloc = l_size; }
4811 #define rms_nam_name_type_l_size(nam) \
4812 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4817 * The CRTL for 8.3 and later can create symbolic links in any mode,
4818 * however in 8.3 the unlink/remove/delete routines will only properly handle
4819 * them if one of the PCP modes is active.
4821 static int rms_erase(const char * vmsname)
4824 struct FAB myfab = cc$rms_fab;
4825 rms_setup_nam(mynam);
4827 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4828 rms_bind_fab_nam(myfab, mynam);
4830 /* Are we removing all versions? */
4831 if (vms_unlink_all_versions == 1) {
4832 const char * defspec = ";*";
4833 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4836 #ifdef NAML$M_OPEN_SPECIAL
4837 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4840 status = sys$erase(&myfab, 0, 0);
4847 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4848 const struct dsc$descriptor_s * vms_dst_dsc,
4849 unsigned long flags)
4851 /* VMS and UNIX handle file permissions differently and the
4852 * the same ACL trick may be needed for renaming files,
4853 * especially if they are directories.
4856 /* todo: get kill_file and rename to share common code */
4857 /* I can not find online documentation for $change_acl
4858 * it appears to be replaced by $set_security some time ago */
4860 const unsigned int access_mode = 0;
4861 $DESCRIPTOR(obj_file_dsc,"FILE");
4864 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4865 int aclsts, fndsts, rnsts = -1;
4866 unsigned int ctx = 0;
4867 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4868 struct dsc$descriptor_s * clean_dsc;
4871 unsigned char myace$b_length;
4872 unsigned char myace$b_type;
4873 unsigned short int myace$w_flags;
4874 unsigned long int myace$l_access;
4875 unsigned long int myace$l_ident;
4876 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4877 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4879 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4882 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4883 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4885 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4886 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4890 /* Expand the input spec using RMS, since we do not want to put
4891 * ACLs on the target of a symbolic link */
4892 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4893 if (vmsname == NULL)
4896 rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4900 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4904 PerlMem_free(vmsname);
4908 /* So we get our own UIC to use as a rights identifier,
4909 * and the insert an ACE at the head of the ACL which allows us
4910 * to delete the file.
4912 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4914 fildsc.dsc$w_length = strlen(vmsname);
4915 fildsc.dsc$a_pointer = vmsname;
4917 newace.myace$l_ident = oldace.myace$l_ident;
4920 /* Grab any existing ACEs with this identifier in case we fail */
4921 clean_dsc = &fildsc;
4922 aclsts = fndsts = sys$get_security(&obj_file_dsc,
4930 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
4931 /* Add the new ACE . . . */
4933 /* if the sys$get_security succeeded, then ctx is valid, and the
4934 * object/file descriptors will be ignored. But otherwise they
4937 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4938 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4939 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4941 set_vaxc_errno(aclsts);
4942 PerlMem_free(vmsname);
4946 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4949 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4951 if ($VMS_STATUS_SUCCESS(rnsts)) {
4952 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4955 /* Put things back the way they were. */
4957 aclsts = sys$get_security(&obj_file_dsc,
4965 if ($VMS_STATUS_SUCCESS(aclsts)) {
4969 if (!$VMS_STATUS_SUCCESS(fndsts))
4970 sec_flags = OSS$M_RELCTX;
4972 /* Get rid of the new ACE */
4973 aclsts = sys$set_security(NULL, NULL, NULL,
4974 sec_flags, dellst, &ctx, &access_mode);
4976 /* If there was an old ACE, put it back */
4977 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4978 addlst[0].bufadr = &oldace;
4979 aclsts = sys$set_security(NULL, NULL, NULL,
4980 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4981 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4983 set_vaxc_errno(aclsts);
4989 /* Try to clear the lock on the ACL list */
4990 aclsts2 = sys$set_security(NULL, NULL, NULL,
4991 OSS$M_RELCTX, NULL, &ctx, &access_mode);
4993 /* Rename errors are most important */
4994 if (!$VMS_STATUS_SUCCESS(rnsts))
4997 set_vaxc_errno(aclsts);
5002 if (aclsts != SS$_ACLEMPTY)
5009 PerlMem_free(vmsname);
5014 /*{{{int rename(const char *, const char * */
5015 /* Not exactly what X/Open says to do, but doing it absolutely right
5016 * and efficiently would require a lot more work. This should be close
5017 * enough to pass all but the most strict X/Open compliance test.
5020 Perl_rename(pTHX_ const char *src, const char * dst)
5029 /* Validate the source file */
5030 src_sts = flex_lstat(src, &src_st);
5033 /* No source file or other problem */
5037 dst_sts = flex_lstat(dst, &dst_st);
5040 if (dst_st.st_dev != src_st.st_dev) {
5041 /* Must be on the same device */
5046 /* VMS_INO_T_COMPARE is true if the inodes are different
5047 * to match the output of memcmp
5050 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5051 /* That was easy, the files are the same! */
5055 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5056 /* If source is a directory, so must be dest */
5064 if ((dst_sts == 0) &&
5065 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5067 /* We have issues here if vms_unlink_all_versions is set
5068 * If the destination exists, and is not a directory, then
5069 * we must delete in advance.
5071 * If the src is a directory, then we must always pre-delete
5074 * If we successfully delete the dst in advance, and the rename fails
5075 * X/Open requires that errno be EIO.
5079 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5081 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5085 /* We killed the destination, so only errno now is EIO */
5090 /* Originally the idea was to call the CRTL rename() and only
5091 * try the lib$rename_file if it failed.
5092 * It turns out that there are too many variants in what the
5093 * the CRTL rename might do, so only use lib$rename_file
5098 /* Is the source and dest both in VMS format */
5099 /* if the source is a directory, then need to fileify */
5100 /* and dest must be a directory or non-existant. */
5106 unsigned long flags;
5107 struct dsc$descriptor_s old_file_dsc;
5108 struct dsc$descriptor_s new_file_dsc;
5110 /* We need to modify the src and dst depending
5111 * on if one or more of them are directories.
5114 vms_src = PerlMem_malloc(VMS_MAXRSS);
5115 if (vms_src == NULL)
5116 _ckvmssts(SS$_INSFMEM);
5118 /* Source is always a VMS format file */
5119 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5120 if (ret_str == NULL) {
5121 PerlMem_free(vms_src);
5126 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5127 if (vms_dst == NULL)
5128 _ckvmssts(SS$_INSFMEM);
5130 if (S_ISDIR(src_st.st_mode)) {
5132 char * vms_dir_file;
5134 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5135 if (vms_dir_file == NULL)
5136 _ckvmssts(SS$_INSFMEM);
5138 /* The source must be a file specification */
5139 ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5140 if (ret_str == NULL) {
5141 PerlMem_free(vms_src);
5142 PerlMem_free(vms_dst);
5143 PerlMem_free(vms_dir_file);
5147 PerlMem_free(vms_src);
5148 vms_src = vms_dir_file;
5150 /* If the dest is a directory, we must remove it
5153 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5155 PerlMem_free(vms_src);
5156 PerlMem_free(vms_dst);
5164 /* The dest must be a VMS file specification */
5165 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5166 if (ret_str == NULL) {
5167 PerlMem_free(vms_src);
5168 PerlMem_free(vms_dst);
5173 /* The source must be a file specification */
5174 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5175 if (vms_dir_file == NULL)
5176 _ckvmssts(SS$_INSFMEM);
5178 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5179 if (ret_str == NULL) {
5180 PerlMem_free(vms_src);
5181 PerlMem_free(vms_dst);
5182 PerlMem_free(vms_dir_file);
5186 PerlMem_free(vms_dst);
5187 vms_dst = vms_dir_file;
5190 /* File to file or file to new dir */
5192 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5193 /* VMS pathify a dir target */
5194 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5195 if (ret_str == NULL) {
5196 PerlMem_free(vms_src);
5197 PerlMem_free(vms_dst);
5203 /* fileify a target VMS file specification */
5204 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5205 if (ret_str == NULL) {
5206 PerlMem_free(vms_src);
5207 PerlMem_free(vms_dst);
5214 old_file_dsc.dsc$a_pointer = vms_src;
5215 old_file_dsc.dsc$w_length = strlen(vms_src);
5216 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5217 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5219 new_file_dsc.dsc$a_pointer = vms_dst;
5220 new_file_dsc.dsc$w_length = strlen(vms_dst);
5221 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5222 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5225 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5226 flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5229 sts = lib$rename_file(&old_file_dsc,
5233 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5234 if (!$VMS_STATUS_SUCCESS(sts)) {
5236 /* We could have failed because VMS style permissions do not
5237 * permit renames that UNIX will allow. Just like the hack
5240 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5243 PerlMem_free(vms_src);
5244 PerlMem_free(vms_dst);
5245 if (!$VMS_STATUS_SUCCESS(sts)) {
5252 if (vms_unlink_all_versions) {
5253 /* Now get rid of any previous versions of the source file that
5258 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5262 /* We deleted the destination, so must force the error to be EIO */
5263 if ((retval != 0) && (pre_delete != 0))
5271 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5272 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5273 * to expand file specification. Allows for a single default file
5274 * specification and a simple mask of options. If outbuf is non-NULL,
5275 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5276 * the resultant file specification is placed. If outbuf is NULL, the
5277 * resultant file specification is placed into a static buffer.
5278 * The third argument, if non-NULL, is taken to be a default file
5279 * specification string. The fourth argument is unused at present.
5280 * rmesexpand() returns the address of the resultant string if
5281 * successful, and NULL on error.
5283 * New functionality for previously unused opts value:
5284 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5285 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5286 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5287 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5289 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5293 (pTHX_ const char *filespec,
5296 const char *defspec,
5301 static char __rmsexpand_retbuf[VMS_MAXRSS];
5302 char * vmsfspec, *tmpfspec;
5303 char * esa, *cp, *out = NULL;
5307 struct FAB myfab = cc$rms_fab;
5308 rms_setup_nam(mynam);
5310 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5313 /* temp hack until UTF8 is actually implemented */
5314 if (fs_utf8 != NULL)
5317 if (!filespec || !*filespec) {
5318 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5322 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5323 else outbuf = __rmsexpand_retbuf;
5331 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5332 isunix = is_unix_filespec(filespec);
5334 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5335 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5336 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5337 PerlMem_free(vmsfspec);
5342 filespec = vmsfspec;
5344 /* Unless we are forcing to VMS format, a UNIX input means
5345 * UNIX output, and that requires long names to be used
5347 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5348 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5349 opts |= PERL_RMSEXPAND_M_LONG;
5356 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5357 rms_bind_fab_nam(myfab, mynam);
5359 if (defspec && *defspec) {
5361 t_isunix = is_unix_filespec(defspec);
5363 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5364 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5365 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5366 PerlMem_free(tmpfspec);
5367 if (vmsfspec != NULL)
5368 PerlMem_free(vmsfspec);
5375 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5378 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5379 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5380 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5381 esal = PerlMem_malloc(VMS_MAXRSS);
5382 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5384 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5386 /* If a NAML block is used RMS always writes to the long and short
5387 * addresses unless you suppress the short name.
5389 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5390 outbufl = PerlMem_malloc(VMS_MAXRSS);
5391 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5393 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5395 #ifdef NAM$M_NO_SHORT_UPCASE
5396 if (decc_efs_case_preserve)
5397 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5400 /* We may not want to follow symbolic links */
5401 #ifdef NAML$M_OPEN_SPECIAL
5402 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5403 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5406 /* First attempt to parse as an existing file */
5407 retsts = sys$parse(&myfab,0,0);
5408 if (!(retsts & STS$K_SUCCESS)) {
5410 /* Could not find the file, try as syntax only if error is not fatal */
5411 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5412 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5413 retsts = sys$parse(&myfab,0,0);
5414 if (retsts & STS$K_SUCCESS) goto expanded;
5417 /* Still could not parse the file specification */
5418 /*----------------------------------------------*/
5419 sts = rms_free_search_context(&myfab); /* Free search context */
5420 if (out) Safefree(out);
5421 if (tmpfspec != NULL)
5422 PerlMem_free(tmpfspec);
5423 if (vmsfspec != NULL)
5424 PerlMem_free(vmsfspec);
5425 if (outbufl != NULL)
5426 PerlMem_free(outbufl);
5430 set_vaxc_errno(retsts);
5431 if (retsts == RMS$_PRV) set_errno(EACCES);
5432 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5433 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5434 else set_errno(EVMSERR);
5437 retsts = sys$search(&myfab,0,0);
5438 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5439 sts = rms_free_search_context(&myfab); /* Free search context */
5440 if (out) Safefree(out);
5441 if (tmpfspec != NULL)
5442 PerlMem_free(tmpfspec);
5443 if (vmsfspec != NULL)
5444 PerlMem_free(vmsfspec);
5445 if (outbufl != NULL)
5446 PerlMem_free(outbufl);
5450 set_vaxc_errno(retsts);
5451 if (retsts == RMS$_PRV) set_errno(EACCES);
5452 else set_errno(EVMSERR);
5456 /* If the input filespec contained any lowercase characters,
5457 * downcase the result for compatibility with Unix-minded code. */
5459 if (!decc_efs_case_preserve) {
5460 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5461 if (islower(*tbuf)) { haslower = 1; break; }
5464 /* Is a long or a short name expected */
5465 /*------------------------------------*/
5466 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5467 if (rms_nam_rsll(mynam)) {
5469 speclen = rms_nam_rsll(mynam);
5472 tbuf = esal; /* Not esa */
5473 speclen = rms_nam_esll(mynam);
5477 if (rms_nam_rsl(mynam)) {
5479 speclen = rms_nam_rsl(mynam);
5482 tbuf = esa; /* Not esal */
5483 speclen = rms_nam_esl(mynam);
5486 tbuf[speclen] = '\0';
5488 /* Trim off null fields added by $PARSE
5489 * If type > 1 char, must have been specified in original or default spec
5490 * (not true for version; $SEARCH may have added version of existing file).
5492 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5493 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5494 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5495 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5498 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5499 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5501 if (trimver || trimtype) {
5502 if (defspec && *defspec) {
5503 char *defesal = NULL;
5504 char *defesa = NULL;
5505 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5506 if (defesa != NULL) {
5507 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5508 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5509 if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5511 struct FAB deffab = cc$rms_fab;
5512 rms_setup_nam(defnam);
5514 rms_bind_fab_nam(deffab, defnam);
5518 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5520 /* RMS needs the esa/esal as a work area if wildcards are involved */
5521 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5523 rms_clear_nam_nop(defnam);
5524 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5525 #ifdef NAM$M_NO_SHORT_UPCASE
5526 if (decc_efs_case_preserve)
5527 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5529 #ifdef NAML$M_OPEN_SPECIAL
5530 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5531 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5533 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5535 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5538 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5541 if (defesal != NULL)
5542 PerlMem_free(defesal);
5543 PerlMem_free(defesa);
5547 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5548 if (*(rms_nam_verl(mynam)) != '\"')
5549 speclen = rms_nam_verl(mynam) - tbuf;
5552 if (*(rms_nam_ver(mynam)) != '\"')
5553 speclen = rms_nam_ver(mynam) - tbuf;
5557 /* If we didn't already trim version, copy down */
5558 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5559 if (speclen > rms_nam_verl(mynam) - tbuf)
5561 (rms_nam_typel(mynam),
5562 rms_nam_verl(mynam),
5563 speclen - (rms_nam_verl(mynam) - tbuf));
5564 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5567 if (speclen > rms_nam_ver(mynam) - tbuf)
5569 (rms_nam_type(mynam),
5571 speclen - (rms_nam_ver(mynam) - tbuf));
5572 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5577 /* Done with these copies of the input files */
5578 /*-------------------------------------------*/
5579 if (vmsfspec != NULL)
5580 PerlMem_free(vmsfspec);
5581 if (tmpfspec != NULL)
5582 PerlMem_free(tmpfspec);
5584 /* If we just had a directory spec on input, $PARSE "helpfully"
5585 * adds an empty name and type for us */
5586 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5587 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5588 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5589 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5590 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5591 speclen = rms_nam_namel(mynam) - tbuf;
5596 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5597 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5598 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5599 speclen = rms_nam_name(mynam) - tbuf;
5602 /* Posix format specifications must have matching quotes */
5603 if (speclen < (VMS_MAXRSS - 1)) {
5604 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5605 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5606 tbuf[speclen] = '\"';
5611 tbuf[speclen] = '\0';
5612 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5614 /* Have we been working with an expanded, but not resultant, spec? */
5615 /* Also, convert back to Unix syntax if necessary. */
5619 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5620 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5621 rsl = rms_nam_rsll(mynam);
5625 rsl = rms_nam_rsl(mynam);
5629 if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5630 if (out) Safefree(out);
5634 if (outbufl != NULL)
5635 PerlMem_free(outbufl);
5639 else strcpy(outbuf, tbuf);
5642 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5643 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5644 if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5645 if (out) Safefree(out);
5649 PerlMem_free(tmpfspec);
5650 if (outbufl != NULL)
5651 PerlMem_free(outbufl);
5654 strcpy(outbuf,tmpfspec);
5655 PerlMem_free(tmpfspec);
5658 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5659 sts = rms_free_search_context(&myfab); /* Free search context */
5663 if (outbufl != NULL)
5664 PerlMem_free(outbufl);
5668 /* External entry points */
5669 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5670 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5671 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5672 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5673 char *Perl_rmsexpand_utf8
5674 (pTHX_ const char *spec, char *buf, const char *def,
5675 unsigned opt, int * fs_utf8, int * dfs_utf8)
5676 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5677 char *Perl_rmsexpand_utf8_ts
5678 (pTHX_ const char *spec, char *buf, const char *def,
5679 unsigned opt, int * fs_utf8, int * dfs_utf8)
5680 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5684 ** The following routines are provided to make life easier when
5685 ** converting among VMS-style and Unix-style directory specifications.
5686 ** All will take input specifications in either VMS or Unix syntax. On
5687 ** failure, all return NULL. If successful, the routines listed below
5688 ** return a pointer to a buffer containing the appropriately
5689 ** reformatted spec (and, therefore, subsequent calls to that routine
5690 ** will clobber the result), while the routines of the same names with
5691 ** a _ts suffix appended will return a pointer to a mallocd string
5692 ** containing the appropriately reformatted spec.
5693 ** In all cases, only explicit syntax is altered; no check is made that
5694 ** the resulting string is valid or that the directory in question
5697 ** fileify_dirspec() - convert a directory spec into the name of the
5698 ** directory file (i.e. what you can stat() to see if it's a dir).
5699 ** The style (VMS or Unix) of the result is the same as the style
5700 ** of the parameter passed in.
5701 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5702 ** what you prepend to a filename to indicate what directory it's in).
5703 ** The style (VMS or Unix) of the result is the same as the style
5704 ** of the parameter passed in.
5705 ** tounixpath() - convert a directory spec into a Unix-style path.
5706 ** tovmspath() - convert a directory spec into a VMS-style path.
5707 ** tounixspec() - convert any file spec into a Unix-style file spec.
5708 ** tovmsspec() - convert any file spec into a VMS-style spec.
5709 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5711 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5712 ** Permission is given to distribute this code as part of the Perl
5713 ** standard distribution under the terms of the GNU General Public
5714 ** License or the Perl Artistic License. Copies of each may be
5715 ** found in the Perl standard distribution.
5718 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5719 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5721 static char __fileify_retbuf[VMS_MAXRSS];
5722 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5723 char *retspec, *cp1, *cp2, *lastdir;
5724 char *trndir, *vmsdir;
5725 unsigned short int trnlnm_iter_count;
5727 if (utf8_fl != NULL)
5730 if (!dir || !*dir) {
5731 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5733 dirlen = strlen(dir);
5734 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5735 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5736 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5743 if (dirlen > (VMS_MAXRSS - 1)) {
5744 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5747 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5748 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5749 if (!strpbrk(dir+1,"/]>:") &&
5750 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5751 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5752 trnlnm_iter_count = 0;
5753 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5754 trnlnm_iter_count++;
5755 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5757 dirlen = strlen(trndir);
5760 strncpy(trndir,dir,dirlen);
5761 trndir[dirlen] = '\0';
5764 /* At this point we are done with *dir and use *trndir which is a
5765 * copy that can be modified. *dir must not be modified.
5768 /* If we were handed a rooted logical name or spec, treat it like a
5769 * simple directory, so that
5770 * $ Define myroot dev:[dir.]
5771 * ... do_fileify_dirspec("myroot",buf,1) ...
5772 * does something useful.
5774 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5775 trndir[--dirlen] = '\0';
5776 trndir[dirlen-1] = ']';
5778 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5779 trndir[--dirlen] = '\0';
5780 trndir[dirlen-1] = '>';
5783 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5784 /* If we've got an explicit filename, we can just shuffle the string. */
5785 if (*(cp1+1)) hasfilename = 1;
5786 /* Similarly, we can just back up a level if we've got multiple levels
5787 of explicit directories in a VMS spec which ends with directories. */
5789 for (cp2 = cp1; cp2 > trndir; cp2--) {
5791 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5792 /* fix-me, can not scan EFS file specs backward like this */
5793 *cp2 = *cp1; *cp1 = '\0';
5798 if (*cp2 == '[' || *cp2 == '<') break;
5803 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5804 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5805 cp1 = strpbrk(trndir,"]:>");
5806 if (hasfilename || !cp1) { /* Unix-style path or filename */
5807 if (trndir[0] == '.') {
5808 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5809 PerlMem_free(trndir);
5810 PerlMem_free(vmsdir);
5811 return do_fileify_dirspec("[]",buf,ts,NULL);
5813 else if (trndir[1] == '.' &&
5814 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5815 PerlMem_free(trndir);
5816 PerlMem_free(vmsdir);
5817 return do_fileify_dirspec("[-]",buf,ts,NULL);
5820 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5821 dirlen -= 1; /* to last element */
5822 lastdir = strrchr(trndir,'/');
5824 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5825 /* If we have "/." or "/..", VMSify it and let the VMS code
5826 * below expand it, rather than repeating the code to handle
5827 * relative components of a filespec here */
5829 if (*(cp1+2) == '.') cp1++;
5830 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5832 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5833 PerlMem_free(trndir);
5834 PerlMem_free(vmsdir);
5837 if (strchr(vmsdir,'/') != NULL) {
5838 /* If do_tovmsspec() returned it, it must have VMS syntax
5839 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5840 * the time to check this here only so we avoid a recursion
5841 * loop; otherwise, gigo.
5843 PerlMem_free(trndir);
5844 PerlMem_free(vmsdir);
5845 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5848 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5849 PerlMem_free(trndir);
5850 PerlMem_free(vmsdir);
5853 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5854 PerlMem_free(trndir);
5855 PerlMem_free(vmsdir);
5859 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5860 lastdir = strrchr(trndir,'/');
5862 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5864 /* Ditto for specs that end in an MFD -- let the VMS code
5865 * figure out whether it's a real device or a rooted logical. */
5867 /* This should not happen any more. Allowing the fake /000000
5868 * in a UNIX pathname causes all sorts of problems when trying
5869 * to run in UNIX emulation. So the VMS to UNIX conversions
5870 * now remove the fake /000000 directories.
5873 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5874 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5875 PerlMem_free(trndir);
5876 PerlMem_free(vmsdir);
5879 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5880 PerlMem_free(trndir);
5881 PerlMem_free(vmsdir);
5884 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5885 PerlMem_free(trndir);
5886 PerlMem_free(vmsdir);
5891 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5892 !(lastdir = cp1 = strrchr(trndir,']')) &&
5893 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5894 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5897 /* For EFS or ODS-5 look for the last dot */
5898 if (decc_efs_charset) {
5899 cp2 = strrchr(cp1,'.');
5901 if (vms_process_case_tolerant) {
5902 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5903 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5904 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5905 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5906 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5907 (ver || *cp3)))))) {
5908 PerlMem_free(trndir);
5909 PerlMem_free(vmsdir);
5911 set_vaxc_errno(RMS$_DIR);
5916 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5917 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5918 !*(cp2+3) || *(cp2+3) != 'R' ||
5919 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5920 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5921 (ver || *cp3)))))) {
5922 PerlMem_free(trndir);
5923 PerlMem_free(vmsdir);
5925 set_vaxc_errno(RMS$_DIR);
5929 dirlen = cp2 - trndir;
5933 retlen = dirlen + 6;
5934 if (buf) retspec = buf;
5935 else if (ts) Newx(retspec,retlen+1,char);
5936 else retspec = __fileify_retbuf;
5937 memcpy(retspec,trndir,dirlen);
5938 retspec[dirlen] = '\0';
5940 /* We've picked up everything up to the directory file name.
5941 Now just add the type and version, and we're set. */
5942 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5943 strcat(retspec,".dir;1");
5945 strcat(retspec,".DIR;1");
5946 PerlMem_free(trndir);
5947 PerlMem_free(vmsdir);
5950 else { /* VMS-style directory spec */
5952 char *esa, *esal, term, *cp;
5955 unsigned long int sts, cmplen, haslower = 0;
5956 unsigned int nam_fnb;
5958 struct FAB dirfab = cc$rms_fab;
5959 rms_setup_nam(savnam);
5960 rms_setup_nam(dirnam);
5962 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5963 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5965 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5966 esal = PerlMem_malloc(VMS_MAXRSS);
5967 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5969 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5970 rms_bind_fab_nam(dirfab, dirnam);
5971 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5972 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5973 #ifdef NAM$M_NO_SHORT_UPCASE
5974 if (decc_efs_case_preserve)
5975 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5978 for (cp = trndir; *cp; cp++)
5979 if (islower(*cp)) { haslower = 1; break; }
5980 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5981 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5982 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5983 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
5989 PerlMem_free(trndir);
5990 PerlMem_free(vmsdir);
5992 set_vaxc_errno(dirfab.fab$l_sts);
5998 /* Does the file really exist? */
5999 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6000 /* Yes; fake the fnb bits so we'll check type below */
6001 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6003 else { /* No; just work with potential name */
6004 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6007 fab_sts = dirfab.fab$l_sts;
6008 sts = rms_free_search_context(&dirfab);
6012 PerlMem_free(trndir);
6013 PerlMem_free(vmsdir);
6014 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6020 /* Make sure we are using the right buffer */
6023 my_esa_len = rms_nam_esll(dirnam);
6026 my_esa_len = rms_nam_esl(dirnam);
6028 my_esa[my_esa_len] = '\0';
6029 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6030 cp1 = strchr(my_esa,']');
6031 if (!cp1) cp1 = strchr(my_esa,'>');
6032 if (cp1) { /* Should always be true */
6033 my_esa_len -= cp1 - my_esa - 1;
6034 memmove(my_esa, cp1 + 1, my_esa_len);
6037 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6038 /* Yep; check version while we're at it, if it's there. */
6039 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6040 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6041 /* Something other than .DIR[;1]. Bzzt. */
6042 sts = rms_free_search_context(&dirfab);
6046 PerlMem_free(trndir);
6047 PerlMem_free(vmsdir);
6049 set_vaxc_errno(RMS$_DIR);
6054 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6055 /* They provided at least the name; we added the type, if necessary, */
6056 if (buf) retspec = buf; /* in sys$parse() */
6057 else if (ts) Newx(retspec, my_esa_len + 1, char);
6058 else retspec = __fileify_retbuf;
6059 strcpy(retspec,my_esa);
6060 sts = rms_free_search_context(&dirfab);
6061 PerlMem_free(trndir);
6065 PerlMem_free(vmsdir);
6068 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6069 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6073 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6074 if (cp1 == NULL) { /* should never happen */
6075 sts = rms_free_search_context(&dirfab);
6076 PerlMem_free(trndir);
6080 PerlMem_free(vmsdir);
6085 retlen = strlen(my_esa);
6086 cp1 = strrchr(my_esa,'.');
6087 /* ODS-5 directory specifications can have extra "." in them. */
6088 /* Fix-me, can not scan EFS file specifications backwards */
6089 while (cp1 != NULL) {
6090 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6094 while ((cp1 > my_esa) && (*cp1 != '.'))
6101 if ((cp1) != NULL) {
6102 /* There's more than one directory in the path. Just roll back. */
6104 if (buf) retspec = buf;
6105 else if (ts) Newx(retspec,retlen+7,char);
6106 else retspec = __fileify_retbuf;
6107 strcpy(retspec,my_esa);
6110 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6111 /* Go back and expand rooted logical name */
6112 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6113 #ifdef NAM$M_NO_SHORT_UPCASE
6114 if (decc_efs_case_preserve)
6115 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6117 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6118 sts = rms_free_search_context(&dirfab);
6122 PerlMem_free(trndir);
6123 PerlMem_free(vmsdir);
6125 set_vaxc_errno(dirfab.fab$l_sts);
6129 /* This changes the length of the string of course */
6131 my_esa_len = rms_nam_esll(dirnam);
6133 my_esa_len = rms_nam_esl(dirnam);
6136 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6137 if (buf) retspec = buf;
6138 else if (ts) Newx(retspec,retlen+16,char);
6139 else retspec = __fileify_retbuf;
6140 cp1 = strstr(my_esa,"][");
6141 if (!cp1) cp1 = strstr(my_esa,"]<");
6142 dirlen = cp1 - my_esa;
6143 memcpy(retspec,my_esa,dirlen);
6144 if (!strncmp(cp1+2,"000000]",7)) {
6145 retspec[dirlen-1] = '\0';
6146 /* fix-me Not full ODS-5, just extra dots in directories for now */
6147 cp1 = retspec + dirlen - 1;
6148 while (cp1 > retspec)
6153 if (*(cp1-1) != '^')
6158 if (*cp1 == '.') *cp1 = ']';
6160 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6161 memmove(cp1+1,"000000]",7);
6165 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6166 retspec[retlen] = '\0';
6167 /* Convert last '.' to ']' */
6168 cp1 = retspec+retlen-1;
6169 while (*cp != '[') {
6172 /* Do not trip on extra dots in ODS-5 directories */
6173 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6177 if (*cp1 == '.') *cp1 = ']';
6179 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6180 memmove(cp1+1,"000000]",7);
6184 else { /* This is a top-level dir. Add the MFD to the path. */
6185 if (buf) retspec = buf;
6186 else if (ts) Newx(retspec,retlen+16,char);
6187 else retspec = __fileify_retbuf;
6190 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6191 strcpy(cp2,":[000000]");
6196 sts = rms_free_search_context(&dirfab);
6197 /* We've set up the string up through the filename. Add the
6198 type and version, and we're done. */
6199 strcat(retspec,".DIR;1");
6201 /* $PARSE may have upcased filespec, so convert output to lower
6202 * case if input contained any lowercase characters. */
6203 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6204 PerlMem_free(trndir);
6208 PerlMem_free(vmsdir);
6211 } /* end of do_fileify_dirspec() */
6213 /* External entry points */
6214 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6215 { return do_fileify_dirspec(dir,buf,0,NULL); }
6216 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6217 { return do_fileify_dirspec(dir,buf,1,NULL); }
6218 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6219 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6220 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6221 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6223 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6224 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6226 static char __pathify_retbuf[VMS_MAXRSS];
6227 unsigned long int retlen;
6228 char *retpath, *cp1, *cp2, *trndir;
6229 unsigned short int trnlnm_iter_count;
6232 if (utf8_fl != NULL)
6235 if (!dir || !*dir) {
6236 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6239 trndir = PerlMem_malloc(VMS_MAXRSS);
6240 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6241 if (*dir) strcpy(trndir,dir);
6242 else getcwd(trndir,VMS_MAXRSS - 1);
6244 trnlnm_iter_count = 0;
6245 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6246 && my_trnlnm(trndir,trndir,0)) {
6247 trnlnm_iter_count++;
6248 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6249 trnlen = strlen(trndir);
6251 /* Trap simple rooted lnms, and return lnm:[000000] */
6252 if (!strcmp(trndir+trnlen-2,".]")) {
6253 if (buf) retpath = buf;
6254 else if (ts) Newx(retpath,strlen(dir)+10,char);
6255 else retpath = __pathify_retbuf;
6256 strcpy(retpath,dir);
6257 strcat(retpath,":[000000]");
6258 PerlMem_free(trndir);
6263 /* At this point we do not work with *dir, but the copy in
6264 * *trndir that is modifiable.
6267 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6268 if (*trndir == '.' && (*(trndir+1) == '\0' ||
6269 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6270 retlen = 2 + (*(trndir+1) != '\0');
6272 if ( !(cp1 = strrchr(trndir,'/')) &&
6273 !(cp1 = strrchr(trndir,']')) &&
6274 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6275 if ((cp2 = strchr(cp1,'.')) != NULL &&
6276 (*(cp2-1) != '/' || /* Trailing '.', '..', */
6277 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
6278 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6279 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6282 /* For EFS or ODS-5 look for the last dot */
6283 if (decc_efs_charset) {
6284 cp2 = strrchr(cp1,'.');
6286 if (vms_process_case_tolerant) {
6287 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6288 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6289 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6290 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6291 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6292 (ver || *cp3)))))) {
6293 PerlMem_free(trndir);
6295 set_vaxc_errno(RMS$_DIR);
6300 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6301 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6302 !*(cp2+3) || *(cp2+3) != 'R' ||
6303 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6304 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6305 (ver || *cp3)))))) {
6306 PerlMem_free(trndir);
6308 set_vaxc_errno(RMS$_DIR);
6312 retlen = cp2 - trndir + 1;
6314 else { /* No file type present. Treat the filename as a directory. */
6315 retlen = strlen(trndir) + 1;
6318 if (buf) retpath = buf;
6319 else if (ts) Newx(retpath,retlen+1,char);
6320 else retpath = __pathify_retbuf;
6321 strncpy(retpath, trndir, retlen-1);
6322 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6323 retpath[retlen-1] = '/'; /* with '/', add it. */
6324 retpath[retlen] = '\0';
6326 else retpath[retlen-1] = '\0';
6328 else { /* VMS-style directory spec */
6329 char *esa, *esal, *cp;
6332 unsigned long int sts, cmplen, haslower;
6333 struct FAB dirfab = cc$rms_fab;
6335 rms_setup_nam(savnam);
6336 rms_setup_nam(dirnam);
6338 /* If we've got an explicit filename, we can just shuffle the string. */
6339 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6340 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
6341 if ((cp2 = strchr(cp1,'.')) != NULL) {
6343 if (vms_process_case_tolerant) {
6344 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6345 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6346 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6347 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6348 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6349 (ver || *cp3)))))) {
6350 PerlMem_free(trndir);
6352 set_vaxc_errno(RMS$_DIR);
6357 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6358 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6359 !*(cp2+3) || *(cp2+3) != 'R' ||
6360 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6361 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6362 (ver || *cp3)))))) {
6363 PerlMem_free(trndir);
6365 set_vaxc_errno(RMS$_DIR);
6370 else { /* No file type, so just draw name into directory part */
6371 for (cp2 = cp1; *cp2; cp2++) ;
6374 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
6376 /* We've now got a VMS 'path'; fall through */
6379 dirlen = strlen(trndir);
6380 if (trndir[dirlen-1] == ']' ||
6381 trndir[dirlen-1] == '>' ||
6382 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6383 if (buf) retpath = buf;
6384 else if (ts) Newx(retpath,strlen(trndir)+1,char);
6385 else retpath = __pathify_retbuf;
6386 strcpy(retpath,trndir);
6387 PerlMem_free(trndir);
6390 rms_set_fna(dirfab, dirnam, trndir, dirlen);
6391 esa = PerlMem_malloc(VMS_MAXRSS);
6392 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6394 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6395 esal = PerlMem_malloc(VMS_MAXRSS);
6396 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6398 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6399 rms_bind_fab_nam(dirfab, dirnam);
6400 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6401 #ifdef NAM$M_NO_SHORT_UPCASE
6402 if (decc_efs_case_preserve)
6403 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6406 for (cp = trndir; *cp; cp++)
6407 if (islower(*cp)) { haslower = 1; break; }
6409 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6410 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6411 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6412 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6415 PerlMem_free(trndir);
6420 set_vaxc_errno(dirfab.fab$l_sts);
6426 /* Does the file really exist? */
6427 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6428 if (dirfab.fab$l_sts != RMS$_FNF) {
6430 sts1 = rms_free_search_context(&dirfab);
6431 PerlMem_free(trndir);
6436 set_vaxc_errno(dirfab.fab$l_sts);
6439 dirnam = savnam; /* No; just work with potential name */
6442 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6443 /* Yep; check version while we're at it, if it's there. */
6444 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6445 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6447 /* Something other than .DIR[;1]. Bzzt. */
6448 sts2 = rms_free_search_context(&dirfab);
6449 PerlMem_free(trndir);
6454 set_vaxc_errno(RMS$_DIR);
6458 /* Make sure we are using the right buffer */
6460 /* We only need one, clean up the other */
6462 my_esa_len = rms_nam_esll(dirnam);
6465 my_esa_len = rms_nam_esl(dirnam);
6468 /* Null terminate the buffer */
6469 my_esa[my_esa_len] = '\0';
6471 /* OK, the type was fine. Now pull any file name into the
6473 if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6475 cp1 = strrchr(my_esa,'>');
6476 *(rms_nam_typel(dirnam)) = '>';
6479 *(rms_nam_typel(dirnam) + 1) = '\0';
6480 retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6481 if (buf) retpath = buf;
6482 else if (ts) Newx(retpath,retlen,char);
6483 else retpath = __pathify_retbuf;
6484 strcpy(retpath,my_esa);
6488 sts = rms_free_search_context(&dirfab);
6489 /* $PARSE may have upcased filespec, so convert output to lower
6490 * case if input contained any lowercase characters. */
6491 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6494 PerlMem_free(trndir);
6496 } /* end of do_pathify_dirspec() */
6498 /* External entry points */
6499 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6500 { return do_pathify_dirspec(dir,buf,0,NULL); }
6501 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6502 { return do_pathify_dirspec(dir,buf,1,NULL); }
6503 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6504 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6505 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6506 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6508 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6509 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6511 static char __tounixspec_retbuf[VMS_MAXRSS];
6512 char *dirend, *rslt, *cp1, *cp3, *tmp;
6514 int devlen, dirlen, retlen = VMS_MAXRSS;
6515 int expand = 1; /* guarantee room for leading and trailing slashes */
6516 unsigned short int trnlnm_iter_count;
6518 if (utf8_fl != NULL)
6521 if (spec == NULL) return NULL;
6522 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6523 if (buf) rslt = buf;
6525 Newx(rslt, VMS_MAXRSS, char);
6527 else rslt = __tounixspec_retbuf;
6529 /* New VMS specific format needs translation
6530 * glob passes filenames with trailing '\n' and expects this preserved.
6532 if (decc_posix_compliant_pathnames) {
6533 if (strncmp(spec, "\"^UP^", 5) == 0) {
6539 tunix = PerlMem_malloc(VMS_MAXRSS);
6540 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6541 strcpy(tunix, spec);
6542 tunix_len = strlen(tunix);
6544 if (tunix[tunix_len - 1] == '\n') {
6545 tunix[tunix_len - 1] = '\"';
6546 tunix[tunix_len] = '\0';
6550 uspec = decc$translate_vms(tunix);
6551 PerlMem_free(tunix);
6552 if ((int)uspec > 0) {
6558 /* If we can not translate it, makemaker wants as-is */
6566 cmp_rslt = 0; /* Presume VMS */
6567 cp1 = strchr(spec, '/');
6571 /* Look for EFS ^/ */
6572 if (decc_efs_charset) {
6573 while (cp1 != NULL) {
6576 /* Found illegal VMS, assume UNIX */
6581 cp1 = strchr(cp1, '/');
6585 /* Look for "." and ".." */
6586 if (decc_filename_unix_report) {
6587 if (spec[0] == '.') {
6588 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6592 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6598 /* This is already UNIX or at least nothing VMS understands */
6606 dirend = strrchr(spec,']');
6607 if (dirend == NULL) dirend = strrchr(spec,'>');
6608 if (dirend == NULL) dirend = strchr(spec,':');
6609 if (dirend == NULL) {
6614 /* Special case 1 - sys$posix_root = / */
6615 #if __CRTL_VER >= 70000000
6616 if (!decc_disable_posix_root) {
6617 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6625 /* Special case 2 - Convert NLA0: to /dev/null */
6626 #if __CRTL_VER < 70000000
6627 cmp_rslt = strncmp(spec,"NLA0:", 5);
6629 cmp_rslt = strncmp(spec,"nla0:", 5);
6631 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6633 if (cmp_rslt == 0) {
6634 strcpy(rslt, "/dev/null");
6637 if (spec[6] != '\0') {
6644 /* Also handle special case "SYS$SCRATCH:" */
6645 #if __CRTL_VER < 70000000
6646 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6648 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6650 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6652 tmp = PerlMem_malloc(VMS_MAXRSS);
6653 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6654 if (cmp_rslt == 0) {
6657 islnm = my_trnlnm(tmp, "TMP", 0);
6659 strcpy(rslt, "/tmp");
6662 if (spec[12] != '\0') {
6670 if (*cp2 != '[' && *cp2 != '<') {
6673 else { /* the VMS spec begins with directories */
6675 if (*cp2 == ']' || *cp2 == '>') {
6676 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6680 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6681 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6682 if (ts) Safefree(rslt);
6686 trnlnm_iter_count = 0;
6689 while (*cp3 != ':' && *cp3) cp3++;
6691 if (strchr(cp3,']') != NULL) break;
6692 trnlnm_iter_count++;
6693 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6694 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6696 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6697 retlen = devlen + dirlen;
6698 Renew(rslt,retlen+1+2*expand,char);
6704 *(cp1++) = *(cp3++);
6705 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6707 return NULL; /* No room */
6712 if ((*cp2 == '^')) {
6713 /* EFS file escape, pass the next character as is */
6714 /* Fix me: HEX encoding for Unicode not implemented */
6717 else if ( *cp2 == '.') {
6718 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6719 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6726 for (; cp2 <= dirend; cp2++) {
6727 if ((*cp2 == '^')) {
6728 /* EFS file escape, pass the next character as is */
6729 /* Fix me: HEX encoding for Unicode not implemented */
6730 *(cp1++) = *(++cp2);
6731 /* An escaped dot stays as is -- don't convert to slash */
6732 if (*cp2 == '.') cp2++;
6736 if (*(cp2+1) == '[') cp2++;
6738 else if (*cp2 == ']' || *cp2 == '>') {
6739 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6741 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6743 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6744 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6745 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6746 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6747 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6749 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6750 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6754 else if (*cp2 == '-') {
6755 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6756 while (*cp2 == '-') {
6758 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6760 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6761 if (ts) Safefree(rslt); /* filespecs like */
6762 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6766 else *(cp1++) = *cp2;
6768 else *(cp1++) = *cp2;
6771 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6772 *(cp1++) = *(cp2++);
6776 /* This still leaves /000000/ when working with a
6777 * VMS device root or concealed root.
6783 ulen = strlen(rslt);
6785 /* Get rid of "000000/ in rooted filespecs */
6787 zeros = strstr(rslt, "/000000/");
6788 if (zeros != NULL) {
6790 mlen = ulen - (zeros - rslt) - 7;
6791 memmove(zeros, &zeros[7], mlen);
6800 } /* end of do_tounixspec() */
6802 /* External entry points */
6803 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6804 { return do_tounixspec(spec,buf,0, NULL); }
6805 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6806 { return do_tounixspec(spec,buf,1, NULL); }
6807 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6808 { return do_tounixspec(spec,buf,0, utf8_fl); }
6809 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6810 { return do_tounixspec(spec,buf,1, utf8_fl); }
6812 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6815 This procedure is used to identify if a path is based in either
6816 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6817 it returns the OpenVMS format directory for it.
6819 It is expecting specifications of only '/' or '/xxxx/'
6821 If a posix root does not exist, or 'xxxx' is not a directory
6822 in the posix root, it returns a failure.
6824 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6826 It is used only internally by posix_to_vmsspec_hardway().
6829 static int posix_root_to_vms
6830 (char *vmspath, int vmspath_len,
6831 const char *unixpath,
6832 const int * utf8_fl)
6835 struct FAB myfab = cc$rms_fab;
6836 rms_setup_nam(mynam);
6837 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6838 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6839 char * esa, * esal, * rsa, * rsal;
6846 unixlen = strlen(unixpath);
6851 #if __CRTL_VER >= 80200000
6852 /* If not a posix spec already, convert it */
6853 if (decc_posix_compliant_pathnames) {
6854 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6855 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6858 /* This is already a VMS specification, no conversion */
6860 strncpy(vmspath,unixpath, vmspath_len);
6869 /* Check to see if this is under the POSIX root */
6870 if (decc_disable_posix_root) {
6874 /* Skip leading / */
6875 if (unixpath[0] == '/') {
6881 strcpy(vmspath,"SYS$POSIX_ROOT:");
6883 /* If this is only the / , or blank, then... */
6884 if (unixpath[0] == '\0') {
6885 /* by definition, this is the answer */
6889 /* Need to look up a directory */
6893 /* Copy and add '^' escape characters as needed */
6896 while (unixpath[i] != 0) {
6899 j += copy_expand_unix_filename_escape
6900 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6904 path_len = strlen(vmspath);
6905 if (vmspath[path_len - 1] == '/')
6907 vmspath[path_len] = ']';
6909 vmspath[path_len] = '\0';
6912 vmspath[vmspath_len] = 0;
6913 if (unixpath[unixlen - 1] == '/')
6915 esal = PerlMem_malloc(VMS_MAXRSS);
6916 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6917 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6918 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6919 rsal = PerlMem_malloc(VMS_MAXRSS);
6920 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6921 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6922 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6923 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6924 rms_bind_fab_nam(myfab, mynam);
6925 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6926 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6927 if (decc_efs_case_preserve)
6928 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6929 #ifdef NAML$M_OPEN_SPECIAL
6930 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6933 /* Set up the remaining naml fields */
6934 sts = sys$parse(&myfab);
6936 /* It failed! Try again as a UNIX filespec */
6945 /* get the Device ID and the FID */
6946 sts = sys$search(&myfab);
6948 /* These are no longer needed */
6953 /* on any failure, returned the POSIX ^UP^ filespec */
6958 specdsc.dsc$a_pointer = vmspath;
6959 specdsc.dsc$w_length = vmspath_len;
6961 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6962 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6963 sts = lib$fid_to_name
6964 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6966 /* on any failure, returned the POSIX ^UP^ filespec */
6968 /* This can happen if user does not have permission to read directories */
6969 if (strncmp(unixpath,"\"^UP^",5) != 0)
6970 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6972 strcpy(vmspath, unixpath);
6975 vmspath[specdsc.dsc$w_length] = 0;
6977 /* Are we expecting a directory? */
6978 if (dir_flag != 0) {
6984 i = specdsc.dsc$w_length - 1;
6988 /* Version must be '1' */
6989 if (vmspath[i--] != '1')
6991 /* Version delimiter is one of ".;" */
6992 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
6995 if (vmspath[i--] != 'R')
6997 if (vmspath[i--] != 'I')
6999 if (vmspath[i--] != 'D')
7001 if (vmspath[i--] != '.')
7003 eptr = &vmspath[i+1];
7005 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7006 if (vmspath[i-1] != '^') {
7014 /* Get rid of 6 imaginary zero directory filename */
7015 vmspath[i+1] = '\0';
7019 if (vmspath[i] == '0')
7033 /* /dev/mumble needs to be handled special.
7034 /dev/null becomes NLA0:, And there is the potential for other stuff
7035 like /dev/tty which may need to be mapped to something.
7039 slash_dev_special_to_vms
7040 (const char * unixptr,
7050 nextslash = strchr(unixptr, '/');
7051 len = strlen(unixptr);
7052 if (nextslash != NULL)
7053 len = nextslash - unixptr;
7054 cmp = strncmp("null", unixptr, 5);
7056 if (vmspath_len >= 6) {
7057 strcpy(vmspath, "_NLA0:");
7064 /* The built in routines do not understand perl's special needs, so
7065 doing a manual conversion from UNIX to VMS
7067 If the utf8_fl is not null and points to a non-zero value, then
7068 treat 8 bit characters as UTF-8.
7070 The sequence starting with '$(' and ending with ')' will be passed
7071 through with out interpretation instead of being escaped.
7074 static int posix_to_vmsspec_hardway
7075 (char *vmspath, int vmspath_len,
7076 const char *unixpath,
7081 const char *unixptr;
7082 const char *unixend;
7084 const char *lastslash;
7085 const char *lastdot;
7091 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7092 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7094 if (utf8_fl != NULL)
7100 /* Ignore leading "/" characters */
7101 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7104 unixlen = strlen(unixptr);
7106 /* Do nothing with blank paths */
7113 /* This could have a "^UP^ on the front */
7114 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7120 lastslash = strrchr(unixptr,'/');
7121 lastdot = strrchr(unixptr,'.');
7122 unixend = strrchr(unixptr,'\"');
7123 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7124 unixend = unixptr + unixlen;
7127 /* last dot is last dot or past end of string */
7128 if (lastdot == NULL)
7129 lastdot = unixptr + unixlen;
7131 /* if no directories, set last slash to beginning of string */
7132 if (lastslash == NULL) {
7133 lastslash = unixptr;
7136 /* Watch out for trailing "." after last slash, still a directory */
7137 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7138 lastslash = unixptr + unixlen;
7141 /* Watch out for traiing ".." after last slash, still a directory */
7142 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7143 lastslash = unixptr + unixlen;
7146 /* dots in directories are aways escaped */
7147 if (lastdot < lastslash)
7148 lastdot = unixptr + unixlen;
7151 /* if (unixptr < lastslash) then we are in a directory */
7158 /* Start with the UNIX path */
7159 if (*unixptr != '/') {
7160 /* relative paths */
7162 /* If allowing logical names on relative pathnames, then handle here */
7163 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7164 !decc_posix_compliant_pathnames) {
7170 /* Find the next slash */
7171 nextslash = strchr(unixptr,'/');
7173 esa = PerlMem_malloc(vmspath_len);
7174 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7176 trn = PerlMem_malloc(VMS_MAXRSS);
7177 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7179 if (nextslash != NULL) {
7181 seg_len = nextslash - unixptr;
7182 strncpy(esa, unixptr, seg_len);
7186 strcpy(esa, unixptr);
7187 seg_len = strlen(unixptr);
7189 /* trnlnm(section) */
7190 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7193 /* Now fix up the directory */
7195 /* Split up the path to find the components */
7196 sts = vms_split_path
7215 /* A logical name must be a directory or the full
7216 specification. It is only a full specification if
7217 it is the only component */
7218 if ((unixptr[seg_len] == '\0') ||
7219 (unixptr[seg_len+1] == '\0')) {
7221 /* Is a directory being required? */
7222 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7223 /* Not a logical name */
7228 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7229 /* This must be a directory */
7230 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7231 strcpy(vmsptr, esa);
7232 vmslen=strlen(vmsptr);
7233 vmsptr[vmslen] = ':';
7235 vmsptr[vmslen] = '\0';
7243 /* must be dev/directory - ignore version */
7244 if ((n_len + e_len) != 0)
7247 /* transfer the volume */
7248 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7249 strncpy(vmsptr, v_spec, v_len);
7255 /* unroot the rooted directory */
7256 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7258 r_spec[r_len - 1] = ']';
7260 /* This should not be there, but nothing is perfect */
7262 cmp = strcmp(&r_spec[1], "000000.");
7272 strncpy(vmsptr, r_spec, r_len);
7278 /* Bring over the directory. */
7280 ((d_len + vmslen) < vmspath_len)) {
7282 d_spec[d_len - 1] = ']';
7284 cmp = strcmp(&d_spec[1], "000000.");
7295 /* Remove the redundant root */
7303 strncpy(vmsptr, d_spec, d_len);
7317 if (lastslash > unixptr) {
7320 /* skip leading ./ */
7322 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7328 /* Are we still in a directory? */
7329 if (unixptr <= lastslash) {
7334 /* if not backing up, then it is relative forward. */
7335 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7336 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7344 /* Perl wants an empty directory here to tell the difference
7345 * between a DCL commmand and a filename
7354 /* Handle two special files . and .. */
7355 if (unixptr[0] == '.') {
7356 if (&unixptr[1] == unixend) {
7363 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7374 else { /* Absolute PATH handling */
7378 /* Need to find out where root is */
7380 /* In theory, this procedure should never get an absolute POSIX pathname
7381 * that can not be found on the POSIX root.
7382 * In practice, that can not be relied on, and things will show up
7383 * here that are a VMS device name or concealed logical name instead.
7384 * So to make things work, this procedure must be tolerant.
7386 esa = PerlMem_malloc(vmspath_len);
7387 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7390 nextslash = strchr(&unixptr[1],'/');
7392 if (nextslash != NULL) {
7394 seg_len = nextslash - &unixptr[1];
7395 strncpy(vmspath, unixptr, seg_len + 1);
7396 vmspath[seg_len+1] = 0;
7399 cmp = strncmp(vmspath, "dev", 4);
7401 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7402 if (sts = SS$_NORMAL)
7406 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7409 if ($VMS_STATUS_SUCCESS(sts)) {
7410 /* This is verified to be a real path */
7412 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7413 if ($VMS_STATUS_SUCCESS(sts)) {
7414 strcpy(vmspath, esa);
7415 vmslen = strlen(vmspath);
7416 vmsptr = vmspath + vmslen;
7418 if (unixptr < lastslash) {
7427 cmp = strcmp(rptr,"000000.");
7432 } /* removing 6 zeros */
7433 } /* vmslen < 7, no 6 zeros possible */
7434 } /* Not in a directory */
7435 } /* Posix root found */
7437 /* No posix root, fall back to default directory */
7438 strcpy(vmspath, "SYS$DISK:[");
7439 vmsptr = &vmspath[10];
7441 if (unixptr > lastslash) {
7450 } /* end of verified real path handling */
7455 /* Ok, we have a device or a concealed root that is not in POSIX
7456 * or we have garbage. Make the best of it.
7459 /* Posix to VMS destroyed this, so copy it again */
7460 strncpy(vmspath, &unixptr[1], seg_len);
7461 vmspath[seg_len] = 0;
7463 vmsptr = &vmsptr[vmslen];
7466 /* Now do we need to add the fake 6 zero directory to it? */
7468 if ((*lastslash == '/') && (nextslash < lastslash)) {
7469 /* No there is another directory */
7476 /* now we have foo:bar or foo:[000000]bar to decide from */
7477 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7479 if (!islnm && !decc_posix_compliant_pathnames) {
7481 cmp = strncmp("bin", vmspath, 4);
7483 /* bin => SYS$SYSTEM: */
7484 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7487 /* tmp => SYS$SCRATCH: */
7488 cmp = strncmp("tmp", vmspath, 4);
7490 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7495 trnend = islnm ? islnm - 1 : 0;
7497 /* if this was a logical name, ']' or '>' must be present */
7498 /* if not a logical name, then assume a device and hope. */
7499 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7501 /* if log name and trailing '.' then rooted - treat as device */
7502 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7504 /* Fix me, if not a logical name, a device lookup should be
7505 * done to see if the device is file structured. If the device
7506 * is not file structured, the 6 zeros should not be put on.
7508 * As it is, perl is occasionally looking for dev:[000000]tty.
7509 * which looks a little strange.
7511 * Not that easy to detect as "/dev" may be file structured with
7512 * special device files.
7515 if ((add_6zero == 0) && (*nextslash == '/') &&
7516 (&nextslash[1] == unixend)) {
7517 /* No real directory present */
7522 /* Put the device delimiter on */
7525 unixptr = nextslash;
7528 /* Start directory if needed */
7529 if (!islnm || add_6zero) {
7535 /* add fake 000000] if needed */
7548 } /* non-POSIX translation */
7550 } /* End of relative/absolute path handling */
7552 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7559 if (dir_start != 0) {
7561 /* First characters in a directory are handled special */
7562 while ((*unixptr == '/') ||
7563 ((*unixptr == '.') &&
7564 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7565 (&unixptr[1]==unixend)))) {
7570 /* Skip redundant / in specification */
7571 while ((*unixptr == '/') && (dir_start != 0)) {
7574 if (unixptr == lastslash)
7577 if (unixptr == lastslash)
7580 /* Skip redundant ./ characters */
7581 while ((*unixptr == '.') &&
7582 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7585 if (unixptr == lastslash)
7587 if (*unixptr == '/')
7590 if (unixptr == lastslash)
7593 /* Skip redundant ../ characters */
7594 while ((*unixptr == '.') && (unixptr[1] == '.') &&
7595 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7596 /* Set the backing up flag */
7602 unixptr++; /* first . */
7603 unixptr++; /* second . */
7604 if (unixptr == lastslash)
7606 if (*unixptr == '/') /* The slash */
7609 if (unixptr == lastslash)
7612 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7613 /* Not needed when VMS is pretending to be UNIX. */
7615 /* Is this loop stuck because of too many dots? */
7616 if (loop_flag == 0) {
7617 /* Exit the loop and pass the rest through */
7622 /* Are we done with directories yet? */
7623 if (unixptr >= lastslash) {
7625 /* Watch out for trailing dots */
7634 if (*unixptr == '/')
7638 /* Have we stopped backing up? */
7643 /* dir_start continues to be = 1 */
7645 if (*unixptr == '-') {
7647 *vmsptr++ = *unixptr++;
7651 /* Now are we done with directories yet? */
7652 if (unixptr >= lastslash) {
7654 /* Watch out for trailing dots */
7670 if (unixptr >= unixend)
7673 /* Normal characters - More EFS work probably needed */
7679 /* remove multiple / */
7680 while (unixptr[1] == '/') {
7683 if (unixptr == lastslash) {
7684 /* Watch out for trailing dots */
7696 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7697 /* Not needed when VMS is pretending to be UNIX. */
7701 if (unixptr != unixend)
7706 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7707 (&unixptr[1] == unixend)) {
7713 /* trailing dot ==> '^..' on VMS */
7714 if (unixptr == unixend) {
7722 *vmsptr++ = *unixptr++;
7726 if (quoted && (&unixptr[1] == unixend)) {
7730 in_cnt = copy_expand_unix_filename_escape
7731 (vmsptr, unixptr, &out_cnt, utf8_fl);
7741 in_cnt = copy_expand_unix_filename_escape
7742 (vmsptr, unixptr, &out_cnt, utf8_fl);
7749 /* Make sure directory is closed */
7750 if (unixptr == lastslash) {
7752 vmsptr2 = vmsptr - 1;
7754 if (*vmsptr2 != ']') {
7757 /* directories do not end in a dot bracket */
7758 if (*vmsptr2 == '.') {
7762 if (*vmsptr2 != '^') {
7763 vmsptr--; /* back up over the dot */
7771 /* Add a trailing dot if a file with no extension */
7772 vmsptr2 = vmsptr - 1;
7774 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7775 (*vmsptr2 != ')') && (*lastdot != '.')) {
7786 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7787 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7792 /* If a UTF8 flag is being passed, honor it */
7794 if (utf8_fl != NULL) {
7795 utf8_flag = *utf8_fl;
7800 /* If there is a possibility of UTF8, then if any UTF8 characters
7801 are present, then they must be converted to VTF-7
7803 result = strcpy(rslt, path); /* FIX-ME */
7806 result = strcpy(rslt, path);
7812 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7813 static char *mp_do_tovmsspec
7814 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7815 static char __tovmsspec_retbuf[VMS_MAXRSS];
7816 char *rslt, *dirend;
7821 unsigned long int infront = 0, hasdir = 1;
7824 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7825 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7827 if (path == NULL) return NULL;
7828 rslt_len = VMS_MAXRSS-1;
7829 if (buf) rslt = buf;
7830 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7831 else rslt = __tovmsspec_retbuf;
7833 /* '.' and '..' are "[]" and "[-]" for a quick check */
7834 if (path[0] == '.') {
7835 if (path[1] == '\0') {
7837 if (utf8_flag != NULL)
7842 if (path[1] == '.' && path[2] == '\0') {
7844 if (utf8_flag != NULL)
7851 /* Posix specifications are now a native VMS format */
7852 /*--------------------------------------------------*/
7853 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7854 if (decc_posix_compliant_pathnames) {
7855 if (strncmp(path,"\"^UP^",5) == 0) {
7856 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7862 /* This is really the only way to see if this is already in VMS format */
7863 sts = vms_split_path
7878 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7879 replacement, because the above parse just took care of most of
7880 what is needed to do vmspath when the specification is already
7883 And if it is not already, it is easier to do the conversion as
7884 part of this routine than to call this routine and then work on
7888 /* If VMS punctuation was found, it is already VMS format */
7889 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7890 if (utf8_flag != NULL)
7895 /* Now, what to do with trailing "." cases where there is no
7896 extension? If this is a UNIX specification, and EFS characters
7897 are enabled, then the trailing "." should be converted to a "^.".
7898 But if this was already a VMS specification, then it should be
7901 So in the case of ambiguity, leave the specification alone.
7905 /* If there is a possibility of UTF8, then if any UTF8 characters
7906 are present, then they must be converted to VTF-7
7908 if (utf8_flag != NULL)
7914 dirend = strrchr(path,'/');
7916 if (dirend == NULL) {
7917 /* If we get here with no UNIX directory delimiters, then this is
7918 not a complete file specification, either garbage a UNIX glob
7919 specification that can not be converted to a VMS wildcard, or
7920 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7921 so apparently other programs expect this also.
7923 utf8 flag setting needs to be preserved.
7929 /* If POSIX mode active, handle the conversion */
7930 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7931 if (decc_efs_charset) {
7932 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7937 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7938 if (!*(dirend+2)) dirend +=2;
7939 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7940 if (decc_efs_charset == 0) {
7941 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7947 lastdot = strrchr(cp2,'.');
7953 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7955 if (decc_disable_posix_root) {
7956 strcpy(rslt,"sys$disk:[000000]");
7959 strcpy(rslt,"sys$posix_root:[000000]");
7961 if (utf8_flag != NULL)
7965 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7967 trndev = PerlMem_malloc(VMS_MAXRSS);
7968 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7969 islnm = my_trnlnm(rslt,trndev,0);
7971 /* DECC special handling */
7973 if (strcmp(rslt,"bin") == 0) {
7974 strcpy(rslt,"sys$system");
7977 islnm = my_trnlnm(rslt,trndev,0);
7979 else if (strcmp(rslt,"tmp") == 0) {
7980 strcpy(rslt,"sys$scratch");
7983 islnm = my_trnlnm(rslt,trndev,0);
7985 else if (!decc_disable_posix_root) {
7986 strcpy(rslt, "sys$posix_root");
7990 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7991 islnm = my_trnlnm(rslt,trndev,0);
7993 else if (strcmp(rslt,"dev") == 0) {
7994 if (strncmp(cp2,"/null", 5) == 0) {
7995 if ((cp2[5] == 0) || (cp2[5] == '/')) {
7996 strcpy(rslt,"NLA0");
8000 islnm = my_trnlnm(rslt,trndev,0);
8006 trnend = islnm ? strlen(trndev) - 1 : 0;
8007 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8008 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8009 /* If the first element of the path is a logical name, determine
8010 * whether it has to be translated so we can add more directories. */
8011 if (!islnm || rooted) {
8014 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8018 if (cp2 != dirend) {
8019 strcpy(rslt,trndev);
8020 cp1 = rslt + trnend;
8027 if (decc_disable_posix_root) {
8033 PerlMem_free(trndev);
8038 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8039 cp2 += 2; /* skip over "./" - it's redundant */
8040 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8042 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8043 *(cp1++) = '-'; /* "../" --> "-" */
8046 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8047 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8048 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8049 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8052 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8053 /* Escape the extra dots in EFS file specifications */
8056 if (cp2 > dirend) cp2 = dirend;
8058 else *(cp1++) = '.';
8060 for (; cp2 < dirend; cp2++) {
8062 if (*(cp2-1) == '/') continue;
8063 if (*(cp1-1) != '.') *(cp1++) = '.';
8066 else if (!infront && *cp2 == '.') {
8067 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8068 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8069 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8070 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8071 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8072 else { /* back up over previous directory name */
8074 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8075 if (*(cp1-1) == '[') {
8076 memcpy(cp1,"000000.",7);
8081 if (cp2 == dirend) break;
8083 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8084 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8085 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8086 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8088 *(cp1++) = '.'; /* Simulate trailing '/' */
8089 cp2 += 2; /* for loop will incr this to == dirend */
8091 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8094 if (decc_efs_charset == 0)
8095 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8097 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8103 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8105 if (decc_efs_charset == 0)
8112 else *(cp1++) = *cp2;
8116 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8117 if (hasdir) *(cp1++) = ']';
8118 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8119 /* fixme for ODS5 */
8126 if (decc_efs_charset == 0)
8137 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8138 decc_readdir_dropdotnotype) {
8143 /* trailing dot ==> '^..' on VMS */
8150 *(cp1++) = *(cp2++);
8155 /* This could be a macro to be passed through */
8156 *(cp1++) = *(cp2++);
8158 const char * save_cp2;
8162 /* paranoid check */
8168 *(cp1++) = *(cp2++);
8169 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8170 *(cp1++) = *(cp2++);
8171 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8172 *(cp1++) = *(cp2++);
8175 *(cp1++) = *(cp2++);
8179 if (is_macro == 0) {
8180 /* Not really a macro - never mind */
8193 /* Don't escape again if following character is
8194 * already something we escape.
8196 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8197 *(cp1++) = *(cp2++);
8200 /* But otherwise fall through and escape it. */
8218 *(cp1++) = *(cp2++);
8221 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8222 * which is wrong. UNIX notation should be ".dir." unless
8223 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8224 * changing this behavior could break more things at this time.
8225 * efs character set effectively does not allow "." to be a version
8226 * delimiter as a further complication about changing this.
8228 if (decc_filename_unix_report != 0) {
8231 *(cp1++) = *(cp2++);
8234 *(cp1++) = *(cp2++);
8237 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8241 /* Fix me for "^]", but that requires making sure that you do
8242 * not back up past the start of the filename
8244 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8249 if (utf8_flag != NULL)
8253 } /* end of do_tovmsspec() */
8255 /* External entry points */
8256 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8257 { return do_tovmsspec(path,buf,0,NULL); }
8258 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8259 { return do_tovmsspec(path,buf,1,NULL); }
8260 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8261 { return do_tovmsspec(path,buf,0,utf8_fl); }
8262 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8263 { return do_tovmsspec(path,buf,1,utf8_fl); }
8265 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8266 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8267 static char __tovmspath_retbuf[VMS_MAXRSS];
8269 char *pathified, *vmsified, *cp;
8271 if (path == NULL) return NULL;
8272 pathified = PerlMem_malloc(VMS_MAXRSS);
8273 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8274 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8275 PerlMem_free(pathified);
8281 Newx(vmsified, VMS_MAXRSS, char);
8282 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8283 PerlMem_free(pathified);
8284 if (vmsified) Safefree(vmsified);
8287 PerlMem_free(pathified);
8292 vmslen = strlen(vmsified);
8293 Newx(cp,vmslen+1,char);
8294 memcpy(cp,vmsified,vmslen);
8300 strcpy(__tovmspath_retbuf,vmsified);
8302 return __tovmspath_retbuf;
8305 } /* end of do_tovmspath() */
8307 /* External entry points */
8308 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8309 { return do_tovmspath(path,buf,0, NULL); }
8310 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8311 { return do_tovmspath(path,buf,1, NULL); }
8312 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8313 { return do_tovmspath(path,buf,0,utf8_fl); }
8314 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8315 { return do_tovmspath(path,buf,1,utf8_fl); }
8318 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8319 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8320 static char __tounixpath_retbuf[VMS_MAXRSS];
8322 char *pathified, *unixified, *cp;
8324 if (path == NULL) return NULL;
8325 pathified = PerlMem_malloc(VMS_MAXRSS);
8326 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8327 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8328 PerlMem_free(pathified);
8334 Newx(unixified, VMS_MAXRSS, char);
8336 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8337 PerlMem_free(pathified);
8338 if (unixified) Safefree(unixified);
8341 PerlMem_free(pathified);
8346 unixlen = strlen(unixified);
8347 Newx(cp,unixlen+1,char);
8348 memcpy(cp,unixified,unixlen);
8350 Safefree(unixified);
8354 strcpy(__tounixpath_retbuf,unixified);
8355 Safefree(unixified);
8356 return __tounixpath_retbuf;
8359 } /* end of do_tounixpath() */
8361 /* External entry points */
8362 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8363 { return do_tounixpath(path,buf,0,NULL); }
8364 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8365 { return do_tounixpath(path,buf,1,NULL); }
8366 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8367 { return do_tounixpath(path,buf,0,utf8_fl); }
8368 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8369 { return do_tounixpath(path,buf,1,utf8_fl); }
8372 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
8374 *****************************************************************************
8376 * Copyright (C) 1989-1994, 2007 by *
8377 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8379 * Permission is hereby granted for the reproduction of this software *
8380 * on condition that this copyright notice is included in source *
8381 * distributions of the software. The code may be modified and *
8382 * distributed under the same terms as Perl itself. *
8384 * 27-Aug-1994 Modified for inclusion in perl5 *
8385 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
8386 *****************************************************************************
8390 * getredirection() is intended to aid in porting C programs
8391 * to VMS (Vax-11 C). The native VMS environment does not support
8392 * '>' and '<' I/O redirection, or command line wild card expansion,
8393 * or a command line pipe mechanism using the '|' AND background
8394 * command execution '&'. All of these capabilities are provided to any
8395 * C program which calls this procedure as the first thing in the
8397 * The piping mechanism will probably work with almost any 'filter' type
8398 * of program. With suitable modification, it may useful for other
8399 * portability problems as well.
8401 * Author: Mark Pizzolato (mark AT infocomm DOT com)
8405 struct list_item *next;
8409 static void add_item(struct list_item **head,
8410 struct list_item **tail,
8414 static void mp_expand_wild_cards(pTHX_ char *item,
8415 struct list_item **head,
8416 struct list_item **tail,
8419 static int background_process(pTHX_ int argc, char **argv);
8421 static void pipe_and_fork(pTHX_ char **cmargv);
8423 /*{{{ void getredirection(int *ac, char ***av)*/
8425 mp_getredirection(pTHX_ int *ac, char ***av)
8427 * Process vms redirection arg's. Exit if any error is seen.
8428 * If getredirection() processes an argument, it is erased
8429 * from the vector. getredirection() returns a new argc and argv value.
8430 * In the event that a background command is requested (by a trailing "&"),
8431 * this routine creates a background subprocess, and simply exits the program.
8433 * Warning: do not try to simplify the code for vms. The code
8434 * presupposes that getredirection() is called before any data is
8435 * read from stdin or written to stdout.
8437 * Normal usage is as follows:
8443 * getredirection(&argc, &argv);
8447 int argc = *ac; /* Argument Count */
8448 char **argv = *av; /* Argument Vector */
8449 char *ap; /* Argument pointer */
8450 int j; /* argv[] index */
8451 int item_count = 0; /* Count of Items in List */
8452 struct list_item *list_head = 0; /* First Item in List */
8453 struct list_item *list_tail; /* Last Item in List */
8454 char *in = NULL; /* Input File Name */
8455 char *out = NULL; /* Output File Name */
8456 char *outmode = "w"; /* Mode to Open Output File */
8457 char *err = NULL; /* Error File Name */
8458 char *errmode = "w"; /* Mode to Open Error File */
8459 int cmargc = 0; /* Piped Command Arg Count */
8460 char **cmargv = NULL;/* Piped Command Arg Vector */
8463 * First handle the case where the last thing on the line ends with
8464 * a '&'. This indicates the desire for the command to be run in a
8465 * subprocess, so we satisfy that desire.
8468 if (0 == strcmp("&", ap))
8469 exit(background_process(aTHX_ --argc, argv));
8470 if (*ap && '&' == ap[strlen(ap)-1])
8472 ap[strlen(ap)-1] = '\0';
8473 exit(background_process(aTHX_ argc, argv));
8476 * Now we handle the general redirection cases that involve '>', '>>',
8477 * '<', and pipes '|'.
8479 for (j = 0; j < argc; ++j)
8481 if (0 == strcmp("<", argv[j]))
8485 fprintf(stderr,"No input file after < on command line");
8486 exit(LIB$_WRONUMARG);
8491 if ('<' == *(ap = argv[j]))
8496 if (0 == strcmp(">", ap))
8500 fprintf(stderr,"No output file after > on command line");
8501 exit(LIB$_WRONUMARG);
8520 fprintf(stderr,"No output file after > or >> on command line");
8521 exit(LIB$_WRONUMARG);
8525 if (('2' == *ap) && ('>' == ap[1]))
8542 fprintf(stderr,"No output file after 2> or 2>> on command line");
8543 exit(LIB$_WRONUMARG);
8547 if (0 == strcmp("|", argv[j]))
8551 fprintf(stderr,"No command into which to pipe on command line");
8552 exit(LIB$_WRONUMARG);
8554 cmargc = argc-(j+1);
8555 cmargv = &argv[j+1];
8559 if ('|' == *(ap = argv[j]))
8567 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8570 * Allocate and fill in the new argument vector, Some Unix's terminate
8571 * the list with an extra null pointer.
8573 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8574 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8576 for (j = 0; j < item_count; ++j, list_head = list_head->next)
8577 argv[j] = list_head->value;
8583 fprintf(stderr,"'|' and '>' may not both be specified on command line");
8584 exit(LIB$_INVARGORD);
8586 pipe_and_fork(aTHX_ cmargv);
8589 /* Check for input from a pipe (mailbox) */
8591 if (in == NULL && 1 == isapipe(0))
8593 char mbxname[L_tmpnam];
8595 long int dvi_item = DVI$_DEVBUFSIZ;
8596 $DESCRIPTOR(mbxnam, "");
8597 $DESCRIPTOR(mbxdevnam, "");
8599 /* Input from a pipe, reopen it in binary mode to disable */
8600 /* carriage control processing. */
8602 fgetname(stdin, mbxname);
8603 mbxnam.dsc$a_pointer = mbxname;
8604 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8605 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8606 mbxdevnam.dsc$a_pointer = mbxname;
8607 mbxdevnam.dsc$w_length = sizeof(mbxname);
8608 dvi_item = DVI$_DEVNAM;
8609 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8610 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8613 freopen(mbxname, "rb", stdin);
8616 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8620 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8622 fprintf(stderr,"Can't open input file %s as stdin",in);
8625 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8627 fprintf(stderr,"Can't open output file %s as stdout",out);
8630 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8633 if (strcmp(err,"&1") == 0) {
8634 dup2(fileno(stdout), fileno(stderr));
8635 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8638 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8640 fprintf(stderr,"Can't open error file %s as stderr",err);
8644 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8648 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8651 #ifdef ARGPROC_DEBUG
8652 PerlIO_printf(Perl_debug_log, "Arglist:\n");
8653 for (j = 0; j < *ac; ++j)
8654 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8656 /* Clear errors we may have hit expanding wildcards, so they don't
8657 show up in Perl's $! later */
8658 set_errno(0); set_vaxc_errno(1);
8659 } /* end of getredirection() */
8662 static void add_item(struct list_item **head,
8663 struct list_item **tail,
8669 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8670 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8674 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8675 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8676 *tail = (*tail)->next;
8678 (*tail)->value = value;
8682 static void mp_expand_wild_cards(pTHX_ char *item,
8683 struct list_item **head,
8684 struct list_item **tail,
8688 unsigned long int context = 0;
8696 $DESCRIPTOR(filespec, "");
8697 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8698 $DESCRIPTOR(resultspec, "");
8699 unsigned long int lff_flags = 0;
8703 #ifdef VMS_LONGNAME_SUPPORT
8704 lff_flags = LIB$M_FIL_LONG_NAMES;
8707 for (cp = item; *cp; cp++) {
8708 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8709 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8711 if (!*cp || isspace(*cp))
8713 add_item(head, tail, item, count);
8718 /* "double quoted" wild card expressions pass as is */
8719 /* From DCL that means using e.g.: */
8720 /* perl program """perl.*""" */
8721 item_len = strlen(item);
8722 if ( '"' == *item && '"' == item[item_len-1] )
8725 item[item_len-2] = '\0';
8726 add_item(head, tail, item, count);
8730 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8731 resultspec.dsc$b_class = DSC$K_CLASS_D;
8732 resultspec.dsc$a_pointer = NULL;
8733 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8734 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8735 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8736 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8737 if (!isunix || !filespec.dsc$a_pointer)
8738 filespec.dsc$a_pointer = item;
8739 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8741 * Only return version specs, if the caller specified a version
8743 had_version = strchr(item, ';');
8745 * Only return device and directory specs, if the caller specifed either.
8747 had_device = strchr(item, ':');
8748 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8750 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8751 (&filespec, &resultspec, &context,
8752 &defaultspec, 0, &rms_sts, &lff_flags)))
8757 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8758 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8759 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8760 string[resultspec.dsc$w_length] = '\0';
8761 if (NULL == had_version)
8762 *(strrchr(string, ';')) = '\0';
8763 if ((!had_directory) && (had_device == NULL))
8765 if (NULL == (devdir = strrchr(string, ']')))
8766 devdir = strrchr(string, '>');
8767 strcpy(string, devdir + 1);
8770 * Be consistent with what the C RTL has already done to the rest of
8771 * the argv items and lowercase all of these names.
8773 if (!decc_efs_case_preserve) {
8774 for (c = string; *c; ++c)
8778 if (isunix) trim_unixpath(string,item,1);
8779 add_item(head, tail, string, count);
8782 PerlMem_free(vmsspec);
8783 if (sts != RMS$_NMF)
8785 set_vaxc_errno(sts);
8788 case RMS$_FNF: case RMS$_DNF:
8789 set_errno(ENOENT); break;
8791 set_errno(ENOTDIR); break;
8793 set_errno(ENODEV); break;
8794 case RMS$_FNM: case RMS$_SYN:
8795 set_errno(EINVAL); break;
8797 set_errno(EACCES); break;
8799 _ckvmssts_noperl(sts);
8803 add_item(head, tail, item, count);
8804 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8805 _ckvmssts_noperl(lib$find_file_end(&context));
8808 static int child_st[2];/* Event Flag set when child process completes */
8810 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8812 static unsigned long int exit_handler(int *status)
8816 if (0 == child_st[0])
8818 #ifdef ARGPROC_DEBUG
8819 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8821 fflush(stdout); /* Have to flush pipe for binary data to */
8822 /* terminate properly -- <tp@mccall.com> */
8823 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8824 sys$dassgn(child_chan);
8826 sys$synch(0, child_st);
8831 static void sig_child(int chan)
8833 #ifdef ARGPROC_DEBUG
8834 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8836 if (child_st[0] == 0)
8840 static struct exit_control_block exit_block =
8845 &exit_block.exit_status,
8850 pipe_and_fork(pTHX_ char **cmargv)
8853 struct dsc$descriptor_s *vmscmd;
8854 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8855 int sts, j, l, ismcr, quote, tquote = 0;
8857 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8858 vms_execfree(vmscmd);
8863 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8864 && toupper(*(q+2)) == 'R' && !*(q+3);
8866 while (q && l < MAX_DCL_LINE_LENGTH) {
8868 if (j > 0 && quote) {
8874 if (ismcr && j > 1) quote = 1;
8875 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8878 if (quote || tquote) {
8884 if ((quote||tquote) && *q == '"') {
8894 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8896 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8900 static int background_process(pTHX_ int argc, char **argv)
8902 char command[MAX_DCL_SYMBOL + 1] = "$";
8903 $DESCRIPTOR(value, "");
8904 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8905 static $DESCRIPTOR(null, "NLA0:");
8906 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8908 $DESCRIPTOR(pidstr, "");
8910 unsigned long int flags = 17, one = 1, retsts;
8913 strcat(command, argv[0]);
8914 len = strlen(command);
8915 while (--argc && (len < MAX_DCL_SYMBOL))
8917 strcat(command, " \"");
8918 strcat(command, *(++argv));
8919 strcat(command, "\"");
8920 len = strlen(command);
8922 value.dsc$a_pointer = command;
8923 value.dsc$w_length = strlen(value.dsc$a_pointer);
8924 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8925 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8926 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8927 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8930 _ckvmssts_noperl(retsts);
8932 #ifdef ARGPROC_DEBUG
8933 PerlIO_printf(Perl_debug_log, "%s\n", command);
8935 sprintf(pidstring, "%08X", pid);
8936 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8937 pidstr.dsc$a_pointer = pidstring;
8938 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8939 lib$set_symbol(&pidsymbol, &pidstr);
8943 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8946 /* OS-specific initialization at image activation (not thread startup) */
8947 /* Older VAXC header files lack these constants */
8948 #ifndef JPI$_RIGHTS_SIZE
8949 # define JPI$_RIGHTS_SIZE 817
8951 #ifndef KGB$M_SUBSYSTEM
8952 # define KGB$M_SUBSYSTEM 0x8
8955 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8957 /*{{{void vms_image_init(int *, char ***)*/
8959 vms_image_init(int *argcp, char ***argvp)
8961 char eqv[LNM$C_NAMLENGTH+1] = "";
8962 unsigned int len, tabct = 8, tabidx = 0;
8963 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8964 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8965 unsigned short int dummy, rlen;
8966 struct dsc$descriptor_s **tabvec;
8967 #if defined(PERL_IMPLICIT_CONTEXT)
8970 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8971 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8972 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8975 #ifdef KILL_BY_SIGPRC
8976 Perl_csighandler_init();
8979 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8980 _ckvmssts_noperl(iosb[0]);
8981 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8982 if (iprv[i]) { /* Running image installed with privs? */
8983 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8988 /* Rights identifiers might trigger tainting as well. */
8989 if (!will_taint && (rlen || rsz)) {
8990 while (rlen < rsz) {
8991 /* We didn't get all the identifiers on the first pass. Allocate a
8992 * buffer much larger than $GETJPI wants (rsz is size in bytes that
8993 * were needed to hold all identifiers at time of last call; we'll
8994 * allocate that many unsigned long ints), and go back and get 'em.
8995 * If it gave us less than it wanted to despite ample buffer space,
8996 * something's broken. Is your system missing a system identifier?
8998 if (rsz <= jpilist[1].buflen) {
8999 /* Perl_croak accvios when used this early in startup. */
9000 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9001 rsz, (unsigned long) jpilist[1].buflen,
9002 "Check your rights database for corruption.\n");
9005 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9006 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9007 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9008 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9009 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9010 _ckvmssts_noperl(iosb[0]);
9012 mask = jpilist[1].bufadr;
9013 /* Check attribute flags for each identifier (2nd longword); protected
9014 * subsystem identifiers trigger tainting.
9016 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9017 if (mask[i] & KGB$M_SUBSYSTEM) {
9022 if (mask != rlst) PerlMem_free(mask);
9025 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9026 * logical, some versions of the CRTL will add a phanthom /000000/
9027 * directory. This needs to be removed.
9029 if (decc_filename_unix_report) {
9032 ulen = strlen(argvp[0][0]);
9034 zeros = strstr(argvp[0][0], "/000000/");
9035 if (zeros != NULL) {
9037 mlen = ulen - (zeros - argvp[0][0]) - 7;
9038 memmove(zeros, &zeros[7], mlen);
9040 argvp[0][0][ulen] = '\0';
9043 /* It also may have a trailing dot that needs to be removed otherwise
9044 * it will be converted to VMS mode incorrectly.
9047 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9048 argvp[0][0][ulen] = '\0';
9051 /* We need to use this hack to tell Perl it should run with tainting,
9052 * since its tainting flag may be part of the PL_curinterp struct, which
9053 * hasn't been allocated when vms_image_init() is called.
9056 char **newargv, **oldargv;
9058 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9059 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9060 newargv[0] = oldargv[0];
9061 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9062 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9063 strcpy(newargv[1], "-T");
9064 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9066 newargv[*argcp] = NULL;
9067 /* We orphan the old argv, since we don't know where it's come from,
9068 * so we don't know how to free it.
9072 else { /* Did user explicitly request tainting? */
9074 char *cp, **av = *argvp;
9075 for (i = 1; i < *argcp; i++) {
9076 if (*av[i] != '-') break;
9077 for (cp = av[i]+1; *cp; cp++) {
9078 if (*cp == 'T') { will_taint = 1; break; }
9079 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9080 strchr("DFIiMmx",*cp)) break;
9082 if (will_taint) break;
9087 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9090 tabvec = (struct dsc$descriptor_s **)
9091 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9092 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9094 else if (tabidx >= tabct) {
9096 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9097 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9099 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9100 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9101 tabvec[tabidx]->dsc$w_length = 0;
9102 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9103 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9104 tabvec[tabidx]->dsc$a_pointer = NULL;
9105 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9107 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9109 getredirection(argcp,argvp);
9110 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9112 # include <reentrancy.h>
9113 decc$set_reentrancy(C$C_MULTITHREAD);
9122 * Trim Unix-style prefix off filespec, so it looks like what a shell
9123 * glob expansion would return (i.e. from specified prefix on, not
9124 * full path). Note that returned filespec is Unix-style, regardless
9125 * of whether input filespec was VMS-style or Unix-style.
9127 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9128 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9129 * vector of options; at present, only bit 0 is used, and if set tells
9130 * trim unixpath to try the current default directory as a prefix when
9131 * presented with a possibly ambiguous ... wildcard.
9133 * Returns !=0 on success, with trimmed filespec replacing contents of
9134 * fspec, and 0 on failure, with contents of fpsec unchanged.
9136 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9138 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9140 char *unixified, *unixwild,
9141 *template, *base, *end, *cp1, *cp2;
9142 register int tmplen, reslen = 0, dirs = 0;
9144 unixwild = PerlMem_malloc(VMS_MAXRSS);
9145 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9146 if (!wildspec || !fspec) return 0;
9147 template = unixwild;
9148 if (strpbrk(wildspec,"]>:") != NULL) {
9149 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9150 PerlMem_free(unixwild);
9155 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9156 unixwild[VMS_MAXRSS-1] = 0;
9158 unixified = PerlMem_malloc(VMS_MAXRSS);
9159 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9160 if (strpbrk(fspec,"]>:") != NULL) {
9161 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9162 PerlMem_free(unixwild);
9163 PerlMem_free(unixified);
9166 else base = unixified;
9167 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9168 * check to see that final result fits into (isn't longer than) fspec */
9169 reslen = strlen(fspec);
9173 /* No prefix or absolute path on wildcard, so nothing to remove */
9174 if (!*template || *template == '/') {
9175 PerlMem_free(unixwild);
9176 if (base == fspec) {
9177 PerlMem_free(unixified);
9180 tmplen = strlen(unixified);
9181 if (tmplen > reslen) {
9182 PerlMem_free(unixified);
9183 return 0; /* not enough space */
9185 /* Copy unixified resultant, including trailing NUL */
9186 memmove(fspec,unixified,tmplen+1);
9187 PerlMem_free(unixified);
9191 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9192 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9193 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9194 for (cp1 = end ;cp1 >= base; cp1--)
9195 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9197 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9198 PerlMem_free(unixified);
9199 PerlMem_free(unixwild);
9204 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9205 int ells = 1, totells, segdirs, match;
9206 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9207 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9209 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9211 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9212 tpl = PerlMem_malloc(VMS_MAXRSS);
9213 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9214 if (ellipsis == template && opts & 1) {
9215 /* Template begins with an ellipsis. Since we can't tell how many
9216 * directory names at the front of the resultant to keep for an
9217 * arbitrary starting point, we arbitrarily choose the current
9218 * default directory as a starting point. If it's there as a prefix,
9219 * clip it off. If not, fall through and act as if the leading
9220 * ellipsis weren't there (i.e. return shortest possible path that
9221 * could match template).
9223 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9225 PerlMem_free(unixified);
9226 PerlMem_free(unixwild);
9229 if (!decc_efs_case_preserve) {
9230 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9231 if (_tolower(*cp1) != _tolower(*cp2)) break;
9233 segdirs = dirs - totells; /* Min # of dirs we must have left */
9234 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9235 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9236 memmove(fspec,cp2+1,end - cp2);
9238 PerlMem_free(unixified);
9239 PerlMem_free(unixwild);
9243 /* First off, back up over constant elements at end of path */
9245 for (front = end ; front >= base; front--)
9246 if (*front == '/' && !dirs--) { front++; break; }
9248 lcres = PerlMem_malloc(VMS_MAXRSS);
9249 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9250 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9252 if (!decc_efs_case_preserve) {
9253 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9261 PerlMem_free(unixified);
9262 PerlMem_free(unixwild);
9263 PerlMem_free(lcres);
9264 return 0; /* Path too long. */
9267 *cp2 = '\0'; /* Pick up with memcpy later */
9268 lcfront = lcres + (front - base);
9269 /* Now skip over each ellipsis and try to match the path in front of it. */
9271 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9272 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9273 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9274 if (cp1 < template) break; /* template started with an ellipsis */
9275 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9276 ellipsis = cp1; continue;
9278 wilddsc.dsc$a_pointer = tpl;
9279 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9281 for (segdirs = 0, cp2 = tpl;
9282 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9284 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9286 if (!decc_efs_case_preserve) {
9287 *cp2 = _tolower(*cp1); /* else lowercase for match */
9290 *cp2 = *cp1; /* else preserve case for match */
9293 if (*cp2 == '/') segdirs++;
9295 if (cp1 != ellipsis - 1) {
9297 PerlMem_free(unixified);
9298 PerlMem_free(unixwild);
9299 PerlMem_free(lcres);
9300 return 0; /* Path too long */
9302 /* Back up at least as many dirs as in template before matching */
9303 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9304 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9305 for (match = 0; cp1 > lcres;) {
9306 resdsc.dsc$a_pointer = cp1;
9307 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9309 if (match == 1) lcfront = cp1;
9311 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9315 PerlMem_free(unixified);
9316 PerlMem_free(unixwild);
9317 PerlMem_free(lcres);
9318 return 0; /* Can't find prefix ??? */
9320 if (match > 1 && opts & 1) {
9321 /* This ... wildcard could cover more than one set of dirs (i.e.
9322 * a set of similar dir names is repeated). If the template
9323 * contains more than 1 ..., upstream elements could resolve the
9324 * ambiguity, but it's not worth a full backtracking setup here.
9325 * As a quick heuristic, clip off the current default directory
9326 * if it's present to find the trimmed spec, else use the
9327 * shortest string that this ... could cover.
9329 char def[NAM$C_MAXRSS+1], *st;
9331 if (getcwd(def, sizeof def,0) == NULL) {
9332 Safefree(unixified);
9338 if (!decc_efs_case_preserve) {
9339 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9340 if (_tolower(*cp1) != _tolower(*cp2)) break;
9342 segdirs = dirs - totells; /* Min # of dirs we must have left */
9343 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9344 if (*cp1 == '\0' && *cp2 == '/') {
9345 memmove(fspec,cp2+1,end - cp2);
9347 PerlMem_free(unixified);
9348 PerlMem_free(unixwild);
9349 PerlMem_free(lcres);
9352 /* Nope -- stick with lcfront from above and keep going. */
9355 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9357 PerlMem_free(unixified);
9358 PerlMem_free(unixwild);
9359 PerlMem_free(lcres);
9364 } /* end of trim_unixpath() */
9369 * VMS readdir() routines.
9370 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9372 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
9373 * Minor modifications to original routines.
9376 /* readdir may have been redefined by reentr.h, so make sure we get
9377 * the local version for what we do here.
9382 #if !defined(PERL_IMPLICIT_CONTEXT)
9383 # define readdir Perl_readdir
9385 # define readdir(a) Perl_readdir(aTHX_ a)
9388 /* Number of elements in vms_versions array */
9389 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9392 * Open a directory, return a handle for later use.
9394 /*{{{ DIR *opendir(char*name) */
9396 Perl_opendir(pTHX_ const char *name)
9402 Newx(dir, VMS_MAXRSS, char);
9403 if (do_tovmspath(name,dir,0,NULL) == NULL) {
9407 /* Check access before stat; otherwise stat does not
9408 * accurately report whether it's a directory.
9410 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9411 /* cando_by_name has already set errno */
9415 if (flex_stat(dir,&sb) == -1) return NULL;
9416 if (!S_ISDIR(sb.st_mode)) {
9418 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9421 /* Get memory for the handle, and the pattern. */
9423 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9425 /* Fill in the fields; mainly playing with the descriptor. */
9426 sprintf(dd->pattern, "%s*.*",dir);
9431 /* By saying we always want the result of readdir() in unix format, we
9432 * are really saying we want all the escapes removed. Otherwise the caller,
9433 * having no way to know whether it's already in VMS format, might send it
9434 * through tovmsspec again, thus double escaping.
9436 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9437 dd->pat.dsc$a_pointer = dd->pattern;
9438 dd->pat.dsc$w_length = strlen(dd->pattern);
9439 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9440 dd->pat.dsc$b_class = DSC$K_CLASS_S;
9441 #if defined(USE_ITHREADS)
9442 Newx(dd->mutex,1,perl_mutex);
9443 MUTEX_INIT( (perl_mutex *) dd->mutex );
9449 } /* end of opendir() */
9453 * Set the flag to indicate we want versions or not.
9455 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9457 vmsreaddirversions(DIR *dd, int flag)
9460 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9462 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9467 * Free up an opened directory.
9469 /*{{{ void closedir(DIR *dd)*/
9471 Perl_closedir(DIR *dd)
9475 sts = lib$find_file_end(&dd->context);
9476 Safefree(dd->pattern);
9477 #if defined(USE_ITHREADS)
9478 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9479 Safefree(dd->mutex);
9486 * Collect all the version numbers for the current file.
9489 collectversions(pTHX_ DIR *dd)
9491 struct dsc$descriptor_s pat;
9492 struct dsc$descriptor_s res;
9494 char *p, *text, *buff;
9496 unsigned long context, tmpsts;
9498 /* Convenient shorthand. */
9501 /* Add the version wildcard, ignoring the "*.*" put on before */
9502 i = strlen(dd->pattern);
9503 Newx(text,i + e->d_namlen + 3,char);
9504 strcpy(text, dd->pattern);
9505 sprintf(&text[i - 3], "%s;*", e->d_name);
9507 /* Set up the pattern descriptor. */
9508 pat.dsc$a_pointer = text;
9509 pat.dsc$w_length = i + e->d_namlen - 1;
9510 pat.dsc$b_dtype = DSC$K_DTYPE_T;
9511 pat.dsc$b_class = DSC$K_CLASS_S;
9513 /* Set up result descriptor. */
9514 Newx(buff, VMS_MAXRSS, char);
9515 res.dsc$a_pointer = buff;
9516 res.dsc$w_length = VMS_MAXRSS - 1;
9517 res.dsc$b_dtype = DSC$K_DTYPE_T;
9518 res.dsc$b_class = DSC$K_CLASS_S;
9520 /* Read files, collecting versions. */
9521 for (context = 0, e->vms_verscount = 0;
9522 e->vms_verscount < VERSIZE(e);
9523 e->vms_verscount++) {
9525 unsigned long flags = 0;
9527 #ifdef VMS_LONGNAME_SUPPORT
9528 flags = LIB$M_FIL_LONG_NAMES;
9530 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9531 if (tmpsts == RMS$_NMF || context == 0) break;
9533 buff[VMS_MAXRSS - 1] = '\0';
9534 if ((p = strchr(buff, ';')))
9535 e->vms_versions[e->vms_verscount] = atoi(p + 1);
9537 e->vms_versions[e->vms_verscount] = -1;
9540 _ckvmssts(lib$find_file_end(&context));
9544 } /* end of collectversions() */
9547 * Read the next entry from the directory.
9549 /*{{{ struct dirent *readdir(DIR *dd)*/
9551 Perl_readdir(pTHX_ DIR *dd)
9553 struct dsc$descriptor_s res;
9555 unsigned long int tmpsts;
9557 unsigned long flags = 0;
9558 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9559 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9561 /* Set up result descriptor, and get next file. */
9562 Newx(buff, VMS_MAXRSS, char);
9563 res.dsc$a_pointer = buff;
9564 res.dsc$w_length = VMS_MAXRSS - 1;
9565 res.dsc$b_dtype = DSC$K_DTYPE_T;
9566 res.dsc$b_class = DSC$K_CLASS_S;
9568 #ifdef VMS_LONGNAME_SUPPORT
9569 flags = LIB$M_FIL_LONG_NAMES;
9572 tmpsts = lib$find_file
9573 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9574 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
9575 if (!(tmpsts & 1)) {
9576 set_vaxc_errno(tmpsts);
9579 set_errno(EACCES); break;
9581 set_errno(ENODEV); break;
9583 set_errno(ENOTDIR); break;
9584 case RMS$_FNF: case RMS$_DNF:
9585 set_errno(ENOENT); break;
9593 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9594 if (!decc_efs_case_preserve) {
9595 buff[VMS_MAXRSS - 1] = '\0';
9596 for (p = buff; *p; p++) *p = _tolower(*p);
9599 /* we don't want to force to lowercase, just null terminate */
9600 buff[res.dsc$w_length] = '\0';
9602 while (--p >= buff) if (!isspace(*p)) break; /* Do we really need this? */
9605 /* Skip any directory component and just copy the name. */
9606 sts = vms_split_path
9621 /* Drop NULL extensions on UNIX file specification */
9622 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9623 (e_len == 1) && decc_readdir_dropdotnotype)) {
9628 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9629 dd->entry.d_name[n_len + e_len] = '\0';
9630 dd->entry.d_namlen = strlen(dd->entry.d_name);
9632 /* Convert the filename to UNIX format if needed */
9633 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9635 /* Translate the encoded characters. */
9636 /* Fixme: Unicode handling could result in embedded 0 characters */
9637 if (strchr(dd->entry.d_name, '^') != NULL) {
9640 p = dd->entry.d_name;
9643 int inchars_read, outchars_added;
9644 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9646 q += outchars_added;
9648 /* if outchars_added > 1, then this is a wide file specification */
9649 /* Wide file specifications need to be passed in Perl */
9650 /* counted strings apparently with a Unicode flag */
9653 strcpy(dd->entry.d_name, new_name);
9654 dd->entry.d_namlen = strlen(dd->entry.d_name);
9658 dd->entry.vms_verscount = 0;
9659 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9663 } /* end of readdir() */
9667 * Read the next entry from the directory -- thread-safe version.
9669 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9671 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9675 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9677 entry = readdir(dd);
9679 retval = ( *result == NULL ? errno : 0 );
9681 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9685 } /* end of readdir_r() */
9689 * Return something that can be used in a seekdir later.
9691 /*{{{ long telldir(DIR *dd)*/
9693 Perl_telldir(DIR *dd)
9700 * Return to a spot where we used to be. Brute force.
9702 /*{{{ void seekdir(DIR *dd,long count)*/
9704 Perl_seekdir(pTHX_ DIR *dd, long count)
9708 /* If we haven't done anything yet... */
9712 /* Remember some state, and clear it. */
9713 old_flags = dd->flags;
9714 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9715 _ckvmssts(lib$find_file_end(&dd->context));
9718 /* The increment is in readdir(). */
9719 for (dd->count = 0; dd->count < count; )
9722 dd->flags = old_flags;
9724 } /* end of seekdir() */
9727 /* VMS subprocess management
9729 * my_vfork() - just a vfork(), after setting a flag to record that
9730 * the current script is trying a Unix-style fork/exec.
9732 * vms_do_aexec() and vms_do_exec() are called in response to the
9733 * perl 'exec' function. If this follows a vfork call, then they
9734 * call out the regular perl routines in doio.c which do an
9735 * execvp (for those who really want to try this under VMS).
9736 * Otherwise, they do exactly what the perl docs say exec should
9737 * do - terminate the current script and invoke a new command
9738 * (See below for notes on command syntax.)
9740 * do_aspawn() and do_spawn() implement the VMS side of the perl
9741 * 'system' function.
9743 * Note on command arguments to perl 'exec' and 'system': When handled
9744 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9745 * are concatenated to form a DCL command string. If the first non-numeric
9746 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9747 * the command string is handed off to DCL directly. Otherwise,
9748 * the first token of the command is taken as the filespec of an image
9749 * to run. The filespec is expanded using a default type of '.EXE' and
9750 * the process defaults for device, directory, etc., and if found, the resultant
9751 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9752 * the command string as parameters. This is perhaps a bit complicated,
9753 * but I hope it will form a happy medium between what VMS folks expect
9754 * from lib$spawn and what Unix folks expect from exec.
9757 static int vfork_called;
9759 /*{{{int my_vfork()*/
9770 vms_execfree(struct dsc$descriptor_s *vmscmd)
9773 if (vmscmd->dsc$a_pointer) {
9774 PerlMem_free(vmscmd->dsc$a_pointer);
9776 PerlMem_free(vmscmd);
9781 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9783 char *junk, *tmps = Nullch;
9784 register size_t cmdlen = 0;
9791 tmps = SvPV(really,rlen);
9798 for (idx++; idx <= sp; idx++) {
9800 junk = SvPVx(*idx,rlen);
9801 cmdlen += rlen ? rlen + 1 : 0;
9804 Newx(PL_Cmd, cmdlen+1, char);
9806 if (tmps && *tmps) {
9807 strcpy(PL_Cmd,tmps);
9810 else *PL_Cmd = '\0';
9811 while (++mark <= sp) {
9813 char *s = SvPVx(*mark,n_a);
9815 if (*PL_Cmd) strcat(PL_Cmd," ");
9821 } /* end of setup_argstr() */
9824 static unsigned long int
9825 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9826 struct dsc$descriptor_s **pvmscmd)
9828 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9829 char image_name[NAM$C_MAXRSS+1];
9830 char image_argv[NAM$C_MAXRSS+1];
9831 $DESCRIPTOR(defdsc,".EXE");
9832 $DESCRIPTOR(defdsc2,".");
9833 $DESCRIPTOR(resdsc,resspec);
9834 struct dsc$descriptor_s *vmscmd;
9835 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9836 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9837 register char *s, *rest, *cp, *wordbreak;
9842 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9843 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9845 /* Make a copy for modification */
9846 cmdlen = strlen(incmd);
9847 cmd = PerlMem_malloc(cmdlen+1);
9848 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9849 strncpy(cmd, incmd, cmdlen);
9854 vmscmd->dsc$a_pointer = NULL;
9855 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9856 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9857 vmscmd->dsc$w_length = 0;
9858 if (pvmscmd) *pvmscmd = vmscmd;
9860 if (suggest_quote) *suggest_quote = 0;
9862 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9864 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9869 while (*s && isspace(*s)) s++;
9871 if (*s == '@' || *s == '$') {
9872 vmsspec[0] = *s; rest = s + 1;
9873 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9875 else { cp = vmsspec; rest = s; }
9876 if (*rest == '.' || *rest == '/') {
9879 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9880 rest++, cp2++) *cp2 = *rest;
9882 if (do_tovmsspec(resspec,cp,0,NULL)) {
9885 for (cp2 = vmsspec + strlen(vmsspec);
9886 *rest && cp2 - vmsspec < sizeof vmsspec;
9887 rest++, cp2++) *cp2 = *rest;
9892 /* Intuit whether verb (first word of cmd) is a DCL command:
9893 * - if first nonspace char is '@', it's a DCL indirection
9895 * - if verb contains a filespec separator, it's not a DCL command
9896 * - if it doesn't, caller tells us whether to default to a DCL
9897 * command, or to a local image unless told it's DCL (by leading '$')
9901 if (suggest_quote) *suggest_quote = 1;
9903 register char *filespec = strpbrk(s,":<[.;");
9904 rest = wordbreak = strpbrk(s," \"\t/");
9905 if (!wordbreak) wordbreak = s + strlen(s);
9906 if (*s == '$') check_img = 0;
9907 if (filespec && (filespec < wordbreak)) isdcl = 0;
9908 else isdcl = !check_img;
9913 imgdsc.dsc$a_pointer = s;
9914 imgdsc.dsc$w_length = wordbreak - s;
9915 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9917 _ckvmssts(lib$find_file_end(&cxt));
9918 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9919 if (!(retsts & 1) && *s == '$') {
9920 _ckvmssts(lib$find_file_end(&cxt));
9921 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9922 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9924 _ckvmssts(lib$find_file_end(&cxt));
9925 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9929 _ckvmssts(lib$find_file_end(&cxt));
9934 while (*s && !isspace(*s)) s++;
9937 /* check that it's really not DCL with no file extension */
9938 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9940 char b[256] = {0,0,0,0};
9941 read(fileno(fp), b, 256);
9942 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9946 /* Check for script */
9948 if ((b[0] == '#') && (b[1] == '!'))
9950 #ifdef ALTERNATE_SHEBANG
9952 shebang_len = strlen(ALTERNATE_SHEBANG);
9953 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9955 perlstr = strstr("perl",b);
9956 if (perlstr == NULL)
9964 if (shebang_len > 0) {
9967 char tmpspec[NAM$C_MAXRSS + 1];
9970 /* Image is following after white space */
9971 /*--------------------------------------*/
9972 while (isprint(b[i]) && isspace(b[i]))
9976 while (isprint(b[i]) && !isspace(b[i])) {
9977 tmpspec[j++] = b[i++];
9978 if (j >= NAM$C_MAXRSS)
9983 /* There may be some default parameters to the image */
9984 /*---------------------------------------------------*/
9986 while (isprint(b[i])) {
9987 image_argv[j++] = b[i++];
9988 if (j >= NAM$C_MAXRSS)
9991 while ((j > 0) && !isprint(image_argv[j-1]))
9995 /* It will need to be converted to VMS format and validated */
9996 if (tmpspec[0] != '\0') {
9999 /* Try to find the exact program requested to be run */
10000 /*---------------------------------------------------*/
10001 iname = do_rmsexpand
10002 (tmpspec, image_name, 0, ".exe",
10003 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10004 if (iname != NULL) {
10005 if (cando_by_name_int
10006 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10007 /* MCR prefix needed */
10011 /* Try again with a null type */
10012 /*----------------------------*/
10013 iname = do_rmsexpand
10014 (tmpspec, image_name, 0, ".",
10015 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10016 if (iname != NULL) {
10017 if (cando_by_name_int
10018 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10019 /* MCR prefix needed */
10025 /* Did we find the image to run the script? */
10026 /*------------------------------------------*/
10030 /* Assume DCL or foreign command exists */
10031 /*--------------------------------------*/
10032 tchr = strrchr(tmpspec, '/');
10033 if (tchr != NULL) {
10039 strcpy(image_name, tchr);
10047 if (check_img && isdcl) return RMS$_FNF;
10049 if (cando_by_name(S_IXUSR,0,resspec)) {
10050 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10051 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10053 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10054 if (image_name[0] != 0) {
10055 strcat(vmscmd->dsc$a_pointer, image_name);
10056 strcat(vmscmd->dsc$a_pointer, " ");
10058 } else if (image_name[0] != 0) {
10059 strcpy(vmscmd->dsc$a_pointer, image_name);
10060 strcat(vmscmd->dsc$a_pointer, " ");
10062 strcpy(vmscmd->dsc$a_pointer,"@");
10064 if (suggest_quote) *suggest_quote = 1;
10066 /* If there is an image name, use original command */
10067 if (image_name[0] == 0)
10068 strcat(vmscmd->dsc$a_pointer,resspec);
10071 while (*rest && isspace(*rest)) rest++;
10074 if (image_argv[0] != 0) {
10075 strcat(vmscmd->dsc$a_pointer,image_argv);
10076 strcat(vmscmd->dsc$a_pointer, " ");
10082 rest_len = strlen(rest);
10083 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10084 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10085 strcat(vmscmd->dsc$a_pointer,rest);
10087 retsts = CLI$_BUFOVF;
10089 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10091 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10097 /* It's either a DCL command or we couldn't find a suitable image */
10098 vmscmd->dsc$w_length = strlen(cmd);
10100 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10101 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10102 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10106 /* check if it's a symbol (for quoting purposes) */
10107 if (suggest_quote && !*suggest_quote) {
10109 char equiv[LNM$C_NAMLENGTH];
10110 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10111 eqvdsc.dsc$a_pointer = equiv;
10113 iss = lib$get_symbol(vmscmd,&eqvdsc);
10114 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10116 if (!(retsts & 1)) {
10117 /* just hand off status values likely to be due to user error */
10118 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10119 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10120 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10121 else { _ckvmssts(retsts); }
10124 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10126 } /* end of setup_cmddsc() */
10129 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10131 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10137 if (vfork_called) { /* this follows a vfork - act Unixish */
10139 if (vfork_called < 0) {
10140 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10143 else return do_aexec(really,mark,sp);
10145 /* no vfork - act VMSish */
10146 cmd = setup_argstr(aTHX_ really,mark,sp);
10147 exec_sts = vms_do_exec(cmd);
10148 Safefree(cmd); /* Clean up from setup_argstr() */
10153 } /* end of vms_do_aexec() */
10156 /* {{{bool vms_do_exec(char *cmd) */
10158 Perl_vms_do_exec(pTHX_ const char *cmd)
10160 struct dsc$descriptor_s *vmscmd;
10162 if (vfork_called) { /* this follows a vfork - act Unixish */
10164 if (vfork_called < 0) {
10165 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10168 else return do_exec(cmd);
10171 { /* no vfork - act VMSish */
10172 unsigned long int retsts;
10175 TAINT_PROPER("exec");
10176 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10177 retsts = lib$do_command(vmscmd);
10180 case RMS$_FNF: case RMS$_DNF:
10181 set_errno(ENOENT); break;
10183 set_errno(ENOTDIR); break;
10185 set_errno(ENODEV); break;
10187 set_errno(EACCES); break;
10189 set_errno(EINVAL); break;
10190 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10191 set_errno(E2BIG); break;
10192 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10193 _ckvmssts(retsts); /* fall through */
10194 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10195 set_errno(EVMSERR);
10197 set_vaxc_errno(retsts);
10198 if (ckWARN(WARN_EXEC)) {
10199 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10200 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10202 vms_execfree(vmscmd);
10207 } /* end of vms_do_exec() */
10210 unsigned long int Perl_do_spawn(pTHX_ const char *);
10211 unsigned long int do_spawn2(pTHX_ const char *, int);
10213 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10215 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10217 unsigned long int sts;
10223 /* We'll copy the (undocumented?) Win32 behavior and allow a
10224 * numeric first argument. But the only value we'll support
10225 * through do_aspawn is a value of 1, which means spawn without
10226 * waiting for completion -- other values are ignored.
10228 if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10230 flags = SvIVx(*(SV**)mark);
10233 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10234 flags = CLI$M_NOWAIT;
10238 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10239 sts = do_spawn2(aTHX_ cmd, flags);
10240 /* pp_sys will clean up cmd */
10244 } /* end of do_aspawn() */
10248 /* {{{unsigned long int do_spawn(char *cmd) */
10250 Perl_do_spawn(pTHX_ const char *cmd)
10252 return do_spawn2(aTHX_ cmd, 0);
10256 /* {{{unsigned long int do_spawn2(char *cmd) */
10258 do_spawn2(pTHX_ const char *cmd, int flags)
10260 unsigned long int sts, substs;
10262 /* The caller of this routine expects to Safefree(PL_Cmd) */
10263 Newx(PL_Cmd,10,char);
10266 TAINT_PROPER("spawn");
10267 if (!cmd || !*cmd) {
10268 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10271 case RMS$_FNF: case RMS$_DNF:
10272 set_errno(ENOENT); break;
10274 set_errno(ENOTDIR); break;
10276 set_errno(ENODEV); break;
10278 set_errno(EACCES); break;
10280 set_errno(EINVAL); break;
10281 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10282 set_errno(E2BIG); break;
10283 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10284 _ckvmssts(sts); /* fall through */
10285 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10286 set_errno(EVMSERR);
10288 set_vaxc_errno(sts);
10289 if (ckWARN(WARN_EXEC)) {
10290 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10299 if (flags & CLI$M_NOWAIT)
10302 strcpy(mode, "nW");
10304 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10307 /* sts will be the pid in the nowait case */
10310 } /* end of do_spawn2() */
10314 static unsigned int *sockflags, sockflagsize;
10317 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10318 * routines found in some versions of the CRTL can't deal with sockets.
10319 * We don't shim the other file open routines since a socket isn't
10320 * likely to be opened by a name.
10322 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10323 FILE *my_fdopen(int fd, const char *mode)
10325 FILE *fp = fdopen(fd, mode);
10328 unsigned int fdoff = fd / sizeof(unsigned int);
10329 Stat_t sbuf; /* native stat; we don't need flex_stat */
10330 if (!sockflagsize || fdoff > sockflagsize) {
10331 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
10332 else Newx (sockflags,fdoff+2,unsigned int);
10333 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10334 sockflagsize = fdoff + 2;
10336 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10337 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10346 * Clear the corresponding bit when the (possibly) socket stream is closed.
10347 * There still a small hole: we miss an implicit close which might occur
10348 * via freopen(). >> Todo
10350 /*{{{ int my_fclose(FILE *fp)*/
10351 int my_fclose(FILE *fp) {
10353 unsigned int fd = fileno(fp);
10354 unsigned int fdoff = fd / sizeof(unsigned int);
10356 if (sockflagsize && fdoff <= sockflagsize)
10357 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10365 * A simple fwrite replacement which outputs itmsz*nitm chars without
10366 * introducing record boundaries every itmsz chars.
10367 * We are using fputs, which depends on a terminating null. We may
10368 * well be writing binary data, so we need to accommodate not only
10369 * data with nulls sprinkled in the middle but also data with no null
10372 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10374 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10376 register char *cp, *end, *cpd, *data;
10377 register unsigned int fd = fileno(dest);
10378 register unsigned int fdoff = fd / sizeof(unsigned int);
10380 int bufsize = itmsz * nitm + 1;
10382 if (fdoff < sockflagsize &&
10383 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10384 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10388 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10389 memcpy( data, src, itmsz*nitm );
10390 data[itmsz*nitm] = '\0';
10392 end = data + itmsz * nitm;
10393 retval = (int) nitm; /* on success return # items written */
10396 while (cpd <= end) {
10397 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10398 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10400 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10404 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10407 } /* end of my_fwrite() */
10410 /*{{{ int my_flush(FILE *fp)*/
10412 Perl_my_flush(pTHX_ FILE *fp)
10415 if ((res = fflush(fp)) == 0 && fp) {
10416 #ifdef VMS_DO_SOCKETS
10418 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10420 res = fsync(fileno(fp));
10423 * If the flush succeeded but set end-of-file, we need to clear
10424 * the error because our caller may check ferror(). BTW, this
10425 * probably means we just flushed an empty file.
10427 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10434 * Here are replacements for the following Unix routines in the VMS environment:
10435 * getpwuid Get information for a particular UIC or UID
10436 * getpwnam Get information for a named user
10437 * getpwent Get information for each user in the rights database
10438 * setpwent Reset search to the start of the rights database
10439 * endpwent Finish searching for users in the rights database
10441 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10442 * (defined in pwd.h), which contains the following fields:-
10444 * char *pw_name; Username (in lower case)
10445 * char *pw_passwd; Hashed password
10446 * unsigned int pw_uid; UIC
10447 * unsigned int pw_gid; UIC group number
10448 * char *pw_unixdir; Default device/directory (VMS-style)
10449 * char *pw_gecos; Owner name
10450 * char *pw_dir; Default device/directory (Unix-style)
10451 * char *pw_shell; Default CLI name (eg. DCL)
10453 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10455 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10456 * not the UIC member number (eg. what's returned by getuid()),
10457 * getpwuid() can accept either as input (if uid is specified, the caller's
10458 * UIC group is used), though it won't recognise gid=0.
10460 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10461 * information about other users in your group or in other groups, respectively.
10462 * If the required privilege is not available, then these routines fill only
10463 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10466 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10469 /* sizes of various UAF record fields */
10470 #define UAI$S_USERNAME 12
10471 #define UAI$S_IDENT 31
10472 #define UAI$S_OWNER 31
10473 #define UAI$S_DEFDEV 31
10474 #define UAI$S_DEFDIR 63
10475 #define UAI$S_DEFCLI 31
10476 #define UAI$S_PWD 8
10478 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10479 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10480 (uic).uic$v_group != UIC$K_WILD_GROUP)
10482 static char __empty[]= "";
10483 static struct passwd __passwd_empty=
10484 {(char *) __empty, (char *) __empty, 0, 0,
10485 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10486 static int contxt= 0;
10487 static struct passwd __pwdcache;
10488 static char __pw_namecache[UAI$S_IDENT+1];
10491 * This routine does most of the work extracting the user information.
10493 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10496 unsigned char length;
10497 char pw_gecos[UAI$S_OWNER+1];
10499 static union uicdef uic;
10501 unsigned char length;
10502 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10505 unsigned char length;
10506 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10509 unsigned char length;
10510 char pw_shell[UAI$S_DEFCLI+1];
10512 static char pw_passwd[UAI$S_PWD+1];
10514 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10515 struct dsc$descriptor_s name_desc;
10516 unsigned long int sts;
10518 static struct itmlst_3 itmlst[]= {
10519 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
10520 {sizeof(uic), UAI$_UIC, &uic, &luic},
10521 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
10522 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
10523 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
10524 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
10525 {0, 0, NULL, NULL}};
10527 name_desc.dsc$w_length= strlen(name);
10528 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10529 name_desc.dsc$b_class= DSC$K_CLASS_S;
10530 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10532 /* Note that sys$getuai returns many fields as counted strings. */
10533 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10534 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10535 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10537 else { _ckvmssts(sts); }
10538 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
10540 if ((int) owner.length < lowner) lowner= (int) owner.length;
10541 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10542 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10543 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10544 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10545 owner.pw_gecos[lowner]= '\0';
10546 defdev.pw_dir[ldefdev+ldefdir]= '\0';
10547 defcli.pw_shell[ldefcli]= '\0';
10548 if (valid_uic(uic)) {
10549 pwd->pw_uid= uic.uic$l_uic;
10550 pwd->pw_gid= uic.uic$v_group;
10553 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10554 pwd->pw_passwd= pw_passwd;
10555 pwd->pw_gecos= owner.pw_gecos;
10556 pwd->pw_dir= defdev.pw_dir;
10557 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10558 pwd->pw_shell= defcli.pw_shell;
10559 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10561 ldir= strlen(pwd->pw_unixdir) - 1;
10562 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10565 strcpy(pwd->pw_unixdir, pwd->pw_dir);
10566 if (!decc_efs_case_preserve)
10567 __mystrtolower(pwd->pw_unixdir);
10572 * Get information for a named user.
10574 /*{{{struct passwd *getpwnam(char *name)*/
10575 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10577 struct dsc$descriptor_s name_desc;
10579 unsigned long int status, sts;
10581 __pwdcache = __passwd_empty;
10582 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10583 /* We still may be able to determine pw_uid and pw_gid */
10584 name_desc.dsc$w_length= strlen(name);
10585 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10586 name_desc.dsc$b_class= DSC$K_CLASS_S;
10587 name_desc.dsc$a_pointer= (char *) name;
10588 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10589 __pwdcache.pw_uid= uic.uic$l_uic;
10590 __pwdcache.pw_gid= uic.uic$v_group;
10593 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10594 set_vaxc_errno(sts);
10595 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10598 else { _ckvmssts(sts); }
10601 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10602 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10603 __pwdcache.pw_name= __pw_namecache;
10604 return &__pwdcache;
10605 } /* end of my_getpwnam() */
10609 * Get information for a particular UIC or UID.
10610 * Called by my_getpwent with uid=-1 to list all users.
10612 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10613 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10615 const $DESCRIPTOR(name_desc,__pw_namecache);
10616 unsigned short lname;
10618 unsigned long int status;
10620 if (uid == (unsigned int) -1) {
10622 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10623 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10624 set_vaxc_errno(status);
10625 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10629 else { _ckvmssts(status); }
10630 } while (!valid_uic (uic));
10633 uic.uic$l_uic= uid;
10634 if (!uic.uic$v_group)
10635 uic.uic$v_group= PerlProc_getgid();
10636 if (valid_uic(uic))
10637 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10638 else status = SS$_IVIDENT;
10639 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10640 status == RMS$_PRV) {
10641 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10644 else { _ckvmssts(status); }
10646 __pw_namecache[lname]= '\0';
10647 __mystrtolower(__pw_namecache);
10649 __pwdcache = __passwd_empty;
10650 __pwdcache.pw_name = __pw_namecache;
10652 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10653 The identifier's value is usually the UIC, but it doesn't have to be,
10654 so if we can, we let fillpasswd update this. */
10655 __pwdcache.pw_uid = uic.uic$l_uic;
10656 __pwdcache.pw_gid = uic.uic$v_group;
10658 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10659 return &__pwdcache;
10661 } /* end of my_getpwuid() */
10665 * Get information for next user.
10667 /*{{{struct passwd *my_getpwent()*/
10668 struct passwd *Perl_my_getpwent(pTHX)
10670 return (my_getpwuid((unsigned int) -1));
10675 * Finish searching rights database for users.
10677 /*{{{void my_endpwent()*/
10678 void Perl_my_endpwent(pTHX)
10681 _ckvmssts(sys$finish_rdb(&contxt));
10687 #ifdef HOMEGROWN_POSIX_SIGNALS
10688 /* Signal handling routines, pulled into the core from POSIX.xs.
10690 * We need these for threads, so they've been rolled into the core,
10691 * rather than left in POSIX.xs.
10693 * (DRS, Oct 23, 1997)
10696 /* sigset_t is atomic under VMS, so these routines are easy */
10697 /*{{{int my_sigemptyset(sigset_t *) */
10698 int my_sigemptyset(sigset_t *set) {
10699 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10700 *set = 0; return 0;
10705 /*{{{int my_sigfillset(sigset_t *)*/
10706 int my_sigfillset(sigset_t *set) {
10708 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10709 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10715 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10716 int my_sigaddset(sigset_t *set, int sig) {
10717 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10718 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10719 *set |= (1 << (sig - 1));
10725 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10726 int my_sigdelset(sigset_t *set, int sig) {
10727 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10728 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10729 *set &= ~(1 << (sig - 1));
10735 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10736 int my_sigismember(sigset_t *set, int sig) {
10737 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10738 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10739 return *set & (1 << (sig - 1));
10744 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10745 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10748 /* If set and oset are both null, then things are badly wrong. Bail out. */
10749 if ((oset == NULL) && (set == NULL)) {
10750 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10754 /* If set's null, then we're just handling a fetch. */
10756 tempmask = sigblock(0);
10761 tempmask = sigsetmask(*set);
10764 tempmask = sigblock(*set);
10767 tempmask = sigblock(0);
10768 sigsetmask(*oset & ~tempmask);
10771 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10776 /* Did they pass us an oset? If so, stick our holding mask into it */
10783 #endif /* HOMEGROWN_POSIX_SIGNALS */
10786 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10787 * my_utime(), and flex_stat(), all of which operate on UTC unless
10788 * VMSISH_TIMES is true.
10790 /* method used to handle UTC conversions:
10791 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10793 static int gmtime_emulation_type;
10794 /* number of secs to add to UTC POSIX-style time to get local time */
10795 static long int utc_offset_secs;
10797 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10798 * in vmsish.h. #undef them here so we can call the CRTL routines
10807 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10808 * qualifier with the extern prefix pragma. This provisional
10809 * hack circumvents this prefix pragma problem in previous
10812 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10813 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10814 # pragma __extern_prefix save
10815 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10816 # define gmtime decc$__utctz_gmtime
10817 # define localtime decc$__utctz_localtime
10818 # define time decc$__utc_time
10819 # pragma __extern_prefix restore
10821 struct tm *gmtime(), *localtime();
10827 static time_t toutc_dst(time_t loc) {
10830 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10831 loc -= utc_offset_secs;
10832 if (rsltmp->tm_isdst) loc -= 3600;
10835 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10836 ((gmtime_emulation_type || my_time(NULL)), \
10837 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10838 ((secs) - utc_offset_secs))))
10840 static time_t toloc_dst(time_t utc) {
10843 utc += utc_offset_secs;
10844 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10845 if (rsltmp->tm_isdst) utc += 3600;
10848 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10849 ((gmtime_emulation_type || my_time(NULL)), \
10850 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10851 ((secs) + utc_offset_secs))))
10853 #ifndef RTL_USES_UTC
10856 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10857 DST starts on 1st sun of april at 02:00 std time
10858 ends on last sun of october at 02:00 dst time
10859 see the UCX management command reference, SET CONFIG TIMEZONE
10860 for formatting info.
10862 No, it's not as general as it should be, but then again, NOTHING
10863 will handle UK times in a sensible way.
10868 parse the DST start/end info:
10869 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10873 tz_parse_startend(char *s, struct tm *w, int *past)
10875 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10876 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10881 if (!past) return 0;
10884 if (w->tm_year % 4 == 0) ly = 1;
10885 if (w->tm_year % 100 == 0) ly = 0;
10886 if (w->tm_year+1900 % 400 == 0) ly = 1;
10889 dozjd = isdigit(*s);
10890 if (*s == 'J' || *s == 'j' || dozjd) {
10891 if (!dozjd && !isdigit(*++s)) return 0;
10894 d = d*10 + *s++ - '0';
10896 d = d*10 + *s++ - '0';
10899 if (d == 0) return 0;
10900 if (d > 366) return 0;
10902 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10905 } else if (*s == 'M' || *s == 'm') {
10906 if (!isdigit(*++s)) return 0;
10908 if (isdigit(*s)) m = 10*m + *s++ - '0';
10909 if (*s != '.') return 0;
10910 if (!isdigit(*++s)) return 0;
10912 if (n < 1 || n > 5) return 0;
10913 if (*s != '.') return 0;
10914 if (!isdigit(*++s)) return 0;
10916 if (d > 6) return 0;
10920 if (!isdigit(*++s)) return 0;
10922 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10924 if (!isdigit(*++s)) return 0;
10926 if (isdigit(*s)) min = 10*min + *s++ - '0';
10928 if (!isdigit(*++s)) return 0;
10930 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10940 if (w->tm_yday < d) goto before;
10941 if (w->tm_yday > d) goto after;
10943 if (w->tm_mon+1 < m) goto before;
10944 if (w->tm_mon+1 > m) goto after;
10946 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10947 k = d - j; /* mday of first d */
10948 if (k <= 0) k += 7;
10949 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10950 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10951 if (w->tm_mday < k) goto before;
10952 if (w->tm_mday > k) goto after;
10955 if (w->tm_hour < hour) goto before;
10956 if (w->tm_hour > hour) goto after;
10957 if (w->tm_min < min) goto before;
10958 if (w->tm_min > min) goto after;
10959 if (w->tm_sec < sec) goto before;
10973 /* parse the offset: (+|-)hh[:mm[:ss]] */
10976 tz_parse_offset(char *s, int *offset)
10978 int hour = 0, min = 0, sec = 0;
10981 if (!offset) return 0;
10983 if (*s == '-') {neg++; s++;}
10984 if (*s == '+') s++;
10985 if (!isdigit(*s)) return 0;
10987 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10988 if (hour > 24) return 0;
10990 if (!isdigit(*++s)) return 0;
10992 if (isdigit(*s)) min = min*10 + (*s++ - '0');
10993 if (min > 59) return 0;
10995 if (!isdigit(*++s)) return 0;
10997 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
10998 if (sec > 59) return 0;
11002 *offset = (hour*60+min)*60 + sec;
11003 if (neg) *offset = -*offset;
11008 input time is w, whatever type of time the CRTL localtime() uses.
11009 sets dst, the zone, and the gmtoff (seconds)
11011 caches the value of TZ and UCX$TZ env variables; note that
11012 my_setenv looks for these and sets a flag if they're changed
11015 We have to watch out for the "australian" case (dst starts in
11016 october, ends in april)...flagged by "reverse" and checked by
11017 scanning through the months of the previous year.
11022 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11027 char *dstzone, *tz, *s_start, *s_end;
11028 int std_off, dst_off, isdst;
11029 int y, dststart, dstend;
11030 static char envtz[1025]; /* longer than any logical, symbol, ... */
11031 static char ucxtz[1025];
11032 static char reversed = 0;
11038 reversed = -1; /* flag need to check */
11039 envtz[0] = ucxtz[0] = '\0';
11040 tz = my_getenv("TZ",0);
11041 if (tz) strcpy(envtz, tz);
11042 tz = my_getenv("UCX$TZ",0);
11043 if (tz) strcpy(ucxtz, tz);
11044 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11047 if (!*tz) tz = ucxtz;
11050 while (isalpha(*s)) s++;
11051 s = tz_parse_offset(s, &std_off);
11053 if (!*s) { /* no DST, hurray we're done! */
11059 while (isalpha(*s)) s++;
11060 s2 = tz_parse_offset(s, &dst_off);
11064 dst_off = std_off - 3600;
11067 if (!*s) { /* default dst start/end?? */
11068 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11069 s = strchr(ucxtz,',');
11071 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11073 if (*s != ',') return 0;
11076 when = _toutc(when); /* convert to utc */
11077 when = when - std_off; /* convert to pseudolocal time*/
11079 w2 = localtime(&when);
11082 s = tz_parse_startend(s_start,w2,&dststart);
11084 if (*s != ',') return 0;
11087 when = _toutc(when); /* convert to utc */
11088 when = when - dst_off; /* convert to pseudolocal time*/
11089 w2 = localtime(&when);
11090 if (w2->tm_year != y) { /* spans a year, just check one time */
11091 when += dst_off - std_off;
11092 w2 = localtime(&when);
11095 s = tz_parse_startend(s_end,w2,&dstend);
11098 if (reversed == -1) { /* need to check if start later than end */
11102 if (when < 2*365*86400) {
11103 when += 2*365*86400;
11107 w2 =localtime(&when);
11108 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11110 for (j = 0; j < 12; j++) {
11111 w2 =localtime(&when);
11112 tz_parse_startend(s_start,w2,&ds);
11113 tz_parse_startend(s_end,w2,&de);
11114 if (ds != de) break;
11118 if (de && !ds) reversed = 1;
11121 isdst = dststart && !dstend;
11122 if (reversed) isdst = dststart || !dstend;
11125 if (dst) *dst = isdst;
11126 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11127 if (isdst) tz = dstzone;
11129 while(isalpha(*tz)) *zone++ = *tz++;
11135 #endif /* !RTL_USES_UTC */
11137 /* my_time(), my_localtime(), my_gmtime()
11138 * By default traffic in UTC time values, using CRTL gmtime() or
11139 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11140 * Note: We need to use these functions even when the CRTL has working
11141 * UTC support, since they also handle C<use vmsish qw(times);>
11143 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11144 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11147 /*{{{time_t my_time(time_t *timep)*/
11148 time_t Perl_my_time(pTHX_ time_t *timep)
11153 if (gmtime_emulation_type == 0) {
11155 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11156 /* results of calls to gmtime() and localtime() */
11157 /* for same &base */
11159 gmtime_emulation_type++;
11160 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11161 char off[LNM$C_NAMLENGTH+1];;
11163 gmtime_emulation_type++;
11164 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11165 gmtime_emulation_type++;
11166 utc_offset_secs = 0;
11167 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11169 else { utc_offset_secs = atol(off); }
11171 else { /* We've got a working gmtime() */
11172 struct tm gmt, local;
11175 tm_p = localtime(&base);
11177 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11178 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11179 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11180 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11185 # ifdef VMSISH_TIME
11186 # ifdef RTL_USES_UTC
11187 if (VMSISH_TIME) when = _toloc(when);
11189 if (!VMSISH_TIME) when = _toutc(when);
11192 if (timep != NULL) *timep = when;
11195 } /* end of my_time() */
11199 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11201 Perl_my_gmtime(pTHX_ const time_t *timep)
11207 if (timep == NULL) {
11208 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11211 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11214 # ifdef VMSISH_TIME
11215 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11217 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11218 return gmtime(&when);
11220 /* CRTL localtime() wants local time as input, so does no tz correction */
11221 rsltmp = localtime(&when);
11222 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11225 } /* end of my_gmtime() */
11229 /*{{{struct tm *my_localtime(const time_t *timep)*/
11231 Perl_my_localtime(pTHX_ const time_t *timep)
11233 time_t when, whenutc;
11237 if (timep == NULL) {
11238 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11241 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11242 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11245 # ifdef RTL_USES_UTC
11246 # ifdef VMSISH_TIME
11247 if (VMSISH_TIME) when = _toutc(when);
11249 /* CRTL localtime() wants UTC as input, does tz correction itself */
11250 return localtime(&when);
11252 # else /* !RTL_USES_UTC */
11254 # ifdef VMSISH_TIME
11255 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11256 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
11259 #ifndef RTL_USES_UTC
11260 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
11261 when = whenutc - offset; /* pseudolocal time*/
11264 /* CRTL localtime() wants local time as input, so does no tz correction */
11265 rsltmp = localtime(&when);
11266 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11270 } /* end of my_localtime() */
11273 /* Reset definitions for later calls */
11274 #define gmtime(t) my_gmtime(t)
11275 #define localtime(t) my_localtime(t)
11276 #define time(t) my_time(t)
11279 /* my_utime - update modification/access time of a file
11281 * VMS 7.3 and later implementation
11282 * Only the UTC translation is home-grown. The rest is handled by the
11283 * CRTL utime(), which will take into account the relevant feature
11284 * logicals and ODS-5 volume characteristics for true access times.
11286 * pre VMS 7.3 implementation:
11287 * The calling sequence is identical to POSIX utime(), but under
11288 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11289 * not maintain access times. Restrictions differ from the POSIX
11290 * definition in that the time can be changed as long as the
11291 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11292 * no separate checks are made to insure that the caller is the
11293 * owner of the file or has special privs enabled.
11294 * Code here is based on Joe Meadows' FILE utility.
11298 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11299 * to VMS epoch (01-JAN-1858 00:00:00.00)
11300 * in 100 ns intervals.
11302 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11304 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11305 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11307 #if __CRTL_VER >= 70300000
11308 struct utimbuf utc_utimes, *utc_utimesp;
11310 if (utimes != NULL) {
11311 utc_utimes.actime = utimes->actime;
11312 utc_utimes.modtime = utimes->modtime;
11313 # ifdef VMSISH_TIME
11314 /* If input was local; convert to UTC for sys svc */
11316 utc_utimes.actime = _toutc(utimes->actime);
11317 utc_utimes.modtime = _toutc(utimes->modtime);
11320 utc_utimesp = &utc_utimes;
11323 utc_utimesp = NULL;
11326 return utime(file, utc_utimesp);
11328 #else /* __CRTL_VER < 70300000 */
11332 long int bintime[2], len = 2, lowbit, unixtime,
11333 secscale = 10000000; /* seconds --> 100 ns intervals */
11334 unsigned long int chan, iosb[2], retsts;
11335 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11336 struct FAB myfab = cc$rms_fab;
11337 struct NAM mynam = cc$rms_nam;
11338 #if defined (__DECC) && defined (__VAX)
11339 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11340 * at least through VMS V6.1, which causes a type-conversion warning.
11342 # pragma message save
11343 # pragma message disable cvtdiftypes
11345 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11346 struct fibdef myfib;
11347 #if defined (__DECC) && defined (__VAX)
11348 /* This should be right after the declaration of myatr, but due
11349 * to a bug in VAX DEC C, this takes effect a statement early.
11351 # pragma message restore
11353 /* cast ok for read only parameter */
11354 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11355 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11356 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11358 if (file == NULL || *file == '\0') {
11359 SETERRNO(ENOENT, LIB$_INVARG);
11363 /* Convert to VMS format ensuring that it will fit in 255 characters */
11364 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11365 SETERRNO(ENOENT, LIB$_INVARG);
11368 if (utimes != NULL) {
11369 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11370 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11371 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11372 * as input, we force the sign bit to be clear by shifting unixtime right
11373 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11375 lowbit = (utimes->modtime & 1) ? secscale : 0;
11376 unixtime = (long int) utimes->modtime;
11377 # ifdef VMSISH_TIME
11378 /* If input was UTC; convert to local for sys svc */
11379 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11381 unixtime >>= 1; secscale <<= 1;
11382 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11383 if (!(retsts & 1)) {
11384 SETERRNO(EVMSERR, retsts);
11387 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11388 if (!(retsts & 1)) {
11389 SETERRNO(EVMSERR, retsts);
11394 /* Just get the current time in VMS format directly */
11395 retsts = sys$gettim(bintime);
11396 if (!(retsts & 1)) {
11397 SETERRNO(EVMSERR, retsts);
11402 myfab.fab$l_fna = vmsspec;
11403 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11404 myfab.fab$l_nam = &mynam;
11405 mynam.nam$l_esa = esa;
11406 mynam.nam$b_ess = (unsigned char) sizeof esa;
11407 mynam.nam$l_rsa = rsa;
11408 mynam.nam$b_rss = (unsigned char) sizeof rsa;
11409 if (decc_efs_case_preserve)
11410 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11412 /* Look for the file to be affected, letting RMS parse the file
11413 * specification for us as well. I have set errno using only
11414 * values documented in the utime() man page for VMS POSIX.
11416 retsts = sys$parse(&myfab,0,0);
11417 if (!(retsts & 1)) {
11418 set_vaxc_errno(retsts);
11419 if (retsts == RMS$_PRV) set_errno(EACCES);
11420 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11421 else set_errno(EVMSERR);
11424 retsts = sys$search(&myfab,0,0);
11425 if (!(retsts & 1)) {
11426 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11427 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11428 set_vaxc_errno(retsts);
11429 if (retsts == RMS$_PRV) set_errno(EACCES);
11430 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11431 else set_errno(EVMSERR);
11435 devdsc.dsc$w_length = mynam.nam$b_dev;
11436 /* cast ok for read only parameter */
11437 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11439 retsts = sys$assign(&devdsc,&chan,0,0);
11440 if (!(retsts & 1)) {
11441 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11442 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11443 set_vaxc_errno(retsts);
11444 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11445 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11446 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11447 else set_errno(EVMSERR);
11451 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11452 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11454 memset((void *) &myfib, 0, sizeof myfib);
11455 #if defined(__DECC) || defined(__DECCXX)
11456 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11457 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11458 /* This prevents the revision time of the file being reset to the current
11459 * time as a result of our IO$_MODIFY $QIO. */
11460 myfib.fib$l_acctl = FIB$M_NORECORD;
11462 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11463 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11464 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11466 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11467 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11468 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11469 _ckvmssts(sys$dassgn(chan));
11470 if (retsts & 1) retsts = iosb[0];
11471 if (!(retsts & 1)) {
11472 set_vaxc_errno(retsts);
11473 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11474 else set_errno(EVMSERR);
11480 #endif /* #if __CRTL_VER >= 70300000 */
11482 } /* end of my_utime() */
11486 * flex_stat, flex_lstat, flex_fstat
11487 * basic stat, but gets it right when asked to stat
11488 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11491 #ifndef _USE_STD_STAT
11492 /* encode_dev packs a VMS device name string into an integer to allow
11493 * simple comparisons. This can be used, for example, to check whether two
11494 * files are located on the same device, by comparing their encoded device
11495 * names. Even a string comparison would not do, because stat() reuses the
11496 * device name buffer for each call; so without encode_dev, it would be
11497 * necessary to save the buffer and use strcmp (this would mean a number of
11498 * changes to the standard Perl code, to say nothing of what a Perl script
11499 * would have to do.
11501 * The device lock id, if it exists, should be unique (unless perhaps compared
11502 * with lock ids transferred from other nodes). We have a lock id if the disk is
11503 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11504 * device names. Thus we use the lock id in preference, and only if that isn't
11505 * available, do we try to pack the device name into an integer (flagged by
11506 * the sign bit (LOCKID_MASK) being set).
11508 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11509 * name and its encoded form, but it seems very unlikely that we will find
11510 * two files on different disks that share the same encoded device names,
11511 * and even more remote that they will share the same file id (if the test
11512 * is to check for the same file).
11514 * A better method might be to use sys$device_scan on the first call, and to
11515 * search for the device, returning an index into the cached array.
11516 * The number returned would be more intelligible.
11517 * This is probably not worth it, and anyway would take quite a bit longer
11518 * on the first call.
11520 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11521 static mydev_t encode_dev (pTHX_ const char *dev)
11524 unsigned long int f;
11529 if (!dev || !dev[0]) return 0;
11533 struct dsc$descriptor_s dev_desc;
11534 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11536 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11537 can try that first. */
11538 dev_desc.dsc$w_length = strlen (dev);
11539 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11540 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11541 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11542 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11543 if (!$VMS_STATUS_SUCCESS(status)) {
11545 case SS$_NOSUCHDEV:
11546 SETERRNO(ENODEV, status);
11552 if (lockid) return (lockid & ~LOCKID_MASK);
11556 /* Otherwise we try to encode the device name */
11560 for (q = dev + strlen(dev); q--; q >= dev) {
11565 else if (isalpha (toupper (*q)))
11566 c= toupper (*q) - 'A' + (char)10;
11568 continue; /* Skip '$'s */
11570 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11572 enc += f * (unsigned long int) c;
11574 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11576 } /* end of encode_dev() */
11577 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11578 device_no = encode_dev(aTHX_ devname)
11580 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11581 device_no = new_dev_no
11585 is_null_device(name)
11588 if (decc_bug_devnull != 0) {
11589 if (strncmp("/dev/null", name, 9) == 0)
11592 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11593 The underscore prefix, controller letter, and unit number are
11594 independently optional; for our purposes, the colon punctuation
11595 is not. The colon can be trailed by optional directory and/or
11596 filename, but two consecutive colons indicates a nodename rather
11597 than a device. [pr] */
11598 if (*name == '_') ++name;
11599 if (tolower(*name++) != 'n') return 0;
11600 if (tolower(*name++) != 'l') return 0;
11601 if (tolower(*name) == 'a') ++name;
11602 if (*name == '0') ++name;
11603 return (*name++ == ':') && (*name != ':');
11608 Perl_cando_by_name_int
11609 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11611 char usrname[L_cuserid];
11612 struct dsc$descriptor_s usrdsc =
11613 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11614 char *vmsname = NULL, *fileified = NULL;
11615 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11616 unsigned short int retlen, trnlnm_iter_count;
11617 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11618 union prvdef curprv;
11619 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11620 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11621 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11622 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11623 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11625 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11627 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11629 static int profile_context = -1;
11631 if (!fname || !*fname) return FALSE;
11633 /* Make sure we expand logical names, since sys$check_access doesn't */
11634 fileified = PerlMem_malloc(VMS_MAXRSS);
11635 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11636 if (!strpbrk(fname,"/]>:")) {
11637 strcpy(fileified,fname);
11638 trnlnm_iter_count = 0;
11639 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11640 trnlnm_iter_count++;
11641 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11646 vmsname = PerlMem_malloc(VMS_MAXRSS);
11647 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11648 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11649 /* Don't know if already in VMS format, so make sure */
11650 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11651 PerlMem_free(fileified);
11652 PerlMem_free(vmsname);
11657 strcpy(vmsname,fname);
11660 /* sys$check_access needs a file spec, not a directory spec.
11661 * Don't use flex_stat here, as that depends on thread context
11662 * having been initialized, and we may get here during startup.
11665 retlen = namdsc.dsc$w_length = strlen(vmsname);
11666 if (vmsname[retlen-1] == ']'
11667 || vmsname[retlen-1] == '>'
11668 || vmsname[retlen-1] == ':'
11669 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11671 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11672 PerlMem_free(fileified);
11673 PerlMem_free(vmsname);
11682 retlen = namdsc.dsc$w_length = strlen(fname);
11683 namdsc.dsc$a_pointer = (char *)fname;
11686 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11687 access = ARM$M_EXECUTE;
11688 flags = CHP$M_READ;
11690 case S_IRUSR: case S_IRGRP: case S_IROTH:
11691 access = ARM$M_READ;
11692 flags = CHP$M_READ | CHP$M_USEREADALL;
11694 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11695 access = ARM$M_WRITE;
11696 flags = CHP$M_READ | CHP$M_WRITE;
11698 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11699 access = ARM$M_DELETE;
11700 flags = CHP$M_READ | CHP$M_WRITE;
11703 if (fileified != NULL)
11704 PerlMem_free(fileified);
11705 if (vmsname != NULL)
11706 PerlMem_free(vmsname);
11710 /* Before we call $check_access, create a user profile with the current
11711 * process privs since otherwise it just uses the default privs from the
11712 * UAF and might give false positives or negatives. This only works on
11713 * VMS versions v6.0 and later since that's when sys$create_user_profile
11714 * became available.
11717 /* get current process privs and username */
11718 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11719 _ckvmssts(iosb[0]);
11721 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11723 /* find out the space required for the profile */
11724 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11725 &usrprodsc.dsc$w_length,&profile_context));
11727 /* allocate space for the profile and get it filled in */
11728 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11729 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11730 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11731 &usrprodsc.dsc$w_length,&profile_context));
11733 /* use the profile to check access to the file; free profile & analyze results */
11734 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11735 PerlMem_free(usrprodsc.dsc$a_pointer);
11736 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11740 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11744 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11745 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11746 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11747 set_vaxc_errno(retsts);
11748 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11749 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11750 else set_errno(ENOENT);
11751 if (fileified != NULL)
11752 PerlMem_free(fileified);
11753 if (vmsname != NULL)
11754 PerlMem_free(vmsname);
11757 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11758 if (fileified != NULL)
11759 PerlMem_free(fileified);
11760 if (vmsname != NULL)
11761 PerlMem_free(vmsname);
11766 if (fileified != NULL)
11767 PerlMem_free(fileified);
11768 if (vmsname != NULL)
11769 PerlMem_free(vmsname);
11770 return FALSE; /* Should never get here */
11774 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11775 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11776 * subset of the applicable information.
11779 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11781 return cando_by_name_int
11782 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11783 } /* end of cando() */
11787 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11789 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11791 return cando_by_name_int(bit, effective, fname, 0);
11793 } /* end of cando_by_name() */
11797 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11799 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11801 if (!fstat(fd,(stat_t *) statbufp)) {
11803 char *vms_filename;
11804 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11805 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11807 /* Save name for cando by name in VMS format */
11808 cptr = getname(fd, vms_filename, 1);
11810 /* This should not happen, but just in case */
11811 if (cptr == NULL) {
11812 statbufp->st_devnam[0] = 0;
11815 /* Make sure that the saved name fits in 255 characters */
11816 cptr = do_rmsexpand
11818 statbufp->st_devnam,
11821 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11825 statbufp->st_devnam[0] = 0;
11827 PerlMem_free(vms_filename);
11829 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11831 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11833 # ifdef RTL_USES_UTC
11834 # ifdef VMSISH_TIME
11836 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11837 statbufp->st_atime = _toloc(statbufp->st_atime);
11838 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11842 # ifdef VMSISH_TIME
11843 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11847 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11848 statbufp->st_atime = _toutc(statbufp->st_atime);
11849 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11856 } /* end of flex_fstat() */
11859 #if !defined(__VAX) && __CRTL_VER >= 80200000
11867 #define lstat(_x, _y) stat(_x, _y)
11870 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11873 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11875 char fileified[VMS_MAXRSS];
11876 char temp_fspec[VMS_MAXRSS];
11879 int saved_errno, saved_vaxc_errno;
11881 if (!fspec) return retval;
11882 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11883 strcpy(temp_fspec, fspec);
11885 if (decc_bug_devnull != 0) {
11886 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11887 memset(statbufp,0,sizeof *statbufp);
11888 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11889 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11890 statbufp->st_uid = 0x00010001;
11891 statbufp->st_gid = 0x0001;
11892 time((time_t *)&statbufp->st_mtime);
11893 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11898 /* Try for a directory name first. If fspec contains a filename without
11899 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11900 * and sea:[wine.dark]water. exist, we prefer the directory here.
11901 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11902 * not sea:[wine.dark]., if the latter exists. If the intended target is
11903 * the file with null type, specify this by calling flex_stat() with
11904 * a '.' at the end of fspec.
11906 * If we are in Posix filespec mode, accept the filename as is.
11910 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11911 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11912 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11914 if (!decc_efs_charset)
11915 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11918 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11919 if (decc_posix_compliant_pathnames == 0) {
11921 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11922 if (lstat_flag == 0)
11923 retval = stat(fileified,(stat_t *) statbufp);
11925 retval = lstat(fileified,(stat_t *) statbufp);
11926 save_spec = fileified;
11929 if (lstat_flag == 0)
11930 retval = stat(temp_fspec,(stat_t *) statbufp);
11932 retval = lstat(temp_fspec,(stat_t *) statbufp);
11933 save_spec = temp_fspec;
11936 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11937 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11938 * and lstat was working correctly for the same file.
11939 * The only syntax that was working for stat was "foo:[bar]t.dir".
11941 * Other directories with the same syntax worked fine.
11942 * So work around the problem when it shows up here.
11945 int save_errno = errno;
11946 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11947 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11948 retval = stat(fileified, (stat_t *) statbufp);
11949 save_spec = fileified;
11952 /* Restore the errno value if third stat does not succeed */
11954 errno = save_errno;
11956 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11958 if (lstat_flag == 0)
11959 retval = stat(temp_fspec,(stat_t *) statbufp);
11961 retval = lstat(temp_fspec,(stat_t *) statbufp);
11962 save_spec = temp_fspec;
11966 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11967 /* As you were... */
11968 if (!decc_efs_charset)
11969 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11974 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11976 /* If this is an lstat, do not follow the link */
11978 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11980 cptr = do_rmsexpand
11981 (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
11983 statbufp->st_devnam[0] = 0;
11985 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11987 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11988 # ifdef RTL_USES_UTC
11989 # ifdef VMSISH_TIME
11991 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11992 statbufp->st_atime = _toloc(statbufp->st_atime);
11993 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11997 # ifdef VMSISH_TIME
11998 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12002 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12003 statbufp->st_atime = _toutc(statbufp->st_atime);
12004 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12008 /* If we were successful, leave errno where we found it */
12009 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12012 } /* end of flex_stat_int() */
12015 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12017 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12019 return flex_stat_int(fspec, statbufp, 0);
12023 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12025 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12027 return flex_stat_int(fspec, statbufp, 1);
12032 /*{{{char *my_getlogin()*/
12033 /* VMS cuserid == Unix getlogin, except calling sequence */
12037 static char user[L_cuserid];
12038 return cuserid(user);
12043 /* rmscopy - copy a file using VMS RMS routines
12045 * Copies contents and attributes of spec_in to spec_out, except owner
12046 * and protection information. Name and type of spec_in are used as
12047 * defaults for spec_out. The third parameter specifies whether rmscopy()
12048 * should try to propagate timestamps from the input file to the output file.
12049 * If it is less than 0, no timestamps are preserved. If it is 0, then
12050 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12051 * propagated to the output file at creation iff the output file specification
12052 * did not contain an explicit name or type, and the revision date is always
12053 * updated at the end of the copy operation. If it is greater than 0, then
12054 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12055 * other than the revision date should be propagated, and bit 1 indicates
12056 * that the revision date should be propagated.
12058 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12060 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12061 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12062 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12063 * as part of the Perl standard distribution under the terms of the
12064 * GNU General Public License or the Perl Artistic License. Copies
12065 * of each may be found in the Perl standard distribution.
12067 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12069 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12071 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12072 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12073 unsigned long int i, sts, sts2;
12075 struct FAB fab_in, fab_out;
12076 struct RAB rab_in, rab_out;
12077 rms_setup_nam(nam);
12078 rms_setup_nam(nam_out);
12079 struct XABDAT xabdat;
12080 struct XABFHC xabfhc;
12081 struct XABRDT xabrdt;
12082 struct XABSUM xabsum;
12084 vmsin = PerlMem_malloc(VMS_MAXRSS);
12085 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12086 vmsout = PerlMem_malloc(VMS_MAXRSS);
12087 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12088 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12089 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12090 PerlMem_free(vmsin);
12091 PerlMem_free(vmsout);
12092 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12096 esa = PerlMem_malloc(VMS_MAXRSS);
12097 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12099 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12100 esal = PerlMem_malloc(VMS_MAXRSS);
12101 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12103 fab_in = cc$rms_fab;
12104 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12105 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12106 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12107 fab_in.fab$l_fop = FAB$M_SQO;
12108 rms_bind_fab_nam(fab_in, nam);
12109 fab_in.fab$l_xab = (void *) &xabdat;
12111 rsa = PerlMem_malloc(VMS_MAXRSS);
12112 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12114 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12115 rsal = PerlMem_malloc(VMS_MAXRSS);
12116 if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12118 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12119 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12120 rms_nam_esl(nam) = 0;
12121 rms_nam_rsl(nam) = 0;
12122 rms_nam_esll(nam) = 0;
12123 rms_nam_rsll(nam) = 0;
12124 #ifdef NAM$M_NO_SHORT_UPCASE
12125 if (decc_efs_case_preserve)
12126 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12129 xabdat = cc$rms_xabdat; /* To get creation date */
12130 xabdat.xab$l_nxt = (void *) &xabfhc;
12132 xabfhc = cc$rms_xabfhc; /* To get record length */
12133 xabfhc.xab$l_nxt = (void *) &xabsum;
12135 xabsum = cc$rms_xabsum; /* To get key and area information */
12137 if (!((sts = sys$open(&fab_in)) & 1)) {
12138 PerlMem_free(vmsin);
12139 PerlMem_free(vmsout);
12142 PerlMem_free(esal);
12145 PerlMem_free(rsal);
12146 set_vaxc_errno(sts);
12148 case RMS$_FNF: case RMS$_DNF:
12149 set_errno(ENOENT); break;
12151 set_errno(ENOTDIR); break;
12153 set_errno(ENODEV); break;
12155 set_errno(EINVAL); break;
12157 set_errno(EACCES); break;
12159 set_errno(EVMSERR);
12166 fab_out.fab$w_ifi = 0;
12167 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12168 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12169 fab_out.fab$l_fop = FAB$M_SQO;
12170 rms_bind_fab_nam(fab_out, nam_out);
12171 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12172 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12173 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12174 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12175 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12176 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12177 if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12180 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12181 esal_out = PerlMem_malloc(VMS_MAXRSS);
12182 if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12183 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12184 if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12186 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12187 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12189 if (preserve_dates == 0) { /* Act like DCL COPY */
12190 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12191 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12192 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12193 PerlMem_free(vmsin);
12194 PerlMem_free(vmsout);
12197 PerlMem_free(esal);
12200 PerlMem_free(rsal);
12201 PerlMem_free(esa_out);
12202 if (esal_out != NULL)
12203 PerlMem_free(esal_out);
12204 PerlMem_free(rsa_out);
12205 if (rsal_out != NULL)
12206 PerlMem_free(rsal_out);
12207 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12208 set_vaxc_errno(sts);
12211 fab_out.fab$l_xab = (void *) &xabdat;
12212 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12213 preserve_dates = 1;
12215 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12216 preserve_dates =0; /* bitmask from this point forward */
12218 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12219 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12220 PerlMem_free(vmsin);
12221 PerlMem_free(vmsout);
12224 PerlMem_free(esal);
12227 PerlMem_free(rsal);
12228 PerlMem_free(esa_out);
12229 if (esal_out != NULL)
12230 PerlMem_free(esal_out);
12231 PerlMem_free(rsa_out);
12232 if (rsal_out != NULL)
12233 PerlMem_free(rsal_out);
12234 set_vaxc_errno(sts);
12237 set_errno(ENOENT); break;
12239 set_errno(ENOTDIR); break;
12241 set_errno(ENODEV); break;
12243 set_errno(EINVAL); break;
12245 set_errno(EACCES); break;
12247 set_errno(EVMSERR);
12251 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12252 if (preserve_dates & 2) {
12253 /* sys$close() will process xabrdt, not xabdat */
12254 xabrdt = cc$rms_xabrdt;
12256 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12258 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12259 * is unsigned long[2], while DECC & VAXC use a struct */
12260 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12262 fab_out.fab$l_xab = (void *) &xabrdt;
12265 ubf = PerlMem_malloc(32256);
12266 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12267 rab_in = cc$rms_rab;
12268 rab_in.rab$l_fab = &fab_in;
12269 rab_in.rab$l_rop = RAB$M_BIO;
12270 rab_in.rab$l_ubf = ubf;
12271 rab_in.rab$w_usz = 32256;
12272 if (!((sts = sys$connect(&rab_in)) & 1)) {
12273 sys$close(&fab_in); sys$close(&fab_out);
12274 PerlMem_free(vmsin);
12275 PerlMem_free(vmsout);
12279 PerlMem_free(esal);
12282 PerlMem_free(rsal);
12283 PerlMem_free(esa_out);
12284 if (esal_out != NULL)
12285 PerlMem_free(esal_out);
12286 PerlMem_free(rsa_out);
12287 if (rsal_out != NULL)
12288 PerlMem_free(rsal_out);
12289 set_errno(EVMSERR); set_vaxc_errno(sts);
12293 rab_out = cc$rms_rab;
12294 rab_out.rab$l_fab = &fab_out;
12295 rab_out.rab$l_rbf = ubf;
12296 if (!((sts = sys$connect(&rab_out)) & 1)) {
12297 sys$close(&fab_in); sys$close(&fab_out);
12298 PerlMem_free(vmsin);
12299 PerlMem_free(vmsout);
12303 PerlMem_free(esal);
12306 PerlMem_free(rsal);
12307 PerlMem_free(esa_out);
12308 if (esal_out != NULL)
12309 PerlMem_free(esal_out);
12310 PerlMem_free(rsa_out);
12311 if (rsal_out != NULL)
12312 PerlMem_free(rsal_out);
12313 set_errno(EVMSERR); set_vaxc_errno(sts);
12317 while ((sts = sys$read(&rab_in))) { /* always true */
12318 if (sts == RMS$_EOF) break;
12319 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12320 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12321 sys$close(&fab_in); sys$close(&fab_out);
12322 PerlMem_free(vmsin);
12323 PerlMem_free(vmsout);
12327 PerlMem_free(esal);
12330 PerlMem_free(rsal);
12331 PerlMem_free(esa_out);
12332 if (esal_out != NULL)
12333 PerlMem_free(esal_out);
12334 PerlMem_free(rsa_out);
12335 if (rsal_out != NULL)
12336 PerlMem_free(rsal_out);
12337 set_errno(EVMSERR); set_vaxc_errno(sts);
12343 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12344 sys$close(&fab_in); sys$close(&fab_out);
12345 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12347 PerlMem_free(vmsin);
12348 PerlMem_free(vmsout);
12352 PerlMem_free(esal);
12355 PerlMem_free(rsal);
12356 PerlMem_free(esa_out);
12357 if (esal_out != NULL)
12358 PerlMem_free(esal_out);
12359 PerlMem_free(rsa_out);
12360 if (rsal_out != NULL)
12361 PerlMem_free(rsal_out);
12364 set_errno(EVMSERR); set_vaxc_errno(sts);
12370 } /* end of rmscopy() */
12374 /*** The following glue provides 'hooks' to make some of the routines
12375 * from this file available from Perl. These routines are sufficiently
12376 * basic, and are required sufficiently early in the build process,
12377 * that's it's nice to have them available to miniperl as well as the
12378 * full Perl, so they're set up here instead of in an extension. The
12379 * Perl code which handles importation of these names into a given
12380 * package lives in [.VMS]Filespec.pm in @INC.
12384 rmsexpand_fromperl(pTHX_ CV *cv)
12387 char *fspec, *defspec = NULL, *rslt;
12389 int fs_utf8, dfs_utf8;
12393 if (!items || items > 2)
12394 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12395 fspec = SvPV(ST(0),n_a);
12396 fs_utf8 = SvUTF8(ST(0));
12397 if (!fspec || !*fspec) XSRETURN_UNDEF;
12399 defspec = SvPV(ST(1),n_a);
12400 dfs_utf8 = SvUTF8(ST(1));
12402 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12403 ST(0) = sv_newmortal();
12404 if (rslt != NULL) {
12405 sv_usepvn(ST(0),rslt,strlen(rslt));
12414 vmsify_fromperl(pTHX_ CV *cv)
12421 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12422 utf8_fl = SvUTF8(ST(0));
12423 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12424 ST(0) = sv_newmortal();
12425 if (vmsified != NULL) {
12426 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12435 unixify_fromperl(pTHX_ CV *cv)
12442 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12443 utf8_fl = SvUTF8(ST(0));
12444 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12445 ST(0) = sv_newmortal();
12446 if (unixified != NULL) {
12447 sv_usepvn(ST(0),unixified,strlen(unixified));
12456 fileify_fromperl(pTHX_ CV *cv)
12463 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12464 utf8_fl = SvUTF8(ST(0));
12465 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12466 ST(0) = sv_newmortal();
12467 if (fileified != NULL) {
12468 sv_usepvn(ST(0),fileified,strlen(fileified));
12477 pathify_fromperl(pTHX_ CV *cv)
12484 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12485 utf8_fl = SvUTF8(ST(0));
12486 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12487 ST(0) = sv_newmortal();
12488 if (pathified != NULL) {
12489 sv_usepvn(ST(0),pathified,strlen(pathified));
12498 vmspath_fromperl(pTHX_ CV *cv)
12505 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12506 utf8_fl = SvUTF8(ST(0));
12507 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12508 ST(0) = sv_newmortal();
12509 if (vmspath != NULL) {
12510 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12519 unixpath_fromperl(pTHX_ CV *cv)
12526 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12527 utf8_fl = SvUTF8(ST(0));
12528 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12529 ST(0) = sv_newmortal();
12530 if (unixpath != NULL) {
12531 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12540 candelete_fromperl(pTHX_ CV *cv)
12548 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12550 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12551 Newx(fspec, VMS_MAXRSS, char);
12552 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12553 if (SvTYPE(mysv) == SVt_PVGV) {
12554 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12555 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12563 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12564 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12571 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12577 rmscopy_fromperl(pTHX_ CV *cv)
12580 char *inspec, *outspec, *inp, *outp;
12582 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12583 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12584 unsigned long int sts;
12589 if (items < 2 || items > 3)
12590 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12592 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12593 Newx(inspec, VMS_MAXRSS, char);
12594 if (SvTYPE(mysv) == SVt_PVGV) {
12595 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12596 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12604 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12605 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12611 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12612 Newx(outspec, VMS_MAXRSS, char);
12613 if (SvTYPE(mysv) == SVt_PVGV) {
12614 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12615 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12624 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12625 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12632 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12634 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12640 /* The mod2fname is limited to shorter filenames by design, so it should
12641 * not be modified to support longer EFS pathnames
12644 mod2fname(pTHX_ CV *cv)
12647 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12648 workbuff[NAM$C_MAXRSS*1 + 1];
12649 int total_namelen = 3, counter, num_entries;
12650 /* ODS-5 ups this, but we want to be consistent, so... */
12651 int max_name_len = 39;
12652 AV *in_array = (AV *)SvRV(ST(0));
12654 num_entries = av_len(in_array);
12656 /* All the names start with PL_. */
12657 strcpy(ultimate_name, "PL_");
12659 /* Clean up our working buffer */
12660 Zero(work_name, sizeof(work_name), char);
12662 /* Run through the entries and build up a working name */
12663 for(counter = 0; counter <= num_entries; counter++) {
12664 /* If it's not the first name then tack on a __ */
12666 strcat(work_name, "__");
12668 strcat(work_name, SvPV(*av_fetch(in_array, counter, FALSE),
12672 /* Check to see if we actually have to bother...*/
12673 if (strlen(work_name) + 3 <= max_name_len) {
12674 strcat(ultimate_name, work_name);
12676 /* It's too darned big, so we need to go strip. We use the same */
12677 /* algorithm as xsubpp does. First, strip out doubled __ */
12678 char *source, *dest, last;
12681 for (source = work_name; *source; source++) {
12682 if (last == *source && last == '_') {
12688 /* Go put it back */
12689 strcpy(work_name, workbuff);
12690 /* Is it still too big? */
12691 if (strlen(work_name) + 3 > max_name_len) {
12692 /* Strip duplicate letters */
12695 for (source = work_name; *source; source++) {
12696 if (last == toupper(*source)) {
12700 last = toupper(*source);
12702 strcpy(work_name, workbuff);
12705 /* Is it *still* too big? */
12706 if (strlen(work_name) + 3 > max_name_len) {
12707 /* Too bad, we truncate */
12708 work_name[max_name_len - 2] = 0;
12710 strcat(ultimate_name, work_name);
12713 /* Okay, return it */
12714 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12719 hushexit_fromperl(pTHX_ CV *cv)
12724 VMSISH_HUSHED = SvTRUE(ST(0));
12726 ST(0) = boolSV(VMSISH_HUSHED);
12732 Perl_vms_start_glob
12733 (pTHX_ SV *tmpglob,
12737 struct vs_str_st *rslt;
12741 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12744 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12745 struct dsc$descriptor_vs rsdsc;
12746 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12747 unsigned long hasver = 0, isunix = 0;
12748 unsigned long int lff_flags = 0;
12751 #ifdef VMS_LONGNAME_SUPPORT
12752 lff_flags = LIB$M_FIL_LONG_NAMES;
12754 /* The Newx macro will not allow me to assign a smaller array
12755 * to the rslt pointer, so we will assign it to the begin char pointer
12756 * and then copy the value into the rslt pointer.
12758 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12759 rslt = (struct vs_str_st *)begin;
12761 rstr = &rslt->str[0];
12762 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12763 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12764 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12765 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12767 Newx(vmsspec, VMS_MAXRSS, char);
12769 /* We could find out if there's an explicit dev/dir or version
12770 by peeking into lib$find_file's internal context at
12771 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12772 but that's unsupported, so I don't want to do it now and
12773 have it bite someone in the future. */
12774 /* Fix-me: vms_split_path() is the only way to do this, the
12775 existing method will fail with many legal EFS or UNIX specifications
12778 cp = SvPV(tmpglob,i);
12781 if (cp[i] == ';') hasver = 1;
12782 if (cp[i] == '.') {
12783 if (sts) hasver = 1;
12786 if (cp[i] == '/') {
12787 hasdir = isunix = 1;
12790 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12795 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12799 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12800 if (!stat_sts && S_ISDIR(st.st_mode)) {
12801 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12802 ok = (wilddsc.dsc$a_pointer != NULL);
12803 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12807 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12808 ok = (wilddsc.dsc$a_pointer != NULL);
12811 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12813 /* If not extended character set, replace ? with % */
12814 /* With extended character set, ? is a wildcard single character */
12815 if (!decc_efs_case_preserve) {
12816 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12817 if (*cp == '?') *cp = '%';
12820 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12821 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12822 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12824 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12825 &dfltdsc,NULL,&rms_sts,&lff_flags);
12826 if (!$VMS_STATUS_SUCCESS(sts))
12831 /* with varying string, 1st word of buffer contains result length */
12832 rstr[rslt->length] = '\0';
12834 /* Find where all the components are */
12835 v_sts = vms_split_path
12850 /* If no version on input, truncate the version on output */
12851 if (!hasver && (vs_len > 0)) {
12855 /* No version & a null extension on UNIX handling */
12856 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12862 if (!decc_efs_case_preserve) {
12863 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12867 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12871 /* Start with the name */
12874 strcat(begin,"\n");
12875 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12877 if (cxt) (void)lib$find_file_end(&cxt);
12880 /* Be POSIXish: return the input pattern when no matches */
12881 strcpy(rstr,SvPVX(tmpglob));
12883 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12886 if (ok && sts != RMS$_NMF &&
12887 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12890 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12892 PerlIO_close(tmpfp);
12896 PerlIO_rewind(tmpfp);
12897 IoTYPE(io) = IoTYPE_RDONLY;
12898 IoIFP(io) = fp = tmpfp;
12899 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12909 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12913 vms_realpath_fromperl(pTHX_ CV *cv)
12916 char *fspec, *rslt_spec, *rslt;
12919 if (!items || items != 1)
12920 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realpath(spec)");
12922 fspec = SvPV(ST(0),n_a);
12923 if (!fspec || !*fspec) XSRETURN_UNDEF;
12925 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12926 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12928 ST(0) = sv_newmortal();
12930 sv_usepvn(ST(0),rslt,strlen(rslt));
12932 Safefree(rslt_spec);
12937 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12941 vms_realname_fromperl(pTHX_ CV *cv)
12944 char *fspec, *rslt_spec, *rslt;
12947 if (!items || items != 1)
12948 Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realname(spec)");
12950 fspec = SvPV(ST(0),n_a);
12951 if (!fspec || !*fspec) XSRETURN_UNDEF;
12953 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12954 rslt = do_vms_realname(fspec, rslt_spec, NULL);
12956 ST(0) = sv_newmortal();
12958 sv_usepvn(ST(0),rslt,strlen(rslt));
12960 Safefree(rslt_spec);
12966 * A thin wrapper around decc$symlink to make sure we follow the
12967 * standard and do not create a symlink with a zero-length name.
12969 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12970 int my_symlink(const char *path1, const char *path2) {
12971 if (!path2 || !*path2) {
12972 SETERRNO(ENOENT, SS$_NOSUCHFILE);
12975 return symlink(path1, path2);
12979 #endif /* HAS_SYMLINK */
12981 int do_vms_case_tolerant(void);
12984 vms_case_tolerant_fromperl(pTHX_ CV *cv)
12987 ST(0) = boolSV(do_vms_case_tolerant());
12992 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
12993 struct interp_intern *dst)
12995 memcpy(dst,src,sizeof(struct interp_intern));
12999 Perl_sys_intern_clear(pTHX)
13004 Perl_sys_intern_init(pTHX)
13006 unsigned int ix = RAND_MAX;
13011 /* fix me later to track running under GNV */
13012 /* this allows some limited testing */
13013 MY_POSIX_EXIT = decc_filename_unix_report;
13016 MY_INV_RAND_MAX = 1./x;
13020 init_os_extras(void)
13023 char* file = __FILE__;
13024 if (decc_disable_to_vms_logname_translation) {
13025 no_translate_barewords = TRUE;
13027 no_translate_barewords = FALSE;
13030 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13031 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13032 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13033 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13034 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13035 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13036 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13037 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13038 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13039 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13040 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13041 newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$");
13042 newXSproto("VMS::Filespec::vms_realname",vms_realname_fromperl,file,"$;$");
13043 newXSproto("VMS::Filepec::vms_case_tolerant",
13044 vms_case_tolerant_fromperl, file, "$");
13046 store_pipelocs(aTHX); /* will redo any earlier attempts */
13051 #if __CRTL_VER == 80200000
13052 /* This missed getting in to the DECC SDK for 8.2 */
13053 char *realpath(const char *file_name, char * resolved_name, ...);
13056 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13057 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13058 * The perl fallback routine to provide realpath() is not as efficient
13062 /* Hack, use old stat() as fastest way of getting ino_t and device */
13063 int decc$stat(const char *name, void * statbuf);
13066 /* Realpath is fragile. In 8.3 it does not work if the feature
13067 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13068 * links are implemented in RMS, not the CRTL. It also can fail if the
13069 * user does not have read/execute access to some of the directories.
13070 * So in order for Do What I Mean mode to work, if realpath() fails,
13071 * fall back to looking up the filename by the device name and FID.
13074 int vms_fid_to_name(char * outname, int outlen, const char * name)
13078 unsigned short st_ino[3];
13079 unsigned short padw;
13080 unsigned long padl[30]; /* plenty of room */
13083 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13084 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13086 sts = decc$stat(name, &statbuf);
13089 dvidsc.dsc$a_pointer=statbuf.st_dev;
13090 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13092 specdsc.dsc$a_pointer = outname;
13093 specdsc.dsc$w_length = outlen-1;
13095 sts = lib$fid_to_name
13096 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13097 if ($VMS_STATUS_SUCCESS(sts)) {
13098 outname[specdsc.dsc$w_length] = 0;
13108 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13111 char * rslt = NULL;
13114 if (decc_posix_compliant_pathnames > 0 ) {
13115 /* realpath currently only works if posix compliant pathnames are
13116 * enabled. It may start working when they are not, but in that
13117 * case we still want the fallback behavior for backwards compatibility
13119 rslt = realpath(filespec, outbuf);
13123 if (rslt == NULL) {
13125 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13126 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13129 /* Fall back to fid_to_name */
13131 Newx(vms_spec, VMS_MAXRSS + 1, char);
13133 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13137 /* Now need to trim the version off */
13138 sts = vms_split_path
13157 /* Trim off the version */
13158 file_len = v_len + r_len + d_len + n_len + e_len;
13159 vms_spec[file_len] = 0;
13161 /* The result is expected to be in UNIX format */
13162 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13166 Safefree(vms_spec);
13172 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13175 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13176 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13179 /* Fall back to fid_to_name */
13181 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13188 /* Now need to trim the version off */
13189 sts = vms_split_path
13208 /* Trim off the version */
13209 file_len = v_len + r_len + d_len + n_len + e_len;
13210 outbuf[file_len] = 0;
13218 /* External entry points */
13219 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13220 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13222 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13223 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13225 /* case_tolerant */
13227 /*{{{int do_vms_case_tolerant(void)*/
13228 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13229 * controlled by a process setting.
13231 int do_vms_case_tolerant(void)
13233 return vms_process_case_tolerant;
13236 /* External entry points */
13237 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13238 int Perl_vms_case_tolerant(void)
13239 { return do_vms_case_tolerant(); }
13241 int Perl_vms_case_tolerant(void)
13242 { return vms_process_case_tolerant; }
13246 /* Start of DECC RTL Feature handling */
13248 static int sys_trnlnm
13249 (const char * logname,
13253 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13254 const unsigned long attr = LNM$M_CASE_BLIND;
13255 struct dsc$descriptor_s name_dsc;
13257 unsigned short result;
13258 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13261 name_dsc.dsc$w_length = strlen(logname);
13262 name_dsc.dsc$a_pointer = (char *)logname;
13263 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13264 name_dsc.dsc$b_class = DSC$K_CLASS_S;
13266 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13268 if ($VMS_STATUS_SUCCESS(status)) {
13270 /* Null terminate and return the string */
13271 /*--------------------------------------*/
13278 static int sys_crelnm
13279 (const char * logname,
13280 const char * value)
13283 const char * proc_table = "LNM$PROCESS_TABLE";
13284 struct dsc$descriptor_s proc_table_dsc;
13285 struct dsc$descriptor_s logname_dsc;
13286 struct itmlst_3 item_list[2];
13288 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13289 proc_table_dsc.dsc$w_length = strlen(proc_table);
13290 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13291 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13293 logname_dsc.dsc$a_pointer = (char *) logname;
13294 logname_dsc.dsc$w_length = strlen(logname);
13295 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13296 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13298 item_list[0].buflen = strlen(value);
13299 item_list[0].itmcode = LNM$_STRING;
13300 item_list[0].bufadr = (char *)value;
13301 item_list[0].retlen = NULL;
13303 item_list[1].buflen = 0;
13304 item_list[1].itmcode = 0;
13306 ret_val = sys$crelnm
13308 (const struct dsc$descriptor_s *)&proc_table_dsc,
13309 (const struct dsc$descriptor_s *)&logname_dsc,
13311 (const struct item_list_3 *) item_list);
13316 /* C RTL Feature settings */
13318 static int set_features
13319 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
13320 int (* cli_routine)(void), /* Not documented */
13321 void *image_info) /* Not documented */
13328 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13329 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13330 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13331 unsigned long case_perm;
13332 unsigned long case_image;
13335 /* Allow an exception to bring Perl into the VMS debugger */
13336 vms_debug_on_exception = 0;
13337 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13338 if ($VMS_STATUS_SUCCESS(status)) {
13339 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13340 vms_debug_on_exception = 1;
13342 vms_debug_on_exception = 0;
13345 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13346 vms_vtf7_filenames = 0;
13347 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13348 if ($VMS_STATUS_SUCCESS(status)) {
13349 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13350 vms_vtf7_filenames = 1;
13352 vms_vtf7_filenames = 0;
13356 /* unlink all versions on unlink() or rename() */
13357 vms_unlink_all_versions = 0;
13358 status = sys_trnlnm
13359 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13360 if ($VMS_STATUS_SUCCESS(status)) {
13361 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13362 vms_unlink_all_versions = 1;
13364 vms_unlink_all_versions = 0;
13367 /* Dectect running under GNV Bash or other UNIX like shell */
13368 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13369 gnv_unix_shell = 0;
13370 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13371 if ($VMS_STATUS_SUCCESS(status)) {
13372 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13373 gnv_unix_shell = 1;
13374 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13375 set_feature_default("DECC$EFS_CHARSET", 1);
13376 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13377 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13378 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13379 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13380 vms_unlink_all_versions = 1;
13383 gnv_unix_shell = 0;
13387 /* hacks to see if known bugs are still present for testing */
13389 /* Readdir is returning filenames in VMS syntax always */
13390 decc_bug_readdir_efs1 = 1;
13391 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13392 if ($VMS_STATUS_SUCCESS(status)) {
13393 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13394 decc_bug_readdir_efs1 = 1;
13396 decc_bug_readdir_efs1 = 0;
13399 /* PCP mode requires creating /dev/null special device file */
13400 decc_bug_devnull = 0;
13401 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13402 if ($VMS_STATUS_SUCCESS(status)) {
13403 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13404 decc_bug_devnull = 1;
13406 decc_bug_devnull = 0;
13409 /* fgetname returning a VMS name in UNIX mode */
13410 decc_bug_fgetname = 1;
13411 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13412 if ($VMS_STATUS_SUCCESS(status)) {
13413 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13414 decc_bug_fgetname = 1;
13416 decc_bug_fgetname = 0;
13419 /* UNIX directory names with no paths are broken in a lot of places */
13420 decc_dir_barename = 1;
13421 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13422 if ($VMS_STATUS_SUCCESS(status)) {
13423 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13424 decc_dir_barename = 1;
13426 decc_dir_barename = 0;
13429 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13430 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13432 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13433 if (decc_disable_to_vms_logname_translation < 0)
13434 decc_disable_to_vms_logname_translation = 0;
13437 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13439 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13440 if (decc_efs_case_preserve < 0)
13441 decc_efs_case_preserve = 0;
13444 s = decc$feature_get_index("DECC$EFS_CHARSET");
13446 decc_efs_charset = decc$feature_get_value(s, 1);
13447 if (decc_efs_charset < 0)
13448 decc_efs_charset = 0;
13451 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13453 decc_filename_unix_report = decc$feature_get_value(s, 1);
13454 if (decc_filename_unix_report > 0)
13455 decc_filename_unix_report = 1;
13457 decc_filename_unix_report = 0;
13460 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13462 decc_filename_unix_only = decc$feature_get_value(s, 1);
13463 if (decc_filename_unix_only > 0) {
13464 decc_filename_unix_only = 1;
13467 decc_filename_unix_only = 0;
13471 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13473 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13474 if (decc_filename_unix_no_version < 0)
13475 decc_filename_unix_no_version = 0;
13478 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13480 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13481 if (decc_readdir_dropdotnotype < 0)
13482 decc_readdir_dropdotnotype = 0;
13485 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13486 if ($VMS_STATUS_SUCCESS(status)) {
13487 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13489 dflt = decc$feature_get_value(s, 4);
13491 decc_disable_posix_root = decc$feature_get_value(s, 1);
13492 if (decc_disable_posix_root <= 0) {
13493 decc$feature_set_value(s, 1, 1);
13494 decc_disable_posix_root = 1;
13498 /* Traditionally Perl assumes this is off */
13499 decc_disable_posix_root = 1;
13500 decc$feature_set_value(s, 1, 1);
13505 #if __CRTL_VER >= 80200000
13506 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13508 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13509 if (decc_posix_compliant_pathnames < 0)
13510 decc_posix_compliant_pathnames = 0;
13511 if (decc_posix_compliant_pathnames > 4)
13512 decc_posix_compliant_pathnames = 0;
13517 status = sys_trnlnm
13518 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13519 if ($VMS_STATUS_SUCCESS(status)) {
13520 val_str[0] = _toupper(val_str[0]);
13521 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13522 decc_disable_to_vms_logname_translation = 1;
13527 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13528 if ($VMS_STATUS_SUCCESS(status)) {
13529 val_str[0] = _toupper(val_str[0]);
13530 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13531 decc_efs_case_preserve = 1;
13536 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13537 if ($VMS_STATUS_SUCCESS(status)) {
13538 val_str[0] = _toupper(val_str[0]);
13539 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13540 decc_filename_unix_report = 1;
13543 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13544 if ($VMS_STATUS_SUCCESS(status)) {
13545 val_str[0] = _toupper(val_str[0]);
13546 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13547 decc_filename_unix_only = 1;
13548 decc_filename_unix_report = 1;
13551 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13552 if ($VMS_STATUS_SUCCESS(status)) {
13553 val_str[0] = _toupper(val_str[0]);
13554 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13555 decc_filename_unix_no_version = 1;
13558 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13559 if ($VMS_STATUS_SUCCESS(status)) {
13560 val_str[0] = _toupper(val_str[0]);
13561 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13562 decc_readdir_dropdotnotype = 1;
13567 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13569 /* Report true case tolerance */
13570 /*----------------------------*/
13571 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13572 if (!$VMS_STATUS_SUCCESS(status))
13573 case_perm = PPROP$K_CASE_BLIND;
13574 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13575 if (!$VMS_STATUS_SUCCESS(status))
13576 case_image = PPROP$K_CASE_BLIND;
13577 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13578 (case_image == PPROP$K_CASE_SENSITIVE))
13579 vms_process_case_tolerant = 0;
13584 /* CRTL can be initialized past this point, but not before. */
13585 /* DECC$CRTL_INIT(); */
13592 #pragma extern_model save
13593 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13594 const __align (LONGWORD) int spare[8] = {0};
13596 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13597 #if __DECC_VER >= 60560002
13598 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13600 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13602 #endif /* __DECC */
13604 const long vms_cc_features = (const long)set_features;
13607 ** Force a reference to LIB$INITIALIZE to ensure it
13608 ** exists in the image.
13610 int lib$initialize(void);
13612 #pragma extern_model strict_refdef
13614 int lib_init_ref = (int) lib$initialize;
13617 #pragma extern_model restore