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.
15 * Yet small as was their hunted band
16 * still fell and fearless was each hand,
17 * and strong deeds they wrought yet oft,
18 * and loved the woods, whose ways more soft
19 * them seemed than thralls of that black throne
20 * to live and languish in halls of stone.
22 * The Lay of Leithian, 135-40
31 #include <climsgdef.h>
42 #include <libclidef.h>
44 #include <lib$routines.h>
48 #if __CRTL_VER >= 70301000 && !defined(__VAX)
58 #include <str$routines.h>
65 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
67 #define NO_EFN EFN$C_ENF
72 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
73 int decc$feature_get_index(const char *name);
74 char* decc$feature_get_name(int index);
75 int decc$feature_get_value(int index, int mode);
76 int decc$feature_set_value(int index, int mode, int value);
81 #pragma member_alignment save
82 #pragma nomember_alignment longword
87 unsigned short * retadr;
89 #pragma member_alignment restore
91 /* More specific prototype than in starlet_c.h makes programming errors
99 const struct dsc$descriptor_s * devnam,
100 const struct item_list_3 * itmlst,
102 void * (astadr)(unsigned long),
107 #ifdef sys$get_security
108 #undef sys$get_security
110 (const struct dsc$descriptor_s * clsnam,
111 const struct dsc$descriptor_s * objnam,
112 const unsigned int *objhan,
114 const struct item_list_3 * itmlst,
115 unsigned int * contxt,
116 const unsigned int * acmode);
119 #ifdef sys$set_security
120 #undef sys$set_security
122 (const struct dsc$descriptor_s * clsnam,
123 const struct dsc$descriptor_s * objnam,
124 const unsigned int *objhan,
126 const struct item_list_3 * itmlst,
127 unsigned int * contxt,
128 const unsigned int * acmode);
131 #ifdef lib$find_image_symbol
132 #undef lib$find_image_symbol
133 int lib$find_image_symbol
134 (const struct dsc$descriptor_s * imgname,
135 const struct dsc$descriptor_s * symname,
137 const struct dsc$descriptor_s * defspec,
141 #ifdef lib$rename_file
142 #undef lib$rename_file
144 (const struct dsc$descriptor_s * old_file_dsc,
145 const struct dsc$descriptor_s * new_file_dsc,
146 const struct dsc$descriptor_s * default_file_dsc,
147 const struct dsc$descriptor_s * related_file_dsc,
148 const unsigned long * flags,
149 void * (success)(const struct dsc$descriptor_s * old_dsc,
150 const struct dsc$descriptor_s * new_dsc,
152 void * (error)(const struct dsc$descriptor_s * old_dsc,
153 const struct dsc$descriptor_s * new_dsc,
156 const int * error_src,
157 const void * usr_arg),
158 int (confirm)(const struct dsc$descriptor_s * old_dsc,
159 const struct dsc$descriptor_s * new_dsc,
160 const void * old_fab,
161 const void * usr_arg),
163 struct dsc$descriptor_s * old_result_name_dsc,
164 struct dsc$descriptor_s * new_result_name_dsc,
165 unsigned long * file_scan_context);
168 #if __CRTL_VER >= 70300000 && !defined(__VAX)
170 static int set_feature_default(const char *name, int value)
175 index = decc$feature_get_index(name);
177 status = decc$feature_set_value(index, 1, value);
178 if (index == -1 || (status == -1)) {
182 status = decc$feature_get_value(index, 1);
183 if (status != value) {
191 /* Older versions of ssdef.h don't have these */
192 #ifndef SS$_INVFILFOROP
193 # define SS$_INVFILFOROP 3930
195 #ifndef SS$_NOSUCHOBJECT
196 # define SS$_NOSUCHOBJECT 2696
199 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
200 #define PERLIO_NOT_STDIO 0
202 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
203 * code below needs to get to the underlying CRTL routines. */
204 #define DONT_MASK_RTL_CALLS
208 /* Anticipating future expansion in lexical warnings . . . */
209 #ifndef WARN_INTERNAL
210 # define WARN_INTERNAL WARN_MISC
213 #ifdef VMS_LONGNAME_SUPPORT
214 #include <libfildef.h>
217 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
218 # define RTL_USES_UTC 1
221 /* Routine to create a decterm for use with the Perl debugger */
222 /* No headers, this information was found in the Programming Concepts Manual */
224 static int (*decw_term_port)
225 (const struct dsc$descriptor_s * display,
226 const struct dsc$descriptor_s * setup_file,
227 const struct dsc$descriptor_s * customization,
228 struct dsc$descriptor_s * result_device_name,
229 unsigned short * result_device_name_length,
232 void * char_change_buffer) = 0;
234 /* gcc's header files don't #define direct access macros
235 * corresponding to VAXC's variant structs */
237 # define uic$v_format uic$r_uic_form.uic$v_format
238 # define uic$v_group uic$r_uic_form.uic$v_group
239 # define uic$v_member uic$r_uic_form.uic$v_member
240 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
241 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
242 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
243 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
246 #if defined(NEED_AN_H_ERRNO)
251 #pragma message disable pragma
252 #pragma member_alignment save
253 #pragma nomember_alignment longword
255 #pragma message disable misalgndmem
258 unsigned short int buflen;
259 unsigned short int itmcode;
261 unsigned short int *retlen;
264 struct filescan_itmlst_2 {
265 unsigned short length;
266 unsigned short itmcode;
271 unsigned short length;
276 #pragma message restore
277 #pragma member_alignment restore
280 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
281 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
282 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
283 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
284 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
285 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
286 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
287 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
288 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
289 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
290 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
291 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
293 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
294 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
295 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
296 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
298 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
299 #define PERL_LNM_MAX_ALLOWED_INDEX 127
301 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
302 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
305 #define PERL_LNM_MAX_ITER 10
307 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
308 #if __CRTL_VER >= 70302000 && !defined(__VAX)
309 #define MAX_DCL_SYMBOL (8192)
310 #define MAX_DCL_LINE_LENGTH (4096 - 4)
312 #define MAX_DCL_SYMBOL (1024)
313 #define MAX_DCL_LINE_LENGTH (1024 - 4)
316 static char *__mystrtolower(char *str)
318 if (str) for (; *str; ++str) *str= tolower(*str);
322 static struct dsc$descriptor_s fildevdsc =
323 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
324 static struct dsc$descriptor_s crtlenvdsc =
325 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
326 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
327 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
328 static struct dsc$descriptor_s **env_tables = defenv;
329 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
331 /* True if we shouldn't treat barewords as logicals during directory */
333 static int no_translate_barewords;
336 static int tz_updated = 1;
339 /* DECC Features that may need to affect how Perl interprets
340 * displays filename information
342 static int decc_disable_to_vms_logname_translation = 1;
343 static int decc_disable_posix_root = 1;
344 int decc_efs_case_preserve = 0;
345 static int decc_efs_charset = 0;
346 static int decc_filename_unix_no_version = 0;
347 static int decc_filename_unix_only = 0;
348 int decc_filename_unix_report = 0;
349 int decc_posix_compliant_pathnames = 0;
350 int decc_readdir_dropdotnotype = 0;
351 static int vms_process_case_tolerant = 1;
352 int vms_vtf7_filenames = 0;
353 int gnv_unix_shell = 0;
354 static int vms_unlink_all_versions = 0;
356 /* bug workarounds if needed */
357 int decc_bug_readdir_efs1 = 0;
358 int decc_bug_devnull = 1;
359 int decc_bug_fgetname = 0;
360 int decc_dir_barename = 0;
362 static int vms_debug_on_exception = 0;
364 /* Is this a UNIX file specification?
365 * No longer a simple check with EFS file specs
366 * For now, not a full check, but need to
367 * handle POSIX ^UP^ specifications
368 * Fixing to handle ^/ cases would require
369 * changes to many other conversion routines.
372 static int is_unix_filespec(const char *path)
378 if (strncmp(path,"\"^UP^",5) != 0) {
379 pch1 = strchr(path, '/');
384 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
385 if (decc_filename_unix_report || decc_filename_unix_only) {
386 if (strcmp(path,".") == 0)
394 /* This routine converts a UCS-2 character to be VTF-7 encoded.
397 static void ucs2_to_vtf7
399 unsigned long ucs2_char,
402 unsigned char * ucs_ptr;
405 ucs_ptr = (unsigned char *)&ucs2_char;
409 hex = (ucs_ptr[1] >> 4) & 0xf;
411 outspec[2] = hex + '0';
413 outspec[2] = (hex - 9) + 'A';
414 hex = ucs_ptr[1] & 0xF;
416 outspec[3] = hex + '0';
418 outspec[3] = (hex - 9) + 'A';
420 hex = (ucs_ptr[0] >> 4) & 0xf;
422 outspec[4] = hex + '0';
424 outspec[4] = (hex - 9) + 'A';
425 hex = ucs_ptr[1] & 0xF;
427 outspec[5] = hex + '0';
429 outspec[5] = (hex - 9) + 'A';
435 /* This handles the conversion of a UNIX extended character set to a ^
436 * escaped VMS character.
437 * in a UNIX file specification.
439 * The output count variable contains the number of characters added
440 * to the output string.
442 * The return value is the number of characters read from the input string
444 static int copy_expand_unix_filename_escape
445 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
453 utf8_flag = *utf8_fl;
457 if (*inspec >= 0x80) {
458 if (utf8_fl && vms_vtf7_filenames) {
459 unsigned long ucs_char;
463 if ((*inspec & 0xE0) == 0xC0) {
465 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
466 if (ucs_char >= 0x80) {
467 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
470 } else if ((*inspec & 0xF0) == 0xE0) {
472 ucs_char = ((inspec[0] & 0xF) << 12) +
473 ((inspec[1] & 0x3f) << 6) +
475 if (ucs_char >= 0x800) {
476 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
480 #if 0 /* I do not see longer sequences supported by OpenVMS */
481 /* Maybe some one can fix this later */
482 } else if ((*inspec & 0xF8) == 0xF0) {
485 } else if ((*inspec & 0xFC) == 0xF8) {
488 } else if ((*inspec & 0xFE) == 0xFC) {
495 /* High bit set, but not a Unicode character! */
497 /* Non printing DECMCS or ISO Latin-1 character? */
498 if (*inspec <= 0x9F) {
502 hex = (*inspec >> 4) & 0xF;
504 outspec[1] = hex + '0';
506 outspec[1] = (hex - 9) + 'A';
510 outspec[2] = hex + '0';
512 outspec[2] = (hex - 9) + 'A';
516 } else if (*inspec == 0xA0) {
522 } else if (*inspec == 0xFF) {
534 /* Is this a macro that needs to be passed through?
535 * Macros start with $( and an alpha character, followed
536 * by a string of alpha numeric characters ending with a )
537 * If this does not match, then encode it as ODS-5.
539 if ((inspec[0] == '$') && (inspec[1] == '(')) {
542 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
544 outspec[0] = inspec[0];
545 outspec[1] = inspec[1];
546 outspec[2] = inspec[2];
548 while(isalnum(inspec[tcnt]) ||
549 (inspec[2] == '.') || (inspec[2] == '_')) {
550 outspec[tcnt] = inspec[tcnt];
553 if (inspec[tcnt] == ')') {
554 outspec[tcnt] = inspec[tcnt];
571 if (decc_efs_charset == 0)
597 /* Don't escape again if following character is
598 * already something we escape.
600 if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
606 /* But otherwise fall through and escape it. */
608 /* Assume that this is to be escaped */
610 outspec[1] = *inspec;
614 case ' ': /* space */
615 /* Assume that this is to be escaped */
630 /* This handles the expansion of a '^' prefix to the proper character
631 * in a UNIX file specification.
633 * The output count variable contains the number of characters added
634 * to the output string.
636 * The return value is the number of characters read from the input
639 static int copy_expand_vms_filename_escape
640 (char *outspec, const char *inspec, int *output_cnt)
647 if (*inspec == '^') {
650 /* Spaces and non-trailing dots should just be passed through,
651 * but eat the escape character.
658 case '_': /* space */
664 /* Hmm. Better leave the escape escaped. */
670 case 'U': /* Unicode - FIX-ME this is wrong. */
673 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
676 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
677 outspec[0] == c1 & 0xff;
678 outspec[1] == c2 & 0xff;
685 /* Error - do best we can to continue */
695 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
699 scnt = sscanf(inspec, "%2x", &c1);
700 outspec[0] = c1 & 0xff;
724 (const struct dsc$descriptor_s * srcstr,
725 struct filescan_itmlst_2 * valuelist,
726 unsigned long * fldflags,
727 struct dsc$descriptor_s *auxout,
728 unsigned short * retlen);
731 /* vms_split_path - Verify that the input file specification is a
732 * VMS format file specification, and provide pointers to the components of
733 * it. With EFS format filenames, this is virtually the only way to
734 * parse a VMS path specification into components.
736 * If the sum of the components do not add up to the length of the
737 * string, then the passed file specification is probably a UNIX style
740 static int vms_split_path
755 struct dsc$descriptor path_desc;
759 struct filescan_itmlst_2 item_list[9];
760 const int filespec = 0;
761 const int nodespec = 1;
762 const int devspec = 2;
763 const int rootspec = 3;
764 const int dirspec = 4;
765 const int namespec = 5;
766 const int typespec = 6;
767 const int verspec = 7;
769 /* Assume the worst for an easy exit */
784 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
785 path_desc.dsc$w_length = strlen(path);
786 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
787 path_desc.dsc$b_class = DSC$K_CLASS_S;
789 /* Get the total length, if it is shorter than the string passed
790 * then this was probably not a VMS formatted file specification
792 item_list[filespec].itmcode = FSCN$_FILESPEC;
793 item_list[filespec].length = 0;
794 item_list[filespec].component = NULL;
796 /* If the node is present, then it gets considered as part of the
797 * volume name to hopefully make things simple.
799 item_list[nodespec].itmcode = FSCN$_NODE;
800 item_list[nodespec].length = 0;
801 item_list[nodespec].component = NULL;
803 item_list[devspec].itmcode = FSCN$_DEVICE;
804 item_list[devspec].length = 0;
805 item_list[devspec].component = NULL;
807 /* root is a special case, adding it to either the directory or
808 * the device components will probalby complicate things for the
809 * callers of this routine, so leave it separate.
811 item_list[rootspec].itmcode = FSCN$_ROOT;
812 item_list[rootspec].length = 0;
813 item_list[rootspec].component = NULL;
815 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
816 item_list[dirspec].length = 0;
817 item_list[dirspec].component = NULL;
819 item_list[namespec].itmcode = FSCN$_NAME;
820 item_list[namespec].length = 0;
821 item_list[namespec].component = NULL;
823 item_list[typespec].itmcode = FSCN$_TYPE;
824 item_list[typespec].length = 0;
825 item_list[typespec].component = NULL;
827 item_list[verspec].itmcode = FSCN$_VERSION;
828 item_list[verspec].length = 0;
829 item_list[verspec].component = NULL;
831 item_list[8].itmcode = 0;
832 item_list[8].length = 0;
833 item_list[8].component = NULL;
835 status = sys$filescan
836 ((const struct dsc$descriptor_s *)&path_desc, item_list,
838 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
840 /* If we parsed it successfully these two lengths should be the same */
841 if (path_desc.dsc$w_length != item_list[filespec].length)
844 /* If we got here, then it is a VMS file specification */
847 /* set the volume name */
848 if (item_list[nodespec].length > 0) {
849 *volume = item_list[nodespec].component;
850 *vol_len = item_list[nodespec].length + item_list[devspec].length;
853 *volume = item_list[devspec].component;
854 *vol_len = item_list[devspec].length;
857 *root = item_list[rootspec].component;
858 *root_len = item_list[rootspec].length;
860 *dir = item_list[dirspec].component;
861 *dir_len = item_list[dirspec].length;
863 /* Now fun with versions and EFS file specifications
864 * The parser can not tell the difference when a "." is a version
865 * delimiter or a part of the file specification.
867 if ((decc_efs_charset) &&
868 (item_list[verspec].length > 0) &&
869 (item_list[verspec].component[0] == '.')) {
870 *name = item_list[namespec].component;
871 *name_len = item_list[namespec].length + item_list[typespec].length;
872 *ext = item_list[verspec].component;
873 *ext_len = item_list[verspec].length;
878 *name = item_list[namespec].component;
879 *name_len = item_list[namespec].length;
880 *ext = item_list[typespec].component;
881 *ext_len = item_list[typespec].length;
882 *version = item_list[verspec].component;
883 *ver_len = item_list[verspec].length;
890 * Routine to retrieve the maximum equivalence index for an input
891 * logical name. Some calls to this routine have no knowledge if
892 * the variable is a logical or not. So on error we return a max
895 /*{{{int my_maxidx(const char *lnm) */
897 my_maxidx(const char *lnm)
901 int attr = LNM$M_CASE_BLIND;
902 struct dsc$descriptor lnmdsc;
903 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
906 lnmdsc.dsc$w_length = strlen(lnm);
907 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
908 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
909 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
911 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
912 if ((status & 1) == 0)
919 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
921 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
922 struct dsc$descriptor_s **tabvec, unsigned long int flags)
925 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
926 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
927 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
929 unsigned char acmode;
930 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
931 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
932 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
933 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
935 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
936 #if defined(PERL_IMPLICIT_CONTEXT)
939 aTHX = PERL_GET_INTERP;
945 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
946 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
948 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
949 *cp2 = _toupper(*cp1);
950 if (cp1 - lnm > LNM$C_NAMLENGTH) {
951 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
955 lnmdsc.dsc$w_length = cp1 - lnm;
956 lnmdsc.dsc$a_pointer = uplnm;
957 uplnm[lnmdsc.dsc$w_length] = '\0';
958 secure = flags & PERL__TRNENV_SECURE;
959 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
960 if (!tabvec || !*tabvec) tabvec = env_tables;
962 for (curtab = 0; tabvec[curtab]; curtab++) {
963 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
964 if (!ivenv && !secure) {
969 Perl_warn(aTHX_ "Can't read CRTL environ\n");
972 retsts = SS$_NOLOGNAM;
973 for (i = 0; environ[i]; i++) {
974 if ((eq = strchr(environ[i],'=')) &&
975 lnmdsc.dsc$w_length == (eq - environ[i]) &&
976 !strncmp(environ[i],uplnm,eq - environ[i])) {
978 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
979 if (!eqvlen) continue;
984 if (retsts != SS$_NOLOGNAM) break;
987 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
988 !str$case_blind_compare(&tmpdsc,&clisym)) {
989 if (!ivsym && !secure) {
990 unsigned short int deflen = LNM$C_NAMLENGTH;
991 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
992 /* dynamic dsc to accomodate possible long value */
993 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
994 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
996 if (eqvlen > MAX_DCL_SYMBOL) {
997 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
998 eqvlen = MAX_DCL_SYMBOL;
999 /* Special hack--we might be called before the interpreter's */
1000 /* fully initialized, in which case either thr or PL_curcop */
1001 /* might be bogus. We have to check, since ckWARN needs them */
1002 /* both to be valid if running threaded */
1003 if (ckWARN(WARN_MISC)) {
1004 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1007 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1009 _ckvmssts(lib$sfree1_dd(&eqvdsc));
1010 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1011 if (retsts == LIB$_NOSUCHSYM) continue;
1016 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1017 midx = my_maxidx(lnm);
1018 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1019 lnmlst[1].bufadr = cp2;
1021 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1022 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1023 if (retsts == SS$_NOLOGNAM) break;
1024 /* PPFs have a prefix */
1027 *((int *)uplnm) == *((int *)"SYS$") &&
1029 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1030 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1031 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1032 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1033 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1034 memmove(eqv,eqv+4,eqvlen-4);
1040 if ((retsts == SS$_IVLOGNAM) ||
1041 (retsts == SS$_NOLOGNAM)) { continue; }
1044 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1045 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1046 if (retsts == SS$_NOLOGNAM) continue;
1049 eqvlen = strlen(eqv);
1053 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1054 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1055 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1056 retsts == SS$_NOLOGNAM) {
1057 set_errno(EINVAL); set_vaxc_errno(retsts);
1059 else _ckvmssts(retsts);
1061 } /* end of vmstrnenv */
1064 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1065 /* Define as a function so we can access statics. */
1066 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1068 return vmstrnenv(lnm,eqv,idx,fildev,
1069 #ifdef SECURE_INTERNAL_GETENV
1070 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1079 * Note: Uses Perl temp to store result so char * can be returned to
1080 * caller; this pointer will be invalidated at next Perl statement
1082 * We define this as a function rather than a macro in terms of my_getenv_len()
1083 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1086 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1088 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1091 static char *__my_getenv_eqv = NULL;
1092 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1093 unsigned long int idx = 0;
1094 int trnsuccess, success, secure, saverr, savvmserr;
1098 midx = my_maxidx(lnm) + 1;
1100 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1101 /* Set up a temporary buffer for the return value; Perl will
1102 * clean it up at the next statement transition */
1103 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1104 if (!tmpsv) return NULL;
1108 /* Assume no interpreter ==> single thread */
1109 if (__my_getenv_eqv != NULL) {
1110 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1113 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1115 eqv = __my_getenv_eqv;
1118 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1119 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1121 getcwd(eqv,LNM$C_NAMLENGTH);
1125 /* Get rid of "000000/ in rooted filespecs */
1128 zeros = strstr(eqv, "/000000/");
1129 if (zeros != NULL) {
1131 mlen = len - (zeros - eqv) - 7;
1132 memmove(zeros, &zeros[7], mlen);
1140 /* Impose security constraints only if tainting */
1142 /* Impose security constraints only if tainting */
1143 secure = PL_curinterp ? PL_tainting : will_taint;
1144 saverr = errno; savvmserr = vaxc$errno;
1151 #ifdef SECURE_INTERNAL_GETENV
1152 secure ? PERL__TRNENV_SECURE : 0
1158 /* For the getenv interface we combine all the equivalence names
1159 * of a search list logical into one value to acquire a maximum
1160 * value length of 255*128 (assuming %ENV is using logicals).
1162 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1164 /* If the name contains a semicolon-delimited index, parse it
1165 * off and make sure we only retrieve the equivalence name for
1167 if ((cp2 = strchr(lnm,';')) != NULL) {
1169 uplnm[cp2-lnm] = '\0';
1170 idx = strtoul(cp2+1,NULL,0);
1172 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1175 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1177 /* Discard NOLOGNAM on internal calls since we're often looking
1178 * for an optional name, and this "error" often shows up as the
1179 * (bogus) exit status for a die() call later on. */
1180 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1181 return success ? eqv : NULL;
1184 } /* end of my_getenv() */
1188 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1190 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1194 unsigned long idx = 0;
1196 static char *__my_getenv_len_eqv = NULL;
1197 int secure, saverr, savvmserr;
1200 midx = my_maxidx(lnm) + 1;
1202 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1203 /* Set up a temporary buffer for the return value; Perl will
1204 * clean it up at the next statement transition */
1205 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1206 if (!tmpsv) return NULL;
1210 /* Assume no interpreter ==> single thread */
1211 if (__my_getenv_len_eqv != NULL) {
1212 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1215 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1217 buf = __my_getenv_len_eqv;
1220 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1221 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1224 getcwd(buf,LNM$C_NAMLENGTH);
1227 /* Get rid of "000000/ in rooted filespecs */
1229 zeros = strstr(buf, "/000000/");
1230 if (zeros != NULL) {
1232 mlen = *len - (zeros - buf) - 7;
1233 memmove(zeros, &zeros[7], mlen);
1242 /* Impose security constraints only if tainting */
1243 secure = PL_curinterp ? PL_tainting : will_taint;
1244 saverr = errno; savvmserr = vaxc$errno;
1251 #ifdef SECURE_INTERNAL_GETENV
1252 secure ? PERL__TRNENV_SECURE : 0
1258 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1260 if ((cp2 = strchr(lnm,';')) != NULL) {
1262 buf[cp2-lnm] = '\0';
1263 idx = strtoul(cp2+1,NULL,0);
1265 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1268 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1270 /* Get rid of "000000/ in rooted filespecs */
1273 zeros = strstr(buf, "/000000/");
1274 if (zeros != NULL) {
1276 mlen = *len - (zeros - buf) - 7;
1277 memmove(zeros, &zeros[7], mlen);
1283 /* Discard NOLOGNAM on internal calls since we're often looking
1284 * for an optional name, and this "error" often shows up as the
1285 * (bogus) exit status for a die() call later on. */
1286 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1287 return *len ? buf : NULL;
1290 } /* end of my_getenv_len() */
1293 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1295 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1297 /*{{{ void prime_env_iter() */
1299 prime_env_iter(void)
1300 /* Fill the %ENV associative array with all logical names we can
1301 * find, in preparation for iterating over it.
1304 static int primed = 0;
1305 HV *seenhv = NULL, *envhv;
1307 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1308 unsigned short int chan;
1309 #ifndef CLI$M_TRUSTED
1310 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1312 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1313 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1315 bool have_sym = FALSE, have_lnm = FALSE;
1316 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1317 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1318 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1319 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1320 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1321 #if defined(PERL_IMPLICIT_CONTEXT)
1324 #if defined(USE_ITHREADS)
1325 static perl_mutex primenv_mutex;
1326 MUTEX_INIT(&primenv_mutex);
1329 #if defined(PERL_IMPLICIT_CONTEXT)
1330 /* We jump through these hoops because we can be called at */
1331 /* platform-specific initialization time, which is before anything is */
1332 /* set up--we can't even do a plain dTHX since that relies on the */
1333 /* interpreter structure to be initialized */
1335 aTHX = PERL_GET_INTERP;
1341 if (primed || !PL_envgv) return;
1342 MUTEX_LOCK(&primenv_mutex);
1343 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1344 envhv = GvHVn(PL_envgv);
1345 /* Perform a dummy fetch as an lval to insure that the hash table is
1346 * set up. Otherwise, the hv_store() will turn into a nullop. */
1347 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1349 for (i = 0; env_tables[i]; i++) {
1350 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1351 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1352 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1354 if (have_sym || have_lnm) {
1355 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1356 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1357 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1358 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1361 for (i--; i >= 0; i--) {
1362 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1365 for (j = 0; environ[j]; j++) {
1366 if (!(start = strchr(environ[j],'='))) {
1367 if (ckWARN(WARN_INTERNAL))
1368 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1372 sv = newSVpv(start,0);
1374 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1379 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1380 !str$case_blind_compare(&tmpdsc,&clisym)) {
1381 strcpy(cmd,"Show Symbol/Global *");
1382 cmddsc.dsc$w_length = 20;
1383 if (env_tables[i]->dsc$w_length == 12 &&
1384 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1385 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1386 flags = defflags | CLI$M_NOLOGNAM;
1389 strcpy(cmd,"Show Logical *");
1390 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1391 strcat(cmd," /Table=");
1392 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1393 cmddsc.dsc$w_length = strlen(cmd);
1395 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1396 flags = defflags | CLI$M_NOCLISYM;
1399 /* Create a new subprocess to execute each command, to exclude the
1400 * remote possibility that someone could subvert a mbx or file used
1401 * to write multiple commands to a single subprocess.
1404 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1405 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1406 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1407 defflags &= ~CLI$M_TRUSTED;
1408 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1410 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1411 if (seenhv) SvREFCNT_dec(seenhv);
1414 char *cp1, *cp2, *key;
1415 unsigned long int sts, iosb[2], retlen, keylen;
1418 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1419 if (sts & 1) sts = iosb[0] & 0xffff;
1420 if (sts == SS$_ENDOFFILE) {
1422 while (substs == 0) { sys$hiber(); wakect++;}
1423 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1428 retlen = iosb[0] >> 16;
1429 if (!retlen) continue; /* blank line */
1431 if (iosb[1] != subpid) {
1433 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1437 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1438 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1440 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1441 if (*cp1 == '(' || /* Logical name table name */
1442 *cp1 == '=' /* Next eqv of searchlist */) continue;
1443 if (*cp1 == '"') cp1++;
1444 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1445 key = cp1; keylen = cp2 - cp1;
1446 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1447 while (*cp2 && *cp2 != '=') cp2++;
1448 while (*cp2 && *cp2 == '=') cp2++;
1449 while (*cp2 && *cp2 == ' ') cp2++;
1450 if (*cp2 == '"') { /* String translation; may embed "" */
1451 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1452 cp2++; cp1--; /* Skip "" surrounding translation */
1454 else { /* Numeric translation */
1455 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1456 cp1--; /* stop on last non-space char */
1458 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1459 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1462 PERL_HASH(hash,key,keylen);
1464 if (cp1 == cp2 && *cp2 == '.') {
1465 /* A single dot usually means an unprintable character, such as a null
1466 * to indicate a zero-length value. Get the actual value to make sure.
1468 char lnm[LNM$C_NAMLENGTH+1];
1469 char eqv[MAX_DCL_SYMBOL+1];
1471 strncpy(lnm, key, keylen);
1472 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1473 sv = newSVpvn(eqv, strlen(eqv));
1476 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1480 hv_store(envhv,key,keylen,sv,hash);
1481 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1483 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1484 /* get the PPFs for this process, not the subprocess */
1485 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1486 char eqv[LNM$C_NAMLENGTH+1];
1488 for (i = 0; ppfs[i]; i++) {
1489 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1490 sv = newSVpv(eqv,trnlen);
1492 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1497 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1498 if (buf) Safefree(buf);
1499 if (seenhv) SvREFCNT_dec(seenhv);
1500 MUTEX_UNLOCK(&primenv_mutex);
1503 } /* end of prime_env_iter */
1507 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1508 /* Define or delete an element in the same "environment" as
1509 * vmstrnenv(). If an element is to be deleted, it's removed from
1510 * the first place it's found. If it's to be set, it's set in the
1511 * place designated by the first element of the table vector.
1512 * Like setenv() returns 0 for success, non-zero on error.
1515 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1518 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1519 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1521 unsigned long int retsts, usermode = PSL$C_USER;
1522 struct itmlst_3 *ile, *ilist;
1523 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1524 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1525 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1526 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1527 $DESCRIPTOR(local,"_LOCAL");
1530 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1531 return SS$_IVLOGNAM;
1534 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1535 *cp2 = _toupper(*cp1);
1536 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1537 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1538 return SS$_IVLOGNAM;
1541 lnmdsc.dsc$w_length = cp1 - lnm;
1542 if (!tabvec || !*tabvec) tabvec = env_tables;
1544 if (!eqv) { /* we're deleting n element */
1545 for (curtab = 0; tabvec[curtab]; curtab++) {
1546 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1548 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1549 if ((cp1 = strchr(environ[i],'=')) &&
1550 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1551 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1553 return setenv(lnm,"",1) ? vaxc$errno : 0;
1556 ivenv = 1; retsts = SS$_NOLOGNAM;
1558 if (ckWARN(WARN_INTERNAL))
1559 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1560 ivenv = 1; retsts = SS$_NOSUCHPGM;
1566 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1567 !str$case_blind_compare(&tmpdsc,&clisym)) {
1568 unsigned int symtype;
1569 if (tabvec[curtab]->dsc$w_length == 12 &&
1570 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1571 !str$case_blind_compare(&tmpdsc,&local))
1572 symtype = LIB$K_CLI_LOCAL_SYM;
1573 else symtype = LIB$K_CLI_GLOBAL_SYM;
1574 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1575 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1576 if (retsts == LIB$_NOSUCHSYM) continue;
1580 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1581 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1582 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1583 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1584 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1588 else { /* we're defining a value */
1589 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1591 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1593 if (ckWARN(WARN_INTERNAL))
1594 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1595 retsts = SS$_NOSUCHPGM;
1599 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1600 eqvdsc.dsc$w_length = strlen(eqv);
1601 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1602 !str$case_blind_compare(&tmpdsc,&clisym)) {
1603 unsigned int symtype;
1604 if (tabvec[0]->dsc$w_length == 12 &&
1605 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1606 !str$case_blind_compare(&tmpdsc,&local))
1607 symtype = LIB$K_CLI_LOCAL_SYM;
1608 else symtype = LIB$K_CLI_GLOBAL_SYM;
1609 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1612 if (!*eqv) eqvdsc.dsc$w_length = 1;
1613 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1615 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1616 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1617 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1618 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1619 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1620 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1623 Newx(ilist,nseg+1,struct itmlst_3);
1626 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1629 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1631 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1632 ile->itmcode = LNM$_STRING;
1634 if ((j+1) == nseg) {
1635 ile->buflen = strlen(c);
1636 /* in case we are truncating one that's too long */
1637 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1640 ile->buflen = LNM$C_NAMLENGTH;
1644 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1648 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1653 if (!(retsts & 1)) {
1655 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1656 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1657 set_errno(EVMSERR); break;
1658 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1659 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1660 set_errno(EINVAL); break;
1662 set_errno(EACCES); break;
1667 set_vaxc_errno(retsts);
1668 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1671 /* We reset error values on success because Perl does an hv_fetch()
1672 * before each hv_store(), and if the thing we're setting didn't
1673 * previously exist, we've got a leftover error message. (Of course,
1674 * this fails in the face of
1675 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1676 * in that the error reported in $! isn't spurious,
1677 * but it's right more often than not.)
1679 set_errno(0); set_vaxc_errno(retsts);
1683 } /* end of vmssetenv() */
1686 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1687 /* This has to be a function since there's a prototype for it in proto.h */
1689 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1692 int len = strlen(lnm);
1696 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1697 if (!strcmp(uplnm,"DEFAULT")) {
1698 if (eqv && *eqv) my_chdir(eqv);
1702 #ifndef RTL_USES_UTC
1703 if (len == 6 || len == 2) {
1706 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1708 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1709 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1713 (void) vmssetenv(lnm,eqv,NULL);
1717 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1719 * sets a user-mode logical in the process logical name table
1720 * used for redirection of sys$error
1723 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1725 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1726 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1727 unsigned long int iss, attr = LNM$M_CONFINE;
1728 unsigned char acmode = PSL$C_USER;
1729 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1731 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1732 d_name.dsc$w_length = strlen(name);
1734 lnmlst[0].buflen = strlen(eqv);
1735 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1737 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1738 if (!(iss&1)) lib$signal(iss);
1743 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1744 /* my_crypt - VMS password hashing
1745 * my_crypt() provides an interface compatible with the Unix crypt()
1746 * C library function, and uses sys$hash_password() to perform VMS
1747 * password hashing. The quadword hashed password value is returned
1748 * as a NUL-terminated 8 character string. my_crypt() does not change
1749 * the case of its string arguments; in order to match the behavior
1750 * of LOGINOUT et al., alphabetic characters in both arguments must
1751 * be upcased by the caller.
1753 * - fix me to call ACM services when available
1756 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1758 # ifndef UAI$C_PREFERRED_ALGORITHM
1759 # define UAI$C_PREFERRED_ALGORITHM 127
1761 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1762 unsigned short int salt = 0;
1763 unsigned long int sts;
1765 unsigned short int dsc$w_length;
1766 unsigned char dsc$b_type;
1767 unsigned char dsc$b_class;
1768 const char * dsc$a_pointer;
1769 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1770 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1771 struct itmlst_3 uailst[3] = {
1772 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1773 { sizeof salt, UAI$_SALT, &salt, 0},
1774 { 0, 0, NULL, NULL}};
1775 static char hash[9];
1777 usrdsc.dsc$w_length = strlen(usrname);
1778 usrdsc.dsc$a_pointer = usrname;
1779 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1781 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1785 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1790 set_vaxc_errno(sts);
1791 if (sts != RMS$_RNF) return NULL;
1794 txtdsc.dsc$w_length = strlen(textpasswd);
1795 txtdsc.dsc$a_pointer = textpasswd;
1796 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1797 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1800 return (char *) hash;
1802 } /* end of my_crypt() */
1806 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1807 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1808 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1810 /* fixup barenames that are directories for internal use.
1811 * There have been problems with the consistent handling of UNIX
1812 * style directory names when routines are presented with a name that
1813 * has no directory delimitors at all. So this routine will eventually
1816 static char * fixup_bare_dirnames(const char * name)
1818 if (decc_disable_to_vms_logname_translation) {
1824 /* 8.3, remove() is now broken on symbolic links */
1825 static int rms_erase(const char * vmsname);
1829 * A little hack to get around a bug in some implemenation of remove()
1830 * that do not know how to delete a directory
1832 * Delete any file to which user has control access, regardless of whether
1833 * delete access is explicitly allowed.
1834 * Limitations: User must have write access to parent directory.
1835 * Does not block signals or ASTs; if interrupted in midstream
1836 * may leave file with an altered ACL.
1839 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1841 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1845 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1846 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1847 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1849 unsigned char myace$b_length;
1850 unsigned char myace$b_type;
1851 unsigned short int myace$w_flags;
1852 unsigned long int myace$l_access;
1853 unsigned long int myace$l_ident;
1854 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1855 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1856 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1858 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1859 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1860 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1861 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1862 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1863 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1865 /* Expand the input spec using RMS, since the CRTL remove() and
1866 * system services won't do this by themselves, so we may miss
1867 * a file "hiding" behind a logical name or search list. */
1868 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1869 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1871 rslt = do_rmsexpand(name,
1875 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1879 PerlMem_free(vmsname);
1883 /* Erase the file */
1884 rmsts = rms_erase(vmsname);
1886 /* Did it succeed */
1887 if ($VMS_STATUS_SUCCESS(rmsts)) {
1888 PerlMem_free(vmsname);
1892 /* If not, can changing protections help? */
1893 if (rmsts != RMS$_PRV) {
1894 set_vaxc_errno(rmsts);
1895 PerlMem_free(vmsname);
1899 /* No, so we get our own UIC to use as a rights identifier,
1900 * and the insert an ACE at the head of the ACL which allows us
1901 * to delete the file.
1903 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1904 fildsc.dsc$w_length = strlen(vmsname);
1905 fildsc.dsc$a_pointer = vmsname;
1907 newace.myace$l_ident = oldace.myace$l_ident;
1909 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1911 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1912 set_errno(ENOENT); break;
1914 set_errno(ENOTDIR); break;
1916 set_errno(ENODEV); break;
1917 case RMS$_SYN: case SS$_INVFILFOROP:
1918 set_errno(EINVAL); break;
1920 set_errno(EACCES); break;
1924 set_vaxc_errno(aclsts);
1925 PerlMem_free(vmsname);
1928 /* Grab any existing ACEs with this identifier in case we fail */
1929 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1930 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1931 || fndsts == SS$_NOMOREACE ) {
1932 /* Add the new ACE . . . */
1933 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1936 rmsts = rms_erase(vmsname);
1937 if ($VMS_STATUS_SUCCESS(rmsts)) {
1942 /* We blew it - dir with files in it, no write priv for
1943 * parent directory, etc. Put things back the way they were. */
1944 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1947 addlst[0].bufadr = &oldace;
1948 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1955 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1956 /* We just deleted it, so of course it's not there. Some versions of
1957 * VMS seem to return success on the unlock operation anyhow (after all
1958 * the unlock is successful), but others don't.
1960 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1961 if (aclsts & 1) aclsts = fndsts;
1962 if (!(aclsts & 1)) {
1964 set_vaxc_errno(aclsts);
1967 PerlMem_free(vmsname);
1970 } /* end of kill_file() */
1974 /*{{{int do_rmdir(char *name)*/
1976 Perl_do_rmdir(pTHX_ const char *name)
1982 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1983 if (dirfile == NULL)
1984 _ckvmssts(SS$_INSFMEM);
1986 /* Force to a directory specification */
1987 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1988 PerlMem_free(dirfile);
1991 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1996 retval = mp_do_kill_file(aTHX_ dirfile, 1);
1998 PerlMem_free(dirfile);
2001 } /* end of do_rmdir */
2005 * Delete any file to which user has control access, regardless of whether
2006 * delete access is explicitly allowed.
2007 * Limitations: User must have write access to parent directory.
2008 * Does not block signals or ASTs; if interrupted in midstream
2009 * may leave file with an altered ACL.
2012 /*{{{int kill_file(char *name)*/
2014 Perl_kill_file(pTHX_ const char *name)
2016 char rspec[NAM$C_MAXRSS+1];
2021 /* Remove() is allowed to delete directories, according to the X/Open
2023 * This may need special handling to work with the ACL hacks.
2025 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2026 rmsts = Perl_do_rmdir(aTHX_ name);
2030 rmsts = mp_do_kill_file(aTHX_ name, 0);
2034 } /* end of kill_file() */
2038 /*{{{int my_mkdir(char *,Mode_t)*/
2040 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2042 STRLEN dirlen = strlen(dir);
2044 /* zero length string sometimes gives ACCVIO */
2045 if (dirlen == 0) return -1;
2047 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2048 * null file name/type. However, it's commonplace under Unix,
2049 * so we'll allow it for a gain in portability.
2051 if (dir[dirlen-1] == '/') {
2052 char *newdir = savepvn(dir,dirlen-1);
2053 int ret = mkdir(newdir,mode);
2057 else return mkdir(dir,mode);
2058 } /* end of my_mkdir */
2061 /*{{{int my_chdir(char *)*/
2063 Perl_my_chdir(pTHX_ const char *dir)
2065 STRLEN dirlen = strlen(dir);
2067 /* zero length string sometimes gives ACCVIO */
2068 if (dirlen == 0) return -1;
2071 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2072 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2073 * so that existing scripts do not need to be changed.
2076 while ((dirlen > 0) && (*dir1 == ' ')) {
2081 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2083 * null file name/type. However, it's commonplace under Unix,
2084 * so we'll allow it for a gain in portability.
2086 * - Preview- '/' will be valid soon on VMS
2088 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2089 char *newdir = savepvn(dir1,dirlen-1);
2090 int ret = chdir(newdir);
2094 else return chdir(dir1);
2095 } /* end of my_chdir */
2099 /*{{{int my_chmod(char *, mode_t)*/
2101 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2103 STRLEN speclen = strlen(file_spec);
2105 /* zero length string sometimes gives ACCVIO */
2106 if (speclen == 0) return -1;
2108 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2109 * that implies null file name/type. However, it's commonplace under Unix,
2110 * so we'll allow it for a gain in portability.
2112 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2113 * in VMS file.dir notation.
2115 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2116 char *vms_src, *vms_dir, *rslt;
2120 /* First convert this to a VMS format specification */
2121 vms_src = PerlMem_malloc(VMS_MAXRSS);
2122 if (vms_src == NULL)
2123 _ckvmssts(SS$_INSFMEM);
2125 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2127 /* If we fail, then not a file specification */
2128 PerlMem_free(vms_src);
2133 /* Now make it a directory spec so chmod is happy */
2134 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2135 if (vms_dir == NULL)
2136 _ckvmssts(SS$_INSFMEM);
2137 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2138 PerlMem_free(vms_src);
2142 ret = chmod(vms_dir, mode);
2146 PerlMem_free(vms_dir);
2149 else return chmod(file_spec, mode);
2150 } /* end of my_chmod */
2154 /*{{{FILE *my_tmpfile()*/
2161 if ((fp = tmpfile())) return fp;
2163 cp = PerlMem_malloc(L_tmpnam+24);
2164 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2166 if (decc_filename_unix_only == 0)
2167 strcpy(cp,"Sys$Scratch:");
2170 tmpnam(cp+strlen(cp));
2171 strcat(cp,".Perltmp");
2172 fp = fopen(cp,"w+","fop=dlt");
2179 #ifndef HOMEGROWN_POSIX_SIGNALS
2181 * The C RTL's sigaction fails to check for invalid signal numbers so we
2182 * help it out a bit. The docs are correct, but the actual routine doesn't
2183 * do what the docs say it will.
2185 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2187 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2188 struct sigaction* oact)
2190 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2191 SETERRNO(EINVAL, SS$_INVARG);
2194 return sigaction(sig, act, oact);
2199 #ifdef KILL_BY_SIGPRC
2200 #include <errnodef.h>
2202 /* We implement our own kill() using the undocumented system service
2203 sys$sigprc for one of two reasons:
2205 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2206 target process to do a sys$exit, which usually can't be handled
2207 gracefully...certainly not by Perl and the %SIG{} mechanism.
2209 2.) If the kill() in the CRTL can't be called from a signal
2210 handler without disappearing into the ether, i.e., the signal
2211 it purportedly sends is never trapped. Still true as of VMS 7.3.
2213 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2214 in the target process rather than calling sys$exit.
2216 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2217 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2218 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2219 with condition codes C$_SIG0+nsig*8, catching the exception on the
2220 target process and resignaling with appropriate arguments.
2222 But we don't have that VMS 7.0+ exception handler, so if you
2223 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2225 Also note that SIGTERM is listed in the docs as being "unimplemented",
2226 yet always seems to be signaled with a VMS condition code of 4 (and
2227 correctly handled for that code). So we hardwire it in.
2229 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2230 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2231 than signalling with an unrecognized (and unhandled by CRTL) code.
2234 #define _MY_SIG_MAX 28
2237 Perl_sig_to_vmscondition_int(int sig)
2239 static unsigned int sig_code[_MY_SIG_MAX+1] =
2242 SS$_HANGUP, /* 1 SIGHUP */
2243 SS$_CONTROLC, /* 2 SIGINT */
2244 SS$_CONTROLY, /* 3 SIGQUIT */
2245 SS$_RADRMOD, /* 4 SIGILL */
2246 SS$_BREAK, /* 5 SIGTRAP */
2247 SS$_OPCCUS, /* 6 SIGABRT */
2248 SS$_COMPAT, /* 7 SIGEMT */
2250 SS$_FLTOVF, /* 8 SIGFPE VAX */
2252 SS$_HPARITH, /* 8 SIGFPE AXP */
2254 SS$_ABORT, /* 9 SIGKILL */
2255 SS$_ACCVIO, /* 10 SIGBUS */
2256 SS$_ACCVIO, /* 11 SIGSEGV */
2257 SS$_BADPARAM, /* 12 SIGSYS */
2258 SS$_NOMBX, /* 13 SIGPIPE */
2259 SS$_ASTFLT, /* 14 SIGALRM */
2276 #if __VMS_VER >= 60200000
2277 static int initted = 0;
2280 sig_code[16] = C$_SIGUSR1;
2281 sig_code[17] = C$_SIGUSR2;
2282 #if __CRTL_VER >= 70000000
2283 sig_code[20] = C$_SIGCHLD;
2285 #if __CRTL_VER >= 70300000
2286 sig_code[28] = C$_SIGWINCH;
2291 if (sig < _SIG_MIN) return 0;
2292 if (sig > _MY_SIG_MAX) return 0;
2293 return sig_code[sig];
2297 Perl_sig_to_vmscondition(int sig)
2300 if (vms_debug_on_exception != 0)
2301 lib$signal(SS$_DEBUG);
2303 return Perl_sig_to_vmscondition_int(sig);
2308 Perl_my_kill(int pid, int sig)
2313 int sys$sigprc(unsigned int *pidadr,
2314 struct dsc$descriptor_s *prcname,
2317 /* sig 0 means validate the PID */
2318 /*------------------------------*/
2320 const unsigned long int jpicode = JPI$_PID;
2323 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2324 if ($VMS_STATUS_SUCCESS(status))
2327 case SS$_NOSUCHNODE:
2328 case SS$_UNREACHABLE:
2342 code = Perl_sig_to_vmscondition_int(sig);
2345 SETERRNO(EINVAL, SS$_BADPARAM);
2349 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2350 * signals are to be sent to multiple processes.
2351 * pid = 0 - all processes in group except ones that the system exempts
2352 * pid = -1 - all processes except ones that the system exempts
2353 * pid = -n - all processes in group (abs(n)) except ...
2354 * For now, just report as not supported.
2358 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2362 iss = sys$sigprc((unsigned int *)&pid,0,code);
2363 if (iss&1) return 0;
2367 set_errno(EPERM); break;
2369 case SS$_NOSUCHNODE:
2370 case SS$_UNREACHABLE:
2371 set_errno(ESRCH); break;
2373 set_errno(ENOMEM); break;
2378 set_vaxc_errno(iss);
2384 /* Routine to convert a VMS status code to a UNIX status code.
2385 ** More tricky than it appears because of conflicting conventions with
2388 ** VMS status codes are a bit mask, with the least significant bit set for
2391 ** Special UNIX status of EVMSERR indicates that no translation is currently
2392 ** available, and programs should check the VMS status code.
2394 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2398 #ifndef C_FACILITY_NO
2399 #define C_FACILITY_NO 0x350000
2402 #define DCL_IVVERB 0x38090
2405 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2413 /* Assume the best or the worst */
2414 if (vms_status & STS$M_SUCCESS)
2417 unix_status = EVMSERR;
2419 msg_status = vms_status & ~STS$M_CONTROL;
2421 facility = vms_status & STS$M_FAC_NO;
2422 fac_sp = vms_status & STS$M_FAC_SP;
2423 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2425 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2431 unix_status = EFAULT;
2433 case SS$_DEVOFFLINE:
2434 unix_status = EBUSY;
2437 unix_status = ENOTCONN;
2445 case SS$_INVFILFOROP:
2449 unix_status = EINVAL;
2451 case SS$_UNSUPPORTED:
2452 unix_status = ENOTSUP;
2457 unix_status = EACCES;
2459 case SS$_DEVICEFULL:
2460 unix_status = ENOSPC;
2463 unix_status = ENODEV;
2465 case SS$_NOSUCHFILE:
2466 case SS$_NOSUCHOBJECT:
2467 unix_status = ENOENT;
2469 case SS$_ABORT: /* Fatal case */
2470 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2471 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2472 unix_status = EINTR;
2475 unix_status = E2BIG;
2478 unix_status = ENOMEM;
2481 unix_status = EPERM;
2483 case SS$_NOSUCHNODE:
2484 case SS$_UNREACHABLE:
2485 unix_status = ESRCH;
2488 unix_status = ECHILD;
2491 if ((facility == 0) && (msg_no < 8)) {
2492 /* These are not real VMS status codes so assume that they are
2493 ** already UNIX status codes
2495 unix_status = msg_no;
2501 /* Translate a POSIX exit code to a UNIX exit code */
2502 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2503 unix_status = (msg_no & 0x07F8) >> 3;
2507 /* Documented traditional behavior for handling VMS child exits */
2508 /*--------------------------------------------------------------*/
2509 if (child_flag != 0) {
2511 /* Success / Informational return 0 */
2512 /*----------------------------------*/
2513 if (msg_no & STS$K_SUCCESS)
2516 /* Warning returns 1 */
2517 /*-------------------*/
2518 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2521 /* Everything else pass through the severity bits */
2522 /*------------------------------------------------*/
2523 return (msg_no & STS$M_SEVERITY);
2526 /* Normal VMS status to ERRNO mapping attempt */
2527 /*--------------------------------------------*/
2528 switch(msg_status) {
2529 /* case RMS$_EOF: */ /* End of File */
2530 case RMS$_FNF: /* File Not Found */
2531 case RMS$_DNF: /* Dir Not Found */
2532 unix_status = ENOENT;
2534 case RMS$_RNF: /* Record Not Found */
2535 unix_status = ESRCH;
2538 unix_status = ENOTDIR;
2541 unix_status = ENODEV;
2546 unix_status = EBADF;
2549 unix_status = EEXIST;
2553 case LIB$_INVSTRDES:
2555 case LIB$_NOSUCHSYM:
2556 case LIB$_INVSYMNAM:
2558 unix_status = EINVAL;
2564 unix_status = E2BIG;
2566 case RMS$_PRV: /* No privilege */
2567 case RMS$_ACC: /* ACP file access failed */
2568 case RMS$_WLK: /* Device write locked */
2569 unix_status = EACCES;
2571 /* case RMS$_NMF: */ /* No more files */
2579 /* Try to guess at what VMS error status should go with a UNIX errno
2580 * value. This is hard to do as there could be many possible VMS
2581 * error statuses that caused the errno value to be set.
2584 int Perl_unix_status_to_vms(int unix_status)
2586 int test_unix_status;
2588 /* Trivial cases first */
2589 /*---------------------*/
2590 if (unix_status == EVMSERR)
2593 /* Is vaxc$errno sane? */
2594 /*---------------------*/
2595 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2596 if (test_unix_status == unix_status)
2599 /* If way out of range, must be VMS code already */
2600 /*-----------------------------------------------*/
2601 if (unix_status > EVMSERR)
2604 /* If out of range, punt */
2605 /*-----------------------*/
2606 if (unix_status > __ERRNO_MAX)
2610 /* Ok, now we have to do it the hard way. */
2611 /*----------------------------------------*/
2612 switch(unix_status) {
2613 case 0: return SS$_NORMAL;
2614 case EPERM: return SS$_NOPRIV;
2615 case ENOENT: return SS$_NOSUCHOBJECT;
2616 case ESRCH: return SS$_UNREACHABLE;
2617 case EINTR: return SS$_ABORT;
2620 case E2BIG: return SS$_BUFFEROVF;
2622 case EBADF: return RMS$_IFI;
2623 case ECHILD: return SS$_NONEXPR;
2625 case ENOMEM: return SS$_INSFMEM;
2626 case EACCES: return SS$_FILACCERR;
2627 case EFAULT: return SS$_ACCVIO;
2629 case EBUSY: return SS$_DEVOFFLINE;
2630 case EEXIST: return RMS$_FEX;
2632 case ENODEV: return SS$_NOSUCHDEV;
2633 case ENOTDIR: return RMS$_DIR;
2635 case EINVAL: return SS$_INVARG;
2641 case ENOSPC: return SS$_DEVICEFULL;
2642 case ESPIPE: return LIB$_INVARG;
2647 case ERANGE: return LIB$_INVARG;
2648 /* case EWOULDBLOCK */
2649 /* case EINPROGRESS */
2652 /* case EDESTADDRREQ */
2654 /* case EPROTOTYPE */
2655 /* case ENOPROTOOPT */
2656 /* case EPROTONOSUPPORT */
2657 /* case ESOCKTNOSUPPORT */
2658 /* case EOPNOTSUPP */
2659 /* case EPFNOSUPPORT */
2660 /* case EAFNOSUPPORT */
2661 /* case EADDRINUSE */
2662 /* case EADDRNOTAVAIL */
2664 /* case ENETUNREACH */
2665 /* case ENETRESET */
2666 /* case ECONNABORTED */
2667 /* case ECONNRESET */
2670 case ENOTCONN: return SS$_CLEARED;
2671 /* case ESHUTDOWN */
2672 /* case ETOOMANYREFS */
2673 /* case ETIMEDOUT */
2674 /* case ECONNREFUSED */
2676 /* case ENAMETOOLONG */
2677 /* case EHOSTDOWN */
2678 /* case EHOSTUNREACH */
2679 /* case ENOTEMPTY */
2691 /* case ECANCELED */
2695 return SS$_UNSUPPORTED;
2701 /* case EABANDONED */
2703 return SS$_ABORT; /* punt */
2706 return SS$_ABORT; /* Should not get here */
2710 /* default piping mailbox size */
2711 #define PERL_BUFSIZ 512
2715 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2717 unsigned long int mbxbufsiz;
2718 static unsigned long int syssize = 0;
2719 unsigned long int dviitm = DVI$_DEVNAM;
2720 char csize[LNM$C_NAMLENGTH+1];
2724 unsigned long syiitm = SYI$_MAXBUF;
2726 * Get the SYSGEN parameter MAXBUF
2728 * If the logical 'PERL_MBX_SIZE' is defined
2729 * use the value of the logical instead of PERL_BUFSIZ, but
2730 * keep the size between 128 and MAXBUF.
2733 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2736 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2737 mbxbufsiz = atoi(csize);
2739 mbxbufsiz = PERL_BUFSIZ;
2741 if (mbxbufsiz < 128) mbxbufsiz = 128;
2742 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2744 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2746 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2747 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2749 } /* end of create_mbx() */
2752 /*{{{ my_popen and my_pclose*/
2754 typedef struct _iosb IOSB;
2755 typedef struct _iosb* pIOSB;
2756 typedef struct _pipe Pipe;
2757 typedef struct _pipe* pPipe;
2758 typedef struct pipe_details Info;
2759 typedef struct pipe_details* pInfo;
2760 typedef struct _srqp RQE;
2761 typedef struct _srqp* pRQE;
2762 typedef struct _tochildbuf CBuf;
2763 typedef struct _tochildbuf* pCBuf;
2766 unsigned short status;
2767 unsigned short count;
2768 unsigned long dvispec;
2771 #pragma member_alignment save
2772 #pragma nomember_alignment quadword
2773 struct _srqp { /* VMS self-relative queue entry */
2774 unsigned long qptr[2];
2776 #pragma member_alignment restore
2777 static RQE RQE_ZERO = {0,0};
2779 struct _tochildbuf {
2782 unsigned short size;
2790 unsigned short chan_in;
2791 unsigned short chan_out;
2793 unsigned int bufsize;
2805 #if defined(PERL_IMPLICIT_CONTEXT)
2806 void *thx; /* Either a thread or an interpreter */
2807 /* pointer, depending on how we're built */
2815 PerlIO *fp; /* file pointer to pipe mailbox */
2816 int useFILE; /* using stdio, not perlio */
2817 int pid; /* PID of subprocess */
2818 int mode; /* == 'r' if pipe open for reading */
2819 int done; /* subprocess has completed */
2820 int waiting; /* waiting for completion/closure */
2821 int closing; /* my_pclose is closing this pipe */
2822 unsigned long completion; /* termination status of subprocess */
2823 pPipe in; /* pipe in to sub */
2824 pPipe out; /* pipe out of sub */
2825 pPipe err; /* pipe of sub's sys$error */
2826 int in_done; /* true when in pipe finished */
2829 unsigned short xchan; /* channel to debug xterm */
2830 unsigned short xchan_valid; /* channel is assigned */
2833 struct exit_control_block
2835 struct exit_control_block *flink;
2836 unsigned long int (*exit_routine)();
2837 unsigned long int arg_count;
2838 unsigned long int *status_address;
2839 unsigned long int exit_status;
2842 typedef struct _closed_pipes Xpipe;
2843 typedef struct _closed_pipes* pXpipe;
2845 struct _closed_pipes {
2846 int pid; /* PID of subprocess */
2847 unsigned long completion; /* termination status of subprocess */
2849 #define NKEEPCLOSED 50
2850 static Xpipe closed_list[NKEEPCLOSED];
2851 static int closed_index = 0;
2852 static int closed_num = 0;
2854 #define RETRY_DELAY "0 ::0.20"
2855 #define MAX_RETRY 50
2857 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2858 static unsigned long mypid;
2859 static unsigned long delaytime[2];
2861 static pInfo open_pipes = NULL;
2862 static $DESCRIPTOR(nl_desc, "NL:");
2864 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2868 static unsigned long int
2869 pipe_exit_routine(pTHX)
2872 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2873 int sts, did_stuff, need_eof, j;
2876 * Flush any pending i/o, but since we are in process run-down, be
2877 * careful about referencing PerlIO structures that may already have
2878 * been deallocated. We may not even have an interpreter anymore.
2884 #if defined(USE_ITHREADS)
2887 && PL_perlio_fd_refcnt)
2888 PerlIO_flush(info->fp);
2890 fflush((FILE *)info->fp);
2896 next we try sending an EOF...ignore if doesn't work, make sure we
2904 _ckvmssts_noperl(sys$setast(0));
2905 if (info->in && !info->in->shut_on_empty) {
2906 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2911 _ckvmssts_noperl(sys$setast(1));
2915 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2917 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2922 _ckvmssts_noperl(sys$setast(0));
2923 if (info->waiting && info->done)
2925 nwait += info->waiting;
2926 _ckvmssts_noperl(sys$setast(1));
2936 _ckvmssts_noperl(sys$setast(0));
2937 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2938 sts = sys$forcex(&info->pid,0,&abort);
2939 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2942 _ckvmssts_noperl(sys$setast(1));
2946 /* again, wait for effect */
2948 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2953 _ckvmssts_noperl(sys$setast(0));
2954 if (info->waiting && info->done)
2956 nwait += info->waiting;
2957 _ckvmssts_noperl(sys$setast(1));
2966 _ckvmssts_noperl(sys$setast(0));
2967 if (!info->done) { /* We tried to be nice . . . */
2968 sts = sys$delprc(&info->pid,0);
2969 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2970 info->done = 1; /* sys$delprc is as done as we're going to get. */
2972 _ckvmssts_noperl(sys$setast(1));
2977 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2978 else if (!(sts & 1)) retsts = sts;
2983 static struct exit_control_block pipe_exitblock =
2984 {(struct exit_control_block *) 0,
2985 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2987 static void pipe_mbxtofd_ast(pPipe p);
2988 static void pipe_tochild1_ast(pPipe p);
2989 static void pipe_tochild2_ast(pPipe p);
2992 popen_completion_ast(pInfo info)
2994 pInfo i = open_pipes;
2999 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3000 closed_list[closed_index].pid = info->pid;
3001 closed_list[closed_index].completion = info->completion;
3003 if (closed_index == NKEEPCLOSED)
3008 if (i == info) break;
3011 if (!i) return; /* unlinked, probably freed too */
3016 Writing to subprocess ...
3017 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3019 chan_out may be waiting for "done" flag, or hung waiting
3020 for i/o completion to child...cancel the i/o. This will
3021 put it into "snarf mode" (done but no EOF yet) that discards
3024 Output from subprocess (stdout, stderr) needs to be flushed and
3025 shut down. We try sending an EOF, but if the mbx is full the pipe
3026 routine should still catch the "shut_on_empty" flag, telling it to
3027 use immediate-style reads so that "mbx empty" -> EOF.
3031 if (info->in && !info->in_done) { /* only for mode=w */
3032 if (info->in->shut_on_empty && info->in->need_wake) {
3033 info->in->need_wake = FALSE;
3034 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3036 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3040 if (info->out && !info->out_done) { /* were we also piping output? */
3041 info->out->shut_on_empty = TRUE;
3042 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3043 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3044 _ckvmssts_noperl(iss);
3047 if (info->err && !info->err_done) { /* we were piping stderr */
3048 info->err->shut_on_empty = TRUE;
3049 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3050 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3051 _ckvmssts_noperl(iss);
3053 _ckvmssts_noperl(sys$setef(pipe_ef));
3057 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3058 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3061 we actually differ from vmstrnenv since we use this to
3062 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3063 are pointing to the same thing
3066 static unsigned short
3067 popen_translate(pTHX_ char *logical, char *result)
3070 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3071 $DESCRIPTOR(d_log,"");
3073 unsigned short length;
3074 unsigned short code;
3076 unsigned short *retlenaddr;
3078 unsigned short l, ifi;
3080 d_log.dsc$a_pointer = logical;
3081 d_log.dsc$w_length = strlen(logical);
3083 itmlst[0].code = LNM$_STRING;
3084 itmlst[0].length = 255;
3085 itmlst[0].buffer_addr = result;
3086 itmlst[0].retlenaddr = &l;
3089 itmlst[1].length = 0;
3090 itmlst[1].buffer_addr = 0;
3091 itmlst[1].retlenaddr = 0;
3093 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3094 if (iss == SS$_NOLOGNAM) {
3098 if (!(iss&1)) lib$signal(iss);
3101 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3102 strip it off and return the ifi, if any
3105 if (result[0] == 0x1b && result[1] == 0x00) {
3106 memmove(&ifi,result+2,2);
3107 strcpy(result,result+4);
3109 return ifi; /* this is the RMS internal file id */
3112 static void pipe_infromchild_ast(pPipe p);
3115 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3116 inside an AST routine without worrying about reentrancy and which Perl
3117 memory allocator is being used.
3119 We read data and queue up the buffers, then spit them out one at a
3120 time to the output mailbox when the output mailbox is ready for one.
3123 #define INITIAL_TOCHILDQUEUE 2
3126 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3130 char mbx1[64], mbx2[64];
3131 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3132 DSC$K_CLASS_S, mbx1},
3133 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3134 DSC$K_CLASS_S, mbx2};
3135 unsigned int dviitm = DVI$_DEVBUFSIZ;
3139 _ckvmssts(lib$get_vm(&n, &p));
3141 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3142 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3143 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3146 p->shut_on_empty = FALSE;
3147 p->need_wake = FALSE;
3150 p->iosb.status = SS$_NORMAL;
3151 p->iosb2.status = SS$_NORMAL;
3157 #ifdef PERL_IMPLICIT_CONTEXT
3161 n = sizeof(CBuf) + p->bufsize;
3163 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3164 _ckvmssts(lib$get_vm(&n, &b));
3165 b->buf = (char *) b + sizeof(CBuf);
3166 _ckvmssts(lib$insqhi(b, &p->free));
3169 pipe_tochild2_ast(p);
3170 pipe_tochild1_ast(p);
3176 /* reads the MBX Perl is writing, and queues */
3179 pipe_tochild1_ast(pPipe p)
3182 int iss = p->iosb.status;
3183 int eof = (iss == SS$_ENDOFFILE);
3185 #ifdef PERL_IMPLICIT_CONTEXT
3191 p->shut_on_empty = TRUE;
3193 _ckvmssts(sys$dassgn(p->chan_in));
3199 b->size = p->iosb.count;
3200 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3202 p->need_wake = FALSE;
3203 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3206 p->retry = 1; /* initial call */
3209 if (eof) { /* flush the free queue, return when done */
3210 int n = sizeof(CBuf) + p->bufsize;
3212 iss = lib$remqti(&p->free, &b);
3213 if (iss == LIB$_QUEWASEMP) return;
3215 _ckvmssts(lib$free_vm(&n, &b));
3219 iss = lib$remqti(&p->free, &b);
3220 if (iss == LIB$_QUEWASEMP) {
3221 int n = sizeof(CBuf) + p->bufsize;
3222 _ckvmssts(lib$get_vm(&n, &b));
3223 b->buf = (char *) b + sizeof(CBuf);
3229 iss = sys$qio(0,p->chan_in,
3230 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3232 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3233 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3238 /* writes queued buffers to output, waits for each to complete before
3242 pipe_tochild2_ast(pPipe p)
3245 int iss = p->iosb2.status;
3246 int n = sizeof(CBuf) + p->bufsize;
3247 int done = (p->info && p->info->done) ||
3248 iss == SS$_CANCEL || iss == SS$_ABORT;
3249 #if defined(PERL_IMPLICIT_CONTEXT)
3254 if (p->type) { /* type=1 has old buffer, dispose */
3255 if (p->shut_on_empty) {
3256 _ckvmssts(lib$free_vm(&n, &b));
3258 _ckvmssts(lib$insqhi(b, &p->free));
3263 iss = lib$remqti(&p->wait, &b);
3264 if (iss == LIB$_QUEWASEMP) {
3265 if (p->shut_on_empty) {
3267 _ckvmssts(sys$dassgn(p->chan_out));
3268 *p->pipe_done = TRUE;
3269 _ckvmssts(sys$setef(pipe_ef));
3271 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3272 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3276 p->need_wake = TRUE;
3286 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3287 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3289 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3290 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3299 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3302 char mbx1[64], mbx2[64];
3303 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3304 DSC$K_CLASS_S, mbx1},
3305 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3306 DSC$K_CLASS_S, mbx2};
3307 unsigned int dviitm = DVI$_DEVBUFSIZ;
3309 int n = sizeof(Pipe);
3310 _ckvmssts(lib$get_vm(&n, &p));
3311 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3312 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3314 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3315 n = p->bufsize * sizeof(char);
3316 _ckvmssts(lib$get_vm(&n, &p->buf));
3317 p->shut_on_empty = FALSE;
3320 p->iosb.status = SS$_NORMAL;
3321 #if defined(PERL_IMPLICIT_CONTEXT)
3324 pipe_infromchild_ast(p);
3332 pipe_infromchild_ast(pPipe p)
3334 int iss = p->iosb.status;
3335 int eof = (iss == SS$_ENDOFFILE);
3336 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3337 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3338 #if defined(PERL_IMPLICIT_CONTEXT)
3342 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3343 _ckvmssts(sys$dassgn(p->chan_out));
3348 input shutdown if EOF from self (done or shut_on_empty)
3349 output shutdown if closing flag set (my_pclose)
3350 send data/eof from child or eof from self
3351 otherwise, re-read (snarf of data from child)
3356 if (myeof && p->chan_in) { /* input shutdown */
3357 _ckvmssts(sys$dassgn(p->chan_in));
3362 if (myeof || kideof) { /* pass EOF to parent */
3363 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3364 pipe_infromchild_ast, p,
3367 } else if (eof) { /* eat EOF --- fall through to read*/
3369 } else { /* transmit data */
3370 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3371 pipe_infromchild_ast,p,
3372 p->buf, p->iosb.count, 0, 0, 0, 0));
3378 /* everything shut? flag as done */
3380 if (!p->chan_in && !p->chan_out) {
3381 *p->pipe_done = TRUE;
3382 _ckvmssts(sys$setef(pipe_ef));
3386 /* write completed (or read, if snarfing from child)
3387 if still have input active,
3388 queue read...immediate mode if shut_on_empty so we get EOF if empty
3390 check if Perl reading, generate EOFs as needed
3396 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3397 pipe_infromchild_ast,p,
3398 p->buf, p->bufsize, 0, 0, 0, 0);
3399 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3401 } else { /* send EOFs for extra reads */
3402 p->iosb.status = SS$_ENDOFFILE;
3403 p->iosb.dvispec = 0;
3404 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3406 pipe_infromchild_ast, p, 0, 0, 0, 0));
3412 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3416 unsigned long dviitm = DVI$_DEVBUFSIZ;
3418 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3419 DSC$K_CLASS_S, mbx};
3420 int n = sizeof(Pipe);
3422 /* things like terminals and mbx's don't need this filter */
3423 if (fd && fstat(fd,&s) == 0) {
3424 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3426 unsigned short dev_len;
3427 struct dsc$descriptor_s d_dev;
3429 struct item_list_3 items[3];
3431 unsigned short dvi_iosb[4];
3433 cptr = getname(fd, out, 1);
3434 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3435 d_dev.dsc$a_pointer = out;
3436 d_dev.dsc$w_length = strlen(out);
3437 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3438 d_dev.dsc$b_class = DSC$K_CLASS_S;
3441 items[0].code = DVI$_DEVCHAR;
3442 items[0].bufadr = &devchar;
3443 items[0].retadr = NULL;
3445 items[1].code = DVI$_FULLDEVNAM;
3446 items[1].bufadr = device;
3447 items[1].retadr = &dev_len;
3451 status = sys$getdviw
3452 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3454 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3455 device[dev_len] = 0;
3457 if (!(devchar & DEV$M_DIR)) {
3458 strcpy(out, device);
3464 _ckvmssts(lib$get_vm(&n, &p));
3465 p->fd_out = dup(fd);
3466 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3467 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3468 n = (p->bufsize+1) * sizeof(char);
3469 _ckvmssts(lib$get_vm(&n, &p->buf));
3470 p->shut_on_empty = FALSE;
3475 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3476 pipe_mbxtofd_ast, p,
3477 p->buf, p->bufsize, 0, 0, 0, 0));
3483 pipe_mbxtofd_ast(pPipe p)
3485 int iss = p->iosb.status;
3486 int done = p->info->done;
3488 int eof = (iss == SS$_ENDOFFILE);
3489 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3490 int err = !(iss&1) && !eof;
3491 #if defined(PERL_IMPLICIT_CONTEXT)
3495 if (done && myeof) { /* end piping */
3497 sys$dassgn(p->chan_in);
3498 *p->pipe_done = TRUE;
3499 _ckvmssts(sys$setef(pipe_ef));
3503 if (!err && !eof) { /* good data to send to file */
3504 p->buf[p->iosb.count] = '\n';
3505 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3508 if (p->retry < MAX_RETRY) {
3509 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3519 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3520 pipe_mbxtofd_ast, p,
3521 p->buf, p->bufsize, 0, 0, 0, 0);
3522 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3527 typedef struct _pipeloc PLOC;
3528 typedef struct _pipeloc* pPLOC;
3532 char dir[NAM$C_MAXRSS+1];
3534 static pPLOC head_PLOC = 0;
3537 free_pipelocs(pTHX_ void *head)
3540 pPLOC *pHead = (pPLOC *)head;
3552 store_pipelocs(pTHX)
3561 char temp[NAM$C_MAXRSS+1];
3565 free_pipelocs(aTHX_ &head_PLOC);
3567 /* the . directory from @INC comes last */
3569 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3570 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3571 p->next = head_PLOC;
3573 strcpy(p->dir,"./");
3575 /* get the directory from $^X */
3577 unixdir = PerlMem_malloc(VMS_MAXRSS);
3578 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3580 #ifdef PERL_IMPLICIT_CONTEXT
3581 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3583 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3585 strcpy(temp, PL_origargv[0]);
3586 x = strrchr(temp,']');
3588 x = strrchr(temp,'>');
3590 /* It could be a UNIX path */
3591 x = strrchr(temp,'/');
3597 /* Got a bare name, so use default directory */
3602 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3603 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3604 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3605 p->next = head_PLOC;
3607 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3608 p->dir[NAM$C_MAXRSS] = '\0';
3612 /* reverse order of @INC entries, skip "." since entered above */
3614 #ifdef PERL_IMPLICIT_CONTEXT
3617 if (PL_incgv) av = GvAVn(PL_incgv);
3619 for (i = 0; av && i <= AvFILL(av); i++) {
3620 dirsv = *av_fetch(av,i,TRUE);
3622 if (SvROK(dirsv)) continue;
3623 dir = SvPVx(dirsv,n_a);
3624 if (strcmp(dir,".") == 0) continue;
3625 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3628 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3629 p->next = head_PLOC;
3631 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3632 p->dir[NAM$C_MAXRSS] = '\0';
3635 /* most likely spot (ARCHLIB) put first in the list */
3638 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3639 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3640 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3641 p->next = head_PLOC;
3643 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3644 p->dir[NAM$C_MAXRSS] = '\0';
3647 PerlMem_free(unixdir);
3651 Perl_cando_by_name_int
3652 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3653 #if !defined(PERL_IMPLICIT_CONTEXT)
3654 #define cando_by_name_int Perl_cando_by_name_int
3656 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3662 static int vmspipe_file_status = 0;
3663 static char vmspipe_file[NAM$C_MAXRSS+1];
3665 /* already found? Check and use ... need read+execute permission */
3667 if (vmspipe_file_status == 1) {
3668 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3669 && cando_by_name_int
3670 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3671 return vmspipe_file;
3673 vmspipe_file_status = 0;
3676 /* scan through stored @INC, $^X */
3678 if (vmspipe_file_status == 0) {
3679 char file[NAM$C_MAXRSS+1];
3680 pPLOC p = head_PLOC;
3685 strcpy(file, p->dir);
3686 dirlen = strlen(file);
3687 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3688 file[NAM$C_MAXRSS] = '\0';
3691 exp_res = do_rmsexpand
3692 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3693 if (!exp_res) continue;
3695 if (cando_by_name_int
3696 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3697 && cando_by_name_int
3698 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3699 vmspipe_file_status = 1;
3700 return vmspipe_file;
3703 vmspipe_file_status = -1; /* failed, use tempfiles */
3710 vmspipe_tempfile(pTHX)
3712 char file[NAM$C_MAXRSS+1];
3714 static int index = 0;
3718 /* create a tempfile */
3720 /* we can't go from W, shr=get to R, shr=get without
3721 an intermediate vulnerable state, so don't bother trying...
3723 and lib$spawn doesn't shr=put, so have to close the write
3725 So... match up the creation date/time and the FID to
3726 make sure we're dealing with the same file
3731 if (!decc_filename_unix_only) {
3732 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3733 fp = fopen(file,"w");
3735 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3736 fp = fopen(file,"w");
3738 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3739 fp = fopen(file,"w");
3744 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3745 fp = fopen(file,"w");
3747 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3748 fp = fopen(file,"w");
3750 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3751 fp = fopen(file,"w");
3755 if (!fp) return 0; /* we're hosed */
3757 fprintf(fp,"$! 'f$verify(0)'\n");
3758 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3759 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3760 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3761 fprintf(fp,"$ perl_on = \"set noon\"\n");
3762 fprintf(fp,"$ perl_exit = \"exit\"\n");
3763 fprintf(fp,"$ perl_del = \"delete\"\n");
3764 fprintf(fp,"$ pif = \"if\"\n");
3765 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3766 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3767 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3768 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3769 fprintf(fp,"$! --- build command line to get max possible length\n");
3770 fprintf(fp,"$c=perl_popen_cmd0\n");
3771 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3772 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3773 fprintf(fp,"$x=perl_popen_cmd3\n");
3774 fprintf(fp,"$c=c+x\n");
3775 fprintf(fp,"$ perl_on\n");
3776 fprintf(fp,"$ 'c'\n");
3777 fprintf(fp,"$ perl_status = $STATUS\n");
3778 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3779 fprintf(fp,"$ perl_exit 'perl_status'\n");
3782 fgetname(fp, file, 1);
3783 fstat(fileno(fp), (struct stat *)&s0);
3786 if (decc_filename_unix_only)
3787 do_tounixspec(file, file, 0, NULL);
3788 fp = fopen(file,"r","shr=get");
3790 fstat(fileno(fp), (struct stat *)&s1);
3792 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3793 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3802 static int vms_is_syscommand_xterm(void)
3804 const static struct dsc$descriptor_s syscommand_dsc =
3805 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3807 const static struct dsc$descriptor_s decwdisplay_dsc =
3808 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3810 struct item_list_3 items[2];
3811 unsigned short dvi_iosb[4];
3812 unsigned long devchar;
3813 unsigned long devclass;
3816 /* Very simple check to guess if sys$command is a decterm? */
3817 /* First see if the DECW$DISPLAY: device exists */
3819 items[0].code = DVI$_DEVCHAR;
3820 items[0].bufadr = &devchar;
3821 items[0].retadr = NULL;
3825 status = sys$getdviw
3826 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3828 if ($VMS_STATUS_SUCCESS(status)) {
3829 status = dvi_iosb[0];
3832 if (!$VMS_STATUS_SUCCESS(status)) {
3833 SETERRNO(EVMSERR, status);
3837 /* If it does, then for now assume that we are on a workstation */
3838 /* Now verify that SYS$COMMAND is a terminal */
3839 /* for creating the debugger DECTerm */
3842 items[0].code = DVI$_DEVCLASS;
3843 items[0].bufadr = &devclass;
3844 items[0].retadr = NULL;
3848 status = sys$getdviw
3849 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3851 if ($VMS_STATUS_SUCCESS(status)) {
3852 status = dvi_iosb[0];
3855 if (!$VMS_STATUS_SUCCESS(status)) {
3856 SETERRNO(EVMSERR, status);
3860 if (devclass == DC$_TERM) {
3867 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3868 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3873 char device_name[65];
3874 unsigned short device_name_len;
3875 struct dsc$descriptor_s customization_dsc;
3876 struct dsc$descriptor_s device_name_dsc;
3879 char customization[200];
3883 unsigned short p_chan;
3885 unsigned short iosb[4];
3886 struct item_list_3 items[2];
3887 const char * cust_str =
3888 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3889 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3890 DSC$K_CLASS_S, mbx1};
3892 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3893 /*---------------------------------------*/
3894 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3897 /* Make sure that this is from the Perl debugger */
3898 ret_char = strstr(cmd," xterm ");
3899 if (ret_char == NULL)
3901 cptr = ret_char + 7;
3902 ret_char = strstr(cmd,"tty");
3903 if (ret_char == NULL)
3905 ret_char = strstr(cmd,"sleep");
3906 if (ret_char == NULL)
3909 if (decw_term_port == 0) {
3910 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3911 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3912 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3914 status = lib$find_image_symbol
3916 &decw_term_port_dsc,
3917 (void *)&decw_term_port,
3921 /* Try again with the other image name */
3922 if (!$VMS_STATUS_SUCCESS(status)) {
3924 status = lib$find_image_symbol
3926 &decw_term_port_dsc,
3927 (void *)&decw_term_port,
3936 /* No decw$term_port, give it up */
3937 if (!$VMS_STATUS_SUCCESS(status))
3940 /* Are we on a workstation? */
3941 /* to do: capture the rows / columns and pass their properties */
3942 ret_stat = vms_is_syscommand_xterm();
3946 /* Make the title: */
3947 ret_char = strstr(cptr,"-title");
3948 if (ret_char != NULL) {
3949 while ((*cptr != 0) && (*cptr != '\"')) {
3955 while ((*cptr != 0) && (*cptr != '\"')) {
3968 strcpy(title,"Perl Debug DECTerm");
3970 sprintf(customization, cust_str, title);
3972 customization_dsc.dsc$a_pointer = customization;
3973 customization_dsc.dsc$w_length = strlen(customization);
3974 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3975 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3977 device_name_dsc.dsc$a_pointer = device_name;
3978 device_name_dsc.dsc$w_length = sizeof device_name -1;
3979 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3980 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3982 device_name_len = 0;
3984 /* Try to create the window */
3985 status = (*decw_term_port)
3994 if (!$VMS_STATUS_SUCCESS(status)) {
3995 SETERRNO(EVMSERR, status);
3999 device_name[device_name_len] = '\0';
4001 /* Need to set this up to look like a pipe for cleanup */
4003 status = lib$get_vm(&n, &info);
4004 if (!$VMS_STATUS_SUCCESS(status)) {
4005 SETERRNO(ENOMEM, status);
4011 info->completion = 0;
4012 info->closing = FALSE;
4019 info->in_done = TRUE;
4020 info->out_done = TRUE;
4021 info->err_done = TRUE;
4023 /* Assign a channel on this so that it will persist, and not login */
4024 /* We stash this channel in the info structure for reference. */
4025 /* The created xterm self destructs when the last channel is removed */
4026 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4027 /* So leave this assigned. */
4028 device_name_dsc.dsc$w_length = device_name_len;
4029 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4030 if (!$VMS_STATUS_SUCCESS(status)) {
4031 SETERRNO(EVMSERR, status);
4034 info->xchan_valid = 1;
4036 /* Now create a mailbox to be read by the application */
4038 create_mbx(aTHX_ &p_chan, &d_mbx1);
4040 /* write the name of the created terminal to the mailbox */
4041 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4042 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4044 if (!$VMS_STATUS_SUCCESS(status)) {
4045 SETERRNO(EVMSERR, status);
4049 info->fp = PerlIO_open(mbx1, mode);
4051 /* Done with this channel */
4054 /* If any errors, then clean up */
4057 _ckvmssts(lib$free_vm(&n, &info));
4066 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4068 static int handler_set_up = FALSE;
4069 unsigned long int sts, flags = CLI$M_NOWAIT;
4070 /* The use of a GLOBAL table (as was done previously) rendered
4071 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4072 * environment. Hence we've switched to LOCAL symbol table.
4074 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4076 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4077 char *in, *out, *err, mbx[512];
4079 char tfilebuf[NAM$C_MAXRSS+1];
4081 char cmd_sym_name[20];
4082 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4083 DSC$K_CLASS_S, symbol};
4084 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4086 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4087 DSC$K_CLASS_S, cmd_sym_name};
4088 struct dsc$descriptor_s *vmscmd;
4089 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4090 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4091 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4093 /* Check here for Xterm create request. This means looking for
4094 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4095 * is possible to create an xterm.
4097 if (*in_mode == 'r') {
4100 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4101 if (xterm_fd != NULL)
4105 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4107 /* once-per-program initialization...
4108 note that the SETAST calls and the dual test of pipe_ef
4109 makes sure that only the FIRST thread through here does
4110 the initialization...all other threads wait until it's
4113 Yeah, uglier than a pthread call, it's got all the stuff inline
4114 rather than in a separate routine.
4118 _ckvmssts(sys$setast(0));
4120 unsigned long int pidcode = JPI$_PID;
4121 $DESCRIPTOR(d_delay, RETRY_DELAY);
4122 _ckvmssts(lib$get_ef(&pipe_ef));
4123 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4124 _ckvmssts(sys$bintim(&d_delay, delaytime));
4126 if (!handler_set_up) {
4127 _ckvmssts(sys$dclexh(&pipe_exitblock));
4128 handler_set_up = TRUE;
4130 _ckvmssts(sys$setast(1));
4133 /* see if we can find a VMSPIPE.COM */
4136 vmspipe = find_vmspipe(aTHX);
4138 strcpy(tfilebuf+1,vmspipe);
4139 } else { /* uh, oh...we're in tempfile hell */
4140 tpipe = vmspipe_tempfile(aTHX);
4141 if (!tpipe) { /* a fish popular in Boston */
4142 if (ckWARN(WARN_PIPE)) {
4143 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4147 fgetname(tpipe,tfilebuf+1,1);
4149 vmspipedsc.dsc$a_pointer = tfilebuf;
4150 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4152 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4155 case RMS$_FNF: case RMS$_DNF:
4156 set_errno(ENOENT); break;
4158 set_errno(ENOTDIR); break;
4160 set_errno(ENODEV); break;
4162 set_errno(EACCES); break;
4164 set_errno(EINVAL); break;
4165 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4166 set_errno(E2BIG); break;
4167 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4168 _ckvmssts(sts); /* fall through */
4169 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4172 set_vaxc_errno(sts);
4173 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4174 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4180 _ckvmssts(lib$get_vm(&n, &info));
4182 strcpy(mode,in_mode);
4185 info->completion = 0;
4186 info->closing = FALSE;
4193 info->in_done = TRUE;
4194 info->out_done = TRUE;
4195 info->err_done = TRUE;
4197 info->xchan_valid = 0;
4199 in = PerlMem_malloc(VMS_MAXRSS);
4200 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4201 out = PerlMem_malloc(VMS_MAXRSS);
4202 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4203 err = PerlMem_malloc(VMS_MAXRSS);
4204 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4206 in[0] = out[0] = err[0] = '\0';
4208 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4212 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4217 if (*mode == 'r') { /* piping from subroutine */
4219 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4221 info->out->pipe_done = &info->out_done;
4222 info->out_done = FALSE;
4223 info->out->info = info;
4225 if (!info->useFILE) {
4226 info->fp = PerlIO_open(mbx, mode);
4228 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4229 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4232 if (!info->fp && info->out) {
4233 sys$cancel(info->out->chan_out);
4235 while (!info->out_done) {
4237 _ckvmssts(sys$setast(0));
4238 done = info->out_done;
4239 if (!done) _ckvmssts(sys$clref(pipe_ef));
4240 _ckvmssts(sys$setast(1));
4241 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4244 if (info->out->buf) {
4245 n = info->out->bufsize * sizeof(char);
4246 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4249 _ckvmssts(lib$free_vm(&n, &info->out));
4251 _ckvmssts(lib$free_vm(&n, &info));
4256 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4258 info->err->pipe_done = &info->err_done;
4259 info->err_done = FALSE;
4260 info->err->info = info;
4263 } else if (*mode == 'w') { /* piping to subroutine */
4265 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4267 info->out->pipe_done = &info->out_done;
4268 info->out_done = FALSE;
4269 info->out->info = info;
4272 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4274 info->err->pipe_done = &info->err_done;
4275 info->err_done = FALSE;
4276 info->err->info = info;
4279 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4280 if (!info->useFILE) {
4281 info->fp = PerlIO_open(mbx, mode);
4283 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4284 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4288 info->in->pipe_done = &info->in_done;
4289 info->in_done = FALSE;
4290 info->in->info = info;
4294 if (!info->fp && info->in) {
4296 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4297 0, 0, 0, 0, 0, 0, 0, 0));
4299 while (!info->in_done) {
4301 _ckvmssts(sys$setast(0));
4302 done = info->in_done;
4303 if (!done) _ckvmssts(sys$clref(pipe_ef));
4304 _ckvmssts(sys$setast(1));
4305 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4308 if (info->in->buf) {
4309 n = info->in->bufsize * sizeof(char);
4310 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4313 _ckvmssts(lib$free_vm(&n, &info->in));
4315 _ckvmssts(lib$free_vm(&n, &info));
4321 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4322 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4324 info->out->pipe_done = &info->out_done;
4325 info->out_done = FALSE;
4326 info->out->info = info;
4329 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4331 info->err->pipe_done = &info->err_done;
4332 info->err_done = FALSE;
4333 info->err->info = info;
4337 symbol[MAX_DCL_SYMBOL] = '\0';
4339 strncpy(symbol, in, MAX_DCL_SYMBOL);
4340 d_symbol.dsc$w_length = strlen(symbol);
4341 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4343 strncpy(symbol, err, MAX_DCL_SYMBOL);
4344 d_symbol.dsc$w_length = strlen(symbol);
4345 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4347 strncpy(symbol, out, MAX_DCL_SYMBOL);
4348 d_symbol.dsc$w_length = strlen(symbol);
4349 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4351 /* Done with the names for the pipes */
4356 p = vmscmd->dsc$a_pointer;
4357 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4358 if (*p == '$') p++; /* remove leading $ */
4359 while (*p == ' ' || *p == '\t') p++;
4361 for (j = 0; j < 4; j++) {
4362 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4363 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4365 strncpy(symbol, p, MAX_DCL_SYMBOL);
4366 d_symbol.dsc$w_length = strlen(symbol);
4367 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4369 if (strlen(p) > MAX_DCL_SYMBOL) {
4370 p += MAX_DCL_SYMBOL;
4375 _ckvmssts(sys$setast(0));
4376 info->next=open_pipes; /* prepend to list */
4378 _ckvmssts(sys$setast(1));
4379 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4380 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4381 * have SYS$COMMAND if we need it.
4383 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4384 0, &info->pid, &info->completion,
4385 0, popen_completion_ast,info,0,0,0));
4387 /* if we were using a tempfile, close it now */
4389 if (tpipe) fclose(tpipe);
4391 /* once the subprocess is spawned, it has copied the symbols and
4392 we can get rid of ours */
4394 for (j = 0; j < 4; j++) {
4395 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4396 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4397 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4399 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4400 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4401 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4402 vms_execfree(vmscmd);
4404 #ifdef PERL_IMPLICIT_CONTEXT
4407 PL_forkprocess = info->pid;
4412 _ckvmssts(sys$setast(0));
4414 if (!done) _ckvmssts(sys$clref(pipe_ef));
4415 _ckvmssts(sys$setast(1));
4416 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4418 *psts = info->completion;
4419 /* Caller thinks it is open and tries to close it. */
4420 /* This causes some problems, as it changes the error status */
4421 /* my_pclose(info->fp); */
4426 } /* end of safe_popen */
4429 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4431 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4435 TAINT_PROPER("popen");
4436 PERL_FLUSHALL_FOR_CHILD;
4437 return safe_popen(aTHX_ cmd,mode,&sts);
4442 /*{{{ I32 my_pclose(PerlIO *fp)*/
4443 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4445 pInfo info, last = NULL;
4446 unsigned long int retsts;
4450 for (info = open_pipes; info != NULL; last = info, info = info->next)
4451 if (info->fp == fp) break;
4453 if (info == NULL) { /* no such pipe open */
4454 set_errno(ECHILD); /* quoth POSIX */
4455 set_vaxc_errno(SS$_NONEXPR);
4459 /* If we were writing to a subprocess, insure that someone reading from
4460 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4461 * produce an EOF record in the mailbox.
4463 * well, at least sometimes it *does*, so we have to watch out for
4464 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4468 #if defined(USE_ITHREADS)
4471 && PL_perlio_fd_refcnt)
4472 PerlIO_flush(info->fp);
4474 fflush((FILE *)info->fp);
4477 _ckvmssts(sys$setast(0));
4478 info->closing = TRUE;
4479 done = info->done && info->in_done && info->out_done && info->err_done;
4480 /* hanging on write to Perl's input? cancel it */
4481 if (info->mode == 'r' && info->out && !info->out_done) {
4482 if (info->out->chan_out) {
4483 _ckvmssts(sys$cancel(info->out->chan_out));
4484 if (!info->out->chan_in) { /* EOF generation, need AST */
4485 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4489 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4490 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4492 _ckvmssts(sys$setast(1));
4495 #if defined(USE_ITHREADS)
4498 && PL_perlio_fd_refcnt)
4499 PerlIO_close(info->fp);
4501 fclose((FILE *)info->fp);
4504 we have to wait until subprocess completes, but ALSO wait until all
4505 the i/o completes...otherwise we'll be freeing the "info" structure
4506 that the i/o ASTs could still be using...
4510 _ckvmssts(sys$setast(0));
4511 done = info->done && info->in_done && info->out_done && info->err_done;
4512 if (!done) _ckvmssts(sys$clref(pipe_ef));
4513 _ckvmssts(sys$setast(1));
4514 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4516 retsts = info->completion;
4518 /* remove from list of open pipes */
4519 _ckvmssts(sys$setast(0));
4520 if (last) last->next = info->next;
4521 else open_pipes = info->next;
4522 _ckvmssts(sys$setast(1));
4524 /* free buffers and structures */
4527 if (info->in->buf) {
4528 n = info->in->bufsize * sizeof(char);
4529 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4532 _ckvmssts(lib$free_vm(&n, &info->in));
4535 if (info->out->buf) {
4536 n = info->out->bufsize * sizeof(char);
4537 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4540 _ckvmssts(lib$free_vm(&n, &info->out));
4543 if (info->err->buf) {
4544 n = info->err->bufsize * sizeof(char);
4545 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4548 _ckvmssts(lib$free_vm(&n, &info->err));
4551 _ckvmssts(lib$free_vm(&n, &info));
4555 } /* end of my_pclose() */
4557 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4558 /* Roll our own prototype because we want this regardless of whether
4559 * _VMS_WAIT is defined.
4561 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4563 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4564 created with popen(); otherwise partially emulate waitpid() unless
4565 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4566 Also check processes not considered by the CRTL waitpid().
4568 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4570 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4577 if (statusp) *statusp = 0;
4579 for (info = open_pipes; info != NULL; info = info->next)
4580 if (info->pid == pid) break;
4582 if (info != NULL) { /* we know about this child */
4583 while (!info->done) {
4584 _ckvmssts(sys$setast(0));
4586 if (!done) _ckvmssts(sys$clref(pipe_ef));
4587 _ckvmssts(sys$setast(1));
4588 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4591 if (statusp) *statusp = info->completion;
4595 /* child that already terminated? */
4597 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4598 if (closed_list[j].pid == pid) {
4599 if (statusp) *statusp = closed_list[j].completion;
4604 /* fall through if this child is not one of our own pipe children */
4606 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4608 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4609 * in 7.2 did we get a version that fills in the VMS completion
4610 * status as Perl has always tried to do.
4613 sts = __vms_waitpid( pid, statusp, flags );
4615 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4618 /* If the real waitpid tells us the child does not exist, we
4619 * fall through here to implement waiting for a child that
4620 * was created by some means other than exec() (say, spawned
4621 * from DCL) or to wait for a process that is not a subprocess
4622 * of the current process.
4625 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4628 $DESCRIPTOR(intdsc,"0 00:00:01");
4629 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4630 unsigned long int pidcode = JPI$_PID, mypid;
4631 unsigned long int interval[2];
4632 unsigned int jpi_iosb[2];
4633 struct itmlst_3 jpilist[2] = {
4634 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4639 /* Sorry folks, we don't presently implement rooting around for
4640 the first child we can find, and we definitely don't want to
4641 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4647 /* Get the owner of the child so I can warn if it's not mine. If the
4648 * process doesn't exist or I don't have the privs to look at it,
4649 * I can go home early.
4651 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4652 if (sts & 1) sts = jpi_iosb[0];
4664 set_vaxc_errno(sts);
4668 if (ckWARN(WARN_EXEC)) {
4669 /* remind folks they are asking for non-standard waitpid behavior */
4670 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4671 if (ownerpid != mypid)
4672 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4673 "waitpid: process %x is not a child of process %x",
4677 /* simply check on it once a second until it's not there anymore. */
4679 _ckvmssts(sys$bintim(&intdsc,interval));
4680 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4681 _ckvmssts(sys$schdwk(0,0,interval,0));
4682 _ckvmssts(sys$hiber());
4684 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4689 } /* end of waitpid() */
4694 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4696 my_gconvert(double val, int ndig, int trail, char *buf)
4698 static char __gcvtbuf[DBL_DIG+1];
4701 loc = buf ? buf : __gcvtbuf;
4703 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4705 sprintf(loc,"%.*g",ndig,val);
4711 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4712 return gcvt(val,ndig,loc);
4715 loc[0] = '0'; loc[1] = '\0';
4722 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4723 static int rms_free_search_context(struct FAB * fab)
4727 nam = fab->fab$l_nam;
4728 nam->nam$b_nop |= NAM$M_SYNCHK;
4729 nam->nam$l_rlf = NULL;
4731 return sys$parse(fab, NULL, NULL);
4734 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4735 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4736 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4737 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4738 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4739 #define rms_nam_esll(nam) nam.nam$b_esl
4740 #define rms_nam_esl(nam) nam.nam$b_esl
4741 #define rms_nam_name(nam) nam.nam$l_name
4742 #define rms_nam_namel(nam) nam.nam$l_name
4743 #define rms_nam_type(nam) nam.nam$l_type
4744 #define rms_nam_typel(nam) nam.nam$l_type
4745 #define rms_nam_ver(nam) nam.nam$l_ver
4746 #define rms_nam_verl(nam) nam.nam$l_ver
4747 #define rms_nam_rsll(nam) nam.nam$b_rsl
4748 #define rms_nam_rsl(nam) nam.nam$b_rsl
4749 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4750 #define rms_set_fna(fab, nam, name, size) \
4751 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4752 #define rms_get_fna(fab, nam) fab.fab$l_fna
4753 #define rms_set_dna(fab, nam, name, size) \
4754 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4755 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4756 #define rms_set_esa(nam, name, size) \
4757 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4758 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4759 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4760 #define rms_set_rsa(nam, name, size) \
4761 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4762 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4763 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4764 #define rms_nam_name_type_l_size(nam) \
4765 (nam.nam$b_name + nam.nam$b_type)
4767 static int rms_free_search_context(struct FAB * fab)
4771 nam = fab->fab$l_naml;
4772 nam->naml$b_nop |= NAM$M_SYNCHK;
4773 nam->naml$l_rlf = NULL;
4774 nam->naml$l_long_defname_size = 0;
4777 return sys$parse(fab, NULL, NULL);
4780 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4781 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4782 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4783 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4784 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4785 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4786 #define rms_nam_esl(nam) nam.naml$b_esl
4787 #define rms_nam_name(nam) nam.naml$l_name
4788 #define rms_nam_namel(nam) nam.naml$l_long_name
4789 #define rms_nam_type(nam) nam.naml$l_type
4790 #define rms_nam_typel(nam) nam.naml$l_long_type
4791 #define rms_nam_ver(nam) nam.naml$l_ver
4792 #define rms_nam_verl(nam) nam.naml$l_long_ver
4793 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4794 #define rms_nam_rsl(nam) nam.naml$b_rsl
4795 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4796 #define rms_set_fna(fab, nam, name, size) \
4797 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4798 nam.naml$l_long_filename_size = size; \
4799 nam.naml$l_long_filename = name;}
4800 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4801 #define rms_set_dna(fab, nam, name, size) \
4802 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4803 nam.naml$l_long_defname_size = size; \
4804 nam.naml$l_long_defname = name; }
4805 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4806 #define rms_set_esa(nam, name, size) \
4807 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4808 nam.naml$l_long_expand_alloc = size; \
4809 nam.naml$l_long_expand = name; }
4810 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4811 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4812 nam.naml$l_long_expand = l_name; \
4813 nam.naml$l_long_expand_alloc = l_size; }
4814 #define rms_set_rsa(nam, name, size) \
4815 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4816 nam.naml$l_long_result = name; \
4817 nam.naml$l_long_result_alloc = size; }
4818 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4819 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4820 nam.naml$l_long_result = l_name; \
4821 nam.naml$l_long_result_alloc = l_size; }
4822 #define rms_nam_name_type_l_size(nam) \
4823 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4828 * The CRTL for 8.3 and later can create symbolic links in any mode,
4829 * however in 8.3 the unlink/remove/delete routines will only properly handle
4830 * them if one of the PCP modes is active.
4832 static int rms_erase(const char * vmsname)
4835 struct FAB myfab = cc$rms_fab;
4836 rms_setup_nam(mynam);
4838 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4839 rms_bind_fab_nam(myfab, mynam);
4841 /* Are we removing all versions? */
4842 if (vms_unlink_all_versions == 1) {
4843 const char * defspec = ";*";
4844 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4847 #ifdef NAML$M_OPEN_SPECIAL
4848 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4851 status = sys$erase(&myfab, 0, 0);
4858 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4859 const struct dsc$descriptor_s * vms_dst_dsc,
4860 unsigned long flags)
4862 /* VMS and UNIX handle file permissions differently and the
4863 * the same ACL trick may be needed for renaming files,
4864 * especially if they are directories.
4867 /* todo: get kill_file and rename to share common code */
4868 /* I can not find online documentation for $change_acl
4869 * it appears to be replaced by $set_security some time ago */
4871 const unsigned int access_mode = 0;
4872 $DESCRIPTOR(obj_file_dsc,"FILE");
4875 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4876 int aclsts, fndsts, rnsts = -1;
4877 unsigned int ctx = 0;
4878 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4879 struct dsc$descriptor_s * clean_dsc;
4882 unsigned char myace$b_length;
4883 unsigned char myace$b_type;
4884 unsigned short int myace$w_flags;
4885 unsigned long int myace$l_access;
4886 unsigned long int myace$l_ident;
4887 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4888 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4890 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4893 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4894 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4896 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4897 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4901 /* Expand the input spec using RMS, since we do not want to put
4902 * ACLs on the target of a symbolic link */
4903 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4904 if (vmsname == NULL)
4907 rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4911 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4915 PerlMem_free(vmsname);
4919 /* So we get our own UIC to use as a rights identifier,
4920 * and the insert an ACE at the head of the ACL which allows us
4921 * to delete the file.
4923 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4925 fildsc.dsc$w_length = strlen(vmsname);
4926 fildsc.dsc$a_pointer = vmsname;
4928 newace.myace$l_ident = oldace.myace$l_ident;
4931 /* Grab any existing ACEs with this identifier in case we fail */
4932 clean_dsc = &fildsc;
4933 aclsts = fndsts = sys$get_security(&obj_file_dsc,
4941 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
4942 /* Add the new ACE . . . */
4944 /* if the sys$get_security succeeded, then ctx is valid, and the
4945 * object/file descriptors will be ignored. But otherwise they
4948 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4949 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4950 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4952 set_vaxc_errno(aclsts);
4953 PerlMem_free(vmsname);
4957 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4960 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4962 if ($VMS_STATUS_SUCCESS(rnsts)) {
4963 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4966 /* Put things back the way they were. */
4968 aclsts = sys$get_security(&obj_file_dsc,
4976 if ($VMS_STATUS_SUCCESS(aclsts)) {
4980 if (!$VMS_STATUS_SUCCESS(fndsts))
4981 sec_flags = OSS$M_RELCTX;
4983 /* Get rid of the new ACE */
4984 aclsts = sys$set_security(NULL, NULL, NULL,
4985 sec_flags, dellst, &ctx, &access_mode);
4987 /* If there was an old ACE, put it back */
4988 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4989 addlst[0].bufadr = &oldace;
4990 aclsts = sys$set_security(NULL, NULL, NULL,
4991 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4992 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4994 set_vaxc_errno(aclsts);
5000 /* Try to clear the lock on the ACL list */
5001 aclsts2 = sys$set_security(NULL, NULL, NULL,
5002 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5004 /* Rename errors are most important */
5005 if (!$VMS_STATUS_SUCCESS(rnsts))
5008 set_vaxc_errno(aclsts);
5013 if (aclsts != SS$_ACLEMPTY)
5020 PerlMem_free(vmsname);
5025 /*{{{int rename(const char *, const char * */
5026 /* Not exactly what X/Open says to do, but doing it absolutely right
5027 * and efficiently would require a lot more work. This should be close
5028 * enough to pass all but the most strict X/Open compliance test.
5031 Perl_rename(pTHX_ const char *src, const char * dst)
5040 /* Validate the source file */
5041 src_sts = flex_lstat(src, &src_st);
5044 /* No source file or other problem */
5048 dst_sts = flex_lstat(dst, &dst_st);
5051 if (dst_st.st_dev != src_st.st_dev) {
5052 /* Must be on the same device */
5057 /* VMS_INO_T_COMPARE is true if the inodes are different
5058 * to match the output of memcmp
5061 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5062 /* That was easy, the files are the same! */
5066 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5067 /* If source is a directory, so must be dest */
5075 if ((dst_sts == 0) &&
5076 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5078 /* We have issues here if vms_unlink_all_versions is set
5079 * If the destination exists, and is not a directory, then
5080 * we must delete in advance.
5082 * If the src is a directory, then we must always pre-delete
5085 * If we successfully delete the dst in advance, and the rename fails
5086 * X/Open requires that errno be EIO.
5090 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5092 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5096 /* We killed the destination, so only errno now is EIO */
5101 /* Originally the idea was to call the CRTL rename() and only
5102 * try the lib$rename_file if it failed.
5103 * It turns out that there are too many variants in what the
5104 * the CRTL rename might do, so only use lib$rename_file
5109 /* Is the source and dest both in VMS format */
5110 /* if the source is a directory, then need to fileify */
5111 /* and dest must be a directory or non-existant. */
5117 unsigned long flags;
5118 struct dsc$descriptor_s old_file_dsc;
5119 struct dsc$descriptor_s new_file_dsc;
5121 /* We need to modify the src and dst depending
5122 * on if one or more of them are directories.
5125 vms_src = PerlMem_malloc(VMS_MAXRSS);
5126 if (vms_src == NULL)
5127 _ckvmssts(SS$_INSFMEM);
5129 /* Source is always a VMS format file */
5130 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5131 if (ret_str == NULL) {
5132 PerlMem_free(vms_src);
5137 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5138 if (vms_dst == NULL)
5139 _ckvmssts(SS$_INSFMEM);
5141 if (S_ISDIR(src_st.st_mode)) {
5143 char * vms_dir_file;
5145 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5146 if (vms_dir_file == NULL)
5147 _ckvmssts(SS$_INSFMEM);
5149 /* The source must be a file specification */
5150 ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5151 if (ret_str == NULL) {
5152 PerlMem_free(vms_src);
5153 PerlMem_free(vms_dst);
5154 PerlMem_free(vms_dir_file);
5158 PerlMem_free(vms_src);
5159 vms_src = vms_dir_file;
5161 /* If the dest is a directory, we must remove it
5164 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5166 PerlMem_free(vms_src);
5167 PerlMem_free(vms_dst);
5175 /* The dest must be a VMS file specification */
5176 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5177 if (ret_str == NULL) {
5178 PerlMem_free(vms_src);
5179 PerlMem_free(vms_dst);
5184 /* The source must be a file specification */
5185 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5186 if (vms_dir_file == NULL)
5187 _ckvmssts(SS$_INSFMEM);
5189 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5190 if (ret_str == NULL) {
5191 PerlMem_free(vms_src);
5192 PerlMem_free(vms_dst);
5193 PerlMem_free(vms_dir_file);
5197 PerlMem_free(vms_dst);
5198 vms_dst = vms_dir_file;
5201 /* File to file or file to new dir */
5203 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5204 /* VMS pathify a dir target */
5205 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5206 if (ret_str == NULL) {
5207 PerlMem_free(vms_src);
5208 PerlMem_free(vms_dst);
5214 /* fileify a target VMS file specification */
5215 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5216 if (ret_str == NULL) {
5217 PerlMem_free(vms_src);
5218 PerlMem_free(vms_dst);
5225 old_file_dsc.dsc$a_pointer = vms_src;
5226 old_file_dsc.dsc$w_length = strlen(vms_src);
5227 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5228 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5230 new_file_dsc.dsc$a_pointer = vms_dst;
5231 new_file_dsc.dsc$w_length = strlen(vms_dst);
5232 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5233 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5236 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5237 flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5240 sts = lib$rename_file(&old_file_dsc,
5244 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5245 if (!$VMS_STATUS_SUCCESS(sts)) {
5247 /* We could have failed because VMS style permissions do not
5248 * permit renames that UNIX will allow. Just like the hack
5251 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5254 PerlMem_free(vms_src);
5255 PerlMem_free(vms_dst);
5256 if (!$VMS_STATUS_SUCCESS(sts)) {
5263 if (vms_unlink_all_versions) {
5264 /* Now get rid of any previous versions of the source file that
5269 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5273 /* We deleted the destination, so must force the error to be EIO */
5274 if ((retval != 0) && (pre_delete != 0))
5282 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5283 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5284 * to expand file specification. Allows for a single default file
5285 * specification and a simple mask of options. If outbuf is non-NULL,
5286 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5287 * the resultant file specification is placed. If outbuf is NULL, the
5288 * resultant file specification is placed into a static buffer.
5289 * The third argument, if non-NULL, is taken to be a default file
5290 * specification string. The fourth argument is unused at present.
5291 * rmesexpand() returns the address of the resultant string if
5292 * successful, and NULL on error.
5294 * New functionality for previously unused opts value:
5295 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5296 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5297 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5298 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5300 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5304 (pTHX_ const char *filespec,
5307 const char *defspec,
5312 static char __rmsexpand_retbuf[VMS_MAXRSS];
5313 char * vmsfspec, *tmpfspec;
5314 char * esa, *cp, *out = NULL;
5318 struct FAB myfab = cc$rms_fab;
5319 rms_setup_nam(mynam);
5321 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5324 /* temp hack until UTF8 is actually implemented */
5325 if (fs_utf8 != NULL)
5328 if (!filespec || !*filespec) {
5329 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5333 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5334 else outbuf = __rmsexpand_retbuf;
5342 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5343 isunix = is_unix_filespec(filespec);
5345 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5346 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5347 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5348 PerlMem_free(vmsfspec);
5353 filespec = vmsfspec;
5355 /* Unless we are forcing to VMS format, a UNIX input means
5356 * UNIX output, and that requires long names to be used
5358 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5359 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5360 opts |= PERL_RMSEXPAND_M_LONG;
5367 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5368 rms_bind_fab_nam(myfab, mynam);
5370 if (defspec && *defspec) {
5372 t_isunix = is_unix_filespec(defspec);
5374 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5375 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5376 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5377 PerlMem_free(tmpfspec);
5378 if (vmsfspec != NULL)
5379 PerlMem_free(vmsfspec);
5386 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5389 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5390 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5391 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5392 esal = PerlMem_malloc(VMS_MAXRSS);
5393 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5395 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5397 /* If a NAML block is used RMS always writes to the long and short
5398 * addresses unless you suppress the short name.
5400 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5401 outbufl = PerlMem_malloc(VMS_MAXRSS);
5402 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5404 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5406 #ifdef NAM$M_NO_SHORT_UPCASE
5407 if (decc_efs_case_preserve)
5408 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5411 /* We may not want to follow symbolic links */
5412 #ifdef NAML$M_OPEN_SPECIAL
5413 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5414 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5417 /* First attempt to parse as an existing file */
5418 retsts = sys$parse(&myfab,0,0);
5419 if (!(retsts & STS$K_SUCCESS)) {
5421 /* Could not find the file, try as syntax only if error is not fatal */
5422 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5423 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5424 retsts = sys$parse(&myfab,0,0);
5425 if (retsts & STS$K_SUCCESS) goto expanded;
5428 /* Still could not parse the file specification */
5429 /*----------------------------------------------*/
5430 sts = rms_free_search_context(&myfab); /* Free search context */
5431 if (out) Safefree(out);
5432 if (tmpfspec != NULL)
5433 PerlMem_free(tmpfspec);
5434 if (vmsfspec != NULL)
5435 PerlMem_free(vmsfspec);
5436 if (outbufl != NULL)
5437 PerlMem_free(outbufl);
5441 set_vaxc_errno(retsts);
5442 if (retsts == RMS$_PRV) set_errno(EACCES);
5443 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5444 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5445 else set_errno(EVMSERR);
5448 retsts = sys$search(&myfab,0,0);
5449 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5450 sts = rms_free_search_context(&myfab); /* Free search context */
5451 if (out) Safefree(out);
5452 if (tmpfspec != NULL)
5453 PerlMem_free(tmpfspec);
5454 if (vmsfspec != NULL)
5455 PerlMem_free(vmsfspec);
5456 if (outbufl != NULL)
5457 PerlMem_free(outbufl);
5461 set_vaxc_errno(retsts);
5462 if (retsts == RMS$_PRV) set_errno(EACCES);
5463 else set_errno(EVMSERR);
5467 /* If the input filespec contained any lowercase characters,
5468 * downcase the result for compatibility with Unix-minded code. */
5470 if (!decc_efs_case_preserve) {
5471 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5472 if (islower(*tbuf)) { haslower = 1; break; }
5475 /* Is a long or a short name expected */
5476 /*------------------------------------*/
5477 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5478 if (rms_nam_rsll(mynam)) {
5480 speclen = rms_nam_rsll(mynam);
5483 tbuf = esal; /* Not esa */
5484 speclen = rms_nam_esll(mynam);
5488 if (rms_nam_rsl(mynam)) {
5490 speclen = rms_nam_rsl(mynam);
5493 tbuf = esa; /* Not esal */
5494 speclen = rms_nam_esl(mynam);
5497 tbuf[speclen] = '\0';
5499 /* Trim off null fields added by $PARSE
5500 * If type > 1 char, must have been specified in original or default spec
5501 * (not true for version; $SEARCH may have added version of existing file).
5503 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5504 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5505 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5506 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5509 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5510 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5512 if (trimver || trimtype) {
5513 if (defspec && *defspec) {
5514 char *defesal = NULL;
5515 char *defesa = NULL;
5516 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5517 if (defesa != NULL) {
5518 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5519 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5520 if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5522 struct FAB deffab = cc$rms_fab;
5523 rms_setup_nam(defnam);
5525 rms_bind_fab_nam(deffab, defnam);
5529 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5531 /* RMS needs the esa/esal as a work area if wildcards are involved */
5532 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5534 rms_clear_nam_nop(defnam);
5535 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5536 #ifdef NAM$M_NO_SHORT_UPCASE
5537 if (decc_efs_case_preserve)
5538 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5540 #ifdef NAML$M_OPEN_SPECIAL
5541 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5542 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5544 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5546 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5549 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5552 if (defesal != NULL)
5553 PerlMem_free(defesal);
5554 PerlMem_free(defesa);
5558 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5559 if (*(rms_nam_verl(mynam)) != '\"')
5560 speclen = rms_nam_verl(mynam) - tbuf;
5563 if (*(rms_nam_ver(mynam)) != '\"')
5564 speclen = rms_nam_ver(mynam) - tbuf;
5568 /* If we didn't already trim version, copy down */
5569 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5570 if (speclen > rms_nam_verl(mynam) - tbuf)
5572 (rms_nam_typel(mynam),
5573 rms_nam_verl(mynam),
5574 speclen - (rms_nam_verl(mynam) - tbuf));
5575 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5578 if (speclen > rms_nam_ver(mynam) - tbuf)
5580 (rms_nam_type(mynam),
5582 speclen - (rms_nam_ver(mynam) - tbuf));
5583 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5588 /* Done with these copies of the input files */
5589 /*-------------------------------------------*/
5590 if (vmsfspec != NULL)
5591 PerlMem_free(vmsfspec);
5592 if (tmpfspec != NULL)
5593 PerlMem_free(tmpfspec);
5595 /* If we just had a directory spec on input, $PARSE "helpfully"
5596 * adds an empty name and type for us */
5597 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5598 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5599 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5600 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5601 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5602 speclen = rms_nam_namel(mynam) - tbuf;
5607 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5608 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5609 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5610 speclen = rms_nam_name(mynam) - tbuf;
5613 /* Posix format specifications must have matching quotes */
5614 if (speclen < (VMS_MAXRSS - 1)) {
5615 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5616 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5617 tbuf[speclen] = '\"';
5622 tbuf[speclen] = '\0';
5623 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5625 /* Have we been working with an expanded, but not resultant, spec? */
5626 /* Also, convert back to Unix syntax if necessary. */
5630 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5631 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5632 rsl = rms_nam_rsll(mynam);
5636 rsl = rms_nam_rsl(mynam);
5640 if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5641 if (out) Safefree(out);
5645 if (outbufl != NULL)
5646 PerlMem_free(outbufl);
5650 else strcpy(outbuf, tbuf);
5653 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5654 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5655 if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5656 if (out) Safefree(out);
5660 PerlMem_free(tmpfspec);
5661 if (outbufl != NULL)
5662 PerlMem_free(outbufl);
5665 strcpy(outbuf,tmpfspec);
5666 PerlMem_free(tmpfspec);
5669 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5670 sts = rms_free_search_context(&myfab); /* Free search context */
5674 if (outbufl != NULL)
5675 PerlMem_free(outbufl);
5679 /* External entry points */
5680 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5681 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5682 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5683 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5684 char *Perl_rmsexpand_utf8
5685 (pTHX_ const char *spec, char *buf, const char *def,
5686 unsigned opt, int * fs_utf8, int * dfs_utf8)
5687 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5688 char *Perl_rmsexpand_utf8_ts
5689 (pTHX_ const char *spec, char *buf, const char *def,
5690 unsigned opt, int * fs_utf8, int * dfs_utf8)
5691 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5695 ** The following routines are provided to make life easier when
5696 ** converting among VMS-style and Unix-style directory specifications.
5697 ** All will take input specifications in either VMS or Unix syntax. On
5698 ** failure, all return NULL. If successful, the routines listed below
5699 ** return a pointer to a buffer containing the appropriately
5700 ** reformatted spec (and, therefore, subsequent calls to that routine
5701 ** will clobber the result), while the routines of the same names with
5702 ** a _ts suffix appended will return a pointer to a mallocd string
5703 ** containing the appropriately reformatted spec.
5704 ** In all cases, only explicit syntax is altered; no check is made that
5705 ** the resulting string is valid or that the directory in question
5708 ** fileify_dirspec() - convert a directory spec into the name of the
5709 ** directory file (i.e. what you can stat() to see if it's a dir).
5710 ** The style (VMS or Unix) of the result is the same as the style
5711 ** of the parameter passed in.
5712 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5713 ** what you prepend to a filename to indicate what directory it's in).
5714 ** The style (VMS or Unix) of the result is the same as the style
5715 ** of the parameter passed in.
5716 ** tounixpath() - convert a directory spec into a Unix-style path.
5717 ** tovmspath() - convert a directory spec into a VMS-style path.
5718 ** tounixspec() - convert any file spec into a Unix-style file spec.
5719 ** tovmsspec() - convert any file spec into a VMS-style spec.
5720 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5722 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5723 ** Permission is given to distribute this code as part of the Perl
5724 ** standard distribution under the terms of the GNU General Public
5725 ** License or the Perl Artistic License. Copies of each may be
5726 ** found in the Perl standard distribution.
5729 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5730 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5732 static char __fileify_retbuf[VMS_MAXRSS];
5733 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5734 char *retspec, *cp1, *cp2, *lastdir;
5735 char *trndir, *vmsdir;
5736 unsigned short int trnlnm_iter_count;
5738 if (utf8_fl != NULL)
5741 if (!dir || !*dir) {
5742 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5744 dirlen = strlen(dir);
5745 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5746 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5747 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5754 if (dirlen > (VMS_MAXRSS - 1)) {
5755 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5758 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5759 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5760 if (!strpbrk(dir+1,"/]>:") &&
5761 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5762 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5763 trnlnm_iter_count = 0;
5764 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5765 trnlnm_iter_count++;
5766 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5768 dirlen = strlen(trndir);
5771 strncpy(trndir,dir,dirlen);
5772 trndir[dirlen] = '\0';
5775 /* At this point we are done with *dir and use *trndir which is a
5776 * copy that can be modified. *dir must not be modified.
5779 /* If we were handed a rooted logical name or spec, treat it like a
5780 * simple directory, so that
5781 * $ Define myroot dev:[dir.]
5782 * ... do_fileify_dirspec("myroot",buf,1) ...
5783 * does something useful.
5785 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5786 trndir[--dirlen] = '\0';
5787 trndir[dirlen-1] = ']';
5789 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5790 trndir[--dirlen] = '\0';
5791 trndir[dirlen-1] = '>';
5794 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5795 /* If we've got an explicit filename, we can just shuffle the string. */
5796 if (*(cp1+1)) hasfilename = 1;
5797 /* Similarly, we can just back up a level if we've got multiple levels
5798 of explicit directories in a VMS spec which ends with directories. */
5800 for (cp2 = cp1; cp2 > trndir; cp2--) {
5802 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5803 /* fix-me, can not scan EFS file specs backward like this */
5804 *cp2 = *cp1; *cp1 = '\0';
5809 if (*cp2 == '[' || *cp2 == '<') break;
5814 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5815 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5816 cp1 = strpbrk(trndir,"]:>");
5817 if (hasfilename || !cp1) { /* Unix-style path or filename */
5818 if (trndir[0] == '.') {
5819 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5820 PerlMem_free(trndir);
5821 PerlMem_free(vmsdir);
5822 return do_fileify_dirspec("[]",buf,ts,NULL);
5824 else if (trndir[1] == '.' &&
5825 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5826 PerlMem_free(trndir);
5827 PerlMem_free(vmsdir);
5828 return do_fileify_dirspec("[-]",buf,ts,NULL);
5831 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5832 dirlen -= 1; /* to last element */
5833 lastdir = strrchr(trndir,'/');
5835 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5836 /* If we have "/." or "/..", VMSify it and let the VMS code
5837 * below expand it, rather than repeating the code to handle
5838 * relative components of a filespec here */
5840 if (*(cp1+2) == '.') cp1++;
5841 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5843 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5844 PerlMem_free(trndir);
5845 PerlMem_free(vmsdir);
5848 if (strchr(vmsdir,'/') != NULL) {
5849 /* If do_tovmsspec() returned it, it must have VMS syntax
5850 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5851 * the time to check this here only so we avoid a recursion
5852 * loop; otherwise, gigo.
5854 PerlMem_free(trndir);
5855 PerlMem_free(vmsdir);
5856 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5859 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5860 PerlMem_free(trndir);
5861 PerlMem_free(vmsdir);
5864 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5865 PerlMem_free(trndir);
5866 PerlMem_free(vmsdir);
5870 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5871 lastdir = strrchr(trndir,'/');
5873 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5875 /* Ditto for specs that end in an MFD -- let the VMS code
5876 * figure out whether it's a real device or a rooted logical. */
5878 /* This should not happen any more. Allowing the fake /000000
5879 * in a UNIX pathname causes all sorts of problems when trying
5880 * to run in UNIX emulation. So the VMS to UNIX conversions
5881 * now remove the fake /000000 directories.
5884 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5885 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5886 PerlMem_free(trndir);
5887 PerlMem_free(vmsdir);
5890 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5891 PerlMem_free(trndir);
5892 PerlMem_free(vmsdir);
5895 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5896 PerlMem_free(trndir);
5897 PerlMem_free(vmsdir);
5902 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5903 !(lastdir = cp1 = strrchr(trndir,']')) &&
5904 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5905 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5908 /* For EFS or ODS-5 look for the last dot */
5909 if (decc_efs_charset) {
5910 cp2 = strrchr(cp1,'.');
5912 if (vms_process_case_tolerant) {
5913 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5914 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5915 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5916 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5917 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5918 (ver || *cp3)))))) {
5919 PerlMem_free(trndir);
5920 PerlMem_free(vmsdir);
5922 set_vaxc_errno(RMS$_DIR);
5927 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5928 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5929 !*(cp2+3) || *(cp2+3) != 'R' ||
5930 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5931 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5932 (ver || *cp3)))))) {
5933 PerlMem_free(trndir);
5934 PerlMem_free(vmsdir);
5936 set_vaxc_errno(RMS$_DIR);
5940 dirlen = cp2 - trndir;
5944 retlen = dirlen + 6;
5945 if (buf) retspec = buf;
5946 else if (ts) Newx(retspec,retlen+1,char);
5947 else retspec = __fileify_retbuf;
5948 memcpy(retspec,trndir,dirlen);
5949 retspec[dirlen] = '\0';
5951 /* We've picked up everything up to the directory file name.
5952 Now just add the type and version, and we're set. */
5953 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5954 strcat(retspec,".dir;1");
5956 strcat(retspec,".DIR;1");
5957 PerlMem_free(trndir);
5958 PerlMem_free(vmsdir);
5961 else { /* VMS-style directory spec */
5963 char *esa, *esal, term, *cp;
5966 unsigned long int sts, cmplen, haslower = 0;
5967 unsigned int nam_fnb;
5969 struct FAB dirfab = cc$rms_fab;
5970 rms_setup_nam(savnam);
5971 rms_setup_nam(dirnam);
5973 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5974 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5976 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5977 esal = PerlMem_malloc(VMS_MAXRSS);
5978 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5980 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5981 rms_bind_fab_nam(dirfab, dirnam);
5982 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5983 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5984 #ifdef NAM$M_NO_SHORT_UPCASE
5985 if (decc_efs_case_preserve)
5986 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5989 for (cp = trndir; *cp; cp++)
5990 if (islower(*cp)) { haslower = 1; break; }
5991 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5992 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5993 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5994 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6000 PerlMem_free(trndir);
6001 PerlMem_free(vmsdir);
6003 set_vaxc_errno(dirfab.fab$l_sts);
6009 /* Does the file really exist? */
6010 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6011 /* Yes; fake the fnb bits so we'll check type below */
6012 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6014 else { /* No; just work with potential name */
6015 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6018 fab_sts = dirfab.fab$l_sts;
6019 sts = rms_free_search_context(&dirfab);
6023 PerlMem_free(trndir);
6024 PerlMem_free(vmsdir);
6025 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6031 /* Make sure we are using the right buffer */
6034 my_esa_len = rms_nam_esll(dirnam);
6037 my_esa_len = rms_nam_esl(dirnam);
6039 my_esa[my_esa_len] = '\0';
6040 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6041 cp1 = strchr(my_esa,']');
6042 if (!cp1) cp1 = strchr(my_esa,'>');
6043 if (cp1) { /* Should always be true */
6044 my_esa_len -= cp1 - my_esa - 1;
6045 memmove(my_esa, cp1 + 1, my_esa_len);
6048 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6049 /* Yep; check version while we're at it, if it's there. */
6050 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6051 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6052 /* Something other than .DIR[;1]. Bzzt. */
6053 sts = rms_free_search_context(&dirfab);
6057 PerlMem_free(trndir);
6058 PerlMem_free(vmsdir);
6060 set_vaxc_errno(RMS$_DIR);
6065 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6066 /* They provided at least the name; we added the type, if necessary, */
6067 if (buf) retspec = buf; /* in sys$parse() */
6068 else if (ts) Newx(retspec, my_esa_len + 1, char);
6069 else retspec = __fileify_retbuf;
6070 strcpy(retspec,my_esa);
6071 sts = rms_free_search_context(&dirfab);
6072 PerlMem_free(trndir);
6076 PerlMem_free(vmsdir);
6079 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6080 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6084 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6085 if (cp1 == NULL) { /* should never happen */
6086 sts = rms_free_search_context(&dirfab);
6087 PerlMem_free(trndir);
6091 PerlMem_free(vmsdir);
6096 retlen = strlen(my_esa);
6097 cp1 = strrchr(my_esa,'.');
6098 /* ODS-5 directory specifications can have extra "." in them. */
6099 /* Fix-me, can not scan EFS file specifications backwards */
6100 while (cp1 != NULL) {
6101 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6105 while ((cp1 > my_esa) && (*cp1 != '.'))
6112 if ((cp1) != NULL) {
6113 /* There's more than one directory in the path. Just roll back. */
6115 if (buf) retspec = buf;
6116 else if (ts) Newx(retspec,retlen+7,char);
6117 else retspec = __fileify_retbuf;
6118 strcpy(retspec,my_esa);
6121 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6122 /* Go back and expand rooted logical name */
6123 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6124 #ifdef NAM$M_NO_SHORT_UPCASE
6125 if (decc_efs_case_preserve)
6126 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6128 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6129 sts = rms_free_search_context(&dirfab);
6133 PerlMem_free(trndir);
6134 PerlMem_free(vmsdir);
6136 set_vaxc_errno(dirfab.fab$l_sts);
6140 /* This changes the length of the string of course */
6142 my_esa_len = rms_nam_esll(dirnam);
6144 my_esa_len = rms_nam_esl(dirnam);
6147 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6148 if (buf) retspec = buf;
6149 else if (ts) Newx(retspec,retlen+16,char);
6150 else retspec = __fileify_retbuf;
6151 cp1 = strstr(my_esa,"][");
6152 if (!cp1) cp1 = strstr(my_esa,"]<");
6153 dirlen = cp1 - my_esa;
6154 memcpy(retspec,my_esa,dirlen);
6155 if (!strncmp(cp1+2,"000000]",7)) {
6156 retspec[dirlen-1] = '\0';
6157 /* fix-me Not full ODS-5, just extra dots in directories for now */
6158 cp1 = retspec + dirlen - 1;
6159 while (cp1 > retspec)
6164 if (*(cp1-1) != '^')
6169 if (*cp1 == '.') *cp1 = ']';
6171 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6172 memmove(cp1+1,"000000]",7);
6176 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6177 retspec[retlen] = '\0';
6178 /* Convert last '.' to ']' */
6179 cp1 = retspec+retlen-1;
6180 while (*cp != '[') {
6183 /* Do not trip on extra dots in ODS-5 directories */
6184 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6188 if (*cp1 == '.') *cp1 = ']';
6190 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6191 memmove(cp1+1,"000000]",7);
6195 else { /* This is a top-level dir. Add the MFD to the path. */
6196 if (buf) retspec = buf;
6197 else if (ts) Newx(retspec,retlen+16,char);
6198 else retspec = __fileify_retbuf;
6201 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6202 strcpy(cp2,":[000000]");
6207 sts = rms_free_search_context(&dirfab);
6208 /* We've set up the string up through the filename. Add the
6209 type and version, and we're done. */
6210 strcat(retspec,".DIR;1");
6212 /* $PARSE may have upcased filespec, so convert output to lower
6213 * case if input contained any lowercase characters. */
6214 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6215 PerlMem_free(trndir);
6219 PerlMem_free(vmsdir);
6222 } /* end of do_fileify_dirspec() */
6224 /* External entry points */
6225 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6226 { return do_fileify_dirspec(dir,buf,0,NULL); }
6227 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6228 { return do_fileify_dirspec(dir,buf,1,NULL); }
6229 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6230 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6231 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6232 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6234 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6235 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6237 static char __pathify_retbuf[VMS_MAXRSS];
6238 unsigned long int retlen;
6239 char *retpath, *cp1, *cp2, *trndir;
6240 unsigned short int trnlnm_iter_count;
6243 if (utf8_fl != NULL)
6246 if (!dir || !*dir) {
6247 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6250 trndir = PerlMem_malloc(VMS_MAXRSS);
6251 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6252 if (*dir) strcpy(trndir,dir);
6253 else getcwd(trndir,VMS_MAXRSS - 1);
6255 trnlnm_iter_count = 0;
6256 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6257 && my_trnlnm(trndir,trndir,0)) {
6258 trnlnm_iter_count++;
6259 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6260 trnlen = strlen(trndir);
6262 /* Trap simple rooted lnms, and return lnm:[000000] */
6263 if (!strcmp(trndir+trnlen-2,".]")) {
6264 if (buf) retpath = buf;
6265 else if (ts) Newx(retpath,strlen(dir)+10,char);
6266 else retpath = __pathify_retbuf;
6267 strcpy(retpath,dir);
6268 strcat(retpath,":[000000]");
6269 PerlMem_free(trndir);
6274 /* At this point we do not work with *dir, but the copy in
6275 * *trndir that is modifiable.
6278 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6279 if (*trndir == '.' && (*(trndir+1) == '\0' ||
6280 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6281 retlen = 2 + (*(trndir+1) != '\0');
6283 if ( !(cp1 = strrchr(trndir,'/')) &&
6284 !(cp1 = strrchr(trndir,']')) &&
6285 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6286 if ((cp2 = strchr(cp1,'.')) != NULL &&
6287 (*(cp2-1) != '/' || /* Trailing '.', '..', */
6288 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
6289 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6290 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6293 /* For EFS or ODS-5 look for the last dot */
6294 if (decc_efs_charset) {
6295 cp2 = strrchr(cp1,'.');
6297 if (vms_process_case_tolerant) {
6298 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6299 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6300 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6301 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6302 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6303 (ver || *cp3)))))) {
6304 PerlMem_free(trndir);
6306 set_vaxc_errno(RMS$_DIR);
6311 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6312 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6313 !*(cp2+3) || *(cp2+3) != 'R' ||
6314 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6315 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6316 (ver || *cp3)))))) {
6317 PerlMem_free(trndir);
6319 set_vaxc_errno(RMS$_DIR);
6323 retlen = cp2 - trndir + 1;
6325 else { /* No file type present. Treat the filename as a directory. */
6326 retlen = strlen(trndir) + 1;
6329 if (buf) retpath = buf;
6330 else if (ts) Newx(retpath,retlen+1,char);
6331 else retpath = __pathify_retbuf;
6332 strncpy(retpath, trndir, retlen-1);
6333 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6334 retpath[retlen-1] = '/'; /* with '/', add it. */
6335 retpath[retlen] = '\0';
6337 else retpath[retlen-1] = '\0';
6339 else { /* VMS-style directory spec */
6340 char *esa, *esal, *cp;
6343 unsigned long int sts, cmplen, haslower;
6344 struct FAB dirfab = cc$rms_fab;
6346 rms_setup_nam(savnam);
6347 rms_setup_nam(dirnam);
6349 /* If we've got an explicit filename, we can just shuffle the string. */
6350 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6351 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
6352 if ((cp2 = strchr(cp1,'.')) != NULL) {
6354 if (vms_process_case_tolerant) {
6355 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6356 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6357 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6358 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6359 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6360 (ver || *cp3)))))) {
6361 PerlMem_free(trndir);
6363 set_vaxc_errno(RMS$_DIR);
6368 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6369 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6370 !*(cp2+3) || *(cp2+3) != 'R' ||
6371 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6372 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6373 (ver || *cp3)))))) {
6374 PerlMem_free(trndir);
6376 set_vaxc_errno(RMS$_DIR);
6381 else { /* No file type, so just draw name into directory part */
6382 for (cp2 = cp1; *cp2; cp2++) ;
6385 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
6387 /* We've now got a VMS 'path'; fall through */
6390 dirlen = strlen(trndir);
6391 if (trndir[dirlen-1] == ']' ||
6392 trndir[dirlen-1] == '>' ||
6393 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6394 if (buf) retpath = buf;
6395 else if (ts) Newx(retpath,strlen(trndir)+1,char);
6396 else retpath = __pathify_retbuf;
6397 strcpy(retpath,trndir);
6398 PerlMem_free(trndir);
6401 rms_set_fna(dirfab, dirnam, trndir, dirlen);
6402 esa = PerlMem_malloc(VMS_MAXRSS);
6403 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6405 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6406 esal = PerlMem_malloc(VMS_MAXRSS);
6407 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6409 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6410 rms_bind_fab_nam(dirfab, dirnam);
6411 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6412 #ifdef NAM$M_NO_SHORT_UPCASE
6413 if (decc_efs_case_preserve)
6414 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6417 for (cp = trndir; *cp; cp++)
6418 if (islower(*cp)) { haslower = 1; break; }
6420 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6421 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6422 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6423 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6426 PerlMem_free(trndir);
6431 set_vaxc_errno(dirfab.fab$l_sts);
6437 /* Does the file really exist? */
6438 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6439 if (dirfab.fab$l_sts != RMS$_FNF) {
6441 sts1 = rms_free_search_context(&dirfab);
6442 PerlMem_free(trndir);
6447 set_vaxc_errno(dirfab.fab$l_sts);
6450 dirnam = savnam; /* No; just work with potential name */
6453 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6454 /* Yep; check version while we're at it, if it's there. */
6455 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6456 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6458 /* Something other than .DIR[;1]. Bzzt. */
6459 sts2 = rms_free_search_context(&dirfab);
6460 PerlMem_free(trndir);
6465 set_vaxc_errno(RMS$_DIR);
6469 /* Make sure we are using the right buffer */
6471 /* We only need one, clean up the other */
6473 my_esa_len = rms_nam_esll(dirnam);
6476 my_esa_len = rms_nam_esl(dirnam);
6479 /* Null terminate the buffer */
6480 my_esa[my_esa_len] = '\0';
6482 /* OK, the type was fine. Now pull any file name into the
6484 if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6486 cp1 = strrchr(my_esa,'>');
6487 *(rms_nam_typel(dirnam)) = '>';
6490 *(rms_nam_typel(dirnam) + 1) = '\0';
6491 retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6492 if (buf) retpath = buf;
6493 else if (ts) Newx(retpath,retlen,char);
6494 else retpath = __pathify_retbuf;
6495 strcpy(retpath,my_esa);
6499 sts = rms_free_search_context(&dirfab);
6500 /* $PARSE may have upcased filespec, so convert output to lower
6501 * case if input contained any lowercase characters. */
6502 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6505 PerlMem_free(trndir);
6507 } /* end of do_pathify_dirspec() */
6509 /* External entry points */
6510 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6511 { return do_pathify_dirspec(dir,buf,0,NULL); }
6512 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6513 { return do_pathify_dirspec(dir,buf,1,NULL); }
6514 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6515 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6516 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6517 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6519 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6520 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6522 static char __tounixspec_retbuf[VMS_MAXRSS];
6523 char *dirend, *rslt, *cp1, *cp3, *tmp;
6525 int devlen, dirlen, retlen = VMS_MAXRSS;
6526 int expand = 1; /* guarantee room for leading and trailing slashes */
6527 unsigned short int trnlnm_iter_count;
6529 if (utf8_fl != NULL)
6532 if (spec == NULL) return NULL;
6533 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6534 if (buf) rslt = buf;
6536 Newx(rslt, VMS_MAXRSS, char);
6538 else rslt = __tounixspec_retbuf;
6540 /* New VMS specific format needs translation
6541 * glob passes filenames with trailing '\n' and expects this preserved.
6543 if (decc_posix_compliant_pathnames) {
6544 if (strncmp(spec, "\"^UP^", 5) == 0) {
6550 tunix = PerlMem_malloc(VMS_MAXRSS);
6551 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6552 strcpy(tunix, spec);
6553 tunix_len = strlen(tunix);
6555 if (tunix[tunix_len - 1] == '\n') {
6556 tunix[tunix_len - 1] = '\"';
6557 tunix[tunix_len] = '\0';
6561 uspec = decc$translate_vms(tunix);
6562 PerlMem_free(tunix);
6563 if ((int)uspec > 0) {
6569 /* If we can not translate it, makemaker wants as-is */
6577 cmp_rslt = 0; /* Presume VMS */
6578 cp1 = strchr(spec, '/');
6582 /* Look for EFS ^/ */
6583 if (decc_efs_charset) {
6584 while (cp1 != NULL) {
6587 /* Found illegal VMS, assume UNIX */
6592 cp1 = strchr(cp1, '/');
6596 /* Look for "." and ".." */
6597 if (decc_filename_unix_report) {
6598 if (spec[0] == '.') {
6599 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6603 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6609 /* This is already UNIX or at least nothing VMS understands */
6617 dirend = strrchr(spec,']');
6618 if (dirend == NULL) dirend = strrchr(spec,'>');
6619 if (dirend == NULL) dirend = strchr(spec,':');
6620 if (dirend == NULL) {
6625 /* Special case 1 - sys$posix_root = / */
6626 #if __CRTL_VER >= 70000000
6627 if (!decc_disable_posix_root) {
6628 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6636 /* Special case 2 - Convert NLA0: to /dev/null */
6637 #if __CRTL_VER < 70000000
6638 cmp_rslt = strncmp(spec,"NLA0:", 5);
6640 cmp_rslt = strncmp(spec,"nla0:", 5);
6642 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6644 if (cmp_rslt == 0) {
6645 strcpy(rslt, "/dev/null");
6648 if (spec[6] != '\0') {
6655 /* Also handle special case "SYS$SCRATCH:" */
6656 #if __CRTL_VER < 70000000
6657 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6659 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6661 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6663 tmp = PerlMem_malloc(VMS_MAXRSS);
6664 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6665 if (cmp_rslt == 0) {
6668 islnm = my_trnlnm(tmp, "TMP", 0);
6670 strcpy(rslt, "/tmp");
6673 if (spec[12] != '\0') {
6681 if (*cp2 != '[' && *cp2 != '<') {
6684 else { /* the VMS spec begins with directories */
6686 if (*cp2 == ']' || *cp2 == '>') {
6687 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6691 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6692 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6693 if (ts) Safefree(rslt);
6697 trnlnm_iter_count = 0;
6700 while (*cp3 != ':' && *cp3) cp3++;
6702 if (strchr(cp3,']') != NULL) break;
6703 trnlnm_iter_count++;
6704 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6705 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6707 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6708 retlen = devlen + dirlen;
6709 Renew(rslt,retlen+1+2*expand,char);
6715 *(cp1++) = *(cp3++);
6716 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6718 return NULL; /* No room */
6723 if ((*cp2 == '^')) {
6724 /* EFS file escape, pass the next character as is */
6725 /* Fix me: HEX encoding for Unicode not implemented */
6728 else if ( *cp2 == '.') {
6729 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6730 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6737 for (; cp2 <= dirend; cp2++) {
6738 if ((*cp2 == '^')) {
6739 /* EFS file escape, pass the next character as is */
6740 /* Fix me: HEX encoding for Unicode not implemented */
6741 *(cp1++) = *(++cp2);
6742 /* An escaped dot stays as is -- don't convert to slash */
6743 if (*cp2 == '.') cp2++;
6747 if (*(cp2+1) == '[') cp2++;
6749 else if (*cp2 == ']' || *cp2 == '>') {
6750 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6752 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6754 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6755 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6756 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6757 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6758 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6760 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6761 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6765 else if (*cp2 == '-') {
6766 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6767 while (*cp2 == '-') {
6769 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6771 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6772 if (ts) Safefree(rslt); /* filespecs like */
6773 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6777 else *(cp1++) = *cp2;
6779 else *(cp1++) = *cp2;
6782 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6783 *(cp1++) = *(cp2++);
6787 /* This still leaves /000000/ when working with a
6788 * VMS device root or concealed root.
6794 ulen = strlen(rslt);
6796 /* Get rid of "000000/ in rooted filespecs */
6798 zeros = strstr(rslt, "/000000/");
6799 if (zeros != NULL) {
6801 mlen = ulen - (zeros - rslt) - 7;
6802 memmove(zeros, &zeros[7], mlen);
6811 } /* end of do_tounixspec() */
6813 /* External entry points */
6814 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6815 { return do_tounixspec(spec,buf,0, NULL); }
6816 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6817 { return do_tounixspec(spec,buf,1, NULL); }
6818 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6819 { return do_tounixspec(spec,buf,0, utf8_fl); }
6820 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6821 { return do_tounixspec(spec,buf,1, utf8_fl); }
6823 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6826 This procedure is used to identify if a path is based in either
6827 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6828 it returns the OpenVMS format directory for it.
6830 It is expecting specifications of only '/' or '/xxxx/'
6832 If a posix root does not exist, or 'xxxx' is not a directory
6833 in the posix root, it returns a failure.
6835 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6837 It is used only internally by posix_to_vmsspec_hardway().
6840 static int posix_root_to_vms
6841 (char *vmspath, int vmspath_len,
6842 const char *unixpath,
6843 const int * utf8_fl)
6846 struct FAB myfab = cc$rms_fab;
6847 rms_setup_nam(mynam);
6848 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6849 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6850 char * esa, * esal, * rsa, * rsal;
6857 unixlen = strlen(unixpath);
6862 #if __CRTL_VER >= 80200000
6863 /* If not a posix spec already, convert it */
6864 if (decc_posix_compliant_pathnames) {
6865 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6866 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6869 /* This is already a VMS specification, no conversion */
6871 strncpy(vmspath,unixpath, vmspath_len);
6880 /* Check to see if this is under the POSIX root */
6881 if (decc_disable_posix_root) {
6885 /* Skip leading / */
6886 if (unixpath[0] == '/') {
6892 strcpy(vmspath,"SYS$POSIX_ROOT:");
6894 /* If this is only the / , or blank, then... */
6895 if (unixpath[0] == '\0') {
6896 /* by definition, this is the answer */
6900 /* Need to look up a directory */
6904 /* Copy and add '^' escape characters as needed */
6907 while (unixpath[i] != 0) {
6910 j += copy_expand_unix_filename_escape
6911 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6915 path_len = strlen(vmspath);
6916 if (vmspath[path_len - 1] == '/')
6918 vmspath[path_len] = ']';
6920 vmspath[path_len] = '\0';
6923 vmspath[vmspath_len] = 0;
6924 if (unixpath[unixlen - 1] == '/')
6926 esal = PerlMem_malloc(VMS_MAXRSS);
6927 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6928 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6929 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6930 rsal = PerlMem_malloc(VMS_MAXRSS);
6931 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6932 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6933 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6934 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6935 rms_bind_fab_nam(myfab, mynam);
6936 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6937 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6938 if (decc_efs_case_preserve)
6939 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6940 #ifdef NAML$M_OPEN_SPECIAL
6941 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6944 /* Set up the remaining naml fields */
6945 sts = sys$parse(&myfab);
6947 /* It failed! Try again as a UNIX filespec */
6956 /* get the Device ID and the FID */
6957 sts = sys$search(&myfab);
6959 /* These are no longer needed */
6964 /* on any failure, returned the POSIX ^UP^ filespec */
6969 specdsc.dsc$a_pointer = vmspath;
6970 specdsc.dsc$w_length = vmspath_len;
6972 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6973 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6974 sts = lib$fid_to_name
6975 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6977 /* on any failure, returned the POSIX ^UP^ filespec */
6979 /* This can happen if user does not have permission to read directories */
6980 if (strncmp(unixpath,"\"^UP^",5) != 0)
6981 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6983 strcpy(vmspath, unixpath);
6986 vmspath[specdsc.dsc$w_length] = 0;
6988 /* Are we expecting a directory? */
6989 if (dir_flag != 0) {
6995 i = specdsc.dsc$w_length - 1;
6999 /* Version must be '1' */
7000 if (vmspath[i--] != '1')
7002 /* Version delimiter is one of ".;" */
7003 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7006 if (vmspath[i--] != 'R')
7008 if (vmspath[i--] != 'I')
7010 if (vmspath[i--] != 'D')
7012 if (vmspath[i--] != '.')
7014 eptr = &vmspath[i+1];
7016 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7017 if (vmspath[i-1] != '^') {
7025 /* Get rid of 6 imaginary zero directory filename */
7026 vmspath[i+1] = '\0';
7030 if (vmspath[i] == '0')
7044 /* /dev/mumble needs to be handled special.
7045 /dev/null becomes NLA0:, And there is the potential for other stuff
7046 like /dev/tty which may need to be mapped to something.
7050 slash_dev_special_to_vms
7051 (const char * unixptr,
7061 nextslash = strchr(unixptr, '/');
7062 len = strlen(unixptr);
7063 if (nextslash != NULL)
7064 len = nextslash - unixptr;
7065 cmp = strncmp("null", unixptr, 5);
7067 if (vmspath_len >= 6) {
7068 strcpy(vmspath, "_NLA0:");
7075 /* The built in routines do not understand perl's special needs, so
7076 doing a manual conversion from UNIX to VMS
7078 If the utf8_fl is not null and points to a non-zero value, then
7079 treat 8 bit characters as UTF-8.
7081 The sequence starting with '$(' and ending with ')' will be passed
7082 through with out interpretation instead of being escaped.
7085 static int posix_to_vmsspec_hardway
7086 (char *vmspath, int vmspath_len,
7087 const char *unixpath,
7092 const char *unixptr;
7093 const char *unixend;
7095 const char *lastslash;
7096 const char *lastdot;
7102 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7103 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7105 if (utf8_fl != NULL)
7111 /* Ignore leading "/" characters */
7112 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7115 unixlen = strlen(unixptr);
7117 /* Do nothing with blank paths */
7124 /* This could have a "^UP^ on the front */
7125 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7131 lastslash = strrchr(unixptr,'/');
7132 lastdot = strrchr(unixptr,'.');
7133 unixend = strrchr(unixptr,'\"');
7134 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7135 unixend = unixptr + unixlen;
7138 /* last dot is last dot or past end of string */
7139 if (lastdot == NULL)
7140 lastdot = unixptr + unixlen;
7142 /* if no directories, set last slash to beginning of string */
7143 if (lastslash == NULL) {
7144 lastslash = unixptr;
7147 /* Watch out for trailing "." after last slash, still a directory */
7148 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7149 lastslash = unixptr + unixlen;
7152 /* Watch out for traiing ".." after last slash, still a directory */
7153 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7154 lastslash = unixptr + unixlen;
7157 /* dots in directories are aways escaped */
7158 if (lastdot < lastslash)
7159 lastdot = unixptr + unixlen;
7162 /* if (unixptr < lastslash) then we are in a directory */
7169 /* Start with the UNIX path */
7170 if (*unixptr != '/') {
7171 /* relative paths */
7173 /* If allowing logical names on relative pathnames, then handle here */
7174 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7175 !decc_posix_compliant_pathnames) {
7181 /* Find the next slash */
7182 nextslash = strchr(unixptr,'/');
7184 esa = PerlMem_malloc(vmspath_len);
7185 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7187 trn = PerlMem_malloc(VMS_MAXRSS);
7188 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7190 if (nextslash != NULL) {
7192 seg_len = nextslash - unixptr;
7193 strncpy(esa, unixptr, seg_len);
7197 strcpy(esa, unixptr);
7198 seg_len = strlen(unixptr);
7200 /* trnlnm(section) */
7201 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7204 /* Now fix up the directory */
7206 /* Split up the path to find the components */
7207 sts = vms_split_path
7226 /* A logical name must be a directory or the full
7227 specification. It is only a full specification if
7228 it is the only component */
7229 if ((unixptr[seg_len] == '\0') ||
7230 (unixptr[seg_len+1] == '\0')) {
7232 /* Is a directory being required? */
7233 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7234 /* Not a logical name */
7239 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7240 /* This must be a directory */
7241 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7242 strcpy(vmsptr, esa);
7243 vmslen=strlen(vmsptr);
7244 vmsptr[vmslen] = ':';
7246 vmsptr[vmslen] = '\0';
7254 /* must be dev/directory - ignore version */
7255 if ((n_len + e_len) != 0)
7258 /* transfer the volume */
7259 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7260 strncpy(vmsptr, v_spec, v_len);
7266 /* unroot the rooted directory */
7267 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7269 r_spec[r_len - 1] = ']';
7271 /* This should not be there, but nothing is perfect */
7273 cmp = strcmp(&r_spec[1], "000000.");
7283 strncpy(vmsptr, r_spec, r_len);
7289 /* Bring over the directory. */
7291 ((d_len + vmslen) < vmspath_len)) {
7293 d_spec[d_len - 1] = ']';
7295 cmp = strcmp(&d_spec[1], "000000.");
7306 /* Remove the redundant root */
7314 strncpy(vmsptr, d_spec, d_len);
7328 if (lastslash > unixptr) {
7331 /* skip leading ./ */
7333 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7339 /* Are we still in a directory? */
7340 if (unixptr <= lastslash) {
7345 /* if not backing up, then it is relative forward. */
7346 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7347 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7355 /* Perl wants an empty directory here to tell the difference
7356 * between a DCL commmand and a filename
7365 /* Handle two special files . and .. */
7366 if (unixptr[0] == '.') {
7367 if (&unixptr[1] == unixend) {
7374 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7385 else { /* Absolute PATH handling */
7389 /* Need to find out where root is */
7391 /* In theory, this procedure should never get an absolute POSIX pathname
7392 * that can not be found on the POSIX root.
7393 * In practice, that can not be relied on, and things will show up
7394 * here that are a VMS device name or concealed logical name instead.
7395 * So to make things work, this procedure must be tolerant.
7397 esa = PerlMem_malloc(vmspath_len);
7398 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7401 nextslash = strchr(&unixptr[1],'/');
7403 if (nextslash != NULL) {
7405 seg_len = nextslash - &unixptr[1];
7406 strncpy(vmspath, unixptr, seg_len + 1);
7407 vmspath[seg_len+1] = 0;
7410 cmp = strncmp(vmspath, "dev", 4);
7412 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7413 if (sts = SS$_NORMAL)
7417 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7420 if ($VMS_STATUS_SUCCESS(sts)) {
7421 /* This is verified to be a real path */
7423 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7424 if ($VMS_STATUS_SUCCESS(sts)) {
7425 strcpy(vmspath, esa);
7426 vmslen = strlen(vmspath);
7427 vmsptr = vmspath + vmslen;
7429 if (unixptr < lastslash) {
7438 cmp = strcmp(rptr,"000000.");
7443 } /* removing 6 zeros */
7444 } /* vmslen < 7, no 6 zeros possible */
7445 } /* Not in a directory */
7446 } /* Posix root found */
7448 /* No posix root, fall back to default directory */
7449 strcpy(vmspath, "SYS$DISK:[");
7450 vmsptr = &vmspath[10];
7452 if (unixptr > lastslash) {
7461 } /* end of verified real path handling */
7466 /* Ok, we have a device or a concealed root that is not in POSIX
7467 * or we have garbage. Make the best of it.
7470 /* Posix to VMS destroyed this, so copy it again */
7471 strncpy(vmspath, &unixptr[1], seg_len);
7472 vmspath[seg_len] = 0;
7474 vmsptr = &vmsptr[vmslen];
7477 /* Now do we need to add the fake 6 zero directory to it? */
7479 if ((*lastslash == '/') && (nextslash < lastslash)) {
7480 /* No there is another directory */
7487 /* now we have foo:bar or foo:[000000]bar to decide from */
7488 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7490 if (!islnm && !decc_posix_compliant_pathnames) {
7492 cmp = strncmp("bin", vmspath, 4);
7494 /* bin => SYS$SYSTEM: */
7495 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7498 /* tmp => SYS$SCRATCH: */
7499 cmp = strncmp("tmp", vmspath, 4);
7501 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7506 trnend = islnm ? islnm - 1 : 0;
7508 /* if this was a logical name, ']' or '>' must be present */
7509 /* if not a logical name, then assume a device and hope. */
7510 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7512 /* if log name and trailing '.' then rooted - treat as device */
7513 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7515 /* Fix me, if not a logical name, a device lookup should be
7516 * done to see if the device is file structured. If the device
7517 * is not file structured, the 6 zeros should not be put on.
7519 * As it is, perl is occasionally looking for dev:[000000]tty.
7520 * which looks a little strange.
7522 * Not that easy to detect as "/dev" may be file structured with
7523 * special device files.
7526 if ((add_6zero == 0) && (*nextslash == '/') &&
7527 (&nextslash[1] == unixend)) {
7528 /* No real directory present */
7533 /* Put the device delimiter on */
7536 unixptr = nextslash;
7539 /* Start directory if needed */
7540 if (!islnm || add_6zero) {
7546 /* add fake 000000] if needed */
7559 } /* non-POSIX translation */
7561 } /* End of relative/absolute path handling */
7563 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7570 if (dir_start != 0) {
7572 /* First characters in a directory are handled special */
7573 while ((*unixptr == '/') ||
7574 ((*unixptr == '.') &&
7575 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7576 (&unixptr[1]==unixend)))) {
7581 /* Skip redundant / in specification */
7582 while ((*unixptr == '/') && (dir_start != 0)) {
7585 if (unixptr == lastslash)
7588 if (unixptr == lastslash)
7591 /* Skip redundant ./ characters */
7592 while ((*unixptr == '.') &&
7593 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7596 if (unixptr == lastslash)
7598 if (*unixptr == '/')
7601 if (unixptr == lastslash)
7604 /* Skip redundant ../ characters */
7605 while ((*unixptr == '.') && (unixptr[1] == '.') &&
7606 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7607 /* Set the backing up flag */
7613 unixptr++; /* first . */
7614 unixptr++; /* second . */
7615 if (unixptr == lastslash)
7617 if (*unixptr == '/') /* The slash */
7620 if (unixptr == lastslash)
7623 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7624 /* Not needed when VMS is pretending to be UNIX. */
7626 /* Is this loop stuck because of too many dots? */
7627 if (loop_flag == 0) {
7628 /* Exit the loop and pass the rest through */
7633 /* Are we done with directories yet? */
7634 if (unixptr >= lastslash) {
7636 /* Watch out for trailing dots */
7645 if (*unixptr == '/')
7649 /* Have we stopped backing up? */
7654 /* dir_start continues to be = 1 */
7656 if (*unixptr == '-') {
7658 *vmsptr++ = *unixptr++;
7662 /* Now are we done with directories yet? */
7663 if (unixptr >= lastslash) {
7665 /* Watch out for trailing dots */
7681 if (unixptr >= unixend)
7684 /* Normal characters - More EFS work probably needed */
7690 /* remove multiple / */
7691 while (unixptr[1] == '/') {
7694 if (unixptr == lastslash) {
7695 /* Watch out for trailing dots */
7707 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7708 /* Not needed when VMS is pretending to be UNIX. */
7712 if (unixptr != unixend)
7717 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7718 (&unixptr[1] == unixend)) {
7724 /* trailing dot ==> '^..' on VMS */
7725 if (unixptr == unixend) {
7733 *vmsptr++ = *unixptr++;
7737 if (quoted && (&unixptr[1] == unixend)) {
7741 in_cnt = copy_expand_unix_filename_escape
7742 (vmsptr, unixptr, &out_cnt, utf8_fl);
7752 in_cnt = copy_expand_unix_filename_escape
7753 (vmsptr, unixptr, &out_cnt, utf8_fl);
7760 /* Make sure directory is closed */
7761 if (unixptr == lastslash) {
7763 vmsptr2 = vmsptr - 1;
7765 if (*vmsptr2 != ']') {
7768 /* directories do not end in a dot bracket */
7769 if (*vmsptr2 == '.') {
7773 if (*vmsptr2 != '^') {
7774 vmsptr--; /* back up over the dot */
7782 /* Add a trailing dot if a file with no extension */
7783 vmsptr2 = vmsptr - 1;
7785 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7786 (*vmsptr2 != ')') && (*lastdot != '.')) {
7797 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7798 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7803 /* If a UTF8 flag is being passed, honor it */
7805 if (utf8_fl != NULL) {
7806 utf8_flag = *utf8_fl;
7811 /* If there is a possibility of UTF8, then if any UTF8 characters
7812 are present, then they must be converted to VTF-7
7814 result = strcpy(rslt, path); /* FIX-ME */
7817 result = strcpy(rslt, path);
7823 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7824 static char *mp_do_tovmsspec
7825 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7826 static char __tovmsspec_retbuf[VMS_MAXRSS];
7827 char *rslt, *dirend;
7832 unsigned long int infront = 0, hasdir = 1;
7835 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7836 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7838 if (path == NULL) return NULL;
7839 rslt_len = VMS_MAXRSS-1;
7840 if (buf) rslt = buf;
7841 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7842 else rslt = __tovmsspec_retbuf;
7844 /* '.' and '..' are "[]" and "[-]" for a quick check */
7845 if (path[0] == '.') {
7846 if (path[1] == '\0') {
7848 if (utf8_flag != NULL)
7853 if (path[1] == '.' && path[2] == '\0') {
7855 if (utf8_flag != NULL)
7862 /* Posix specifications are now a native VMS format */
7863 /*--------------------------------------------------*/
7864 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7865 if (decc_posix_compliant_pathnames) {
7866 if (strncmp(path,"\"^UP^",5) == 0) {
7867 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7873 /* This is really the only way to see if this is already in VMS format */
7874 sts = vms_split_path
7889 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7890 replacement, because the above parse just took care of most of
7891 what is needed to do vmspath when the specification is already
7894 And if it is not already, it is easier to do the conversion as
7895 part of this routine than to call this routine and then work on
7899 /* If VMS punctuation was found, it is already VMS format */
7900 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7901 if (utf8_flag != NULL)
7906 /* Now, what to do with trailing "." cases where there is no
7907 extension? If this is a UNIX specification, and EFS characters
7908 are enabled, then the trailing "." should be converted to a "^.".
7909 But if this was already a VMS specification, then it should be
7912 So in the case of ambiguity, leave the specification alone.
7916 /* If there is a possibility of UTF8, then if any UTF8 characters
7917 are present, then they must be converted to VTF-7
7919 if (utf8_flag != NULL)
7925 dirend = strrchr(path,'/');
7927 if (dirend == NULL) {
7928 /* If we get here with no UNIX directory delimiters, then this is
7929 not a complete file specification, either garbage a UNIX glob
7930 specification that can not be converted to a VMS wildcard, or
7931 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7932 so apparently other programs expect this also.
7934 utf8 flag setting needs to be preserved.
7940 /* If POSIX mode active, handle the conversion */
7941 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7942 if (decc_efs_charset) {
7943 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7948 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7949 if (!*(dirend+2)) dirend +=2;
7950 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7951 if (decc_efs_charset == 0) {
7952 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7958 lastdot = strrchr(cp2,'.');
7964 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7966 if (decc_disable_posix_root) {
7967 strcpy(rslt,"sys$disk:[000000]");
7970 strcpy(rslt,"sys$posix_root:[000000]");
7972 if (utf8_flag != NULL)
7976 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7978 trndev = PerlMem_malloc(VMS_MAXRSS);
7979 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7980 islnm = my_trnlnm(rslt,trndev,0);
7982 /* DECC special handling */
7984 if (strcmp(rslt,"bin") == 0) {
7985 strcpy(rslt,"sys$system");
7988 islnm = my_trnlnm(rslt,trndev,0);
7990 else if (strcmp(rslt,"tmp") == 0) {
7991 strcpy(rslt,"sys$scratch");
7994 islnm = my_trnlnm(rslt,trndev,0);
7996 else if (!decc_disable_posix_root) {
7997 strcpy(rslt, "sys$posix_root");
8001 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8002 islnm = my_trnlnm(rslt,trndev,0);
8004 else if (strcmp(rslt,"dev") == 0) {
8005 if (strncmp(cp2,"/null", 5) == 0) {
8006 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8007 strcpy(rslt,"NLA0");
8011 islnm = my_trnlnm(rslt,trndev,0);
8017 trnend = islnm ? strlen(trndev) - 1 : 0;
8018 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8019 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8020 /* If the first element of the path is a logical name, determine
8021 * whether it has to be translated so we can add more directories. */
8022 if (!islnm || rooted) {
8025 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8029 if (cp2 != dirend) {
8030 strcpy(rslt,trndev);
8031 cp1 = rslt + trnend;
8038 if (decc_disable_posix_root) {
8044 PerlMem_free(trndev);
8049 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8050 cp2 += 2; /* skip over "./" - it's redundant */
8051 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8053 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8054 *(cp1++) = '-'; /* "../" --> "-" */
8057 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8058 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8059 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8060 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8063 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8064 /* Escape the extra dots in EFS file specifications */
8067 if (cp2 > dirend) cp2 = dirend;
8069 else *(cp1++) = '.';
8071 for (; cp2 < dirend; cp2++) {
8073 if (*(cp2-1) == '/') continue;
8074 if (*(cp1-1) != '.') *(cp1++) = '.';
8077 else if (!infront && *cp2 == '.') {
8078 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8079 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8080 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8081 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8082 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8083 else { /* back up over previous directory name */
8085 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8086 if (*(cp1-1) == '[') {
8087 memcpy(cp1,"000000.",7);
8092 if (cp2 == dirend) break;
8094 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8095 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8096 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8097 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8099 *(cp1++) = '.'; /* Simulate trailing '/' */
8100 cp2 += 2; /* for loop will incr this to == dirend */
8102 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8105 if (decc_efs_charset == 0)
8106 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8108 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8114 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8116 if (decc_efs_charset == 0)
8123 else *(cp1++) = *cp2;
8127 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8128 if (hasdir) *(cp1++) = ']';
8129 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8130 /* fixme for ODS5 */
8137 if (decc_efs_charset == 0)
8148 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8149 decc_readdir_dropdotnotype) {
8154 /* trailing dot ==> '^..' on VMS */
8161 *(cp1++) = *(cp2++);
8166 /* This could be a macro to be passed through */
8167 *(cp1++) = *(cp2++);
8169 const char * save_cp2;
8173 /* paranoid check */
8179 *(cp1++) = *(cp2++);
8180 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8181 *(cp1++) = *(cp2++);
8182 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8183 *(cp1++) = *(cp2++);
8186 *(cp1++) = *(cp2++);
8190 if (is_macro == 0) {
8191 /* Not really a macro - never mind */
8204 /* Don't escape again if following character is
8205 * already something we escape.
8207 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8208 *(cp1++) = *(cp2++);
8211 /* But otherwise fall through and escape it. */
8229 *(cp1++) = *(cp2++);
8232 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8233 * which is wrong. UNIX notation should be ".dir." unless
8234 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8235 * changing this behavior could break more things at this time.
8236 * efs character set effectively does not allow "." to be a version
8237 * delimiter as a further complication about changing this.
8239 if (decc_filename_unix_report != 0) {
8242 *(cp1++) = *(cp2++);
8245 *(cp1++) = *(cp2++);
8248 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8252 /* Fix me for "^]", but that requires making sure that you do
8253 * not back up past the start of the filename
8255 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8260 if (utf8_flag != NULL)
8264 } /* end of do_tovmsspec() */
8266 /* External entry points */
8267 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8268 { return do_tovmsspec(path,buf,0,NULL); }
8269 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8270 { return do_tovmsspec(path,buf,1,NULL); }
8271 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8272 { return do_tovmsspec(path,buf,0,utf8_fl); }
8273 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8274 { return do_tovmsspec(path,buf,1,utf8_fl); }
8276 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8277 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8278 static char __tovmspath_retbuf[VMS_MAXRSS];
8280 char *pathified, *vmsified, *cp;
8282 if (path == NULL) return NULL;
8283 pathified = PerlMem_malloc(VMS_MAXRSS);
8284 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8285 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8286 PerlMem_free(pathified);
8292 Newx(vmsified, VMS_MAXRSS, char);
8293 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8294 PerlMem_free(pathified);
8295 if (vmsified) Safefree(vmsified);
8298 PerlMem_free(pathified);
8303 vmslen = strlen(vmsified);
8304 Newx(cp,vmslen+1,char);
8305 memcpy(cp,vmsified,vmslen);
8311 strcpy(__tovmspath_retbuf,vmsified);
8313 return __tovmspath_retbuf;
8316 } /* end of do_tovmspath() */
8318 /* External entry points */
8319 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8320 { return do_tovmspath(path,buf,0, NULL); }
8321 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8322 { return do_tovmspath(path,buf,1, NULL); }
8323 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8324 { return do_tovmspath(path,buf,0,utf8_fl); }
8325 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8326 { return do_tovmspath(path,buf,1,utf8_fl); }
8329 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8330 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8331 static char __tounixpath_retbuf[VMS_MAXRSS];
8333 char *pathified, *unixified, *cp;
8335 if (path == NULL) return NULL;
8336 pathified = PerlMem_malloc(VMS_MAXRSS);
8337 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8338 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8339 PerlMem_free(pathified);
8345 Newx(unixified, VMS_MAXRSS, char);
8347 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8348 PerlMem_free(pathified);
8349 if (unixified) Safefree(unixified);
8352 PerlMem_free(pathified);
8357 unixlen = strlen(unixified);
8358 Newx(cp,unixlen+1,char);
8359 memcpy(cp,unixified,unixlen);
8361 Safefree(unixified);
8365 strcpy(__tounixpath_retbuf,unixified);
8366 Safefree(unixified);
8367 return __tounixpath_retbuf;
8370 } /* end of do_tounixpath() */
8372 /* External entry points */
8373 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8374 { return do_tounixpath(path,buf,0,NULL); }
8375 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8376 { return do_tounixpath(path,buf,1,NULL); }
8377 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8378 { return do_tounixpath(path,buf,0,utf8_fl); }
8379 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8380 { return do_tounixpath(path,buf,1,utf8_fl); }
8383 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
8385 *****************************************************************************
8387 * Copyright (C) 1989-1994, 2007 by *
8388 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8390 * Permission is hereby granted for the reproduction of this software *
8391 * on condition that this copyright notice is included in source *
8392 * distributions of the software. The code may be modified and *
8393 * distributed under the same terms as Perl itself. *
8395 * 27-Aug-1994 Modified for inclusion in perl5 *
8396 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
8397 *****************************************************************************
8401 * getredirection() is intended to aid in porting C programs
8402 * to VMS (Vax-11 C). The native VMS environment does not support
8403 * '>' and '<' I/O redirection, or command line wild card expansion,
8404 * or a command line pipe mechanism using the '|' AND background
8405 * command execution '&'. All of these capabilities are provided to any
8406 * C program which calls this procedure as the first thing in the
8408 * The piping mechanism will probably work with almost any 'filter' type
8409 * of program. With suitable modification, it may useful for other
8410 * portability problems as well.
8412 * Author: Mark Pizzolato (mark AT infocomm DOT com)
8416 struct list_item *next;
8420 static void add_item(struct list_item **head,
8421 struct list_item **tail,
8425 static void mp_expand_wild_cards(pTHX_ char *item,
8426 struct list_item **head,
8427 struct list_item **tail,
8430 static int background_process(pTHX_ int argc, char **argv);
8432 static void pipe_and_fork(pTHX_ char **cmargv);
8434 /*{{{ void getredirection(int *ac, char ***av)*/
8436 mp_getredirection(pTHX_ int *ac, char ***av)
8438 * Process vms redirection arg's. Exit if any error is seen.
8439 * If getredirection() processes an argument, it is erased
8440 * from the vector. getredirection() returns a new argc and argv value.
8441 * In the event that a background command is requested (by a trailing "&"),
8442 * this routine creates a background subprocess, and simply exits the program.
8444 * Warning: do not try to simplify the code for vms. The code
8445 * presupposes that getredirection() is called before any data is
8446 * read from stdin or written to stdout.
8448 * Normal usage is as follows:
8454 * getredirection(&argc, &argv);
8458 int argc = *ac; /* Argument Count */
8459 char **argv = *av; /* Argument Vector */
8460 char *ap; /* Argument pointer */
8461 int j; /* argv[] index */
8462 int item_count = 0; /* Count of Items in List */
8463 struct list_item *list_head = 0; /* First Item in List */
8464 struct list_item *list_tail; /* Last Item in List */
8465 char *in = NULL; /* Input File Name */
8466 char *out = NULL; /* Output File Name */
8467 char *outmode = "w"; /* Mode to Open Output File */
8468 char *err = NULL; /* Error File Name */
8469 char *errmode = "w"; /* Mode to Open Error File */
8470 int cmargc = 0; /* Piped Command Arg Count */
8471 char **cmargv = NULL;/* Piped Command Arg Vector */
8474 * First handle the case where the last thing on the line ends with
8475 * a '&'. This indicates the desire for the command to be run in a
8476 * subprocess, so we satisfy that desire.
8479 if (0 == strcmp("&", ap))
8480 exit(background_process(aTHX_ --argc, argv));
8481 if (*ap && '&' == ap[strlen(ap)-1])
8483 ap[strlen(ap)-1] = '\0';
8484 exit(background_process(aTHX_ argc, argv));
8487 * Now we handle the general redirection cases that involve '>', '>>',
8488 * '<', and pipes '|'.
8490 for (j = 0; j < argc; ++j)
8492 if (0 == strcmp("<", argv[j]))
8496 fprintf(stderr,"No input file after < on command line");
8497 exit(LIB$_WRONUMARG);
8502 if ('<' == *(ap = argv[j]))
8507 if (0 == strcmp(">", ap))
8511 fprintf(stderr,"No output file after > on command line");
8512 exit(LIB$_WRONUMARG);
8531 fprintf(stderr,"No output file after > or >> on command line");
8532 exit(LIB$_WRONUMARG);
8536 if (('2' == *ap) && ('>' == ap[1]))
8553 fprintf(stderr,"No output file after 2> or 2>> on command line");
8554 exit(LIB$_WRONUMARG);
8558 if (0 == strcmp("|", argv[j]))
8562 fprintf(stderr,"No command into which to pipe on command line");
8563 exit(LIB$_WRONUMARG);
8565 cmargc = argc-(j+1);
8566 cmargv = &argv[j+1];
8570 if ('|' == *(ap = argv[j]))
8578 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8581 * Allocate and fill in the new argument vector, Some Unix's terminate
8582 * the list with an extra null pointer.
8584 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8585 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8587 for (j = 0; j < item_count; ++j, list_head = list_head->next)
8588 argv[j] = list_head->value;
8594 fprintf(stderr,"'|' and '>' may not both be specified on command line");
8595 exit(LIB$_INVARGORD);
8597 pipe_and_fork(aTHX_ cmargv);
8600 /* Check for input from a pipe (mailbox) */
8602 if (in == NULL && 1 == isapipe(0))
8604 char mbxname[L_tmpnam];
8606 long int dvi_item = DVI$_DEVBUFSIZ;
8607 $DESCRIPTOR(mbxnam, "");
8608 $DESCRIPTOR(mbxdevnam, "");
8610 /* Input from a pipe, reopen it in binary mode to disable */
8611 /* carriage control processing. */
8613 fgetname(stdin, mbxname);
8614 mbxnam.dsc$a_pointer = mbxname;
8615 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8616 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8617 mbxdevnam.dsc$a_pointer = mbxname;
8618 mbxdevnam.dsc$w_length = sizeof(mbxname);
8619 dvi_item = DVI$_DEVNAM;
8620 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8621 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8624 freopen(mbxname, "rb", stdin);
8627 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8631 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8633 fprintf(stderr,"Can't open input file %s as stdin",in);
8636 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8638 fprintf(stderr,"Can't open output file %s as stdout",out);
8641 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8644 if (strcmp(err,"&1") == 0) {
8645 dup2(fileno(stdout), fileno(stderr));
8646 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8649 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8651 fprintf(stderr,"Can't open error file %s as stderr",err);
8655 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8659 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8662 #ifdef ARGPROC_DEBUG
8663 PerlIO_printf(Perl_debug_log, "Arglist:\n");
8664 for (j = 0; j < *ac; ++j)
8665 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8667 /* Clear errors we may have hit expanding wildcards, so they don't
8668 show up in Perl's $! later */
8669 set_errno(0); set_vaxc_errno(1);
8670 } /* end of getredirection() */
8673 static void add_item(struct list_item **head,
8674 struct list_item **tail,
8680 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8681 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8685 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8686 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8687 *tail = (*tail)->next;
8689 (*tail)->value = value;
8693 static void mp_expand_wild_cards(pTHX_ char *item,
8694 struct list_item **head,
8695 struct list_item **tail,
8699 unsigned long int context = 0;
8707 $DESCRIPTOR(filespec, "");
8708 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8709 $DESCRIPTOR(resultspec, "");
8710 unsigned long int lff_flags = 0;
8714 #ifdef VMS_LONGNAME_SUPPORT
8715 lff_flags = LIB$M_FIL_LONG_NAMES;
8718 for (cp = item; *cp; cp++) {
8719 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8720 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8722 if (!*cp || isspace(*cp))
8724 add_item(head, tail, item, count);
8729 /* "double quoted" wild card expressions pass as is */
8730 /* From DCL that means using e.g.: */
8731 /* perl program """perl.*""" */
8732 item_len = strlen(item);
8733 if ( '"' == *item && '"' == item[item_len-1] )
8736 item[item_len-2] = '\0';
8737 add_item(head, tail, item, count);
8741 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8742 resultspec.dsc$b_class = DSC$K_CLASS_D;
8743 resultspec.dsc$a_pointer = NULL;
8744 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8745 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8746 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8747 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8748 if (!isunix || !filespec.dsc$a_pointer)
8749 filespec.dsc$a_pointer = item;
8750 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8752 * Only return version specs, if the caller specified a version
8754 had_version = strchr(item, ';');
8756 * Only return device and directory specs, if the caller specifed either.
8758 had_device = strchr(item, ':');
8759 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8761 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8762 (&filespec, &resultspec, &context,
8763 &defaultspec, 0, &rms_sts, &lff_flags)))
8768 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8769 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8770 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8771 string[resultspec.dsc$w_length] = '\0';
8772 if (NULL == had_version)
8773 *(strrchr(string, ';')) = '\0';
8774 if ((!had_directory) && (had_device == NULL))
8776 if (NULL == (devdir = strrchr(string, ']')))
8777 devdir = strrchr(string, '>');
8778 strcpy(string, devdir + 1);
8781 * Be consistent with what the C RTL has already done to the rest of
8782 * the argv items and lowercase all of these names.
8784 if (!decc_efs_case_preserve) {
8785 for (c = string; *c; ++c)
8789 if (isunix) trim_unixpath(string,item,1);
8790 add_item(head, tail, string, count);
8793 PerlMem_free(vmsspec);
8794 if (sts != RMS$_NMF)
8796 set_vaxc_errno(sts);
8799 case RMS$_FNF: case RMS$_DNF:
8800 set_errno(ENOENT); break;
8802 set_errno(ENOTDIR); break;
8804 set_errno(ENODEV); break;
8805 case RMS$_FNM: case RMS$_SYN:
8806 set_errno(EINVAL); break;
8808 set_errno(EACCES); break;
8810 _ckvmssts_noperl(sts);
8814 add_item(head, tail, item, count);
8815 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8816 _ckvmssts_noperl(lib$find_file_end(&context));
8819 static int child_st[2];/* Event Flag set when child process completes */
8821 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8823 static unsigned long int exit_handler(int *status)
8827 if (0 == child_st[0])
8829 #ifdef ARGPROC_DEBUG
8830 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8832 fflush(stdout); /* Have to flush pipe for binary data to */
8833 /* terminate properly -- <tp@mccall.com> */
8834 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8835 sys$dassgn(child_chan);
8837 sys$synch(0, child_st);
8842 static void sig_child(int chan)
8844 #ifdef ARGPROC_DEBUG
8845 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8847 if (child_st[0] == 0)
8851 static struct exit_control_block exit_block =
8856 &exit_block.exit_status,
8861 pipe_and_fork(pTHX_ char **cmargv)
8864 struct dsc$descriptor_s *vmscmd;
8865 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8866 int sts, j, l, ismcr, quote, tquote = 0;
8868 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8869 vms_execfree(vmscmd);
8874 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8875 && toupper(*(q+2)) == 'R' && !*(q+3);
8877 while (q && l < MAX_DCL_LINE_LENGTH) {
8879 if (j > 0 && quote) {
8885 if (ismcr && j > 1) quote = 1;
8886 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8889 if (quote || tquote) {
8895 if ((quote||tquote) && *q == '"') {
8905 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8907 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8911 static int background_process(pTHX_ int argc, char **argv)
8913 char command[MAX_DCL_SYMBOL + 1] = "$";
8914 $DESCRIPTOR(value, "");
8915 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8916 static $DESCRIPTOR(null, "NLA0:");
8917 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8919 $DESCRIPTOR(pidstr, "");
8921 unsigned long int flags = 17, one = 1, retsts;
8924 strcat(command, argv[0]);
8925 len = strlen(command);
8926 while (--argc && (len < MAX_DCL_SYMBOL))
8928 strcat(command, " \"");
8929 strcat(command, *(++argv));
8930 strcat(command, "\"");
8931 len = strlen(command);
8933 value.dsc$a_pointer = command;
8934 value.dsc$w_length = strlen(value.dsc$a_pointer);
8935 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8936 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8937 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8938 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8941 _ckvmssts_noperl(retsts);
8943 #ifdef ARGPROC_DEBUG
8944 PerlIO_printf(Perl_debug_log, "%s\n", command);
8946 sprintf(pidstring, "%08X", pid);
8947 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8948 pidstr.dsc$a_pointer = pidstring;
8949 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8950 lib$set_symbol(&pidsymbol, &pidstr);
8954 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8957 /* OS-specific initialization at image activation (not thread startup) */
8958 /* Older VAXC header files lack these constants */
8959 #ifndef JPI$_RIGHTS_SIZE
8960 # define JPI$_RIGHTS_SIZE 817
8962 #ifndef KGB$M_SUBSYSTEM
8963 # define KGB$M_SUBSYSTEM 0x8
8966 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8968 /*{{{void vms_image_init(int *, char ***)*/
8970 vms_image_init(int *argcp, char ***argvp)
8972 char eqv[LNM$C_NAMLENGTH+1] = "";
8973 unsigned int len, tabct = 8, tabidx = 0;
8974 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8975 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8976 unsigned short int dummy, rlen;
8977 struct dsc$descriptor_s **tabvec;
8978 #if defined(PERL_IMPLICIT_CONTEXT)
8981 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8982 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8983 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8986 #ifdef KILL_BY_SIGPRC
8987 Perl_csighandler_init();
8990 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8991 _ckvmssts_noperl(iosb[0]);
8992 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8993 if (iprv[i]) { /* Running image installed with privs? */
8994 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
8999 /* Rights identifiers might trigger tainting as well. */
9000 if (!will_taint && (rlen || rsz)) {
9001 while (rlen < rsz) {
9002 /* We didn't get all the identifiers on the first pass. Allocate a
9003 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9004 * were needed to hold all identifiers at time of last call; we'll
9005 * allocate that many unsigned long ints), and go back and get 'em.
9006 * If it gave us less than it wanted to despite ample buffer space,
9007 * something's broken. Is your system missing a system identifier?
9009 if (rsz <= jpilist[1].buflen) {
9010 /* Perl_croak accvios when used this early in startup. */
9011 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9012 rsz, (unsigned long) jpilist[1].buflen,
9013 "Check your rights database for corruption.\n");
9016 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9017 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9018 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9019 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9020 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9021 _ckvmssts_noperl(iosb[0]);
9023 mask = jpilist[1].bufadr;
9024 /* Check attribute flags for each identifier (2nd longword); protected
9025 * subsystem identifiers trigger tainting.
9027 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9028 if (mask[i] & KGB$M_SUBSYSTEM) {
9033 if (mask != rlst) PerlMem_free(mask);
9036 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9037 * logical, some versions of the CRTL will add a phanthom /000000/
9038 * directory. This needs to be removed.
9040 if (decc_filename_unix_report) {
9043 ulen = strlen(argvp[0][0]);
9045 zeros = strstr(argvp[0][0], "/000000/");
9046 if (zeros != NULL) {
9048 mlen = ulen - (zeros - argvp[0][0]) - 7;
9049 memmove(zeros, &zeros[7], mlen);
9051 argvp[0][0][ulen] = '\0';
9054 /* It also may have a trailing dot that needs to be removed otherwise
9055 * it will be converted to VMS mode incorrectly.
9058 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9059 argvp[0][0][ulen] = '\0';
9062 /* We need to use this hack to tell Perl it should run with tainting,
9063 * since its tainting flag may be part of the PL_curinterp struct, which
9064 * hasn't been allocated when vms_image_init() is called.
9067 char **newargv, **oldargv;
9069 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9070 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9071 newargv[0] = oldargv[0];
9072 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9073 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9074 strcpy(newargv[1], "-T");
9075 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9077 newargv[*argcp] = NULL;
9078 /* We orphan the old argv, since we don't know where it's come from,
9079 * so we don't know how to free it.
9083 else { /* Did user explicitly request tainting? */
9085 char *cp, **av = *argvp;
9086 for (i = 1; i < *argcp; i++) {
9087 if (*av[i] != '-') break;
9088 for (cp = av[i]+1; *cp; cp++) {
9089 if (*cp == 'T') { will_taint = 1; break; }
9090 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9091 strchr("DFIiMmx",*cp)) break;
9093 if (will_taint) break;
9098 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9101 tabvec = (struct dsc$descriptor_s **)
9102 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9103 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9105 else if (tabidx >= tabct) {
9107 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9108 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9110 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9111 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9112 tabvec[tabidx]->dsc$w_length = 0;
9113 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9114 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9115 tabvec[tabidx]->dsc$a_pointer = NULL;
9116 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9118 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9120 getredirection(argcp,argvp);
9121 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9123 # include <reentrancy.h>
9124 decc$set_reentrancy(C$C_MULTITHREAD);
9133 * Trim Unix-style prefix off filespec, so it looks like what a shell
9134 * glob expansion would return (i.e. from specified prefix on, not
9135 * full path). Note that returned filespec is Unix-style, regardless
9136 * of whether input filespec was VMS-style or Unix-style.
9138 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9139 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9140 * vector of options; at present, only bit 0 is used, and if set tells
9141 * trim unixpath to try the current default directory as a prefix when
9142 * presented with a possibly ambiguous ... wildcard.
9144 * Returns !=0 on success, with trimmed filespec replacing contents of
9145 * fspec, and 0 on failure, with contents of fpsec unchanged.
9147 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9149 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9151 char *unixified, *unixwild,
9152 *template, *base, *end, *cp1, *cp2;
9153 register int tmplen, reslen = 0, dirs = 0;
9155 unixwild = PerlMem_malloc(VMS_MAXRSS);
9156 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9157 if (!wildspec || !fspec) return 0;
9158 template = unixwild;
9159 if (strpbrk(wildspec,"]>:") != NULL) {
9160 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9161 PerlMem_free(unixwild);
9166 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9167 unixwild[VMS_MAXRSS-1] = 0;
9169 unixified = PerlMem_malloc(VMS_MAXRSS);
9170 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9171 if (strpbrk(fspec,"]>:") != NULL) {
9172 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9173 PerlMem_free(unixwild);
9174 PerlMem_free(unixified);
9177 else base = unixified;
9178 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9179 * check to see that final result fits into (isn't longer than) fspec */
9180 reslen = strlen(fspec);
9184 /* No prefix or absolute path on wildcard, so nothing to remove */
9185 if (!*template || *template == '/') {
9186 PerlMem_free(unixwild);
9187 if (base == fspec) {
9188 PerlMem_free(unixified);
9191 tmplen = strlen(unixified);
9192 if (tmplen > reslen) {
9193 PerlMem_free(unixified);
9194 return 0; /* not enough space */
9196 /* Copy unixified resultant, including trailing NUL */
9197 memmove(fspec,unixified,tmplen+1);
9198 PerlMem_free(unixified);
9202 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9203 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9204 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9205 for (cp1 = end ;cp1 >= base; cp1--)
9206 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9208 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9209 PerlMem_free(unixified);
9210 PerlMem_free(unixwild);
9215 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9216 int ells = 1, totells, segdirs, match;
9217 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9218 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9220 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9222 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9223 tpl = PerlMem_malloc(VMS_MAXRSS);
9224 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9225 if (ellipsis == template && opts & 1) {
9226 /* Template begins with an ellipsis. Since we can't tell how many
9227 * directory names at the front of the resultant to keep for an
9228 * arbitrary starting point, we arbitrarily choose the current
9229 * default directory as a starting point. If it's there as a prefix,
9230 * clip it off. If not, fall through and act as if the leading
9231 * ellipsis weren't there (i.e. return shortest possible path that
9232 * could match template).
9234 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9236 PerlMem_free(unixified);
9237 PerlMem_free(unixwild);
9240 if (!decc_efs_case_preserve) {
9241 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9242 if (_tolower(*cp1) != _tolower(*cp2)) break;
9244 segdirs = dirs - totells; /* Min # of dirs we must have left */
9245 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9246 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9247 memmove(fspec,cp2+1,end - cp2);
9249 PerlMem_free(unixified);
9250 PerlMem_free(unixwild);
9254 /* First off, back up over constant elements at end of path */
9256 for (front = end ; front >= base; front--)
9257 if (*front == '/' && !dirs--) { front++; break; }
9259 lcres = PerlMem_malloc(VMS_MAXRSS);
9260 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9261 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9263 if (!decc_efs_case_preserve) {
9264 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9272 PerlMem_free(unixified);
9273 PerlMem_free(unixwild);
9274 PerlMem_free(lcres);
9275 return 0; /* Path too long. */
9278 *cp2 = '\0'; /* Pick up with memcpy later */
9279 lcfront = lcres + (front - base);
9280 /* Now skip over each ellipsis and try to match the path in front of it. */
9282 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9283 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9284 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9285 if (cp1 < template) break; /* template started with an ellipsis */
9286 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9287 ellipsis = cp1; continue;
9289 wilddsc.dsc$a_pointer = tpl;
9290 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9292 for (segdirs = 0, cp2 = tpl;
9293 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9295 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9297 if (!decc_efs_case_preserve) {
9298 *cp2 = _tolower(*cp1); /* else lowercase for match */
9301 *cp2 = *cp1; /* else preserve case for match */
9304 if (*cp2 == '/') segdirs++;
9306 if (cp1 != ellipsis - 1) {
9308 PerlMem_free(unixified);
9309 PerlMem_free(unixwild);
9310 PerlMem_free(lcres);
9311 return 0; /* Path too long */
9313 /* Back up at least as many dirs as in template before matching */
9314 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9315 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9316 for (match = 0; cp1 > lcres;) {
9317 resdsc.dsc$a_pointer = cp1;
9318 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9320 if (match == 1) lcfront = cp1;
9322 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9326 PerlMem_free(unixified);
9327 PerlMem_free(unixwild);
9328 PerlMem_free(lcres);
9329 return 0; /* Can't find prefix ??? */
9331 if (match > 1 && opts & 1) {
9332 /* This ... wildcard could cover more than one set of dirs (i.e.
9333 * a set of similar dir names is repeated). If the template
9334 * contains more than 1 ..., upstream elements could resolve the
9335 * ambiguity, but it's not worth a full backtracking setup here.
9336 * As a quick heuristic, clip off the current default directory
9337 * if it's present to find the trimmed spec, else use the
9338 * shortest string that this ... could cover.
9340 char def[NAM$C_MAXRSS+1], *st;
9342 if (getcwd(def, sizeof def,0) == NULL) {
9343 Safefree(unixified);
9349 if (!decc_efs_case_preserve) {
9350 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9351 if (_tolower(*cp1) != _tolower(*cp2)) break;
9353 segdirs = dirs - totells; /* Min # of dirs we must have left */
9354 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9355 if (*cp1 == '\0' && *cp2 == '/') {
9356 memmove(fspec,cp2+1,end - cp2);
9358 PerlMem_free(unixified);
9359 PerlMem_free(unixwild);
9360 PerlMem_free(lcres);
9363 /* Nope -- stick with lcfront from above and keep going. */
9366 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9368 PerlMem_free(unixified);
9369 PerlMem_free(unixwild);
9370 PerlMem_free(lcres);
9375 } /* end of trim_unixpath() */
9380 * VMS readdir() routines.
9381 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9383 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
9384 * Minor modifications to original routines.
9387 /* readdir may have been redefined by reentr.h, so make sure we get
9388 * the local version for what we do here.
9393 #if !defined(PERL_IMPLICIT_CONTEXT)
9394 # define readdir Perl_readdir
9396 # define readdir(a) Perl_readdir(aTHX_ a)
9399 /* Number of elements in vms_versions array */
9400 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9403 * Open a directory, return a handle for later use.
9405 /*{{{ DIR *opendir(char*name) */
9407 Perl_opendir(pTHX_ const char *name)
9413 Newx(dir, VMS_MAXRSS, char);
9414 if (do_tovmspath(name,dir,0,NULL) == NULL) {
9418 /* Check access before stat; otherwise stat does not
9419 * accurately report whether it's a directory.
9421 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9422 /* cando_by_name has already set errno */
9426 if (flex_stat(dir,&sb) == -1) return NULL;
9427 if (!S_ISDIR(sb.st_mode)) {
9429 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9432 /* Get memory for the handle, and the pattern. */
9434 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9436 /* Fill in the fields; mainly playing with the descriptor. */
9437 sprintf(dd->pattern, "%s*.*",dir);
9442 /* By saying we always want the result of readdir() in unix format, we
9443 * are really saying we want all the escapes removed. Otherwise the caller,
9444 * having no way to know whether it's already in VMS format, might send it
9445 * through tovmsspec again, thus double escaping.
9447 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9448 dd->pat.dsc$a_pointer = dd->pattern;
9449 dd->pat.dsc$w_length = strlen(dd->pattern);
9450 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9451 dd->pat.dsc$b_class = DSC$K_CLASS_S;
9452 #if defined(USE_ITHREADS)
9453 Newx(dd->mutex,1,perl_mutex);
9454 MUTEX_INIT( (perl_mutex *) dd->mutex );
9460 } /* end of opendir() */
9464 * Set the flag to indicate we want versions or not.
9466 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9468 vmsreaddirversions(DIR *dd, int flag)
9471 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9473 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9478 * Free up an opened directory.
9480 /*{{{ void closedir(DIR *dd)*/
9482 Perl_closedir(DIR *dd)
9486 sts = lib$find_file_end(&dd->context);
9487 Safefree(dd->pattern);
9488 #if defined(USE_ITHREADS)
9489 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9490 Safefree(dd->mutex);
9497 * Collect all the version numbers for the current file.
9500 collectversions(pTHX_ DIR *dd)
9502 struct dsc$descriptor_s pat;
9503 struct dsc$descriptor_s res;
9505 char *p, *text, *buff;
9507 unsigned long context, tmpsts;
9509 /* Convenient shorthand. */
9512 /* Add the version wildcard, ignoring the "*.*" put on before */
9513 i = strlen(dd->pattern);
9514 Newx(text,i + e->d_namlen + 3,char);
9515 strcpy(text, dd->pattern);
9516 sprintf(&text[i - 3], "%s;*", e->d_name);
9518 /* Set up the pattern descriptor. */
9519 pat.dsc$a_pointer = text;
9520 pat.dsc$w_length = i + e->d_namlen - 1;
9521 pat.dsc$b_dtype = DSC$K_DTYPE_T;
9522 pat.dsc$b_class = DSC$K_CLASS_S;
9524 /* Set up result descriptor. */
9525 Newx(buff, VMS_MAXRSS, char);
9526 res.dsc$a_pointer = buff;
9527 res.dsc$w_length = VMS_MAXRSS - 1;
9528 res.dsc$b_dtype = DSC$K_DTYPE_T;
9529 res.dsc$b_class = DSC$K_CLASS_S;
9531 /* Read files, collecting versions. */
9532 for (context = 0, e->vms_verscount = 0;
9533 e->vms_verscount < VERSIZE(e);
9534 e->vms_verscount++) {
9536 unsigned long flags = 0;
9538 #ifdef VMS_LONGNAME_SUPPORT
9539 flags = LIB$M_FIL_LONG_NAMES;
9541 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9542 if (tmpsts == RMS$_NMF || context == 0) break;
9544 buff[VMS_MAXRSS - 1] = '\0';
9545 if ((p = strchr(buff, ';')))
9546 e->vms_versions[e->vms_verscount] = atoi(p + 1);
9548 e->vms_versions[e->vms_verscount] = -1;
9551 _ckvmssts(lib$find_file_end(&context));
9555 } /* end of collectversions() */
9558 * Read the next entry from the directory.
9560 /*{{{ struct dirent *readdir(DIR *dd)*/
9562 Perl_readdir(pTHX_ DIR *dd)
9564 struct dsc$descriptor_s res;
9566 unsigned long int tmpsts;
9568 unsigned long flags = 0;
9569 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9570 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9572 /* Set up result descriptor, and get next file. */
9573 Newx(buff, VMS_MAXRSS, char);
9574 res.dsc$a_pointer = buff;
9575 res.dsc$w_length = VMS_MAXRSS - 1;
9576 res.dsc$b_dtype = DSC$K_DTYPE_T;
9577 res.dsc$b_class = DSC$K_CLASS_S;
9579 #ifdef VMS_LONGNAME_SUPPORT
9580 flags = LIB$M_FIL_LONG_NAMES;
9583 tmpsts = lib$find_file
9584 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9585 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
9586 if (!(tmpsts & 1)) {
9587 set_vaxc_errno(tmpsts);
9590 set_errno(EACCES); break;
9592 set_errno(ENODEV); break;
9594 set_errno(ENOTDIR); break;
9595 case RMS$_FNF: case RMS$_DNF:
9596 set_errno(ENOENT); break;
9604 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9605 buff[res.dsc$w_length] = '\0';
9606 p = buff + res.dsc$w_length;
9607 while (--p >= buff) if (!isspace(*p)) break;
9609 if (!decc_efs_case_preserve) {
9610 for (p = buff; *p; p++) *p = _tolower(*p);
9613 /* Skip any directory component and just copy the name. */
9614 sts = vms_split_path
9629 /* Drop NULL extensions on UNIX file specification */
9630 if ((dd->flags & PERL_VMSDIR_M_UNIXSPECS &&
9631 (e_len == 1) && decc_readdir_dropdotnotype)) {
9636 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9637 dd->entry.d_name[n_len + e_len] = '\0';
9638 dd->entry.d_namlen = strlen(dd->entry.d_name);
9640 /* Convert the filename to UNIX format if needed */
9641 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9643 /* Translate the encoded characters. */
9644 /* Fixme: Unicode handling could result in embedded 0 characters */
9645 if (strchr(dd->entry.d_name, '^') != NULL) {
9648 p = dd->entry.d_name;
9651 int inchars_read, outchars_added;
9652 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9654 q += outchars_added;
9656 /* if outchars_added > 1, then this is a wide file specification */
9657 /* Wide file specifications need to be passed in Perl */
9658 /* counted strings apparently with a Unicode flag */
9661 strcpy(dd->entry.d_name, new_name);
9662 dd->entry.d_namlen = strlen(dd->entry.d_name);
9666 dd->entry.vms_verscount = 0;
9667 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9671 } /* end of readdir() */
9675 * Read the next entry from the directory -- thread-safe version.
9677 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9679 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9683 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9685 entry = readdir(dd);
9687 retval = ( *result == NULL ? errno : 0 );
9689 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9693 } /* end of readdir_r() */
9697 * Return something that can be used in a seekdir later.
9699 /*{{{ long telldir(DIR *dd)*/
9701 Perl_telldir(DIR *dd)
9708 * Return to a spot where we used to be. Brute force.
9710 /*{{{ void seekdir(DIR *dd,long count)*/
9712 Perl_seekdir(pTHX_ DIR *dd, long count)
9716 /* If we haven't done anything yet... */
9720 /* Remember some state, and clear it. */
9721 old_flags = dd->flags;
9722 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9723 _ckvmssts(lib$find_file_end(&dd->context));
9726 /* The increment is in readdir(). */
9727 for (dd->count = 0; dd->count < count; )
9730 dd->flags = old_flags;
9732 } /* end of seekdir() */
9735 /* VMS subprocess management
9737 * my_vfork() - just a vfork(), after setting a flag to record that
9738 * the current script is trying a Unix-style fork/exec.
9740 * vms_do_aexec() and vms_do_exec() are called in response to the
9741 * perl 'exec' function. If this follows a vfork call, then they
9742 * call out the regular perl routines in doio.c which do an
9743 * execvp (for those who really want to try this under VMS).
9744 * Otherwise, they do exactly what the perl docs say exec should
9745 * do - terminate the current script and invoke a new command
9746 * (See below for notes on command syntax.)
9748 * do_aspawn() and do_spawn() implement the VMS side of the perl
9749 * 'system' function.
9751 * Note on command arguments to perl 'exec' and 'system': When handled
9752 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9753 * are concatenated to form a DCL command string. If the first non-numeric
9754 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9755 * the command string is handed off to DCL directly. Otherwise,
9756 * the first token of the command is taken as the filespec of an image
9757 * to run. The filespec is expanded using a default type of '.EXE' and
9758 * the process defaults for device, directory, etc., and if found, the resultant
9759 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9760 * the command string as parameters. This is perhaps a bit complicated,
9761 * but I hope it will form a happy medium between what VMS folks expect
9762 * from lib$spawn and what Unix folks expect from exec.
9765 static int vfork_called;
9767 /*{{{int my_vfork()*/
9778 vms_execfree(struct dsc$descriptor_s *vmscmd)
9781 if (vmscmd->dsc$a_pointer) {
9782 PerlMem_free(vmscmd->dsc$a_pointer);
9784 PerlMem_free(vmscmd);
9789 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9791 char *junk, *tmps = NULL;
9792 register size_t cmdlen = 0;
9799 tmps = SvPV(really,rlen);
9806 for (idx++; idx <= sp; idx++) {
9808 junk = SvPVx(*idx,rlen);
9809 cmdlen += rlen ? rlen + 1 : 0;
9812 Newx(PL_Cmd, cmdlen+1, char);
9814 if (tmps && *tmps) {
9815 strcpy(PL_Cmd,tmps);
9818 else *PL_Cmd = '\0';
9819 while (++mark <= sp) {
9821 char *s = SvPVx(*mark,n_a);
9823 if (*PL_Cmd) strcat(PL_Cmd," ");
9829 } /* end of setup_argstr() */
9832 static unsigned long int
9833 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9834 struct dsc$descriptor_s **pvmscmd)
9836 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9837 char image_name[NAM$C_MAXRSS+1];
9838 char image_argv[NAM$C_MAXRSS+1];
9839 $DESCRIPTOR(defdsc,".EXE");
9840 $DESCRIPTOR(defdsc2,".");
9841 $DESCRIPTOR(resdsc,resspec);
9842 struct dsc$descriptor_s *vmscmd;
9843 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9844 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9845 register char *s, *rest, *cp, *wordbreak;
9850 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9851 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9853 /* Make a copy for modification */
9854 cmdlen = strlen(incmd);
9855 cmd = PerlMem_malloc(cmdlen+1);
9856 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9857 strncpy(cmd, incmd, cmdlen);
9862 vmscmd->dsc$a_pointer = NULL;
9863 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9864 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9865 vmscmd->dsc$w_length = 0;
9866 if (pvmscmd) *pvmscmd = vmscmd;
9868 if (suggest_quote) *suggest_quote = 0;
9870 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9872 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9877 while (*s && isspace(*s)) s++;
9879 if (*s == '@' || *s == '$') {
9880 vmsspec[0] = *s; rest = s + 1;
9881 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9883 else { cp = vmsspec; rest = s; }
9884 if (*rest == '.' || *rest == '/') {
9887 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9888 rest++, cp2++) *cp2 = *rest;
9890 if (do_tovmsspec(resspec,cp,0,NULL)) {
9893 for (cp2 = vmsspec + strlen(vmsspec);
9894 *rest && cp2 - vmsspec < sizeof vmsspec;
9895 rest++, cp2++) *cp2 = *rest;
9900 /* Intuit whether verb (first word of cmd) is a DCL command:
9901 * - if first nonspace char is '@', it's a DCL indirection
9903 * - if verb contains a filespec separator, it's not a DCL command
9904 * - if it doesn't, caller tells us whether to default to a DCL
9905 * command, or to a local image unless told it's DCL (by leading '$')
9909 if (suggest_quote) *suggest_quote = 1;
9911 register char *filespec = strpbrk(s,":<[.;");
9912 rest = wordbreak = strpbrk(s," \"\t/");
9913 if (!wordbreak) wordbreak = s + strlen(s);
9914 if (*s == '$') check_img = 0;
9915 if (filespec && (filespec < wordbreak)) isdcl = 0;
9916 else isdcl = !check_img;
9921 imgdsc.dsc$a_pointer = s;
9922 imgdsc.dsc$w_length = wordbreak - s;
9923 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9925 _ckvmssts(lib$find_file_end(&cxt));
9926 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9927 if (!(retsts & 1) && *s == '$') {
9928 _ckvmssts(lib$find_file_end(&cxt));
9929 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9930 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9932 _ckvmssts(lib$find_file_end(&cxt));
9933 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9937 _ckvmssts(lib$find_file_end(&cxt));
9942 while (*s && !isspace(*s)) s++;
9945 /* check that it's really not DCL with no file extension */
9946 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9948 char b[256] = {0,0,0,0};
9949 read(fileno(fp), b, 256);
9950 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9954 /* Check for script */
9956 if ((b[0] == '#') && (b[1] == '!'))
9958 #ifdef ALTERNATE_SHEBANG
9960 shebang_len = strlen(ALTERNATE_SHEBANG);
9961 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
9963 perlstr = strstr("perl",b);
9964 if (perlstr == NULL)
9972 if (shebang_len > 0) {
9975 char tmpspec[NAM$C_MAXRSS + 1];
9978 /* Image is following after white space */
9979 /*--------------------------------------*/
9980 while (isprint(b[i]) && isspace(b[i]))
9984 while (isprint(b[i]) && !isspace(b[i])) {
9985 tmpspec[j++] = b[i++];
9986 if (j >= NAM$C_MAXRSS)
9991 /* There may be some default parameters to the image */
9992 /*---------------------------------------------------*/
9994 while (isprint(b[i])) {
9995 image_argv[j++] = b[i++];
9996 if (j >= NAM$C_MAXRSS)
9999 while ((j > 0) && !isprint(image_argv[j-1]))
10003 /* It will need to be converted to VMS format and validated */
10004 if (tmpspec[0] != '\0') {
10007 /* Try to find the exact program requested to be run */
10008 /*---------------------------------------------------*/
10009 iname = do_rmsexpand
10010 (tmpspec, image_name, 0, ".exe",
10011 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10012 if (iname != NULL) {
10013 if (cando_by_name_int
10014 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10015 /* MCR prefix needed */
10019 /* Try again with a null type */
10020 /*----------------------------*/
10021 iname = do_rmsexpand
10022 (tmpspec, image_name, 0, ".",
10023 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10024 if (iname != NULL) {
10025 if (cando_by_name_int
10026 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10027 /* MCR prefix needed */
10033 /* Did we find the image to run the script? */
10034 /*------------------------------------------*/
10038 /* Assume DCL or foreign command exists */
10039 /*--------------------------------------*/
10040 tchr = strrchr(tmpspec, '/');
10041 if (tchr != NULL) {
10047 strcpy(image_name, tchr);
10055 if (check_img && isdcl) return RMS$_FNF;
10057 if (cando_by_name(S_IXUSR,0,resspec)) {
10058 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10059 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10061 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10062 if (image_name[0] != 0) {
10063 strcat(vmscmd->dsc$a_pointer, image_name);
10064 strcat(vmscmd->dsc$a_pointer, " ");
10066 } else if (image_name[0] != 0) {
10067 strcpy(vmscmd->dsc$a_pointer, image_name);
10068 strcat(vmscmd->dsc$a_pointer, " ");
10070 strcpy(vmscmd->dsc$a_pointer,"@");
10072 if (suggest_quote) *suggest_quote = 1;
10074 /* If there is an image name, use original command */
10075 if (image_name[0] == 0)
10076 strcat(vmscmd->dsc$a_pointer,resspec);
10079 while (*rest && isspace(*rest)) rest++;
10082 if (image_argv[0] != 0) {
10083 strcat(vmscmd->dsc$a_pointer,image_argv);
10084 strcat(vmscmd->dsc$a_pointer, " ");
10090 rest_len = strlen(rest);
10091 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10092 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10093 strcat(vmscmd->dsc$a_pointer,rest);
10095 retsts = CLI$_BUFOVF;
10097 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10099 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10105 /* It's either a DCL command or we couldn't find a suitable image */
10106 vmscmd->dsc$w_length = strlen(cmd);
10108 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10109 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10110 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10114 /* check if it's a symbol (for quoting purposes) */
10115 if (suggest_quote && !*suggest_quote) {
10117 char equiv[LNM$C_NAMLENGTH];
10118 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10119 eqvdsc.dsc$a_pointer = equiv;
10121 iss = lib$get_symbol(vmscmd,&eqvdsc);
10122 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10124 if (!(retsts & 1)) {
10125 /* just hand off status values likely to be due to user error */
10126 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10127 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10128 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10129 else { _ckvmssts(retsts); }
10132 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10134 } /* end of setup_cmddsc() */
10137 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10139 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10145 if (vfork_called) { /* this follows a vfork - act Unixish */
10147 if (vfork_called < 0) {
10148 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10151 else return do_aexec(really,mark,sp);
10153 /* no vfork - act VMSish */
10154 cmd = setup_argstr(aTHX_ really,mark,sp);
10155 exec_sts = vms_do_exec(cmd);
10156 Safefree(cmd); /* Clean up from setup_argstr() */
10161 } /* end of vms_do_aexec() */
10164 /* {{{bool vms_do_exec(char *cmd) */
10166 Perl_vms_do_exec(pTHX_ const char *cmd)
10168 struct dsc$descriptor_s *vmscmd;
10170 if (vfork_called) { /* this follows a vfork - act Unixish */
10172 if (vfork_called < 0) {
10173 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10176 else return do_exec(cmd);
10179 { /* no vfork - act VMSish */
10180 unsigned long int retsts;
10183 TAINT_PROPER("exec");
10184 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10185 retsts = lib$do_command(vmscmd);
10188 case RMS$_FNF: case RMS$_DNF:
10189 set_errno(ENOENT); break;
10191 set_errno(ENOTDIR); break;
10193 set_errno(ENODEV); break;
10195 set_errno(EACCES); break;
10197 set_errno(EINVAL); break;
10198 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10199 set_errno(E2BIG); break;
10200 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10201 _ckvmssts(retsts); /* fall through */
10202 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10203 set_errno(EVMSERR);
10205 set_vaxc_errno(retsts);
10206 if (ckWARN(WARN_EXEC)) {
10207 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10208 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10210 vms_execfree(vmscmd);
10215 } /* end of vms_do_exec() */
10218 int do_spawn2(pTHX_ const char *, int);
10221 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10223 unsigned long int sts;
10229 /* We'll copy the (undocumented?) Win32 behavior and allow a
10230 * numeric first argument. But the only value we'll support
10231 * through do_aspawn is a value of 1, which means spawn without
10232 * waiting for completion -- other values are ignored.
10234 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10236 flags = SvIVx(*mark);
10239 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10240 flags = CLI$M_NOWAIT;
10244 cmd = setup_argstr(aTHX_ really, mark, sp);
10245 sts = do_spawn2(aTHX_ cmd, flags);
10246 /* pp_sys will clean up cmd */
10250 } /* end of do_aspawn() */
10254 /* {{{int do_spawn(char* cmd) */
10256 Perl_do_spawn(pTHX_ char* cmd)
10258 PERL_ARGS_ASSERT_DO_SPAWN;
10260 return do_spawn2(aTHX_ cmd, 0);
10264 /* {{{int do_spawn_nowait(char* cmd) */
10266 Perl_do_spawn_nowait(pTHX_ char* cmd)
10268 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10270 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10274 /* {{{int do_spawn2(char *cmd) */
10276 do_spawn2(pTHX_ const char *cmd, int flags)
10278 unsigned long int sts, substs;
10280 /* The caller of this routine expects to Safefree(PL_Cmd) */
10281 Newx(PL_Cmd,10,char);
10284 TAINT_PROPER("spawn");
10285 if (!cmd || !*cmd) {
10286 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10289 case RMS$_FNF: case RMS$_DNF:
10290 set_errno(ENOENT); break;
10292 set_errno(ENOTDIR); break;
10294 set_errno(ENODEV); break;
10296 set_errno(EACCES); break;
10298 set_errno(EINVAL); break;
10299 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10300 set_errno(E2BIG); break;
10301 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10302 _ckvmssts(sts); /* fall through */
10303 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10304 set_errno(EVMSERR);
10306 set_vaxc_errno(sts);
10307 if (ckWARN(WARN_EXEC)) {
10308 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10317 if (flags & CLI$M_NOWAIT)
10320 strcpy(mode, "nW");
10322 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10325 /* sts will be the pid in the nowait case */
10328 } /* end of do_spawn2() */
10332 static unsigned int *sockflags, sockflagsize;
10335 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10336 * routines found in some versions of the CRTL can't deal with sockets.
10337 * We don't shim the other file open routines since a socket isn't
10338 * likely to be opened by a name.
10340 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10341 FILE *my_fdopen(int fd, const char *mode)
10343 FILE *fp = fdopen(fd, mode);
10346 unsigned int fdoff = fd / sizeof(unsigned int);
10347 Stat_t sbuf; /* native stat; we don't need flex_stat */
10348 if (!sockflagsize || fdoff > sockflagsize) {
10349 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
10350 else Newx (sockflags,fdoff+2,unsigned int);
10351 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10352 sockflagsize = fdoff + 2;
10354 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10355 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10364 * Clear the corresponding bit when the (possibly) socket stream is closed.
10365 * There still a small hole: we miss an implicit close which might occur
10366 * via freopen(). >> Todo
10368 /*{{{ int my_fclose(FILE *fp)*/
10369 int my_fclose(FILE *fp) {
10371 unsigned int fd = fileno(fp);
10372 unsigned int fdoff = fd / sizeof(unsigned int);
10374 if (sockflagsize && fdoff <= sockflagsize)
10375 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10383 * A simple fwrite replacement which outputs itmsz*nitm chars without
10384 * introducing record boundaries every itmsz chars.
10385 * We are using fputs, which depends on a terminating null. We may
10386 * well be writing binary data, so we need to accommodate not only
10387 * data with nulls sprinkled in the middle but also data with no null
10390 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10392 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10394 register char *cp, *end, *cpd, *data;
10395 register unsigned int fd = fileno(dest);
10396 register unsigned int fdoff = fd / sizeof(unsigned int);
10398 int bufsize = itmsz * nitm + 1;
10400 if (fdoff < sockflagsize &&
10401 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10402 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10406 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10407 memcpy( data, src, itmsz*nitm );
10408 data[itmsz*nitm] = '\0';
10410 end = data + itmsz * nitm;
10411 retval = (int) nitm; /* on success return # items written */
10414 while (cpd <= end) {
10415 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10416 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10418 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10422 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10425 } /* end of my_fwrite() */
10428 /*{{{ int my_flush(FILE *fp)*/
10430 Perl_my_flush(pTHX_ FILE *fp)
10433 if ((res = fflush(fp)) == 0 && fp) {
10434 #ifdef VMS_DO_SOCKETS
10436 if (fstat(fileno(fp), (stat_t *)&s) == 0 && !S_ISSOCK(s.st_mode))
10438 res = fsync(fileno(fp));
10441 * If the flush succeeded but set end-of-file, we need to clear
10442 * the error because our caller may check ferror(). BTW, this
10443 * probably means we just flushed an empty file.
10445 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10452 * Here are replacements for the following Unix routines in the VMS environment:
10453 * getpwuid Get information for a particular UIC or UID
10454 * getpwnam Get information for a named user
10455 * getpwent Get information for each user in the rights database
10456 * setpwent Reset search to the start of the rights database
10457 * endpwent Finish searching for users in the rights database
10459 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10460 * (defined in pwd.h), which contains the following fields:-
10462 * char *pw_name; Username (in lower case)
10463 * char *pw_passwd; Hashed password
10464 * unsigned int pw_uid; UIC
10465 * unsigned int pw_gid; UIC group number
10466 * char *pw_unixdir; Default device/directory (VMS-style)
10467 * char *pw_gecos; Owner name
10468 * char *pw_dir; Default device/directory (Unix-style)
10469 * char *pw_shell; Default CLI name (eg. DCL)
10471 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10473 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10474 * not the UIC member number (eg. what's returned by getuid()),
10475 * getpwuid() can accept either as input (if uid is specified, the caller's
10476 * UIC group is used), though it won't recognise gid=0.
10478 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10479 * information about other users in your group or in other groups, respectively.
10480 * If the required privilege is not available, then these routines fill only
10481 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10484 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10487 /* sizes of various UAF record fields */
10488 #define UAI$S_USERNAME 12
10489 #define UAI$S_IDENT 31
10490 #define UAI$S_OWNER 31
10491 #define UAI$S_DEFDEV 31
10492 #define UAI$S_DEFDIR 63
10493 #define UAI$S_DEFCLI 31
10494 #define UAI$S_PWD 8
10496 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10497 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10498 (uic).uic$v_group != UIC$K_WILD_GROUP)
10500 static char __empty[]= "";
10501 static struct passwd __passwd_empty=
10502 {(char *) __empty, (char *) __empty, 0, 0,
10503 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10504 static int contxt= 0;
10505 static struct passwd __pwdcache;
10506 static char __pw_namecache[UAI$S_IDENT+1];
10509 * This routine does most of the work extracting the user information.
10511 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10514 unsigned char length;
10515 char pw_gecos[UAI$S_OWNER+1];
10517 static union uicdef uic;
10519 unsigned char length;
10520 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10523 unsigned char length;
10524 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10527 unsigned char length;
10528 char pw_shell[UAI$S_DEFCLI+1];
10530 static char pw_passwd[UAI$S_PWD+1];
10532 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10533 struct dsc$descriptor_s name_desc;
10534 unsigned long int sts;
10536 static struct itmlst_3 itmlst[]= {
10537 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
10538 {sizeof(uic), UAI$_UIC, &uic, &luic},
10539 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
10540 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
10541 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
10542 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
10543 {0, 0, NULL, NULL}};
10545 name_desc.dsc$w_length= strlen(name);
10546 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10547 name_desc.dsc$b_class= DSC$K_CLASS_S;
10548 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10550 /* Note that sys$getuai returns many fields as counted strings. */
10551 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10552 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10553 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10555 else { _ckvmssts(sts); }
10556 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
10558 if ((int) owner.length < lowner) lowner= (int) owner.length;
10559 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10560 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10561 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10562 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10563 owner.pw_gecos[lowner]= '\0';
10564 defdev.pw_dir[ldefdev+ldefdir]= '\0';
10565 defcli.pw_shell[ldefcli]= '\0';
10566 if (valid_uic(uic)) {
10567 pwd->pw_uid= uic.uic$l_uic;
10568 pwd->pw_gid= uic.uic$v_group;
10571 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10572 pwd->pw_passwd= pw_passwd;
10573 pwd->pw_gecos= owner.pw_gecos;
10574 pwd->pw_dir= defdev.pw_dir;
10575 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10576 pwd->pw_shell= defcli.pw_shell;
10577 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10579 ldir= strlen(pwd->pw_unixdir) - 1;
10580 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10583 strcpy(pwd->pw_unixdir, pwd->pw_dir);
10584 if (!decc_efs_case_preserve)
10585 __mystrtolower(pwd->pw_unixdir);
10590 * Get information for a named user.
10592 /*{{{struct passwd *getpwnam(char *name)*/
10593 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10595 struct dsc$descriptor_s name_desc;
10597 unsigned long int status, sts;
10599 __pwdcache = __passwd_empty;
10600 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10601 /* We still may be able to determine pw_uid and pw_gid */
10602 name_desc.dsc$w_length= strlen(name);
10603 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10604 name_desc.dsc$b_class= DSC$K_CLASS_S;
10605 name_desc.dsc$a_pointer= (char *) name;
10606 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10607 __pwdcache.pw_uid= uic.uic$l_uic;
10608 __pwdcache.pw_gid= uic.uic$v_group;
10611 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10612 set_vaxc_errno(sts);
10613 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10616 else { _ckvmssts(sts); }
10619 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10620 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10621 __pwdcache.pw_name= __pw_namecache;
10622 return &__pwdcache;
10623 } /* end of my_getpwnam() */
10627 * Get information for a particular UIC or UID.
10628 * Called by my_getpwent with uid=-1 to list all users.
10630 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10631 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10633 const $DESCRIPTOR(name_desc,__pw_namecache);
10634 unsigned short lname;
10636 unsigned long int status;
10638 if (uid == (unsigned int) -1) {
10640 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10641 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10642 set_vaxc_errno(status);
10643 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10647 else { _ckvmssts(status); }
10648 } while (!valid_uic (uic));
10651 uic.uic$l_uic= uid;
10652 if (!uic.uic$v_group)
10653 uic.uic$v_group= PerlProc_getgid();
10654 if (valid_uic(uic))
10655 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10656 else status = SS$_IVIDENT;
10657 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10658 status == RMS$_PRV) {
10659 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10662 else { _ckvmssts(status); }
10664 __pw_namecache[lname]= '\0';
10665 __mystrtolower(__pw_namecache);
10667 __pwdcache = __passwd_empty;
10668 __pwdcache.pw_name = __pw_namecache;
10670 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10671 The identifier's value is usually the UIC, but it doesn't have to be,
10672 so if we can, we let fillpasswd update this. */
10673 __pwdcache.pw_uid = uic.uic$l_uic;
10674 __pwdcache.pw_gid = uic.uic$v_group;
10676 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10677 return &__pwdcache;
10679 } /* end of my_getpwuid() */
10683 * Get information for next user.
10685 /*{{{struct passwd *my_getpwent()*/
10686 struct passwd *Perl_my_getpwent(pTHX)
10688 return (my_getpwuid((unsigned int) -1));
10693 * Finish searching rights database for users.
10695 /*{{{void my_endpwent()*/
10696 void Perl_my_endpwent(pTHX)
10699 _ckvmssts(sys$finish_rdb(&contxt));
10705 #ifdef HOMEGROWN_POSIX_SIGNALS
10706 /* Signal handling routines, pulled into the core from POSIX.xs.
10708 * We need these for threads, so they've been rolled into the core,
10709 * rather than left in POSIX.xs.
10711 * (DRS, Oct 23, 1997)
10714 /* sigset_t is atomic under VMS, so these routines are easy */
10715 /*{{{int my_sigemptyset(sigset_t *) */
10716 int my_sigemptyset(sigset_t *set) {
10717 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10718 *set = 0; return 0;
10723 /*{{{int my_sigfillset(sigset_t *)*/
10724 int my_sigfillset(sigset_t *set) {
10726 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10727 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10733 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10734 int my_sigaddset(sigset_t *set, int sig) {
10735 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10736 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10737 *set |= (1 << (sig - 1));
10743 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10744 int my_sigdelset(sigset_t *set, int sig) {
10745 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10746 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10747 *set &= ~(1 << (sig - 1));
10753 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10754 int my_sigismember(sigset_t *set, int sig) {
10755 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10756 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10757 return *set & (1 << (sig - 1));
10762 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10763 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10766 /* If set and oset are both null, then things are badly wrong. Bail out. */
10767 if ((oset == NULL) && (set == NULL)) {
10768 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10772 /* If set's null, then we're just handling a fetch. */
10774 tempmask = sigblock(0);
10779 tempmask = sigsetmask(*set);
10782 tempmask = sigblock(*set);
10785 tempmask = sigblock(0);
10786 sigsetmask(*oset & ~tempmask);
10789 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10794 /* Did they pass us an oset? If so, stick our holding mask into it */
10801 #endif /* HOMEGROWN_POSIX_SIGNALS */
10804 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10805 * my_utime(), and flex_stat(), all of which operate on UTC unless
10806 * VMSISH_TIMES is true.
10808 /* method used to handle UTC conversions:
10809 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10811 static int gmtime_emulation_type;
10812 /* number of secs to add to UTC POSIX-style time to get local time */
10813 static long int utc_offset_secs;
10815 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10816 * in vmsish.h. #undef them here so we can call the CRTL routines
10825 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10826 * qualifier with the extern prefix pragma. This provisional
10827 * hack circumvents this prefix pragma problem in previous
10830 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10831 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10832 # pragma __extern_prefix save
10833 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10834 # define gmtime decc$__utctz_gmtime
10835 # define localtime decc$__utctz_localtime
10836 # define time decc$__utc_time
10837 # pragma __extern_prefix restore
10839 struct tm *gmtime(), *localtime();
10845 static time_t toutc_dst(time_t loc) {
10848 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10849 loc -= utc_offset_secs;
10850 if (rsltmp->tm_isdst) loc -= 3600;
10853 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10854 ((gmtime_emulation_type || my_time(NULL)), \
10855 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10856 ((secs) - utc_offset_secs))))
10858 static time_t toloc_dst(time_t utc) {
10861 utc += utc_offset_secs;
10862 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10863 if (rsltmp->tm_isdst) utc += 3600;
10866 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10867 ((gmtime_emulation_type || my_time(NULL)), \
10868 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10869 ((secs) + utc_offset_secs))))
10871 #ifndef RTL_USES_UTC
10874 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10875 DST starts on 1st sun of april at 02:00 std time
10876 ends on last sun of october at 02:00 dst time
10877 see the UCX management command reference, SET CONFIG TIMEZONE
10878 for formatting info.
10880 No, it's not as general as it should be, but then again, NOTHING
10881 will handle UK times in a sensible way.
10886 parse the DST start/end info:
10887 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10891 tz_parse_startend(char *s, struct tm *w, int *past)
10893 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10894 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10899 if (!past) return 0;
10902 if (w->tm_year % 4 == 0) ly = 1;
10903 if (w->tm_year % 100 == 0) ly = 0;
10904 if (w->tm_year+1900 % 400 == 0) ly = 1;
10907 dozjd = isdigit(*s);
10908 if (*s == 'J' || *s == 'j' || dozjd) {
10909 if (!dozjd && !isdigit(*++s)) return 0;
10912 d = d*10 + *s++ - '0';
10914 d = d*10 + *s++ - '0';
10917 if (d == 0) return 0;
10918 if (d > 366) return 0;
10920 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10923 } else if (*s == 'M' || *s == 'm') {
10924 if (!isdigit(*++s)) return 0;
10926 if (isdigit(*s)) m = 10*m + *s++ - '0';
10927 if (*s != '.') return 0;
10928 if (!isdigit(*++s)) return 0;
10930 if (n < 1 || n > 5) return 0;
10931 if (*s != '.') return 0;
10932 if (!isdigit(*++s)) return 0;
10934 if (d > 6) return 0;
10938 if (!isdigit(*++s)) return 0;
10940 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10942 if (!isdigit(*++s)) return 0;
10944 if (isdigit(*s)) min = 10*min + *s++ - '0';
10946 if (!isdigit(*++s)) return 0;
10948 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10958 if (w->tm_yday < d) goto before;
10959 if (w->tm_yday > d) goto after;
10961 if (w->tm_mon+1 < m) goto before;
10962 if (w->tm_mon+1 > m) goto after;
10964 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10965 k = d - j; /* mday of first d */
10966 if (k <= 0) k += 7;
10967 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10968 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10969 if (w->tm_mday < k) goto before;
10970 if (w->tm_mday > k) goto after;
10973 if (w->tm_hour < hour) goto before;
10974 if (w->tm_hour > hour) goto after;
10975 if (w->tm_min < min) goto before;
10976 if (w->tm_min > min) goto after;
10977 if (w->tm_sec < sec) goto before;
10991 /* parse the offset: (+|-)hh[:mm[:ss]] */
10994 tz_parse_offset(char *s, int *offset)
10996 int hour = 0, min = 0, sec = 0;
10999 if (!offset) return 0;
11001 if (*s == '-') {neg++; s++;}
11002 if (*s == '+') s++;
11003 if (!isdigit(*s)) return 0;
11005 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11006 if (hour > 24) return 0;
11008 if (!isdigit(*++s)) return 0;
11010 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11011 if (min > 59) return 0;
11013 if (!isdigit(*++s)) return 0;
11015 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11016 if (sec > 59) return 0;
11020 *offset = (hour*60+min)*60 + sec;
11021 if (neg) *offset = -*offset;
11026 input time is w, whatever type of time the CRTL localtime() uses.
11027 sets dst, the zone, and the gmtoff (seconds)
11029 caches the value of TZ and UCX$TZ env variables; note that
11030 my_setenv looks for these and sets a flag if they're changed
11033 We have to watch out for the "australian" case (dst starts in
11034 october, ends in april)...flagged by "reverse" and checked by
11035 scanning through the months of the previous year.
11040 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11045 char *dstzone, *tz, *s_start, *s_end;
11046 int std_off, dst_off, isdst;
11047 int y, dststart, dstend;
11048 static char envtz[1025]; /* longer than any logical, symbol, ... */
11049 static char ucxtz[1025];
11050 static char reversed = 0;
11056 reversed = -1; /* flag need to check */
11057 envtz[0] = ucxtz[0] = '\0';
11058 tz = my_getenv("TZ",0);
11059 if (tz) strcpy(envtz, tz);
11060 tz = my_getenv("UCX$TZ",0);
11061 if (tz) strcpy(ucxtz, tz);
11062 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11065 if (!*tz) tz = ucxtz;
11068 while (isalpha(*s)) s++;
11069 s = tz_parse_offset(s, &std_off);
11071 if (!*s) { /* no DST, hurray we're done! */
11077 while (isalpha(*s)) s++;
11078 s2 = tz_parse_offset(s, &dst_off);
11082 dst_off = std_off - 3600;
11085 if (!*s) { /* default dst start/end?? */
11086 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11087 s = strchr(ucxtz,',');
11089 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11091 if (*s != ',') return 0;
11094 when = _toutc(when); /* convert to utc */
11095 when = when - std_off; /* convert to pseudolocal time*/
11097 w2 = localtime(&when);
11100 s = tz_parse_startend(s_start,w2,&dststart);
11102 if (*s != ',') return 0;
11105 when = _toutc(when); /* convert to utc */
11106 when = when - dst_off; /* convert to pseudolocal time*/
11107 w2 = localtime(&when);
11108 if (w2->tm_year != y) { /* spans a year, just check one time */
11109 when += dst_off - std_off;
11110 w2 = localtime(&when);
11113 s = tz_parse_startend(s_end,w2,&dstend);
11116 if (reversed == -1) { /* need to check if start later than end */
11120 if (when < 2*365*86400) {
11121 when += 2*365*86400;
11125 w2 =localtime(&when);
11126 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11128 for (j = 0; j < 12; j++) {
11129 w2 =localtime(&when);
11130 tz_parse_startend(s_start,w2,&ds);
11131 tz_parse_startend(s_end,w2,&de);
11132 if (ds != de) break;
11136 if (de && !ds) reversed = 1;
11139 isdst = dststart && !dstend;
11140 if (reversed) isdst = dststart || !dstend;
11143 if (dst) *dst = isdst;
11144 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11145 if (isdst) tz = dstzone;
11147 while(isalpha(*tz)) *zone++ = *tz++;
11153 #endif /* !RTL_USES_UTC */
11155 /* my_time(), my_localtime(), my_gmtime()
11156 * By default traffic in UTC time values, using CRTL gmtime() or
11157 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11158 * Note: We need to use these functions even when the CRTL has working
11159 * UTC support, since they also handle C<use vmsish qw(times);>
11161 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11162 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11165 /*{{{time_t my_time(time_t *timep)*/
11166 time_t Perl_my_time(pTHX_ time_t *timep)
11171 if (gmtime_emulation_type == 0) {
11173 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11174 /* results of calls to gmtime() and localtime() */
11175 /* for same &base */
11177 gmtime_emulation_type++;
11178 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11179 char off[LNM$C_NAMLENGTH+1];;
11181 gmtime_emulation_type++;
11182 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11183 gmtime_emulation_type++;
11184 utc_offset_secs = 0;
11185 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11187 else { utc_offset_secs = atol(off); }
11189 else { /* We've got a working gmtime() */
11190 struct tm gmt, local;
11193 tm_p = localtime(&base);
11195 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11196 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11197 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11198 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11203 # ifdef VMSISH_TIME
11204 # ifdef RTL_USES_UTC
11205 if (VMSISH_TIME) when = _toloc(when);
11207 if (!VMSISH_TIME) when = _toutc(when);
11210 if (timep != NULL) *timep = when;
11213 } /* end of my_time() */
11217 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11219 Perl_my_gmtime(pTHX_ const time_t *timep)
11225 if (timep == NULL) {
11226 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11229 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11232 # ifdef VMSISH_TIME
11233 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11235 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11236 return gmtime(&when);
11238 /* CRTL localtime() wants local time as input, so does no tz correction */
11239 rsltmp = localtime(&when);
11240 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11243 } /* end of my_gmtime() */
11247 /*{{{struct tm *my_localtime(const time_t *timep)*/
11249 Perl_my_localtime(pTHX_ const time_t *timep)
11251 time_t when, whenutc;
11255 if (timep == NULL) {
11256 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11259 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11260 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11263 # ifdef RTL_USES_UTC
11264 # ifdef VMSISH_TIME
11265 if (VMSISH_TIME) when = _toutc(when);
11267 /* CRTL localtime() wants UTC as input, does tz correction itself */
11268 return localtime(&when);
11270 # else /* !RTL_USES_UTC */
11272 # ifdef VMSISH_TIME
11273 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11274 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
11277 #ifndef RTL_USES_UTC
11278 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
11279 when = whenutc - offset; /* pseudolocal time*/
11282 /* CRTL localtime() wants local time as input, so does no tz correction */
11283 rsltmp = localtime(&when);
11284 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11288 } /* end of my_localtime() */
11291 /* Reset definitions for later calls */
11292 #define gmtime(t) my_gmtime(t)
11293 #define localtime(t) my_localtime(t)
11294 #define time(t) my_time(t)
11297 /* my_utime - update modification/access time of a file
11299 * VMS 7.3 and later implementation
11300 * Only the UTC translation is home-grown. The rest is handled by the
11301 * CRTL utime(), which will take into account the relevant feature
11302 * logicals and ODS-5 volume characteristics for true access times.
11304 * pre VMS 7.3 implementation:
11305 * The calling sequence is identical to POSIX utime(), but under
11306 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11307 * not maintain access times. Restrictions differ from the POSIX
11308 * definition in that the time can be changed as long as the
11309 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11310 * no separate checks are made to insure that the caller is the
11311 * owner of the file or has special privs enabled.
11312 * Code here is based on Joe Meadows' FILE utility.
11316 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11317 * to VMS epoch (01-JAN-1858 00:00:00.00)
11318 * in 100 ns intervals.
11320 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11322 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11323 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11325 #if __CRTL_VER >= 70300000
11326 struct utimbuf utc_utimes, *utc_utimesp;
11328 if (utimes != NULL) {
11329 utc_utimes.actime = utimes->actime;
11330 utc_utimes.modtime = utimes->modtime;
11331 # ifdef VMSISH_TIME
11332 /* If input was local; convert to UTC for sys svc */
11334 utc_utimes.actime = _toutc(utimes->actime);
11335 utc_utimes.modtime = _toutc(utimes->modtime);
11338 utc_utimesp = &utc_utimes;
11341 utc_utimesp = NULL;
11344 return utime(file, utc_utimesp);
11346 #else /* __CRTL_VER < 70300000 */
11350 long int bintime[2], len = 2, lowbit, unixtime,
11351 secscale = 10000000; /* seconds --> 100 ns intervals */
11352 unsigned long int chan, iosb[2], retsts;
11353 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11354 struct FAB myfab = cc$rms_fab;
11355 struct NAM mynam = cc$rms_nam;
11356 #if defined (__DECC) && defined (__VAX)
11357 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11358 * at least through VMS V6.1, which causes a type-conversion warning.
11360 # pragma message save
11361 # pragma message disable cvtdiftypes
11363 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11364 struct fibdef myfib;
11365 #if defined (__DECC) && defined (__VAX)
11366 /* This should be right after the declaration of myatr, but due
11367 * to a bug in VAX DEC C, this takes effect a statement early.
11369 # pragma message restore
11371 /* cast ok for read only parameter */
11372 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11373 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11374 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11376 if (file == NULL || *file == '\0') {
11377 SETERRNO(ENOENT, LIB$_INVARG);
11381 /* Convert to VMS format ensuring that it will fit in 255 characters */
11382 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11383 SETERRNO(ENOENT, LIB$_INVARG);
11386 if (utimes != NULL) {
11387 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11388 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11389 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11390 * as input, we force the sign bit to be clear by shifting unixtime right
11391 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11393 lowbit = (utimes->modtime & 1) ? secscale : 0;
11394 unixtime = (long int) utimes->modtime;
11395 # ifdef VMSISH_TIME
11396 /* If input was UTC; convert to local for sys svc */
11397 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11399 unixtime >>= 1; secscale <<= 1;
11400 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11401 if (!(retsts & 1)) {
11402 SETERRNO(EVMSERR, retsts);
11405 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11406 if (!(retsts & 1)) {
11407 SETERRNO(EVMSERR, retsts);
11412 /* Just get the current time in VMS format directly */
11413 retsts = sys$gettim(bintime);
11414 if (!(retsts & 1)) {
11415 SETERRNO(EVMSERR, retsts);
11420 myfab.fab$l_fna = vmsspec;
11421 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11422 myfab.fab$l_nam = &mynam;
11423 mynam.nam$l_esa = esa;
11424 mynam.nam$b_ess = (unsigned char) sizeof esa;
11425 mynam.nam$l_rsa = rsa;
11426 mynam.nam$b_rss = (unsigned char) sizeof rsa;
11427 if (decc_efs_case_preserve)
11428 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11430 /* Look for the file to be affected, letting RMS parse the file
11431 * specification for us as well. I have set errno using only
11432 * values documented in the utime() man page for VMS POSIX.
11434 retsts = sys$parse(&myfab,0,0);
11435 if (!(retsts & 1)) {
11436 set_vaxc_errno(retsts);
11437 if (retsts == RMS$_PRV) set_errno(EACCES);
11438 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11439 else set_errno(EVMSERR);
11442 retsts = sys$search(&myfab,0,0);
11443 if (!(retsts & 1)) {
11444 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11445 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11446 set_vaxc_errno(retsts);
11447 if (retsts == RMS$_PRV) set_errno(EACCES);
11448 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11449 else set_errno(EVMSERR);
11453 devdsc.dsc$w_length = mynam.nam$b_dev;
11454 /* cast ok for read only parameter */
11455 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11457 retsts = sys$assign(&devdsc,&chan,0,0);
11458 if (!(retsts & 1)) {
11459 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11460 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11461 set_vaxc_errno(retsts);
11462 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11463 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11464 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11465 else set_errno(EVMSERR);
11469 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11470 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11472 memset((void *) &myfib, 0, sizeof myfib);
11473 #if defined(__DECC) || defined(__DECCXX)
11474 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11475 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11476 /* This prevents the revision time of the file being reset to the current
11477 * time as a result of our IO$_MODIFY $QIO. */
11478 myfib.fib$l_acctl = FIB$M_NORECORD;
11480 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11481 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11482 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11484 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11485 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11486 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11487 _ckvmssts(sys$dassgn(chan));
11488 if (retsts & 1) retsts = iosb[0];
11489 if (!(retsts & 1)) {
11490 set_vaxc_errno(retsts);
11491 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11492 else set_errno(EVMSERR);
11498 #endif /* #if __CRTL_VER >= 70300000 */
11500 } /* end of my_utime() */
11504 * flex_stat, flex_lstat, flex_fstat
11505 * basic stat, but gets it right when asked to stat
11506 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11509 #ifndef _USE_STD_STAT
11510 /* encode_dev packs a VMS device name string into an integer to allow
11511 * simple comparisons. This can be used, for example, to check whether two
11512 * files are located on the same device, by comparing their encoded device
11513 * names. Even a string comparison would not do, because stat() reuses the
11514 * device name buffer for each call; so without encode_dev, it would be
11515 * necessary to save the buffer and use strcmp (this would mean a number of
11516 * changes to the standard Perl code, to say nothing of what a Perl script
11517 * would have to do.
11519 * The device lock id, if it exists, should be unique (unless perhaps compared
11520 * with lock ids transferred from other nodes). We have a lock id if the disk is
11521 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11522 * device names. Thus we use the lock id in preference, and only if that isn't
11523 * available, do we try to pack the device name into an integer (flagged by
11524 * the sign bit (LOCKID_MASK) being set).
11526 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11527 * name and its encoded form, but it seems very unlikely that we will find
11528 * two files on different disks that share the same encoded device names,
11529 * and even more remote that they will share the same file id (if the test
11530 * is to check for the same file).
11532 * A better method might be to use sys$device_scan on the first call, and to
11533 * search for the device, returning an index into the cached array.
11534 * The number returned would be more intelligible.
11535 * This is probably not worth it, and anyway would take quite a bit longer
11536 * on the first call.
11538 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11539 static mydev_t encode_dev (pTHX_ const char *dev)
11542 unsigned long int f;
11547 if (!dev || !dev[0]) return 0;
11551 struct dsc$descriptor_s dev_desc;
11552 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11554 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11555 can try that first. */
11556 dev_desc.dsc$w_length = strlen (dev);
11557 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11558 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11559 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11560 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11561 if (!$VMS_STATUS_SUCCESS(status)) {
11563 case SS$_NOSUCHDEV:
11564 SETERRNO(ENODEV, status);
11570 if (lockid) return (lockid & ~LOCKID_MASK);
11574 /* Otherwise we try to encode the device name */
11578 for (q = dev + strlen(dev); q--; q >= dev) {
11583 else if (isalpha (toupper (*q)))
11584 c= toupper (*q) - 'A' + (char)10;
11586 continue; /* Skip '$'s */
11588 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11590 enc += f * (unsigned long int) c;
11592 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11594 } /* end of encode_dev() */
11595 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11596 device_no = encode_dev(aTHX_ devname)
11598 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11599 device_no = new_dev_no
11603 is_null_device(name)
11606 if (decc_bug_devnull != 0) {
11607 if (strncmp("/dev/null", name, 9) == 0)
11610 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11611 The underscore prefix, controller letter, and unit number are
11612 independently optional; for our purposes, the colon punctuation
11613 is not. The colon can be trailed by optional directory and/or
11614 filename, but two consecutive colons indicates a nodename rather
11615 than a device. [pr] */
11616 if (*name == '_') ++name;
11617 if (tolower(*name++) != 'n') return 0;
11618 if (tolower(*name++) != 'l') return 0;
11619 if (tolower(*name) == 'a') ++name;
11620 if (*name == '0') ++name;
11621 return (*name++ == ':') && (*name != ':');
11626 Perl_cando_by_name_int
11627 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11629 char usrname[L_cuserid];
11630 struct dsc$descriptor_s usrdsc =
11631 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11632 char *vmsname = NULL, *fileified = NULL;
11633 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11634 unsigned short int retlen, trnlnm_iter_count;
11635 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11636 union prvdef curprv;
11637 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11638 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11639 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11640 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11641 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11643 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11645 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11647 static int profile_context = -1;
11649 if (!fname || !*fname) return FALSE;
11651 /* Make sure we expand logical names, since sys$check_access doesn't */
11652 fileified = PerlMem_malloc(VMS_MAXRSS);
11653 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11654 if (!strpbrk(fname,"/]>:")) {
11655 strcpy(fileified,fname);
11656 trnlnm_iter_count = 0;
11657 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11658 trnlnm_iter_count++;
11659 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11664 vmsname = PerlMem_malloc(VMS_MAXRSS);
11665 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11666 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11667 /* Don't know if already in VMS format, so make sure */
11668 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11669 PerlMem_free(fileified);
11670 PerlMem_free(vmsname);
11675 strcpy(vmsname,fname);
11678 /* sys$check_access needs a file spec, not a directory spec.
11679 * Don't use flex_stat here, as that depends on thread context
11680 * having been initialized, and we may get here during startup.
11683 retlen = namdsc.dsc$w_length = strlen(vmsname);
11684 if (vmsname[retlen-1] == ']'
11685 || vmsname[retlen-1] == '>'
11686 || vmsname[retlen-1] == ':'
11687 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11689 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11690 PerlMem_free(fileified);
11691 PerlMem_free(vmsname);
11700 retlen = namdsc.dsc$w_length = strlen(fname);
11701 namdsc.dsc$a_pointer = (char *)fname;
11704 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11705 access = ARM$M_EXECUTE;
11706 flags = CHP$M_READ;
11708 case S_IRUSR: case S_IRGRP: case S_IROTH:
11709 access = ARM$M_READ;
11710 flags = CHP$M_READ | CHP$M_USEREADALL;
11712 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11713 access = ARM$M_WRITE;
11714 flags = CHP$M_READ | CHP$M_WRITE;
11716 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11717 access = ARM$M_DELETE;
11718 flags = CHP$M_READ | CHP$M_WRITE;
11721 if (fileified != NULL)
11722 PerlMem_free(fileified);
11723 if (vmsname != NULL)
11724 PerlMem_free(vmsname);
11728 /* Before we call $check_access, create a user profile with the current
11729 * process privs since otherwise it just uses the default privs from the
11730 * UAF and might give false positives or negatives. This only works on
11731 * VMS versions v6.0 and later since that's when sys$create_user_profile
11732 * became available.
11735 /* get current process privs and username */
11736 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11737 _ckvmssts(iosb[0]);
11739 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11741 /* find out the space required for the profile */
11742 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11743 &usrprodsc.dsc$w_length,&profile_context));
11745 /* allocate space for the profile and get it filled in */
11746 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11747 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11748 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11749 &usrprodsc.dsc$w_length,&profile_context));
11751 /* use the profile to check access to the file; free profile & analyze results */
11752 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11753 PerlMem_free(usrprodsc.dsc$a_pointer);
11754 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11758 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11762 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11763 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11764 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11765 set_vaxc_errno(retsts);
11766 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11767 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11768 else set_errno(ENOENT);
11769 if (fileified != NULL)
11770 PerlMem_free(fileified);
11771 if (vmsname != NULL)
11772 PerlMem_free(vmsname);
11775 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11776 if (fileified != NULL)
11777 PerlMem_free(fileified);
11778 if (vmsname != NULL)
11779 PerlMem_free(vmsname);
11784 if (fileified != NULL)
11785 PerlMem_free(fileified);
11786 if (vmsname != NULL)
11787 PerlMem_free(vmsname);
11788 return FALSE; /* Should never get here */
11792 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11793 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11794 * subset of the applicable information.
11797 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11799 return cando_by_name_int
11800 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11801 } /* end of cando() */
11805 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11807 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11809 return cando_by_name_int(bit, effective, fname, 0);
11811 } /* end of cando_by_name() */
11815 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11817 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11819 if (!fstat(fd,(stat_t *) statbufp)) {
11821 char *vms_filename;
11822 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11823 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11825 /* Save name for cando by name in VMS format */
11826 cptr = getname(fd, vms_filename, 1);
11828 /* This should not happen, but just in case */
11829 if (cptr == NULL) {
11830 statbufp->st_devnam[0] = 0;
11833 /* Make sure that the saved name fits in 255 characters */
11834 cptr = do_rmsexpand
11836 statbufp->st_devnam,
11839 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11843 statbufp->st_devnam[0] = 0;
11845 PerlMem_free(vms_filename);
11847 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11849 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11851 # ifdef RTL_USES_UTC
11852 # ifdef VMSISH_TIME
11854 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11855 statbufp->st_atime = _toloc(statbufp->st_atime);
11856 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11860 # ifdef VMSISH_TIME
11861 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11865 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11866 statbufp->st_atime = _toutc(statbufp->st_atime);
11867 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11874 } /* end of flex_fstat() */
11877 #if !defined(__VAX) && __CRTL_VER >= 80200000
11885 #define lstat(_x, _y) stat(_x, _y)
11888 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11891 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11893 char fileified[VMS_MAXRSS];
11894 char temp_fspec[VMS_MAXRSS];
11897 int saved_errno, saved_vaxc_errno;
11899 if (!fspec) return retval;
11900 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11901 strcpy(temp_fspec, fspec);
11903 if (decc_bug_devnull != 0) {
11904 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11905 memset(statbufp,0,sizeof *statbufp);
11906 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11907 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11908 statbufp->st_uid = 0x00010001;
11909 statbufp->st_gid = 0x0001;
11910 time((time_t *)&statbufp->st_mtime);
11911 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11916 /* Try for a directory name first. If fspec contains a filename without
11917 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11918 * and sea:[wine.dark]water. exist, we prefer the directory here.
11919 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11920 * not sea:[wine.dark]., if the latter exists. If the intended target is
11921 * the file with null type, specify this by calling flex_stat() with
11922 * a '.' at the end of fspec.
11924 * If we are in Posix filespec mode, accept the filename as is.
11928 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11929 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11930 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11932 if (!decc_efs_charset)
11933 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11936 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11937 if (decc_posix_compliant_pathnames == 0) {
11939 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11940 if (lstat_flag == 0)
11941 retval = stat(fileified,(stat_t *) statbufp);
11943 retval = lstat(fileified,(stat_t *) statbufp);
11944 save_spec = fileified;
11947 if (lstat_flag == 0)
11948 retval = stat(temp_fspec,(stat_t *) statbufp);
11950 retval = lstat(temp_fspec,(stat_t *) statbufp);
11951 save_spec = temp_fspec;
11954 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11955 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11956 * and lstat was working correctly for the same file.
11957 * The only syntax that was working for stat was "foo:[bar]t.dir".
11959 * Other directories with the same syntax worked fine.
11960 * So work around the problem when it shows up here.
11963 int save_errno = errno;
11964 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11965 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11966 retval = stat(fileified, (stat_t *) statbufp);
11967 save_spec = fileified;
11970 /* Restore the errno value if third stat does not succeed */
11972 errno = save_errno;
11974 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11976 if (lstat_flag == 0)
11977 retval = stat(temp_fspec,(stat_t *) statbufp);
11979 retval = lstat(temp_fspec,(stat_t *) statbufp);
11980 save_spec = temp_fspec;
11984 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11985 /* As you were... */
11986 if (!decc_efs_charset)
11987 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11992 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11994 /* If this is an lstat, do not follow the link */
11996 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11998 cptr = do_rmsexpand
11999 (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
12001 statbufp->st_devnam[0] = 0;
12003 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12005 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12006 # ifdef RTL_USES_UTC
12007 # ifdef VMSISH_TIME
12009 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12010 statbufp->st_atime = _toloc(statbufp->st_atime);
12011 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12015 # ifdef VMSISH_TIME
12016 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12020 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12021 statbufp->st_atime = _toutc(statbufp->st_atime);
12022 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12026 /* If we were successful, leave errno where we found it */
12027 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12030 } /* end of flex_stat_int() */
12033 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12035 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12037 return flex_stat_int(fspec, statbufp, 0);
12041 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12043 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12045 return flex_stat_int(fspec, statbufp, 1);
12050 /*{{{char *my_getlogin()*/
12051 /* VMS cuserid == Unix getlogin, except calling sequence */
12055 static char user[L_cuserid];
12056 return cuserid(user);
12061 /* rmscopy - copy a file using VMS RMS routines
12063 * Copies contents and attributes of spec_in to spec_out, except owner
12064 * and protection information. Name and type of spec_in are used as
12065 * defaults for spec_out. The third parameter specifies whether rmscopy()
12066 * should try to propagate timestamps from the input file to the output file.
12067 * If it is less than 0, no timestamps are preserved. If it is 0, then
12068 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12069 * propagated to the output file at creation iff the output file specification
12070 * did not contain an explicit name or type, and the revision date is always
12071 * updated at the end of the copy operation. If it is greater than 0, then
12072 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12073 * other than the revision date should be propagated, and bit 1 indicates
12074 * that the revision date should be propagated.
12076 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12078 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12079 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12080 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12081 * as part of the Perl standard distribution under the terms of the
12082 * GNU General Public License or the Perl Artistic License. Copies
12083 * of each may be found in the Perl standard distribution.
12085 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12087 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12089 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12090 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12091 unsigned long int i, sts, sts2;
12093 struct FAB fab_in, fab_out;
12094 struct RAB rab_in, rab_out;
12095 rms_setup_nam(nam);
12096 rms_setup_nam(nam_out);
12097 struct XABDAT xabdat;
12098 struct XABFHC xabfhc;
12099 struct XABRDT xabrdt;
12100 struct XABSUM xabsum;
12102 vmsin = PerlMem_malloc(VMS_MAXRSS);
12103 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12104 vmsout = PerlMem_malloc(VMS_MAXRSS);
12105 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12106 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12107 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12108 PerlMem_free(vmsin);
12109 PerlMem_free(vmsout);
12110 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12114 esa = PerlMem_malloc(VMS_MAXRSS);
12115 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12117 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12118 esal = PerlMem_malloc(VMS_MAXRSS);
12119 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12121 fab_in = cc$rms_fab;
12122 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12123 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12124 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12125 fab_in.fab$l_fop = FAB$M_SQO;
12126 rms_bind_fab_nam(fab_in, nam);
12127 fab_in.fab$l_xab = (void *) &xabdat;
12129 rsa = PerlMem_malloc(VMS_MAXRSS);
12130 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12132 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12133 rsal = PerlMem_malloc(VMS_MAXRSS);
12134 if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12136 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12137 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12138 rms_nam_esl(nam) = 0;
12139 rms_nam_rsl(nam) = 0;
12140 rms_nam_esll(nam) = 0;
12141 rms_nam_rsll(nam) = 0;
12142 #ifdef NAM$M_NO_SHORT_UPCASE
12143 if (decc_efs_case_preserve)
12144 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12147 xabdat = cc$rms_xabdat; /* To get creation date */
12148 xabdat.xab$l_nxt = (void *) &xabfhc;
12150 xabfhc = cc$rms_xabfhc; /* To get record length */
12151 xabfhc.xab$l_nxt = (void *) &xabsum;
12153 xabsum = cc$rms_xabsum; /* To get key and area information */
12155 if (!((sts = sys$open(&fab_in)) & 1)) {
12156 PerlMem_free(vmsin);
12157 PerlMem_free(vmsout);
12160 PerlMem_free(esal);
12163 PerlMem_free(rsal);
12164 set_vaxc_errno(sts);
12166 case RMS$_FNF: case RMS$_DNF:
12167 set_errno(ENOENT); break;
12169 set_errno(ENOTDIR); break;
12171 set_errno(ENODEV); break;
12173 set_errno(EINVAL); break;
12175 set_errno(EACCES); break;
12177 set_errno(EVMSERR);
12184 fab_out.fab$w_ifi = 0;
12185 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12186 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12187 fab_out.fab$l_fop = FAB$M_SQO;
12188 rms_bind_fab_nam(fab_out, nam_out);
12189 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12190 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12191 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12192 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12193 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12194 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12195 if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12198 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12199 esal_out = PerlMem_malloc(VMS_MAXRSS);
12200 if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12201 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12202 if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12204 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12205 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12207 if (preserve_dates == 0) { /* Act like DCL COPY */
12208 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12209 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12210 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12211 PerlMem_free(vmsin);
12212 PerlMem_free(vmsout);
12215 PerlMem_free(esal);
12218 PerlMem_free(rsal);
12219 PerlMem_free(esa_out);
12220 if (esal_out != NULL)
12221 PerlMem_free(esal_out);
12222 PerlMem_free(rsa_out);
12223 if (rsal_out != NULL)
12224 PerlMem_free(rsal_out);
12225 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12226 set_vaxc_errno(sts);
12229 fab_out.fab$l_xab = (void *) &xabdat;
12230 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12231 preserve_dates = 1;
12233 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12234 preserve_dates =0; /* bitmask from this point forward */
12236 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12237 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12238 PerlMem_free(vmsin);
12239 PerlMem_free(vmsout);
12242 PerlMem_free(esal);
12245 PerlMem_free(rsal);
12246 PerlMem_free(esa_out);
12247 if (esal_out != NULL)
12248 PerlMem_free(esal_out);
12249 PerlMem_free(rsa_out);
12250 if (rsal_out != NULL)
12251 PerlMem_free(rsal_out);
12252 set_vaxc_errno(sts);
12255 set_errno(ENOENT); break;
12257 set_errno(ENOTDIR); break;
12259 set_errno(ENODEV); break;
12261 set_errno(EINVAL); break;
12263 set_errno(EACCES); break;
12265 set_errno(EVMSERR);
12269 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12270 if (preserve_dates & 2) {
12271 /* sys$close() will process xabrdt, not xabdat */
12272 xabrdt = cc$rms_xabrdt;
12274 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12276 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12277 * is unsigned long[2], while DECC & VAXC use a struct */
12278 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12280 fab_out.fab$l_xab = (void *) &xabrdt;
12283 ubf = PerlMem_malloc(32256);
12284 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12285 rab_in = cc$rms_rab;
12286 rab_in.rab$l_fab = &fab_in;
12287 rab_in.rab$l_rop = RAB$M_BIO;
12288 rab_in.rab$l_ubf = ubf;
12289 rab_in.rab$w_usz = 32256;
12290 if (!((sts = sys$connect(&rab_in)) & 1)) {
12291 sys$close(&fab_in); sys$close(&fab_out);
12292 PerlMem_free(vmsin);
12293 PerlMem_free(vmsout);
12297 PerlMem_free(esal);
12300 PerlMem_free(rsal);
12301 PerlMem_free(esa_out);
12302 if (esal_out != NULL)
12303 PerlMem_free(esal_out);
12304 PerlMem_free(rsa_out);
12305 if (rsal_out != NULL)
12306 PerlMem_free(rsal_out);
12307 set_errno(EVMSERR); set_vaxc_errno(sts);
12311 rab_out = cc$rms_rab;
12312 rab_out.rab$l_fab = &fab_out;
12313 rab_out.rab$l_rbf = ubf;
12314 if (!((sts = sys$connect(&rab_out)) & 1)) {
12315 sys$close(&fab_in); sys$close(&fab_out);
12316 PerlMem_free(vmsin);
12317 PerlMem_free(vmsout);
12321 PerlMem_free(esal);
12324 PerlMem_free(rsal);
12325 PerlMem_free(esa_out);
12326 if (esal_out != NULL)
12327 PerlMem_free(esal_out);
12328 PerlMem_free(rsa_out);
12329 if (rsal_out != NULL)
12330 PerlMem_free(rsal_out);
12331 set_errno(EVMSERR); set_vaxc_errno(sts);
12335 while ((sts = sys$read(&rab_in))) { /* always true */
12336 if (sts == RMS$_EOF) break;
12337 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12338 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12339 sys$close(&fab_in); sys$close(&fab_out);
12340 PerlMem_free(vmsin);
12341 PerlMem_free(vmsout);
12345 PerlMem_free(esal);
12348 PerlMem_free(rsal);
12349 PerlMem_free(esa_out);
12350 if (esal_out != NULL)
12351 PerlMem_free(esal_out);
12352 PerlMem_free(rsa_out);
12353 if (rsal_out != NULL)
12354 PerlMem_free(rsal_out);
12355 set_errno(EVMSERR); set_vaxc_errno(sts);
12361 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12362 sys$close(&fab_in); sys$close(&fab_out);
12363 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12365 PerlMem_free(vmsin);
12366 PerlMem_free(vmsout);
12370 PerlMem_free(esal);
12373 PerlMem_free(rsal);
12374 PerlMem_free(esa_out);
12375 if (esal_out != NULL)
12376 PerlMem_free(esal_out);
12377 PerlMem_free(rsa_out);
12378 if (rsal_out != NULL)
12379 PerlMem_free(rsal_out);
12382 set_errno(EVMSERR); set_vaxc_errno(sts);
12388 } /* end of rmscopy() */
12392 /*** The following glue provides 'hooks' to make some of the routines
12393 * from this file available from Perl. These routines are sufficiently
12394 * basic, and are required sufficiently early in the build process,
12395 * that's it's nice to have them available to miniperl as well as the
12396 * full Perl, so they're set up here instead of in an extension. The
12397 * Perl code which handles importation of these names into a given
12398 * package lives in [.VMS]Filespec.pm in @INC.
12402 rmsexpand_fromperl(pTHX_ CV *cv)
12405 char *fspec, *defspec = NULL, *rslt;
12407 int fs_utf8, dfs_utf8;
12411 if (!items || items > 2)
12412 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12413 fspec = SvPV(ST(0),n_a);
12414 fs_utf8 = SvUTF8(ST(0));
12415 if (!fspec || !*fspec) XSRETURN_UNDEF;
12417 defspec = SvPV(ST(1),n_a);
12418 dfs_utf8 = SvUTF8(ST(1));
12420 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12421 ST(0) = sv_newmortal();
12422 if (rslt != NULL) {
12423 sv_usepvn(ST(0),rslt,strlen(rslt));
12432 vmsify_fromperl(pTHX_ CV *cv)
12439 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12440 utf8_fl = SvUTF8(ST(0));
12441 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12442 ST(0) = sv_newmortal();
12443 if (vmsified != NULL) {
12444 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12453 unixify_fromperl(pTHX_ CV *cv)
12460 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12461 utf8_fl = SvUTF8(ST(0));
12462 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12463 ST(0) = sv_newmortal();
12464 if (unixified != NULL) {
12465 sv_usepvn(ST(0),unixified,strlen(unixified));
12474 fileify_fromperl(pTHX_ CV *cv)
12481 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12482 utf8_fl = SvUTF8(ST(0));
12483 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12484 ST(0) = sv_newmortal();
12485 if (fileified != NULL) {
12486 sv_usepvn(ST(0),fileified,strlen(fileified));
12495 pathify_fromperl(pTHX_ CV *cv)
12502 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12503 utf8_fl = SvUTF8(ST(0));
12504 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12505 ST(0) = sv_newmortal();
12506 if (pathified != NULL) {
12507 sv_usepvn(ST(0),pathified,strlen(pathified));
12516 vmspath_fromperl(pTHX_ CV *cv)
12523 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12524 utf8_fl = SvUTF8(ST(0));
12525 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12526 ST(0) = sv_newmortal();
12527 if (vmspath != NULL) {
12528 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12537 unixpath_fromperl(pTHX_ CV *cv)
12544 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12545 utf8_fl = SvUTF8(ST(0));
12546 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12547 ST(0) = sv_newmortal();
12548 if (unixpath != NULL) {
12549 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12558 candelete_fromperl(pTHX_ CV *cv)
12566 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12568 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12569 Newx(fspec, VMS_MAXRSS, char);
12570 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12571 if (SvTYPE(mysv) == SVt_PVGV) {
12572 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12573 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12581 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12582 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12589 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12595 rmscopy_fromperl(pTHX_ CV *cv)
12598 char *inspec, *outspec, *inp, *outp;
12600 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12601 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12602 unsigned long int sts;
12607 if (items < 2 || items > 3)
12608 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12610 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12611 Newx(inspec, VMS_MAXRSS, char);
12612 if (SvTYPE(mysv) == SVt_PVGV) {
12613 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12614 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12622 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12623 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12629 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12630 Newx(outspec, VMS_MAXRSS, char);
12631 if (SvTYPE(mysv) == SVt_PVGV) {
12632 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12633 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12642 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12643 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12650 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12652 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12658 /* The mod2fname is limited to shorter filenames by design, so it should
12659 * not be modified to support longer EFS pathnames
12662 mod2fname(pTHX_ CV *cv)
12665 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12666 workbuff[NAM$C_MAXRSS*1 + 1];
12667 int total_namelen = 3, counter, num_entries;
12668 /* ODS-5 ups this, but we want to be consistent, so... */
12669 int max_name_len = 39;
12670 AV *in_array = (AV *)SvRV(ST(0));
12672 num_entries = av_len(in_array);
12674 /* All the names start with PL_. */
12675 strcpy(ultimate_name, "PL_");
12677 /* Clean up our working buffer */
12678 Zero(work_name, sizeof(work_name), char);
12680 /* Run through the entries and build up a working name */
12681 for(counter = 0; counter <= num_entries; counter++) {
12682 /* If it's not the first name then tack on a __ */
12684 strcat(work_name, "__");
12686 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
12689 /* Check to see if we actually have to bother...*/
12690 if (strlen(work_name) + 3 <= max_name_len) {
12691 strcat(ultimate_name, work_name);
12693 /* It's too darned big, so we need to go strip. We use the same */
12694 /* algorithm as xsubpp does. First, strip out doubled __ */
12695 char *source, *dest, last;
12698 for (source = work_name; *source; source++) {
12699 if (last == *source && last == '_') {
12705 /* Go put it back */
12706 strcpy(work_name, workbuff);
12707 /* Is it still too big? */
12708 if (strlen(work_name) + 3 > max_name_len) {
12709 /* Strip duplicate letters */
12712 for (source = work_name; *source; source++) {
12713 if (last == toupper(*source)) {
12717 last = toupper(*source);
12719 strcpy(work_name, workbuff);
12722 /* Is it *still* too big? */
12723 if (strlen(work_name) + 3 > max_name_len) {
12724 /* Too bad, we truncate */
12725 work_name[max_name_len - 2] = 0;
12727 strcat(ultimate_name, work_name);
12730 /* Okay, return it */
12731 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12736 hushexit_fromperl(pTHX_ CV *cv)
12741 VMSISH_HUSHED = SvTRUE(ST(0));
12743 ST(0) = boolSV(VMSISH_HUSHED);
12749 Perl_vms_start_glob
12750 (pTHX_ SV *tmpglob,
12754 struct vs_str_st *rslt;
12758 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12761 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12762 struct dsc$descriptor_vs rsdsc;
12763 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12764 unsigned long hasver = 0, isunix = 0;
12765 unsigned long int lff_flags = 0;
12768 #ifdef VMS_LONGNAME_SUPPORT
12769 lff_flags = LIB$M_FIL_LONG_NAMES;
12771 /* The Newx macro will not allow me to assign a smaller array
12772 * to the rslt pointer, so we will assign it to the begin char pointer
12773 * and then copy the value into the rslt pointer.
12775 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12776 rslt = (struct vs_str_st *)begin;
12778 rstr = &rslt->str[0];
12779 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12780 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12781 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12782 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12784 Newx(vmsspec, VMS_MAXRSS, char);
12786 /* We could find out if there's an explicit dev/dir or version
12787 by peeking into lib$find_file's internal context at
12788 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12789 but that's unsupported, so I don't want to do it now and
12790 have it bite someone in the future. */
12791 /* Fix-me: vms_split_path() is the only way to do this, the
12792 existing method will fail with many legal EFS or UNIX specifications
12795 cp = SvPV(tmpglob,i);
12798 if (cp[i] == ';') hasver = 1;
12799 if (cp[i] == '.') {
12800 if (sts) hasver = 1;
12803 if (cp[i] == '/') {
12804 hasdir = isunix = 1;
12807 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12812 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12816 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12817 if (!stat_sts && S_ISDIR(st.st_mode)) {
12818 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12819 ok = (wilddsc.dsc$a_pointer != NULL);
12820 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12824 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12825 ok = (wilddsc.dsc$a_pointer != NULL);
12828 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12830 /* If not extended character set, replace ? with % */
12831 /* With extended character set, ? is a wildcard single character */
12832 if (!decc_efs_case_preserve) {
12833 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12834 if (*cp == '?') *cp = '%';
12837 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12838 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12839 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12841 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12842 &dfltdsc,NULL,&rms_sts,&lff_flags);
12843 if (!$VMS_STATUS_SUCCESS(sts))
12848 /* with varying string, 1st word of buffer contains result length */
12849 rstr[rslt->length] = '\0';
12851 /* Find where all the components are */
12852 v_sts = vms_split_path
12867 /* If no version on input, truncate the version on output */
12868 if (!hasver && (vs_len > 0)) {
12872 /* No version & a null extension on UNIX handling */
12873 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12879 if (!decc_efs_case_preserve) {
12880 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12884 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12888 /* Start with the name */
12891 strcat(begin,"\n");
12892 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12894 if (cxt) (void)lib$find_file_end(&cxt);
12897 /* Be POSIXish: return the input pattern when no matches */
12898 strcpy(rstr,SvPVX(tmpglob));
12900 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12903 if (ok && sts != RMS$_NMF &&
12904 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12907 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12909 PerlIO_close(tmpfp);
12913 PerlIO_rewind(tmpfp);
12914 IoTYPE(io) = IoTYPE_RDONLY;
12915 IoIFP(io) = fp = tmpfp;
12916 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12926 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12930 unixrealpath_fromperl(pTHX_ CV *cv)
12933 char *fspec, *rslt_spec, *rslt;
12936 if (!items || items != 1)
12937 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
12939 fspec = SvPV(ST(0),n_a);
12940 if (!fspec || !*fspec) XSRETURN_UNDEF;
12942 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12943 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12945 ST(0) = sv_newmortal();
12947 sv_usepvn(ST(0),rslt,strlen(rslt));
12949 Safefree(rslt_spec);
12954 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12958 vmsrealpath_fromperl(pTHX_ CV *cv)
12961 char *fspec, *rslt_spec, *rslt;
12964 if (!items || items != 1)
12965 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
12967 fspec = SvPV(ST(0),n_a);
12968 if (!fspec || !*fspec) XSRETURN_UNDEF;
12970 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12971 rslt = do_vms_realname(fspec, rslt_spec, NULL);
12973 ST(0) = sv_newmortal();
12975 sv_usepvn(ST(0),rslt,strlen(rslt));
12977 Safefree(rslt_spec);
12983 * A thin wrapper around decc$symlink to make sure we follow the
12984 * standard and do not create a symlink with a zero-length name.
12986 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12987 int my_symlink(const char *path1, const char *path2) {
12988 if (!path2 || !*path2) {
12989 SETERRNO(ENOENT, SS$_NOSUCHFILE);
12992 return symlink(path1, path2);
12996 #endif /* HAS_SYMLINK */
12998 int do_vms_case_tolerant(void);
13001 case_tolerant_process_fromperl(pTHX_ CV *cv)
13004 ST(0) = boolSV(do_vms_case_tolerant());
13008 #ifdef USE_ITHREADS
13011 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13012 struct interp_intern *dst)
13014 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13016 memcpy(dst,src,sizeof(struct interp_intern));
13022 Perl_sys_intern_clear(pTHX)
13027 Perl_sys_intern_init(pTHX)
13029 unsigned int ix = RAND_MAX;
13034 /* fix me later to track running under GNV */
13035 /* this allows some limited testing */
13036 MY_POSIX_EXIT = decc_filename_unix_report;
13039 MY_INV_RAND_MAX = 1./x;
13043 init_os_extras(void)
13046 char* file = __FILE__;
13047 if (decc_disable_to_vms_logname_translation) {
13048 no_translate_barewords = TRUE;
13050 no_translate_barewords = FALSE;
13053 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13054 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13055 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13056 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13057 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13058 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13059 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13060 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13061 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13062 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13063 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13064 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13065 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13066 newXSproto("VMS::Filespec::case_tolerant_process",
13067 case_tolerant_process_fromperl,file,"");
13069 store_pipelocs(aTHX); /* will redo any earlier attempts */
13074 #if __CRTL_VER == 80200000
13075 /* This missed getting in to the DECC SDK for 8.2 */
13076 char *realpath(const char *file_name, char * resolved_name, ...);
13079 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13080 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13081 * The perl fallback routine to provide realpath() is not as efficient
13085 /* Hack, use old stat() as fastest way of getting ino_t and device */
13086 int decc$stat(const char *name, void * statbuf);
13089 /* Realpath is fragile. In 8.3 it does not work if the feature
13090 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13091 * links are implemented in RMS, not the CRTL. It also can fail if the
13092 * user does not have read/execute access to some of the directories.
13093 * So in order for Do What I Mean mode to work, if realpath() fails,
13094 * fall back to looking up the filename by the device name and FID.
13097 int vms_fid_to_name(char * outname, int outlen, const char * name)
13101 unsigned short st_ino[3];
13102 unsigned short padw;
13103 unsigned long padl[30]; /* plenty of room */
13106 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13107 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13109 sts = decc$stat(name, &statbuf);
13112 dvidsc.dsc$a_pointer=statbuf.st_dev;
13113 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13115 specdsc.dsc$a_pointer = outname;
13116 specdsc.dsc$w_length = outlen-1;
13118 sts = lib$fid_to_name
13119 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13120 if ($VMS_STATUS_SUCCESS(sts)) {
13121 outname[specdsc.dsc$w_length] = 0;
13131 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13134 char * rslt = NULL;
13137 if (decc_posix_compliant_pathnames > 0 ) {
13138 /* realpath currently only works if posix compliant pathnames are
13139 * enabled. It may start working when they are not, but in that
13140 * case we still want the fallback behavior for backwards compatibility
13142 rslt = realpath(filespec, outbuf);
13146 if (rslt == NULL) {
13148 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13149 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13152 /* Fall back to fid_to_name */
13154 Newx(vms_spec, VMS_MAXRSS + 1, char);
13156 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13160 /* Now need to trim the version off */
13161 sts = vms_split_path
13181 /* Trim off the version */
13182 int file_len = v_len + r_len + d_len + n_len + e_len;
13183 vms_spec[file_len] = 0;
13185 /* The result is expected to be in UNIX format */
13186 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13188 /* Downcase if input had any lower case letters and
13189 * case preservation is not in effect.
13191 if (!decc_efs_case_preserve) {
13192 for (cp = filespec; *cp; cp++)
13193 if (islower(*cp)) { haslower = 1; break; }
13195 if (haslower) __mystrtolower(rslt);
13200 Safefree(vms_spec);
13206 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13209 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13210 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13213 /* Fall back to fid_to_name */
13215 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13222 /* Now need to trim the version off */
13223 sts = vms_split_path
13243 /* Trim off the version */
13244 int file_len = v_len + r_len + d_len + n_len + e_len;
13245 outbuf[file_len] = 0;
13247 /* Downcase if input had any lower case letters and
13248 * case preservation is not in effect.
13250 if (!decc_efs_case_preserve) {
13251 for (cp = filespec; *cp; cp++)
13252 if (islower(*cp)) { haslower = 1; break; }
13254 if (haslower) __mystrtolower(outbuf);
13263 /* External entry points */
13264 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13265 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13267 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13268 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13270 /* case_tolerant */
13272 /*{{{int do_vms_case_tolerant(void)*/
13273 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13274 * controlled by a process setting.
13276 int do_vms_case_tolerant(void)
13278 return vms_process_case_tolerant;
13281 /* External entry points */
13282 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13283 int Perl_vms_case_tolerant(void)
13284 { return do_vms_case_tolerant(); }
13286 int Perl_vms_case_tolerant(void)
13287 { return vms_process_case_tolerant; }
13291 /* Start of DECC RTL Feature handling */
13293 static int sys_trnlnm
13294 (const char * logname,
13298 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13299 const unsigned long attr = LNM$M_CASE_BLIND;
13300 struct dsc$descriptor_s name_dsc;
13302 unsigned short result;
13303 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13306 name_dsc.dsc$w_length = strlen(logname);
13307 name_dsc.dsc$a_pointer = (char *)logname;
13308 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13309 name_dsc.dsc$b_class = DSC$K_CLASS_S;
13311 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13313 if ($VMS_STATUS_SUCCESS(status)) {
13315 /* Null terminate and return the string */
13316 /*--------------------------------------*/
13323 static int sys_crelnm
13324 (const char * logname,
13325 const char * value)
13328 const char * proc_table = "LNM$PROCESS_TABLE";
13329 struct dsc$descriptor_s proc_table_dsc;
13330 struct dsc$descriptor_s logname_dsc;
13331 struct itmlst_3 item_list[2];
13333 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13334 proc_table_dsc.dsc$w_length = strlen(proc_table);
13335 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13336 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13338 logname_dsc.dsc$a_pointer = (char *) logname;
13339 logname_dsc.dsc$w_length = strlen(logname);
13340 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13341 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13343 item_list[0].buflen = strlen(value);
13344 item_list[0].itmcode = LNM$_STRING;
13345 item_list[0].bufadr = (char *)value;
13346 item_list[0].retlen = NULL;
13348 item_list[1].buflen = 0;
13349 item_list[1].itmcode = 0;
13351 ret_val = sys$crelnm
13353 (const struct dsc$descriptor_s *)&proc_table_dsc,
13354 (const struct dsc$descriptor_s *)&logname_dsc,
13356 (const struct item_list_3 *) item_list);
13361 /* C RTL Feature settings */
13363 static int set_features
13364 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
13365 int (* cli_routine)(void), /* Not documented */
13366 void *image_info) /* Not documented */
13373 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13374 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13375 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13376 unsigned long case_perm;
13377 unsigned long case_image;
13380 /* Allow an exception to bring Perl into the VMS debugger */
13381 vms_debug_on_exception = 0;
13382 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13383 if ($VMS_STATUS_SUCCESS(status)) {
13384 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13385 vms_debug_on_exception = 1;
13387 vms_debug_on_exception = 0;
13390 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13391 vms_vtf7_filenames = 0;
13392 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13393 if ($VMS_STATUS_SUCCESS(status)) {
13394 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13395 vms_vtf7_filenames = 1;
13397 vms_vtf7_filenames = 0;
13401 /* unlink all versions on unlink() or rename() */
13402 vms_unlink_all_versions = 0;
13403 status = sys_trnlnm
13404 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13405 if ($VMS_STATUS_SUCCESS(status)) {
13406 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13407 vms_unlink_all_versions = 1;
13409 vms_unlink_all_versions = 0;
13412 /* Dectect running under GNV Bash or other UNIX like shell */
13413 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13414 gnv_unix_shell = 0;
13415 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13416 if ($VMS_STATUS_SUCCESS(status)) {
13417 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13418 gnv_unix_shell = 1;
13419 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13420 set_feature_default("DECC$EFS_CHARSET", 1);
13421 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13422 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13423 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13424 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13425 vms_unlink_all_versions = 1;
13428 gnv_unix_shell = 0;
13432 /* hacks to see if known bugs are still present for testing */
13434 /* Readdir is returning filenames in VMS syntax always */
13435 decc_bug_readdir_efs1 = 1;
13436 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13437 if ($VMS_STATUS_SUCCESS(status)) {
13438 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13439 decc_bug_readdir_efs1 = 1;
13441 decc_bug_readdir_efs1 = 0;
13444 /* PCP mode requires creating /dev/null special device file */
13445 decc_bug_devnull = 0;
13446 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13447 if ($VMS_STATUS_SUCCESS(status)) {
13448 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13449 decc_bug_devnull = 1;
13451 decc_bug_devnull = 0;
13454 /* fgetname returning a VMS name in UNIX mode */
13455 decc_bug_fgetname = 1;
13456 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13457 if ($VMS_STATUS_SUCCESS(status)) {
13458 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13459 decc_bug_fgetname = 1;
13461 decc_bug_fgetname = 0;
13464 /* UNIX directory names with no paths are broken in a lot of places */
13465 decc_dir_barename = 1;
13466 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13467 if ($VMS_STATUS_SUCCESS(status)) {
13468 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13469 decc_dir_barename = 1;
13471 decc_dir_barename = 0;
13474 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13475 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13477 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13478 if (decc_disable_to_vms_logname_translation < 0)
13479 decc_disable_to_vms_logname_translation = 0;
13482 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13484 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13485 if (decc_efs_case_preserve < 0)
13486 decc_efs_case_preserve = 0;
13489 s = decc$feature_get_index("DECC$EFS_CHARSET");
13491 decc_efs_charset = decc$feature_get_value(s, 1);
13492 if (decc_efs_charset < 0)
13493 decc_efs_charset = 0;
13496 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13498 decc_filename_unix_report = decc$feature_get_value(s, 1);
13499 if (decc_filename_unix_report > 0)
13500 decc_filename_unix_report = 1;
13502 decc_filename_unix_report = 0;
13505 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13507 decc_filename_unix_only = decc$feature_get_value(s, 1);
13508 if (decc_filename_unix_only > 0) {
13509 decc_filename_unix_only = 1;
13512 decc_filename_unix_only = 0;
13516 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13518 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13519 if (decc_filename_unix_no_version < 0)
13520 decc_filename_unix_no_version = 0;
13523 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13525 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13526 if (decc_readdir_dropdotnotype < 0)
13527 decc_readdir_dropdotnotype = 0;
13530 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13531 if ($VMS_STATUS_SUCCESS(status)) {
13532 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13534 dflt = decc$feature_get_value(s, 4);
13536 decc_disable_posix_root = decc$feature_get_value(s, 1);
13537 if (decc_disable_posix_root <= 0) {
13538 decc$feature_set_value(s, 1, 1);
13539 decc_disable_posix_root = 1;
13543 /* Traditionally Perl assumes this is off */
13544 decc_disable_posix_root = 1;
13545 decc$feature_set_value(s, 1, 1);
13550 #if __CRTL_VER >= 80200000
13551 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13553 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13554 if (decc_posix_compliant_pathnames < 0)
13555 decc_posix_compliant_pathnames = 0;
13556 if (decc_posix_compliant_pathnames > 4)
13557 decc_posix_compliant_pathnames = 0;
13562 status = sys_trnlnm
13563 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13564 if ($VMS_STATUS_SUCCESS(status)) {
13565 val_str[0] = _toupper(val_str[0]);
13566 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13567 decc_disable_to_vms_logname_translation = 1;
13572 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13573 if ($VMS_STATUS_SUCCESS(status)) {
13574 val_str[0] = _toupper(val_str[0]);
13575 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13576 decc_efs_case_preserve = 1;
13581 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13582 if ($VMS_STATUS_SUCCESS(status)) {
13583 val_str[0] = _toupper(val_str[0]);
13584 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13585 decc_filename_unix_report = 1;
13588 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13589 if ($VMS_STATUS_SUCCESS(status)) {
13590 val_str[0] = _toupper(val_str[0]);
13591 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13592 decc_filename_unix_only = 1;
13593 decc_filename_unix_report = 1;
13596 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13597 if ($VMS_STATUS_SUCCESS(status)) {
13598 val_str[0] = _toupper(val_str[0]);
13599 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13600 decc_filename_unix_no_version = 1;
13603 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13604 if ($VMS_STATUS_SUCCESS(status)) {
13605 val_str[0] = _toupper(val_str[0]);
13606 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13607 decc_readdir_dropdotnotype = 1;
13612 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13614 /* Report true case tolerance */
13615 /*----------------------------*/
13616 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13617 if (!$VMS_STATUS_SUCCESS(status))
13618 case_perm = PPROP$K_CASE_BLIND;
13619 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13620 if (!$VMS_STATUS_SUCCESS(status))
13621 case_image = PPROP$K_CASE_BLIND;
13622 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13623 (case_image == PPROP$K_CASE_SENSITIVE))
13624 vms_process_case_tolerant = 0;
13629 /* CRTL can be initialized past this point, but not before. */
13630 /* DECC$CRTL_INIT(); */
13637 #pragma extern_model save
13638 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13639 const __align (LONGWORD) int spare[8] = {0};
13641 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13642 #if __DECC_VER >= 60560002
13643 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13645 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13647 #endif /* __DECC */
13649 const long vms_cc_features = (const long)set_features;
13652 ** Force a reference to LIB$INITIALIZE to ensure it
13653 ** exists in the image.
13655 int lib$initialize(void);
13657 #pragma extern_model strict_refdef
13659 int lib_init_ref = (int) lib$initialize;
13662 #pragma extern_model restore