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 unsigned long int Perl_do_spawn(pTHX_ const char *);
10219 unsigned long int do_spawn2(pTHX_ const char *, int);
10221 /* {{{ unsigned long int do_aspawn(void *really,void **mark,void **sp) */
10223 Perl_do_aspawn(pTHX_ void *really,void **mark,void **sp)
10225 unsigned long int sts;
10231 /* We'll copy the (undocumented?) Win32 behavior and allow a
10232 * numeric first argument. But the only value we'll support
10233 * through do_aspawn is a value of 1, which means spawn without
10234 * waiting for completion -- other values are ignored.
10236 if (SvNIOKp(*((SV**)mark+1)) && !SvPOKp(*((SV**)mark+1))) {
10238 flags = SvIVx(*(SV**)mark);
10241 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10242 flags = CLI$M_NOWAIT;
10246 cmd = setup_argstr(aTHX_ (SV *)really,(SV **)mark,(SV **)sp);
10247 sts = do_spawn2(aTHX_ cmd, flags);
10248 /* pp_sys will clean up cmd */
10252 } /* end of do_aspawn() */
10256 /* {{{unsigned long int do_spawn(char *cmd) */
10258 Perl_do_spawn(pTHX_ const char *cmd)
10260 return do_spawn2(aTHX_ cmd, 0);
10264 /* {{{unsigned long int do_spawn2(char *cmd) */
10266 do_spawn2(pTHX_ const char *cmd, int flags)
10268 unsigned long int sts, substs;
10270 /* The caller of this routine expects to Safefree(PL_Cmd) */
10271 Newx(PL_Cmd,10,char);
10274 TAINT_PROPER("spawn");
10275 if (!cmd || !*cmd) {
10276 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10279 case RMS$_FNF: case RMS$_DNF:
10280 set_errno(ENOENT); break;
10282 set_errno(ENOTDIR); break;
10284 set_errno(ENODEV); break;
10286 set_errno(EACCES); break;
10288 set_errno(EINVAL); break;
10289 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10290 set_errno(E2BIG); break;
10291 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10292 _ckvmssts(sts); /* fall through */
10293 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10294 set_errno(EVMSERR);
10296 set_vaxc_errno(sts);
10297 if (ckWARN(WARN_EXEC)) {
10298 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10307 if (flags & CLI$M_NOWAIT)
10310 strcpy(mode, "nW");
10312 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10315 /* sts will be the pid in the nowait case */
10318 } /* end of do_spawn2() */
10322 static unsigned int *sockflags, sockflagsize;
10325 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10326 * routines found in some versions of the CRTL can't deal with sockets.
10327 * We don't shim the other file open routines since a socket isn't
10328 * likely to be opened by a name.
10330 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10331 FILE *my_fdopen(int fd, const char *mode)
10333 FILE *fp = fdopen(fd, mode);
10336 unsigned int fdoff = fd / sizeof(unsigned int);
10337 Stat_t sbuf; /* native stat; we don't need flex_stat */
10338 if (!sockflagsize || fdoff > sockflagsize) {
10339 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
10340 else Newx (sockflags,fdoff+2,unsigned int);
10341 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10342 sockflagsize = fdoff + 2;
10344 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10345 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10354 * Clear the corresponding bit when the (possibly) socket stream is closed.
10355 * There still a small hole: we miss an implicit close which might occur
10356 * via freopen(). >> Todo
10358 /*{{{ int my_fclose(FILE *fp)*/
10359 int my_fclose(FILE *fp) {
10361 unsigned int fd = fileno(fp);
10362 unsigned int fdoff = fd / sizeof(unsigned int);
10364 if (sockflagsize && fdoff <= sockflagsize)
10365 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10373 * A simple fwrite replacement which outputs itmsz*nitm chars without
10374 * introducing record boundaries every itmsz chars.
10375 * We are using fputs, which depends on a terminating null. We may
10376 * well be writing binary data, so we need to accommodate not only
10377 * data with nulls sprinkled in the middle but also data with no null
10380 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10382 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10384 register char *cp, *end, *cpd, *data;
10385 register unsigned int fd = fileno(dest);
10386 register unsigned int fdoff = fd / sizeof(unsigned int);
10388 int bufsize = itmsz * nitm + 1;
10390 if (fdoff < sockflagsize &&
10391 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10392 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10396 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10397 memcpy( data, src, itmsz*nitm );
10398 data[itmsz*nitm] = '\0';
10400 end = data + itmsz * nitm;
10401 retval = (int) nitm; /* on success return # items written */
10404 while (cpd <= end) {
10405 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10406 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10408 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10412 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10415 } /* end of my_fwrite() */
10418 /*{{{ int my_flush(FILE *fp)*/
10420 Perl_my_flush(pTHX_ FILE *fp)
10423 if ((res = fflush(fp)) == 0 && fp) {
10424 #ifdef VMS_DO_SOCKETS
10426 if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
10428 res = fsync(fileno(fp));
10431 * If the flush succeeded but set end-of-file, we need to clear
10432 * the error because our caller may check ferror(). BTW, this
10433 * probably means we just flushed an empty file.
10435 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10442 * Here are replacements for the following Unix routines in the VMS environment:
10443 * getpwuid Get information for a particular UIC or UID
10444 * getpwnam Get information for a named user
10445 * getpwent Get information for each user in the rights database
10446 * setpwent Reset search to the start of the rights database
10447 * endpwent Finish searching for users in the rights database
10449 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10450 * (defined in pwd.h), which contains the following fields:-
10452 * char *pw_name; Username (in lower case)
10453 * char *pw_passwd; Hashed password
10454 * unsigned int pw_uid; UIC
10455 * unsigned int pw_gid; UIC group number
10456 * char *pw_unixdir; Default device/directory (VMS-style)
10457 * char *pw_gecos; Owner name
10458 * char *pw_dir; Default device/directory (Unix-style)
10459 * char *pw_shell; Default CLI name (eg. DCL)
10461 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10463 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10464 * not the UIC member number (eg. what's returned by getuid()),
10465 * getpwuid() can accept either as input (if uid is specified, the caller's
10466 * UIC group is used), though it won't recognise gid=0.
10468 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10469 * information about other users in your group or in other groups, respectively.
10470 * If the required privilege is not available, then these routines fill only
10471 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10474 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10477 /* sizes of various UAF record fields */
10478 #define UAI$S_USERNAME 12
10479 #define UAI$S_IDENT 31
10480 #define UAI$S_OWNER 31
10481 #define UAI$S_DEFDEV 31
10482 #define UAI$S_DEFDIR 63
10483 #define UAI$S_DEFCLI 31
10484 #define UAI$S_PWD 8
10486 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10487 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10488 (uic).uic$v_group != UIC$K_WILD_GROUP)
10490 static char __empty[]= "";
10491 static struct passwd __passwd_empty=
10492 {(char *) __empty, (char *) __empty, 0, 0,
10493 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10494 static int contxt= 0;
10495 static struct passwd __pwdcache;
10496 static char __pw_namecache[UAI$S_IDENT+1];
10499 * This routine does most of the work extracting the user information.
10501 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10504 unsigned char length;
10505 char pw_gecos[UAI$S_OWNER+1];
10507 static union uicdef uic;
10509 unsigned char length;
10510 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10513 unsigned char length;
10514 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10517 unsigned char length;
10518 char pw_shell[UAI$S_DEFCLI+1];
10520 static char pw_passwd[UAI$S_PWD+1];
10522 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10523 struct dsc$descriptor_s name_desc;
10524 unsigned long int sts;
10526 static struct itmlst_3 itmlst[]= {
10527 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
10528 {sizeof(uic), UAI$_UIC, &uic, &luic},
10529 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
10530 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
10531 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
10532 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
10533 {0, 0, NULL, NULL}};
10535 name_desc.dsc$w_length= strlen(name);
10536 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10537 name_desc.dsc$b_class= DSC$K_CLASS_S;
10538 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10540 /* Note that sys$getuai returns many fields as counted strings. */
10541 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10542 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10543 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10545 else { _ckvmssts(sts); }
10546 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
10548 if ((int) owner.length < lowner) lowner= (int) owner.length;
10549 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10550 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10551 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10552 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10553 owner.pw_gecos[lowner]= '\0';
10554 defdev.pw_dir[ldefdev+ldefdir]= '\0';
10555 defcli.pw_shell[ldefcli]= '\0';
10556 if (valid_uic(uic)) {
10557 pwd->pw_uid= uic.uic$l_uic;
10558 pwd->pw_gid= uic.uic$v_group;
10561 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10562 pwd->pw_passwd= pw_passwd;
10563 pwd->pw_gecos= owner.pw_gecos;
10564 pwd->pw_dir= defdev.pw_dir;
10565 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10566 pwd->pw_shell= defcli.pw_shell;
10567 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10569 ldir= strlen(pwd->pw_unixdir) - 1;
10570 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10573 strcpy(pwd->pw_unixdir, pwd->pw_dir);
10574 if (!decc_efs_case_preserve)
10575 __mystrtolower(pwd->pw_unixdir);
10580 * Get information for a named user.
10582 /*{{{struct passwd *getpwnam(char *name)*/
10583 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10585 struct dsc$descriptor_s name_desc;
10587 unsigned long int status, sts;
10589 __pwdcache = __passwd_empty;
10590 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10591 /* We still may be able to determine pw_uid and pw_gid */
10592 name_desc.dsc$w_length= strlen(name);
10593 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10594 name_desc.dsc$b_class= DSC$K_CLASS_S;
10595 name_desc.dsc$a_pointer= (char *) name;
10596 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10597 __pwdcache.pw_uid= uic.uic$l_uic;
10598 __pwdcache.pw_gid= uic.uic$v_group;
10601 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10602 set_vaxc_errno(sts);
10603 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10606 else { _ckvmssts(sts); }
10609 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10610 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10611 __pwdcache.pw_name= __pw_namecache;
10612 return &__pwdcache;
10613 } /* end of my_getpwnam() */
10617 * Get information for a particular UIC or UID.
10618 * Called by my_getpwent with uid=-1 to list all users.
10620 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10621 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10623 const $DESCRIPTOR(name_desc,__pw_namecache);
10624 unsigned short lname;
10626 unsigned long int status;
10628 if (uid == (unsigned int) -1) {
10630 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10631 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10632 set_vaxc_errno(status);
10633 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10637 else { _ckvmssts(status); }
10638 } while (!valid_uic (uic));
10641 uic.uic$l_uic= uid;
10642 if (!uic.uic$v_group)
10643 uic.uic$v_group= PerlProc_getgid();
10644 if (valid_uic(uic))
10645 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10646 else status = SS$_IVIDENT;
10647 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10648 status == RMS$_PRV) {
10649 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10652 else { _ckvmssts(status); }
10654 __pw_namecache[lname]= '\0';
10655 __mystrtolower(__pw_namecache);
10657 __pwdcache = __passwd_empty;
10658 __pwdcache.pw_name = __pw_namecache;
10660 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10661 The identifier's value is usually the UIC, but it doesn't have to be,
10662 so if we can, we let fillpasswd update this. */
10663 __pwdcache.pw_uid = uic.uic$l_uic;
10664 __pwdcache.pw_gid = uic.uic$v_group;
10666 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10667 return &__pwdcache;
10669 } /* end of my_getpwuid() */
10673 * Get information for next user.
10675 /*{{{struct passwd *my_getpwent()*/
10676 struct passwd *Perl_my_getpwent(pTHX)
10678 return (my_getpwuid((unsigned int) -1));
10683 * Finish searching rights database for users.
10685 /*{{{void my_endpwent()*/
10686 void Perl_my_endpwent(pTHX)
10689 _ckvmssts(sys$finish_rdb(&contxt));
10695 #ifdef HOMEGROWN_POSIX_SIGNALS
10696 /* Signal handling routines, pulled into the core from POSIX.xs.
10698 * We need these for threads, so they've been rolled into the core,
10699 * rather than left in POSIX.xs.
10701 * (DRS, Oct 23, 1997)
10704 /* sigset_t is atomic under VMS, so these routines are easy */
10705 /*{{{int my_sigemptyset(sigset_t *) */
10706 int my_sigemptyset(sigset_t *set) {
10707 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10708 *set = 0; return 0;
10713 /*{{{int my_sigfillset(sigset_t *)*/
10714 int my_sigfillset(sigset_t *set) {
10716 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10717 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10723 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10724 int my_sigaddset(sigset_t *set, int sig) {
10725 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10726 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10727 *set |= (1 << (sig - 1));
10733 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10734 int my_sigdelset(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_sigismember(sigset_t *set, int sig)*/
10744 int my_sigismember(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 return *set & (1 << (sig - 1));
10752 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10753 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10756 /* If set and oset are both null, then things are badly wrong. Bail out. */
10757 if ((oset == NULL) && (set == NULL)) {
10758 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10762 /* If set's null, then we're just handling a fetch. */
10764 tempmask = sigblock(0);
10769 tempmask = sigsetmask(*set);
10772 tempmask = sigblock(*set);
10775 tempmask = sigblock(0);
10776 sigsetmask(*oset & ~tempmask);
10779 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10784 /* Did they pass us an oset? If so, stick our holding mask into it */
10791 #endif /* HOMEGROWN_POSIX_SIGNALS */
10794 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10795 * my_utime(), and flex_stat(), all of which operate on UTC unless
10796 * VMSISH_TIMES is true.
10798 /* method used to handle UTC conversions:
10799 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10801 static int gmtime_emulation_type;
10802 /* number of secs to add to UTC POSIX-style time to get local time */
10803 static long int utc_offset_secs;
10805 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10806 * in vmsish.h. #undef them here so we can call the CRTL routines
10815 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10816 * qualifier with the extern prefix pragma. This provisional
10817 * hack circumvents this prefix pragma problem in previous
10820 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10821 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10822 # pragma __extern_prefix save
10823 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10824 # define gmtime decc$__utctz_gmtime
10825 # define localtime decc$__utctz_localtime
10826 # define time decc$__utc_time
10827 # pragma __extern_prefix restore
10829 struct tm *gmtime(), *localtime();
10835 static time_t toutc_dst(time_t loc) {
10838 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10839 loc -= utc_offset_secs;
10840 if (rsltmp->tm_isdst) loc -= 3600;
10843 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10844 ((gmtime_emulation_type || my_time(NULL)), \
10845 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10846 ((secs) - utc_offset_secs))))
10848 static time_t toloc_dst(time_t utc) {
10851 utc += utc_offset_secs;
10852 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10853 if (rsltmp->tm_isdst) utc += 3600;
10856 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10857 ((gmtime_emulation_type || my_time(NULL)), \
10858 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10859 ((secs) + utc_offset_secs))))
10861 #ifndef RTL_USES_UTC
10864 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10865 DST starts on 1st sun of april at 02:00 std time
10866 ends on last sun of october at 02:00 dst time
10867 see the UCX management command reference, SET CONFIG TIMEZONE
10868 for formatting info.
10870 No, it's not as general as it should be, but then again, NOTHING
10871 will handle UK times in a sensible way.
10876 parse the DST start/end info:
10877 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10881 tz_parse_startend(char *s, struct tm *w, int *past)
10883 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10884 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10889 if (!past) return 0;
10892 if (w->tm_year % 4 == 0) ly = 1;
10893 if (w->tm_year % 100 == 0) ly = 0;
10894 if (w->tm_year+1900 % 400 == 0) ly = 1;
10897 dozjd = isdigit(*s);
10898 if (*s == 'J' || *s == 'j' || dozjd) {
10899 if (!dozjd && !isdigit(*++s)) return 0;
10902 d = d*10 + *s++ - '0';
10904 d = d*10 + *s++ - '0';
10907 if (d == 0) return 0;
10908 if (d > 366) return 0;
10910 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10913 } else if (*s == 'M' || *s == 'm') {
10914 if (!isdigit(*++s)) return 0;
10916 if (isdigit(*s)) m = 10*m + *s++ - '0';
10917 if (*s != '.') return 0;
10918 if (!isdigit(*++s)) return 0;
10920 if (n < 1 || n > 5) return 0;
10921 if (*s != '.') return 0;
10922 if (!isdigit(*++s)) return 0;
10924 if (d > 6) return 0;
10928 if (!isdigit(*++s)) return 0;
10930 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10932 if (!isdigit(*++s)) return 0;
10934 if (isdigit(*s)) min = 10*min + *s++ - '0';
10936 if (!isdigit(*++s)) return 0;
10938 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10948 if (w->tm_yday < d) goto before;
10949 if (w->tm_yday > d) goto after;
10951 if (w->tm_mon+1 < m) goto before;
10952 if (w->tm_mon+1 > m) goto after;
10954 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
10955 k = d - j; /* mday of first d */
10956 if (k <= 0) k += 7;
10957 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
10958 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
10959 if (w->tm_mday < k) goto before;
10960 if (w->tm_mday > k) goto after;
10963 if (w->tm_hour < hour) goto before;
10964 if (w->tm_hour > hour) goto after;
10965 if (w->tm_min < min) goto before;
10966 if (w->tm_min > min) goto after;
10967 if (w->tm_sec < sec) goto before;
10981 /* parse the offset: (+|-)hh[:mm[:ss]] */
10984 tz_parse_offset(char *s, int *offset)
10986 int hour = 0, min = 0, sec = 0;
10989 if (!offset) return 0;
10991 if (*s == '-') {neg++; s++;}
10992 if (*s == '+') s++;
10993 if (!isdigit(*s)) return 0;
10995 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
10996 if (hour > 24) return 0;
10998 if (!isdigit(*++s)) return 0;
11000 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11001 if (min > 59) return 0;
11003 if (!isdigit(*++s)) return 0;
11005 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11006 if (sec > 59) return 0;
11010 *offset = (hour*60+min)*60 + sec;
11011 if (neg) *offset = -*offset;
11016 input time is w, whatever type of time the CRTL localtime() uses.
11017 sets dst, the zone, and the gmtoff (seconds)
11019 caches the value of TZ and UCX$TZ env variables; note that
11020 my_setenv looks for these and sets a flag if they're changed
11023 We have to watch out for the "australian" case (dst starts in
11024 october, ends in april)...flagged by "reverse" and checked by
11025 scanning through the months of the previous year.
11030 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11035 char *dstzone, *tz, *s_start, *s_end;
11036 int std_off, dst_off, isdst;
11037 int y, dststart, dstend;
11038 static char envtz[1025]; /* longer than any logical, symbol, ... */
11039 static char ucxtz[1025];
11040 static char reversed = 0;
11046 reversed = -1; /* flag need to check */
11047 envtz[0] = ucxtz[0] = '\0';
11048 tz = my_getenv("TZ",0);
11049 if (tz) strcpy(envtz, tz);
11050 tz = my_getenv("UCX$TZ",0);
11051 if (tz) strcpy(ucxtz, tz);
11052 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11055 if (!*tz) tz = ucxtz;
11058 while (isalpha(*s)) s++;
11059 s = tz_parse_offset(s, &std_off);
11061 if (!*s) { /* no DST, hurray we're done! */
11067 while (isalpha(*s)) s++;
11068 s2 = tz_parse_offset(s, &dst_off);
11072 dst_off = std_off - 3600;
11075 if (!*s) { /* default dst start/end?? */
11076 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11077 s = strchr(ucxtz,',');
11079 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11081 if (*s != ',') return 0;
11084 when = _toutc(when); /* convert to utc */
11085 when = when - std_off; /* convert to pseudolocal time*/
11087 w2 = localtime(&when);
11090 s = tz_parse_startend(s_start,w2,&dststart);
11092 if (*s != ',') return 0;
11095 when = _toutc(when); /* convert to utc */
11096 when = when - dst_off; /* convert to pseudolocal time*/
11097 w2 = localtime(&when);
11098 if (w2->tm_year != y) { /* spans a year, just check one time */
11099 when += dst_off - std_off;
11100 w2 = localtime(&when);
11103 s = tz_parse_startend(s_end,w2,&dstend);
11106 if (reversed == -1) { /* need to check if start later than end */
11110 if (when < 2*365*86400) {
11111 when += 2*365*86400;
11115 w2 =localtime(&when);
11116 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11118 for (j = 0; j < 12; j++) {
11119 w2 =localtime(&when);
11120 tz_parse_startend(s_start,w2,&ds);
11121 tz_parse_startend(s_end,w2,&de);
11122 if (ds != de) break;
11126 if (de && !ds) reversed = 1;
11129 isdst = dststart && !dstend;
11130 if (reversed) isdst = dststart || !dstend;
11133 if (dst) *dst = isdst;
11134 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11135 if (isdst) tz = dstzone;
11137 while(isalpha(*tz)) *zone++ = *tz++;
11143 #endif /* !RTL_USES_UTC */
11145 /* my_time(), my_localtime(), my_gmtime()
11146 * By default traffic in UTC time values, using CRTL gmtime() or
11147 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11148 * Note: We need to use these functions even when the CRTL has working
11149 * UTC support, since they also handle C<use vmsish qw(times);>
11151 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11152 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11155 /*{{{time_t my_time(time_t *timep)*/
11156 time_t Perl_my_time(pTHX_ time_t *timep)
11161 if (gmtime_emulation_type == 0) {
11163 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11164 /* results of calls to gmtime() and localtime() */
11165 /* for same &base */
11167 gmtime_emulation_type++;
11168 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11169 char off[LNM$C_NAMLENGTH+1];;
11171 gmtime_emulation_type++;
11172 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11173 gmtime_emulation_type++;
11174 utc_offset_secs = 0;
11175 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11177 else { utc_offset_secs = atol(off); }
11179 else { /* We've got a working gmtime() */
11180 struct tm gmt, local;
11183 tm_p = localtime(&base);
11185 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11186 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11187 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11188 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11193 # ifdef VMSISH_TIME
11194 # ifdef RTL_USES_UTC
11195 if (VMSISH_TIME) when = _toloc(when);
11197 if (!VMSISH_TIME) when = _toutc(when);
11200 if (timep != NULL) *timep = when;
11203 } /* end of my_time() */
11207 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11209 Perl_my_gmtime(pTHX_ const time_t *timep)
11215 if (timep == NULL) {
11216 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11219 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11222 # ifdef VMSISH_TIME
11223 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11225 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11226 return gmtime(&when);
11228 /* CRTL localtime() wants local time as input, so does no tz correction */
11229 rsltmp = localtime(&when);
11230 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11233 } /* end of my_gmtime() */
11237 /*{{{struct tm *my_localtime(const time_t *timep)*/
11239 Perl_my_localtime(pTHX_ const time_t *timep)
11241 time_t when, whenutc;
11245 if (timep == NULL) {
11246 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11249 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11250 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11253 # ifdef RTL_USES_UTC
11254 # ifdef VMSISH_TIME
11255 if (VMSISH_TIME) when = _toutc(when);
11257 /* CRTL localtime() wants UTC as input, does tz correction itself */
11258 return localtime(&when);
11260 # else /* !RTL_USES_UTC */
11262 # ifdef VMSISH_TIME
11263 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11264 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
11267 #ifndef RTL_USES_UTC
11268 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
11269 when = whenutc - offset; /* pseudolocal time*/
11272 /* CRTL localtime() wants local time as input, so does no tz correction */
11273 rsltmp = localtime(&when);
11274 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11278 } /* end of my_localtime() */
11281 /* Reset definitions for later calls */
11282 #define gmtime(t) my_gmtime(t)
11283 #define localtime(t) my_localtime(t)
11284 #define time(t) my_time(t)
11287 /* my_utime - update modification/access time of a file
11289 * VMS 7.3 and later implementation
11290 * Only the UTC translation is home-grown. The rest is handled by the
11291 * CRTL utime(), which will take into account the relevant feature
11292 * logicals and ODS-5 volume characteristics for true access times.
11294 * pre VMS 7.3 implementation:
11295 * The calling sequence is identical to POSIX utime(), but under
11296 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11297 * not maintain access times. Restrictions differ from the POSIX
11298 * definition in that the time can be changed as long as the
11299 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11300 * no separate checks are made to insure that the caller is the
11301 * owner of the file or has special privs enabled.
11302 * Code here is based on Joe Meadows' FILE utility.
11306 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11307 * to VMS epoch (01-JAN-1858 00:00:00.00)
11308 * in 100 ns intervals.
11310 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11312 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11313 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11315 #if __CRTL_VER >= 70300000
11316 struct utimbuf utc_utimes, *utc_utimesp;
11318 if (utimes != NULL) {
11319 utc_utimes.actime = utimes->actime;
11320 utc_utimes.modtime = utimes->modtime;
11321 # ifdef VMSISH_TIME
11322 /* If input was local; convert to UTC for sys svc */
11324 utc_utimes.actime = _toutc(utimes->actime);
11325 utc_utimes.modtime = _toutc(utimes->modtime);
11328 utc_utimesp = &utc_utimes;
11331 utc_utimesp = NULL;
11334 return utime(file, utc_utimesp);
11336 #else /* __CRTL_VER < 70300000 */
11340 long int bintime[2], len = 2, lowbit, unixtime,
11341 secscale = 10000000; /* seconds --> 100 ns intervals */
11342 unsigned long int chan, iosb[2], retsts;
11343 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11344 struct FAB myfab = cc$rms_fab;
11345 struct NAM mynam = cc$rms_nam;
11346 #if defined (__DECC) && defined (__VAX)
11347 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11348 * at least through VMS V6.1, which causes a type-conversion warning.
11350 # pragma message save
11351 # pragma message disable cvtdiftypes
11353 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11354 struct fibdef myfib;
11355 #if defined (__DECC) && defined (__VAX)
11356 /* This should be right after the declaration of myatr, but due
11357 * to a bug in VAX DEC C, this takes effect a statement early.
11359 # pragma message restore
11361 /* cast ok for read only parameter */
11362 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11363 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11364 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11366 if (file == NULL || *file == '\0') {
11367 SETERRNO(ENOENT, LIB$_INVARG);
11371 /* Convert to VMS format ensuring that it will fit in 255 characters */
11372 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11373 SETERRNO(ENOENT, LIB$_INVARG);
11376 if (utimes != NULL) {
11377 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11378 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11379 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11380 * as input, we force the sign bit to be clear by shifting unixtime right
11381 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11383 lowbit = (utimes->modtime & 1) ? secscale : 0;
11384 unixtime = (long int) utimes->modtime;
11385 # ifdef VMSISH_TIME
11386 /* If input was UTC; convert to local for sys svc */
11387 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11389 unixtime >>= 1; secscale <<= 1;
11390 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11391 if (!(retsts & 1)) {
11392 SETERRNO(EVMSERR, retsts);
11395 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11396 if (!(retsts & 1)) {
11397 SETERRNO(EVMSERR, retsts);
11402 /* Just get the current time in VMS format directly */
11403 retsts = sys$gettim(bintime);
11404 if (!(retsts & 1)) {
11405 SETERRNO(EVMSERR, retsts);
11410 myfab.fab$l_fna = vmsspec;
11411 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11412 myfab.fab$l_nam = &mynam;
11413 mynam.nam$l_esa = esa;
11414 mynam.nam$b_ess = (unsigned char) sizeof esa;
11415 mynam.nam$l_rsa = rsa;
11416 mynam.nam$b_rss = (unsigned char) sizeof rsa;
11417 if (decc_efs_case_preserve)
11418 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11420 /* Look for the file to be affected, letting RMS parse the file
11421 * specification for us as well. I have set errno using only
11422 * values documented in the utime() man page for VMS POSIX.
11424 retsts = sys$parse(&myfab,0,0);
11425 if (!(retsts & 1)) {
11426 set_vaxc_errno(retsts);
11427 if (retsts == RMS$_PRV) set_errno(EACCES);
11428 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11429 else set_errno(EVMSERR);
11432 retsts = sys$search(&myfab,0,0);
11433 if (!(retsts & 1)) {
11434 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11435 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11436 set_vaxc_errno(retsts);
11437 if (retsts == RMS$_PRV) set_errno(EACCES);
11438 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11439 else set_errno(EVMSERR);
11443 devdsc.dsc$w_length = mynam.nam$b_dev;
11444 /* cast ok for read only parameter */
11445 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11447 retsts = sys$assign(&devdsc,&chan,0,0);
11448 if (!(retsts & 1)) {
11449 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11450 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11451 set_vaxc_errno(retsts);
11452 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11453 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11454 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11455 else set_errno(EVMSERR);
11459 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11460 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11462 memset((void *) &myfib, 0, sizeof myfib);
11463 #if defined(__DECC) || defined(__DECCXX)
11464 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11465 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11466 /* This prevents the revision time of the file being reset to the current
11467 * time as a result of our IO$_MODIFY $QIO. */
11468 myfib.fib$l_acctl = FIB$M_NORECORD;
11470 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11471 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11472 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11474 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11475 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11476 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11477 _ckvmssts(sys$dassgn(chan));
11478 if (retsts & 1) retsts = iosb[0];
11479 if (!(retsts & 1)) {
11480 set_vaxc_errno(retsts);
11481 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11482 else set_errno(EVMSERR);
11488 #endif /* #if __CRTL_VER >= 70300000 */
11490 } /* end of my_utime() */
11494 * flex_stat, flex_lstat, flex_fstat
11495 * basic stat, but gets it right when asked to stat
11496 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11499 #ifndef _USE_STD_STAT
11500 /* encode_dev packs a VMS device name string into an integer to allow
11501 * simple comparisons. This can be used, for example, to check whether two
11502 * files are located on the same device, by comparing their encoded device
11503 * names. Even a string comparison would not do, because stat() reuses the
11504 * device name buffer for each call; so without encode_dev, it would be
11505 * necessary to save the buffer and use strcmp (this would mean a number of
11506 * changes to the standard Perl code, to say nothing of what a Perl script
11507 * would have to do.
11509 * The device lock id, if it exists, should be unique (unless perhaps compared
11510 * with lock ids transferred from other nodes). We have a lock id if the disk is
11511 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11512 * device names. Thus we use the lock id in preference, and only if that isn't
11513 * available, do we try to pack the device name into an integer (flagged by
11514 * the sign bit (LOCKID_MASK) being set).
11516 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11517 * name and its encoded form, but it seems very unlikely that we will find
11518 * two files on different disks that share the same encoded device names,
11519 * and even more remote that they will share the same file id (if the test
11520 * is to check for the same file).
11522 * A better method might be to use sys$device_scan on the first call, and to
11523 * search for the device, returning an index into the cached array.
11524 * The number returned would be more intelligible.
11525 * This is probably not worth it, and anyway would take quite a bit longer
11526 * on the first call.
11528 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11529 static mydev_t encode_dev (pTHX_ const char *dev)
11532 unsigned long int f;
11537 if (!dev || !dev[0]) return 0;
11541 struct dsc$descriptor_s dev_desc;
11542 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11544 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11545 can try that first. */
11546 dev_desc.dsc$w_length = strlen (dev);
11547 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11548 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11549 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11550 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11551 if (!$VMS_STATUS_SUCCESS(status)) {
11553 case SS$_NOSUCHDEV:
11554 SETERRNO(ENODEV, status);
11560 if (lockid) return (lockid & ~LOCKID_MASK);
11564 /* Otherwise we try to encode the device name */
11568 for (q = dev + strlen(dev); q--; q >= dev) {
11573 else if (isalpha (toupper (*q)))
11574 c= toupper (*q) - 'A' + (char)10;
11576 continue; /* Skip '$'s */
11578 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11580 enc += f * (unsigned long int) c;
11582 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11584 } /* end of encode_dev() */
11585 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11586 device_no = encode_dev(aTHX_ devname)
11588 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11589 device_no = new_dev_no
11593 is_null_device(name)
11596 if (decc_bug_devnull != 0) {
11597 if (strncmp("/dev/null", name, 9) == 0)
11600 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11601 The underscore prefix, controller letter, and unit number are
11602 independently optional; for our purposes, the colon punctuation
11603 is not. The colon can be trailed by optional directory and/or
11604 filename, but two consecutive colons indicates a nodename rather
11605 than a device. [pr] */
11606 if (*name == '_') ++name;
11607 if (tolower(*name++) != 'n') return 0;
11608 if (tolower(*name++) != 'l') return 0;
11609 if (tolower(*name) == 'a') ++name;
11610 if (*name == '0') ++name;
11611 return (*name++ == ':') && (*name != ':');
11616 Perl_cando_by_name_int
11617 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11619 char usrname[L_cuserid];
11620 struct dsc$descriptor_s usrdsc =
11621 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11622 char *vmsname = NULL, *fileified = NULL;
11623 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11624 unsigned short int retlen, trnlnm_iter_count;
11625 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11626 union prvdef curprv;
11627 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11628 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11629 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11630 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11631 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11633 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11635 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11637 static int profile_context = -1;
11639 if (!fname || !*fname) return FALSE;
11641 /* Make sure we expand logical names, since sys$check_access doesn't */
11642 fileified = PerlMem_malloc(VMS_MAXRSS);
11643 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11644 if (!strpbrk(fname,"/]>:")) {
11645 strcpy(fileified,fname);
11646 trnlnm_iter_count = 0;
11647 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11648 trnlnm_iter_count++;
11649 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11654 vmsname = PerlMem_malloc(VMS_MAXRSS);
11655 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11656 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11657 /* Don't know if already in VMS format, so make sure */
11658 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11659 PerlMem_free(fileified);
11660 PerlMem_free(vmsname);
11665 strcpy(vmsname,fname);
11668 /* sys$check_access needs a file spec, not a directory spec.
11669 * Don't use flex_stat here, as that depends on thread context
11670 * having been initialized, and we may get here during startup.
11673 retlen = namdsc.dsc$w_length = strlen(vmsname);
11674 if (vmsname[retlen-1] == ']'
11675 || vmsname[retlen-1] == '>'
11676 || vmsname[retlen-1] == ':'
11677 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11679 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11680 PerlMem_free(fileified);
11681 PerlMem_free(vmsname);
11690 retlen = namdsc.dsc$w_length = strlen(fname);
11691 namdsc.dsc$a_pointer = (char *)fname;
11694 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11695 access = ARM$M_EXECUTE;
11696 flags = CHP$M_READ;
11698 case S_IRUSR: case S_IRGRP: case S_IROTH:
11699 access = ARM$M_READ;
11700 flags = CHP$M_READ | CHP$M_USEREADALL;
11702 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11703 access = ARM$M_WRITE;
11704 flags = CHP$M_READ | CHP$M_WRITE;
11706 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11707 access = ARM$M_DELETE;
11708 flags = CHP$M_READ | CHP$M_WRITE;
11711 if (fileified != NULL)
11712 PerlMem_free(fileified);
11713 if (vmsname != NULL)
11714 PerlMem_free(vmsname);
11718 /* Before we call $check_access, create a user profile with the current
11719 * process privs since otherwise it just uses the default privs from the
11720 * UAF and might give false positives or negatives. This only works on
11721 * VMS versions v6.0 and later since that's when sys$create_user_profile
11722 * became available.
11725 /* get current process privs and username */
11726 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11727 _ckvmssts(iosb[0]);
11729 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11731 /* find out the space required for the profile */
11732 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11733 &usrprodsc.dsc$w_length,&profile_context));
11735 /* allocate space for the profile and get it filled in */
11736 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11737 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11738 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11739 &usrprodsc.dsc$w_length,&profile_context));
11741 /* use the profile to check access to the file; free profile & analyze results */
11742 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11743 PerlMem_free(usrprodsc.dsc$a_pointer);
11744 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11748 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11752 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11753 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11754 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11755 set_vaxc_errno(retsts);
11756 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11757 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11758 else set_errno(ENOENT);
11759 if (fileified != NULL)
11760 PerlMem_free(fileified);
11761 if (vmsname != NULL)
11762 PerlMem_free(vmsname);
11765 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11766 if (fileified != NULL)
11767 PerlMem_free(fileified);
11768 if (vmsname != NULL)
11769 PerlMem_free(vmsname);
11774 if (fileified != NULL)
11775 PerlMem_free(fileified);
11776 if (vmsname != NULL)
11777 PerlMem_free(vmsname);
11778 return FALSE; /* Should never get here */
11782 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11783 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11784 * subset of the applicable information.
11787 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11789 return cando_by_name_int
11790 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11791 } /* end of cando() */
11795 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11797 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11799 return cando_by_name_int(bit, effective, fname, 0);
11801 } /* end of cando_by_name() */
11805 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11807 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11809 if (!fstat(fd,(stat_t *) statbufp)) {
11811 char *vms_filename;
11812 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11813 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11815 /* Save name for cando by name in VMS format */
11816 cptr = getname(fd, vms_filename, 1);
11818 /* This should not happen, but just in case */
11819 if (cptr == NULL) {
11820 statbufp->st_devnam[0] = 0;
11823 /* Make sure that the saved name fits in 255 characters */
11824 cptr = do_rmsexpand
11826 statbufp->st_devnam,
11829 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11833 statbufp->st_devnam[0] = 0;
11835 PerlMem_free(vms_filename);
11837 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11839 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11841 # ifdef RTL_USES_UTC
11842 # ifdef VMSISH_TIME
11844 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11845 statbufp->st_atime = _toloc(statbufp->st_atime);
11846 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11850 # ifdef VMSISH_TIME
11851 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11855 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11856 statbufp->st_atime = _toutc(statbufp->st_atime);
11857 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11864 } /* end of flex_fstat() */
11867 #if !defined(__VAX) && __CRTL_VER >= 80200000
11875 #define lstat(_x, _y) stat(_x, _y)
11878 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11881 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11883 char fileified[VMS_MAXRSS];
11884 char temp_fspec[VMS_MAXRSS];
11887 int saved_errno, saved_vaxc_errno;
11889 if (!fspec) return retval;
11890 saved_errno = errno; saved_vaxc_errno = vaxc$errno;
11891 strcpy(temp_fspec, fspec);
11893 if (decc_bug_devnull != 0) {
11894 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11895 memset(statbufp,0,sizeof *statbufp);
11896 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11897 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11898 statbufp->st_uid = 0x00010001;
11899 statbufp->st_gid = 0x0001;
11900 time((time_t *)&statbufp->st_mtime);
11901 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11906 /* Try for a directory name first. If fspec contains a filename without
11907 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11908 * and sea:[wine.dark]water. exist, we prefer the directory here.
11909 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11910 * not sea:[wine.dark]., if the latter exists. If the intended target is
11911 * the file with null type, specify this by calling flex_stat() with
11912 * a '.' at the end of fspec.
11914 * If we are in Posix filespec mode, accept the filename as is.
11918 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11919 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11920 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11922 if (!decc_efs_charset)
11923 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11926 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11927 if (decc_posix_compliant_pathnames == 0) {
11929 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11930 if (lstat_flag == 0)
11931 retval = stat(fileified,(stat_t *) statbufp);
11933 retval = lstat(fileified,(stat_t *) statbufp);
11934 save_spec = fileified;
11937 if (lstat_flag == 0)
11938 retval = stat(temp_fspec,(stat_t *) statbufp);
11940 retval = lstat(temp_fspec,(stat_t *) statbufp);
11941 save_spec = temp_fspec;
11944 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11945 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11946 * and lstat was working correctly for the same file.
11947 * The only syntax that was working for stat was "foo:[bar]t.dir".
11949 * Other directories with the same syntax worked fine.
11950 * So work around the problem when it shows up here.
11953 int save_errno = errno;
11954 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
11955 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
11956 retval = stat(fileified, (stat_t *) statbufp);
11957 save_spec = fileified;
11960 /* Restore the errno value if third stat does not succeed */
11962 errno = save_errno;
11964 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11966 if (lstat_flag == 0)
11967 retval = stat(temp_fspec,(stat_t *) statbufp);
11969 retval = lstat(temp_fspec,(stat_t *) statbufp);
11970 save_spec = temp_fspec;
11974 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11975 /* As you were... */
11976 if (!decc_efs_charset)
11977 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
11982 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
11984 /* If this is an lstat, do not follow the link */
11986 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
11988 cptr = do_rmsexpand
11989 (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
11991 statbufp->st_devnam[0] = 0;
11993 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11995 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11996 # ifdef RTL_USES_UTC
11997 # ifdef VMSISH_TIME
11999 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12000 statbufp->st_atime = _toloc(statbufp->st_atime);
12001 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12005 # ifdef VMSISH_TIME
12006 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12010 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12011 statbufp->st_atime = _toutc(statbufp->st_atime);
12012 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12016 /* If we were successful, leave errno where we found it */
12017 if (retval == 0) { errno = saved_errno; vaxc$errno = saved_vaxc_errno; }
12020 } /* end of flex_stat_int() */
12023 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12025 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12027 return flex_stat_int(fspec, statbufp, 0);
12031 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12033 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12035 return flex_stat_int(fspec, statbufp, 1);
12040 /*{{{char *my_getlogin()*/
12041 /* VMS cuserid == Unix getlogin, except calling sequence */
12045 static char user[L_cuserid];
12046 return cuserid(user);
12051 /* rmscopy - copy a file using VMS RMS routines
12053 * Copies contents and attributes of spec_in to spec_out, except owner
12054 * and protection information. Name and type of spec_in are used as
12055 * defaults for spec_out. The third parameter specifies whether rmscopy()
12056 * should try to propagate timestamps from the input file to the output file.
12057 * If it is less than 0, no timestamps are preserved. If it is 0, then
12058 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12059 * propagated to the output file at creation iff the output file specification
12060 * did not contain an explicit name or type, and the revision date is always
12061 * updated at the end of the copy operation. If it is greater than 0, then
12062 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12063 * other than the revision date should be propagated, and bit 1 indicates
12064 * that the revision date should be propagated.
12066 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12068 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12069 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12070 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12071 * as part of the Perl standard distribution under the terms of the
12072 * GNU General Public License or the Perl Artistic License. Copies
12073 * of each may be found in the Perl standard distribution.
12075 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12077 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12079 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12080 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12081 unsigned long int i, sts, sts2;
12083 struct FAB fab_in, fab_out;
12084 struct RAB rab_in, rab_out;
12085 rms_setup_nam(nam);
12086 rms_setup_nam(nam_out);
12087 struct XABDAT xabdat;
12088 struct XABFHC xabfhc;
12089 struct XABRDT xabrdt;
12090 struct XABSUM xabsum;
12092 vmsin = PerlMem_malloc(VMS_MAXRSS);
12093 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12094 vmsout = PerlMem_malloc(VMS_MAXRSS);
12095 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12096 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12097 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12098 PerlMem_free(vmsin);
12099 PerlMem_free(vmsout);
12100 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12104 esa = PerlMem_malloc(VMS_MAXRSS);
12105 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12107 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12108 esal = PerlMem_malloc(VMS_MAXRSS);
12109 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12111 fab_in = cc$rms_fab;
12112 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12113 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12114 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12115 fab_in.fab$l_fop = FAB$M_SQO;
12116 rms_bind_fab_nam(fab_in, nam);
12117 fab_in.fab$l_xab = (void *) &xabdat;
12119 rsa = PerlMem_malloc(VMS_MAXRSS);
12120 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12122 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12123 rsal = PerlMem_malloc(VMS_MAXRSS);
12124 if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12126 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12127 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12128 rms_nam_esl(nam) = 0;
12129 rms_nam_rsl(nam) = 0;
12130 rms_nam_esll(nam) = 0;
12131 rms_nam_rsll(nam) = 0;
12132 #ifdef NAM$M_NO_SHORT_UPCASE
12133 if (decc_efs_case_preserve)
12134 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12137 xabdat = cc$rms_xabdat; /* To get creation date */
12138 xabdat.xab$l_nxt = (void *) &xabfhc;
12140 xabfhc = cc$rms_xabfhc; /* To get record length */
12141 xabfhc.xab$l_nxt = (void *) &xabsum;
12143 xabsum = cc$rms_xabsum; /* To get key and area information */
12145 if (!((sts = sys$open(&fab_in)) & 1)) {
12146 PerlMem_free(vmsin);
12147 PerlMem_free(vmsout);
12150 PerlMem_free(esal);
12153 PerlMem_free(rsal);
12154 set_vaxc_errno(sts);
12156 case RMS$_FNF: case RMS$_DNF:
12157 set_errno(ENOENT); break;
12159 set_errno(ENOTDIR); break;
12161 set_errno(ENODEV); break;
12163 set_errno(EINVAL); break;
12165 set_errno(EACCES); break;
12167 set_errno(EVMSERR);
12174 fab_out.fab$w_ifi = 0;
12175 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12176 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12177 fab_out.fab$l_fop = FAB$M_SQO;
12178 rms_bind_fab_nam(fab_out, nam_out);
12179 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12180 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12181 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12182 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12183 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12184 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12185 if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12188 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12189 esal_out = PerlMem_malloc(VMS_MAXRSS);
12190 if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12191 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12192 if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12194 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12195 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12197 if (preserve_dates == 0) { /* Act like DCL COPY */
12198 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12199 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12200 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12201 PerlMem_free(vmsin);
12202 PerlMem_free(vmsout);
12205 PerlMem_free(esal);
12208 PerlMem_free(rsal);
12209 PerlMem_free(esa_out);
12210 if (esal_out != NULL)
12211 PerlMem_free(esal_out);
12212 PerlMem_free(rsa_out);
12213 if (rsal_out != NULL)
12214 PerlMem_free(rsal_out);
12215 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12216 set_vaxc_errno(sts);
12219 fab_out.fab$l_xab = (void *) &xabdat;
12220 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12221 preserve_dates = 1;
12223 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12224 preserve_dates =0; /* bitmask from this point forward */
12226 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12227 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12228 PerlMem_free(vmsin);
12229 PerlMem_free(vmsout);
12232 PerlMem_free(esal);
12235 PerlMem_free(rsal);
12236 PerlMem_free(esa_out);
12237 if (esal_out != NULL)
12238 PerlMem_free(esal_out);
12239 PerlMem_free(rsa_out);
12240 if (rsal_out != NULL)
12241 PerlMem_free(rsal_out);
12242 set_vaxc_errno(sts);
12245 set_errno(ENOENT); break;
12247 set_errno(ENOTDIR); break;
12249 set_errno(ENODEV); break;
12251 set_errno(EINVAL); break;
12253 set_errno(EACCES); break;
12255 set_errno(EVMSERR);
12259 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12260 if (preserve_dates & 2) {
12261 /* sys$close() will process xabrdt, not xabdat */
12262 xabrdt = cc$rms_xabrdt;
12264 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12266 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12267 * is unsigned long[2], while DECC & VAXC use a struct */
12268 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12270 fab_out.fab$l_xab = (void *) &xabrdt;
12273 ubf = PerlMem_malloc(32256);
12274 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12275 rab_in = cc$rms_rab;
12276 rab_in.rab$l_fab = &fab_in;
12277 rab_in.rab$l_rop = RAB$M_BIO;
12278 rab_in.rab$l_ubf = ubf;
12279 rab_in.rab$w_usz = 32256;
12280 if (!((sts = sys$connect(&rab_in)) & 1)) {
12281 sys$close(&fab_in); sys$close(&fab_out);
12282 PerlMem_free(vmsin);
12283 PerlMem_free(vmsout);
12287 PerlMem_free(esal);
12290 PerlMem_free(rsal);
12291 PerlMem_free(esa_out);
12292 if (esal_out != NULL)
12293 PerlMem_free(esal_out);
12294 PerlMem_free(rsa_out);
12295 if (rsal_out != NULL)
12296 PerlMem_free(rsal_out);
12297 set_errno(EVMSERR); set_vaxc_errno(sts);
12301 rab_out = cc$rms_rab;
12302 rab_out.rab$l_fab = &fab_out;
12303 rab_out.rab$l_rbf = ubf;
12304 if (!((sts = sys$connect(&rab_out)) & 1)) {
12305 sys$close(&fab_in); sys$close(&fab_out);
12306 PerlMem_free(vmsin);
12307 PerlMem_free(vmsout);
12311 PerlMem_free(esal);
12314 PerlMem_free(rsal);
12315 PerlMem_free(esa_out);
12316 if (esal_out != NULL)
12317 PerlMem_free(esal_out);
12318 PerlMem_free(rsa_out);
12319 if (rsal_out != NULL)
12320 PerlMem_free(rsal_out);
12321 set_errno(EVMSERR); set_vaxc_errno(sts);
12325 while ((sts = sys$read(&rab_in))) { /* always true */
12326 if (sts == RMS$_EOF) break;
12327 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12328 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12329 sys$close(&fab_in); sys$close(&fab_out);
12330 PerlMem_free(vmsin);
12331 PerlMem_free(vmsout);
12335 PerlMem_free(esal);
12338 PerlMem_free(rsal);
12339 PerlMem_free(esa_out);
12340 if (esal_out != NULL)
12341 PerlMem_free(esal_out);
12342 PerlMem_free(rsa_out);
12343 if (rsal_out != NULL)
12344 PerlMem_free(rsal_out);
12345 set_errno(EVMSERR); set_vaxc_errno(sts);
12351 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12352 sys$close(&fab_in); sys$close(&fab_out);
12353 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12355 PerlMem_free(vmsin);
12356 PerlMem_free(vmsout);
12360 PerlMem_free(esal);
12363 PerlMem_free(rsal);
12364 PerlMem_free(esa_out);
12365 if (esal_out != NULL)
12366 PerlMem_free(esal_out);
12367 PerlMem_free(rsa_out);
12368 if (rsal_out != NULL)
12369 PerlMem_free(rsal_out);
12372 set_errno(EVMSERR); set_vaxc_errno(sts);
12378 } /* end of rmscopy() */
12382 /*** The following glue provides 'hooks' to make some of the routines
12383 * from this file available from Perl. These routines are sufficiently
12384 * basic, and are required sufficiently early in the build process,
12385 * that's it's nice to have them available to miniperl as well as the
12386 * full Perl, so they're set up here instead of in an extension. The
12387 * Perl code which handles importation of these names into a given
12388 * package lives in [.VMS]Filespec.pm in @INC.
12392 rmsexpand_fromperl(pTHX_ CV *cv)
12395 char *fspec, *defspec = NULL, *rslt;
12397 int fs_utf8, dfs_utf8;
12401 if (!items || items > 2)
12402 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12403 fspec = SvPV(ST(0),n_a);
12404 fs_utf8 = SvUTF8(ST(0));
12405 if (!fspec || !*fspec) XSRETURN_UNDEF;
12407 defspec = SvPV(ST(1),n_a);
12408 dfs_utf8 = SvUTF8(ST(1));
12410 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12411 ST(0) = sv_newmortal();
12412 if (rslt != NULL) {
12413 sv_usepvn(ST(0),rslt,strlen(rslt));
12422 vmsify_fromperl(pTHX_ CV *cv)
12429 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12430 utf8_fl = SvUTF8(ST(0));
12431 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12432 ST(0) = sv_newmortal();
12433 if (vmsified != NULL) {
12434 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12443 unixify_fromperl(pTHX_ CV *cv)
12450 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12451 utf8_fl = SvUTF8(ST(0));
12452 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12453 ST(0) = sv_newmortal();
12454 if (unixified != NULL) {
12455 sv_usepvn(ST(0),unixified,strlen(unixified));
12464 fileify_fromperl(pTHX_ CV *cv)
12471 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12472 utf8_fl = SvUTF8(ST(0));
12473 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12474 ST(0) = sv_newmortal();
12475 if (fileified != NULL) {
12476 sv_usepvn(ST(0),fileified,strlen(fileified));
12485 pathify_fromperl(pTHX_ CV *cv)
12492 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12493 utf8_fl = SvUTF8(ST(0));
12494 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12495 ST(0) = sv_newmortal();
12496 if (pathified != NULL) {
12497 sv_usepvn(ST(0),pathified,strlen(pathified));
12506 vmspath_fromperl(pTHX_ CV *cv)
12513 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12514 utf8_fl = SvUTF8(ST(0));
12515 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12516 ST(0) = sv_newmortal();
12517 if (vmspath != NULL) {
12518 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12527 unixpath_fromperl(pTHX_ CV *cv)
12534 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12535 utf8_fl = SvUTF8(ST(0));
12536 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12537 ST(0) = sv_newmortal();
12538 if (unixpath != NULL) {
12539 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12548 candelete_fromperl(pTHX_ CV *cv)
12556 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12558 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12559 Newx(fspec, VMS_MAXRSS, char);
12560 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12561 if (SvTYPE(mysv) == SVt_PVGV) {
12562 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12563 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12571 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12572 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12579 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12585 rmscopy_fromperl(pTHX_ CV *cv)
12588 char *inspec, *outspec, *inp, *outp;
12590 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12591 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12592 unsigned long int sts;
12597 if (items < 2 || items > 3)
12598 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12600 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12601 Newx(inspec, VMS_MAXRSS, char);
12602 if (SvTYPE(mysv) == SVt_PVGV) {
12603 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12604 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12612 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12613 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12619 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12620 Newx(outspec, VMS_MAXRSS, char);
12621 if (SvTYPE(mysv) == SVt_PVGV) {
12622 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12623 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12632 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12633 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12640 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12642 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12648 /* The mod2fname is limited to shorter filenames by design, so it should
12649 * not be modified to support longer EFS pathnames
12652 mod2fname(pTHX_ CV *cv)
12655 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12656 workbuff[NAM$C_MAXRSS*1 + 1];
12657 int total_namelen = 3, counter, num_entries;
12658 /* ODS-5 ups this, but we want to be consistent, so... */
12659 int max_name_len = 39;
12660 AV *in_array = (AV *)SvRV(ST(0));
12662 num_entries = av_len(in_array);
12664 /* All the names start with PL_. */
12665 strcpy(ultimate_name, "PL_");
12667 /* Clean up our working buffer */
12668 Zero(work_name, sizeof(work_name), char);
12670 /* Run through the entries and build up a working name */
12671 for(counter = 0; counter <= num_entries; counter++) {
12672 /* If it's not the first name then tack on a __ */
12674 strcat(work_name, "__");
12676 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
12679 /* Check to see if we actually have to bother...*/
12680 if (strlen(work_name) + 3 <= max_name_len) {
12681 strcat(ultimate_name, work_name);
12683 /* It's too darned big, so we need to go strip. We use the same */
12684 /* algorithm as xsubpp does. First, strip out doubled __ */
12685 char *source, *dest, last;
12688 for (source = work_name; *source; source++) {
12689 if (last == *source && last == '_') {
12695 /* Go put it back */
12696 strcpy(work_name, workbuff);
12697 /* Is it still too big? */
12698 if (strlen(work_name) + 3 > max_name_len) {
12699 /* Strip duplicate letters */
12702 for (source = work_name; *source; source++) {
12703 if (last == toupper(*source)) {
12707 last = toupper(*source);
12709 strcpy(work_name, workbuff);
12712 /* Is it *still* too big? */
12713 if (strlen(work_name) + 3 > max_name_len) {
12714 /* Too bad, we truncate */
12715 work_name[max_name_len - 2] = 0;
12717 strcat(ultimate_name, work_name);
12720 /* Okay, return it */
12721 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12726 hushexit_fromperl(pTHX_ CV *cv)
12731 VMSISH_HUSHED = SvTRUE(ST(0));
12733 ST(0) = boolSV(VMSISH_HUSHED);
12739 Perl_vms_start_glob
12740 (pTHX_ SV *tmpglob,
12744 struct vs_str_st *rslt;
12748 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12751 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12752 struct dsc$descriptor_vs rsdsc;
12753 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12754 unsigned long hasver = 0, isunix = 0;
12755 unsigned long int lff_flags = 0;
12758 #ifdef VMS_LONGNAME_SUPPORT
12759 lff_flags = LIB$M_FIL_LONG_NAMES;
12761 /* The Newx macro will not allow me to assign a smaller array
12762 * to the rslt pointer, so we will assign it to the begin char pointer
12763 * and then copy the value into the rslt pointer.
12765 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12766 rslt = (struct vs_str_st *)begin;
12768 rstr = &rslt->str[0];
12769 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12770 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12771 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12772 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12774 Newx(vmsspec, VMS_MAXRSS, char);
12776 /* We could find out if there's an explicit dev/dir or version
12777 by peeking into lib$find_file's internal context at
12778 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12779 but that's unsupported, so I don't want to do it now and
12780 have it bite someone in the future. */
12781 /* Fix-me: vms_split_path() is the only way to do this, the
12782 existing method will fail with many legal EFS or UNIX specifications
12785 cp = SvPV(tmpglob,i);
12788 if (cp[i] == ';') hasver = 1;
12789 if (cp[i] == '.') {
12790 if (sts) hasver = 1;
12793 if (cp[i] == '/') {
12794 hasdir = isunix = 1;
12797 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12802 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12806 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12807 if (!stat_sts && S_ISDIR(st.st_mode)) {
12808 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12809 ok = (wilddsc.dsc$a_pointer != NULL);
12810 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12814 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12815 ok = (wilddsc.dsc$a_pointer != NULL);
12818 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12820 /* If not extended character set, replace ? with % */
12821 /* With extended character set, ? is a wildcard single character */
12822 if (!decc_efs_case_preserve) {
12823 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12824 if (*cp == '?') *cp = '%';
12827 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12828 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12829 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12831 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12832 &dfltdsc,NULL,&rms_sts,&lff_flags);
12833 if (!$VMS_STATUS_SUCCESS(sts))
12838 /* with varying string, 1st word of buffer contains result length */
12839 rstr[rslt->length] = '\0';
12841 /* Find where all the components are */
12842 v_sts = vms_split_path
12857 /* If no version on input, truncate the version on output */
12858 if (!hasver && (vs_len > 0)) {
12862 /* No version & a null extension on UNIX handling */
12863 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12869 if (!decc_efs_case_preserve) {
12870 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12874 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12878 /* Start with the name */
12881 strcat(begin,"\n");
12882 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12884 if (cxt) (void)lib$find_file_end(&cxt);
12887 /* Be POSIXish: return the input pattern when no matches */
12888 strcpy(rstr,SvPVX(tmpglob));
12890 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12893 if (ok && sts != RMS$_NMF &&
12894 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12897 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12899 PerlIO_close(tmpfp);
12903 PerlIO_rewind(tmpfp);
12904 IoTYPE(io) = IoTYPE_RDONLY;
12905 IoIFP(io) = fp = tmpfp;
12906 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12916 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12920 unixrealpath_fromperl(pTHX_ CV *cv)
12923 char *fspec, *rslt_spec, *rslt;
12926 if (!items || items != 1)
12927 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
12929 fspec = SvPV(ST(0),n_a);
12930 if (!fspec || !*fspec) XSRETURN_UNDEF;
12932 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12933 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12935 ST(0) = sv_newmortal();
12937 sv_usepvn(ST(0),rslt,strlen(rslt));
12939 Safefree(rslt_spec);
12944 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
12948 vmsrealpath_fromperl(pTHX_ CV *cv)
12951 char *fspec, *rslt_spec, *rslt;
12954 if (!items || items != 1)
12955 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
12957 fspec = SvPV(ST(0),n_a);
12958 if (!fspec || !*fspec) XSRETURN_UNDEF;
12960 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12961 rslt = do_vms_realname(fspec, rslt_spec, NULL);
12963 ST(0) = sv_newmortal();
12965 sv_usepvn(ST(0),rslt,strlen(rslt));
12967 Safefree(rslt_spec);
12973 * A thin wrapper around decc$symlink to make sure we follow the
12974 * standard and do not create a symlink with a zero-length name.
12976 /*{{{ int my_symlink(const char *path1, const char *path2)*/
12977 int my_symlink(const char *path1, const char *path2) {
12978 if (!path2 || !*path2) {
12979 SETERRNO(ENOENT, SS$_NOSUCHFILE);
12982 return symlink(path1, path2);
12986 #endif /* HAS_SYMLINK */
12988 int do_vms_case_tolerant(void);
12991 case_tolerant_process_fromperl(pTHX_ CV *cv)
12994 ST(0) = boolSV(do_vms_case_tolerant());
12999 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13000 struct interp_intern *dst)
13002 memcpy(dst,src,sizeof(struct interp_intern));
13006 Perl_sys_intern_clear(pTHX)
13011 Perl_sys_intern_init(pTHX)
13013 unsigned int ix = RAND_MAX;
13018 /* fix me later to track running under GNV */
13019 /* this allows some limited testing */
13020 MY_POSIX_EXIT = decc_filename_unix_report;
13023 MY_INV_RAND_MAX = 1./x;
13027 init_os_extras(void)
13030 char* file = __FILE__;
13031 if (decc_disable_to_vms_logname_translation) {
13032 no_translate_barewords = TRUE;
13034 no_translate_barewords = FALSE;
13037 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13038 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13039 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13040 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13041 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13042 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13043 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13044 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13045 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13046 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13047 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13048 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13049 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13050 newXSproto("VMS::Filespec::case_tolerant_process",
13051 case_tolerant_process_fromperl,file,"");
13053 store_pipelocs(aTHX); /* will redo any earlier attempts */
13058 #if __CRTL_VER == 80200000
13059 /* This missed getting in to the DECC SDK for 8.2 */
13060 char *realpath(const char *file_name, char * resolved_name, ...);
13063 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13064 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13065 * The perl fallback routine to provide realpath() is not as efficient
13069 /* Hack, use old stat() as fastest way of getting ino_t and device */
13070 int decc$stat(const char *name, void * statbuf);
13073 /* Realpath is fragile. In 8.3 it does not work if the feature
13074 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13075 * links are implemented in RMS, not the CRTL. It also can fail if the
13076 * user does not have read/execute access to some of the directories.
13077 * So in order for Do What I Mean mode to work, if realpath() fails,
13078 * fall back to looking up the filename by the device name and FID.
13081 int vms_fid_to_name(char * outname, int outlen, const char * name)
13085 unsigned short st_ino[3];
13086 unsigned short padw;
13087 unsigned long padl[30]; /* plenty of room */
13090 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13091 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13093 sts = decc$stat(name, &statbuf);
13096 dvidsc.dsc$a_pointer=statbuf.st_dev;
13097 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13099 specdsc.dsc$a_pointer = outname;
13100 specdsc.dsc$w_length = outlen-1;
13102 sts = lib$fid_to_name
13103 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13104 if ($VMS_STATUS_SUCCESS(sts)) {
13105 outname[specdsc.dsc$w_length] = 0;
13115 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13118 char * rslt = NULL;
13121 if (decc_posix_compliant_pathnames > 0 ) {
13122 /* realpath currently only works if posix compliant pathnames are
13123 * enabled. It may start working when they are not, but in that
13124 * case we still want the fallback behavior for backwards compatibility
13126 rslt = realpath(filespec, outbuf);
13130 if (rslt == NULL) {
13132 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13133 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13136 /* Fall back to fid_to_name */
13138 Newx(vms_spec, VMS_MAXRSS + 1, char);
13140 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13144 /* Now need to trim the version off */
13145 sts = vms_split_path
13165 /* Trim off the version */
13166 int file_len = v_len + r_len + d_len + n_len + e_len;
13167 vms_spec[file_len] = 0;
13169 /* The result is expected to be in UNIX format */
13170 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13172 /* Downcase if input had any lower case letters and
13173 * case preservation is not in effect.
13175 if (!decc_efs_case_preserve) {
13176 for (cp = filespec; *cp; cp++)
13177 if (islower(*cp)) { haslower = 1; break; }
13179 if (haslower) __mystrtolower(rslt);
13184 Safefree(vms_spec);
13190 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13193 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13194 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13197 /* Fall back to fid_to_name */
13199 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13206 /* Now need to trim the version off */
13207 sts = vms_split_path
13227 /* Trim off the version */
13228 int file_len = v_len + r_len + d_len + n_len + e_len;
13229 outbuf[file_len] = 0;
13231 /* Downcase if input had any lower case letters and
13232 * case preservation is not in effect.
13234 if (!decc_efs_case_preserve) {
13235 for (cp = filespec; *cp; cp++)
13236 if (islower(*cp)) { haslower = 1; break; }
13238 if (haslower) __mystrtolower(outbuf);
13247 /* External entry points */
13248 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13249 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13251 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13252 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13254 /* case_tolerant */
13256 /*{{{int do_vms_case_tolerant(void)*/
13257 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13258 * controlled by a process setting.
13260 int do_vms_case_tolerant(void)
13262 return vms_process_case_tolerant;
13265 /* External entry points */
13266 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13267 int Perl_vms_case_tolerant(void)
13268 { return do_vms_case_tolerant(); }
13270 int Perl_vms_case_tolerant(void)
13271 { return vms_process_case_tolerant; }
13275 /* Start of DECC RTL Feature handling */
13277 static int sys_trnlnm
13278 (const char * logname,
13282 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13283 const unsigned long attr = LNM$M_CASE_BLIND;
13284 struct dsc$descriptor_s name_dsc;
13286 unsigned short result;
13287 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13290 name_dsc.dsc$w_length = strlen(logname);
13291 name_dsc.dsc$a_pointer = (char *)logname;
13292 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13293 name_dsc.dsc$b_class = DSC$K_CLASS_S;
13295 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13297 if ($VMS_STATUS_SUCCESS(status)) {
13299 /* Null terminate and return the string */
13300 /*--------------------------------------*/
13307 static int sys_crelnm
13308 (const char * logname,
13309 const char * value)
13312 const char * proc_table = "LNM$PROCESS_TABLE";
13313 struct dsc$descriptor_s proc_table_dsc;
13314 struct dsc$descriptor_s logname_dsc;
13315 struct itmlst_3 item_list[2];
13317 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13318 proc_table_dsc.dsc$w_length = strlen(proc_table);
13319 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13320 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13322 logname_dsc.dsc$a_pointer = (char *) logname;
13323 logname_dsc.dsc$w_length = strlen(logname);
13324 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13325 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13327 item_list[0].buflen = strlen(value);
13328 item_list[0].itmcode = LNM$_STRING;
13329 item_list[0].bufadr = (char *)value;
13330 item_list[0].retlen = NULL;
13332 item_list[1].buflen = 0;
13333 item_list[1].itmcode = 0;
13335 ret_val = sys$crelnm
13337 (const struct dsc$descriptor_s *)&proc_table_dsc,
13338 (const struct dsc$descriptor_s *)&logname_dsc,
13340 (const struct item_list_3 *) item_list);
13345 /* C RTL Feature settings */
13347 static int set_features
13348 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
13349 int (* cli_routine)(void), /* Not documented */
13350 void *image_info) /* Not documented */
13357 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13358 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13359 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13360 unsigned long case_perm;
13361 unsigned long case_image;
13364 /* Allow an exception to bring Perl into the VMS debugger */
13365 vms_debug_on_exception = 0;
13366 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13367 if ($VMS_STATUS_SUCCESS(status)) {
13368 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13369 vms_debug_on_exception = 1;
13371 vms_debug_on_exception = 0;
13374 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13375 vms_vtf7_filenames = 0;
13376 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13377 if ($VMS_STATUS_SUCCESS(status)) {
13378 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13379 vms_vtf7_filenames = 1;
13381 vms_vtf7_filenames = 0;
13385 /* unlink all versions on unlink() or rename() */
13386 vms_unlink_all_versions = 0;
13387 status = sys_trnlnm
13388 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13389 if ($VMS_STATUS_SUCCESS(status)) {
13390 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13391 vms_unlink_all_versions = 1;
13393 vms_unlink_all_versions = 0;
13396 /* Dectect running under GNV Bash or other UNIX like shell */
13397 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13398 gnv_unix_shell = 0;
13399 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13400 if ($VMS_STATUS_SUCCESS(status)) {
13401 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13402 gnv_unix_shell = 1;
13403 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13404 set_feature_default("DECC$EFS_CHARSET", 1);
13405 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13406 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13407 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13408 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13409 vms_unlink_all_versions = 1;
13412 gnv_unix_shell = 0;
13416 /* hacks to see if known bugs are still present for testing */
13418 /* Readdir is returning filenames in VMS syntax always */
13419 decc_bug_readdir_efs1 = 1;
13420 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13421 if ($VMS_STATUS_SUCCESS(status)) {
13422 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13423 decc_bug_readdir_efs1 = 1;
13425 decc_bug_readdir_efs1 = 0;
13428 /* PCP mode requires creating /dev/null special device file */
13429 decc_bug_devnull = 0;
13430 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13431 if ($VMS_STATUS_SUCCESS(status)) {
13432 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13433 decc_bug_devnull = 1;
13435 decc_bug_devnull = 0;
13438 /* fgetname returning a VMS name in UNIX mode */
13439 decc_bug_fgetname = 1;
13440 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13441 if ($VMS_STATUS_SUCCESS(status)) {
13442 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13443 decc_bug_fgetname = 1;
13445 decc_bug_fgetname = 0;
13448 /* UNIX directory names with no paths are broken in a lot of places */
13449 decc_dir_barename = 1;
13450 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13451 if ($VMS_STATUS_SUCCESS(status)) {
13452 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13453 decc_dir_barename = 1;
13455 decc_dir_barename = 0;
13458 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13459 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13461 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13462 if (decc_disable_to_vms_logname_translation < 0)
13463 decc_disable_to_vms_logname_translation = 0;
13466 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13468 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13469 if (decc_efs_case_preserve < 0)
13470 decc_efs_case_preserve = 0;
13473 s = decc$feature_get_index("DECC$EFS_CHARSET");
13475 decc_efs_charset = decc$feature_get_value(s, 1);
13476 if (decc_efs_charset < 0)
13477 decc_efs_charset = 0;
13480 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13482 decc_filename_unix_report = decc$feature_get_value(s, 1);
13483 if (decc_filename_unix_report > 0)
13484 decc_filename_unix_report = 1;
13486 decc_filename_unix_report = 0;
13489 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13491 decc_filename_unix_only = decc$feature_get_value(s, 1);
13492 if (decc_filename_unix_only > 0) {
13493 decc_filename_unix_only = 1;
13496 decc_filename_unix_only = 0;
13500 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13502 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13503 if (decc_filename_unix_no_version < 0)
13504 decc_filename_unix_no_version = 0;
13507 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13509 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13510 if (decc_readdir_dropdotnotype < 0)
13511 decc_readdir_dropdotnotype = 0;
13514 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13515 if ($VMS_STATUS_SUCCESS(status)) {
13516 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13518 dflt = decc$feature_get_value(s, 4);
13520 decc_disable_posix_root = decc$feature_get_value(s, 1);
13521 if (decc_disable_posix_root <= 0) {
13522 decc$feature_set_value(s, 1, 1);
13523 decc_disable_posix_root = 1;
13527 /* Traditionally Perl assumes this is off */
13528 decc_disable_posix_root = 1;
13529 decc$feature_set_value(s, 1, 1);
13534 #if __CRTL_VER >= 80200000
13535 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13537 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13538 if (decc_posix_compliant_pathnames < 0)
13539 decc_posix_compliant_pathnames = 0;
13540 if (decc_posix_compliant_pathnames > 4)
13541 decc_posix_compliant_pathnames = 0;
13546 status = sys_trnlnm
13547 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13548 if ($VMS_STATUS_SUCCESS(status)) {
13549 val_str[0] = _toupper(val_str[0]);
13550 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13551 decc_disable_to_vms_logname_translation = 1;
13556 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13557 if ($VMS_STATUS_SUCCESS(status)) {
13558 val_str[0] = _toupper(val_str[0]);
13559 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13560 decc_efs_case_preserve = 1;
13565 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13566 if ($VMS_STATUS_SUCCESS(status)) {
13567 val_str[0] = _toupper(val_str[0]);
13568 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13569 decc_filename_unix_report = 1;
13572 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", 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_filename_unix_only = 1;
13577 decc_filename_unix_report = 1;
13580 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13581 if ($VMS_STATUS_SUCCESS(status)) {
13582 val_str[0] = _toupper(val_str[0]);
13583 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13584 decc_filename_unix_no_version = 1;
13587 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13588 if ($VMS_STATUS_SUCCESS(status)) {
13589 val_str[0] = _toupper(val_str[0]);
13590 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13591 decc_readdir_dropdotnotype = 1;
13596 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13598 /* Report true case tolerance */
13599 /*----------------------------*/
13600 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13601 if (!$VMS_STATUS_SUCCESS(status))
13602 case_perm = PPROP$K_CASE_BLIND;
13603 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13604 if (!$VMS_STATUS_SUCCESS(status))
13605 case_image = PPROP$K_CASE_BLIND;
13606 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13607 (case_image == PPROP$K_CASE_SENSITIVE))
13608 vms_process_case_tolerant = 0;
13613 /* CRTL can be initialized past this point, but not before. */
13614 /* DECC$CRTL_INIT(); */
13621 #pragma extern_model save
13622 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13623 const __align (LONGWORD) int spare[8] = {0};
13625 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13626 #if __DECC_VER >= 60560002
13627 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13629 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13631 #endif /* __DECC */
13633 const long vms_cc_features = (const long)set_features;
13636 ** Force a reference to LIB$INITIALIZE to ensure it
13637 ** exists in the image.
13639 int lib$initialize(void);
13641 #pragma extern_model strict_refdef
13643 int lib_init_ref = (int) lib$initialize;
13646 #pragma extern_model restore