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.
21 * "The Lay of Leithian", Canto II, lines 135-40
23 * [p.162 of _The Lays of Beleriand_]
32 #include <climsgdef.h>
43 #include <libclidef.h>
45 #include <lib$routines.h>
49 #if __CRTL_VER >= 70301000 && !defined(__VAX)
59 #include <str$routines.h>
66 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
68 #define NO_EFN EFN$C_ENF
73 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
74 int decc$feature_get_index(const char *name);
75 char* decc$feature_get_name(int index);
76 int decc$feature_get_value(int index, int mode);
77 int decc$feature_set_value(int index, int mode, int value);
82 #pragma member_alignment save
83 #pragma nomember_alignment longword
88 unsigned short * retadr;
90 #pragma member_alignment restore
92 /* More specific prototype than in starlet_c.h makes programming errors
100 const struct dsc$descriptor_s * devnam,
101 const struct item_list_3 * itmlst,
103 void * (astadr)(unsigned long),
108 #ifdef sys$get_security
109 #undef sys$get_security
111 (const struct dsc$descriptor_s * clsnam,
112 const struct dsc$descriptor_s * objnam,
113 const unsigned int *objhan,
115 const struct item_list_3 * itmlst,
116 unsigned int * contxt,
117 const unsigned int * acmode);
120 #ifdef sys$set_security
121 #undef sys$set_security
123 (const struct dsc$descriptor_s * clsnam,
124 const struct dsc$descriptor_s * objnam,
125 const unsigned int *objhan,
127 const struct item_list_3 * itmlst,
128 unsigned int * contxt,
129 const unsigned int * acmode);
132 #ifdef lib$find_image_symbol
133 #undef lib$find_image_symbol
134 int lib$find_image_symbol
135 (const struct dsc$descriptor_s * imgname,
136 const struct dsc$descriptor_s * symname,
138 const struct dsc$descriptor_s * defspec,
142 #ifdef lib$rename_file
143 #undef lib$rename_file
145 (const struct dsc$descriptor_s * old_file_dsc,
146 const struct dsc$descriptor_s * new_file_dsc,
147 const struct dsc$descriptor_s * default_file_dsc,
148 const struct dsc$descriptor_s * related_file_dsc,
149 const unsigned long * flags,
150 void * (success)(const struct dsc$descriptor_s * old_dsc,
151 const struct dsc$descriptor_s * new_dsc,
153 void * (error)(const struct dsc$descriptor_s * old_dsc,
154 const struct dsc$descriptor_s * new_dsc,
157 const int * error_src,
158 const void * usr_arg),
159 int (confirm)(const struct dsc$descriptor_s * old_dsc,
160 const struct dsc$descriptor_s * new_dsc,
161 const void * old_fab,
162 const void * usr_arg),
164 struct dsc$descriptor_s * old_result_name_dsc,
165 struct dsc$descriptor_s * new_result_name_dsc,
166 unsigned long * file_scan_context);
169 #if __CRTL_VER >= 70300000 && !defined(__VAX)
171 static int set_feature_default(const char *name, int value)
176 index = decc$feature_get_index(name);
178 status = decc$feature_set_value(index, 1, value);
179 if (index == -1 || (status == -1)) {
183 status = decc$feature_get_value(index, 1);
184 if (status != value) {
192 /* Older versions of ssdef.h don't have these */
193 #ifndef SS$_INVFILFOROP
194 # define SS$_INVFILFOROP 3930
196 #ifndef SS$_NOSUCHOBJECT
197 # define SS$_NOSUCHOBJECT 2696
200 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
201 #define PERLIO_NOT_STDIO 0
203 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
204 * code below needs to get to the underlying CRTL routines. */
205 #define DONT_MASK_RTL_CALLS
209 /* Anticipating future expansion in lexical warnings . . . */
210 #ifndef WARN_INTERNAL
211 # define WARN_INTERNAL WARN_MISC
214 #ifdef VMS_LONGNAME_SUPPORT
215 #include <libfildef.h>
218 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
219 # define RTL_USES_UTC 1
222 /* Routine to create a decterm for use with the Perl debugger */
223 /* No headers, this information was found in the Programming Concepts Manual */
225 static int (*decw_term_port)
226 (const struct dsc$descriptor_s * display,
227 const struct dsc$descriptor_s * setup_file,
228 const struct dsc$descriptor_s * customization,
229 struct dsc$descriptor_s * result_device_name,
230 unsigned short * result_device_name_length,
233 void * char_change_buffer) = 0;
235 /* gcc's header files don't #define direct access macros
236 * corresponding to VAXC's variant structs */
238 # define uic$v_format uic$r_uic_form.uic$v_format
239 # define uic$v_group uic$r_uic_form.uic$v_group
240 # define uic$v_member uic$r_uic_form.uic$v_member
241 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
242 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
243 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
244 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
247 #if defined(NEED_AN_H_ERRNO)
252 #pragma message disable pragma
253 #pragma member_alignment save
254 #pragma nomember_alignment longword
256 #pragma message disable misalgndmem
259 unsigned short int buflen;
260 unsigned short int itmcode;
262 unsigned short int *retlen;
265 struct filescan_itmlst_2 {
266 unsigned short length;
267 unsigned short itmcode;
272 unsigned short length;
277 #pragma message restore
278 #pragma member_alignment restore
281 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
282 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
283 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
284 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
285 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
286 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
287 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
288 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
289 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
290 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
291 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
292 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
294 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
295 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
296 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
297 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
299 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
300 #define PERL_LNM_MAX_ALLOWED_INDEX 127
302 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
303 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
306 #define PERL_LNM_MAX_ITER 10
308 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
309 #if __CRTL_VER >= 70302000 && !defined(__VAX)
310 #define MAX_DCL_SYMBOL (8192)
311 #define MAX_DCL_LINE_LENGTH (4096 - 4)
313 #define MAX_DCL_SYMBOL (1024)
314 #define MAX_DCL_LINE_LENGTH (1024 - 4)
317 static char *__mystrtolower(char *str)
319 if (str) for (; *str; ++str) *str= tolower(*str);
323 static struct dsc$descriptor_s fildevdsc =
324 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
325 static struct dsc$descriptor_s crtlenvdsc =
326 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
327 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
328 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
329 static struct dsc$descriptor_s **env_tables = defenv;
330 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
332 /* True if we shouldn't treat barewords as logicals during directory */
334 static int no_translate_barewords;
337 static int tz_updated = 1;
340 /* DECC Features that may need to affect how Perl interprets
341 * displays filename information
343 static int decc_disable_to_vms_logname_translation = 1;
344 static int decc_disable_posix_root = 1;
345 int decc_efs_case_preserve = 0;
346 static int decc_efs_charset = 0;
347 static int decc_filename_unix_no_version = 0;
348 static int decc_filename_unix_only = 0;
349 int decc_filename_unix_report = 0;
350 int decc_posix_compliant_pathnames = 0;
351 int decc_readdir_dropdotnotype = 0;
352 static int vms_process_case_tolerant = 1;
353 int vms_vtf7_filenames = 0;
354 int gnv_unix_shell = 0;
355 static int vms_unlink_all_versions = 0;
356 static int vms_posix_exit = 0;
358 /* bug workarounds if needed */
359 int decc_bug_readdir_efs1 = 0;
360 int decc_bug_devnull = 1;
361 int decc_bug_fgetname = 0;
362 int decc_dir_barename = 0;
364 static int vms_debug_on_exception = 0;
366 /* Is this a UNIX file specification?
367 * No longer a simple check with EFS file specs
368 * For now, not a full check, but need to
369 * handle POSIX ^UP^ specifications
370 * Fixing to handle ^/ cases would require
371 * changes to many other conversion routines.
374 static int is_unix_filespec(const char *path)
380 if (strncmp(path,"\"^UP^",5) != 0) {
381 pch1 = strchr(path, '/');
386 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
387 if (decc_filename_unix_report || decc_filename_unix_only) {
388 if (strcmp(path,".") == 0)
396 /* This routine converts a UCS-2 character to be VTF-7 encoded.
399 static void ucs2_to_vtf7
401 unsigned long ucs2_char,
404 unsigned char * ucs_ptr;
407 ucs_ptr = (unsigned char *)&ucs2_char;
411 hex = (ucs_ptr[1] >> 4) & 0xf;
413 outspec[2] = hex + '0';
415 outspec[2] = (hex - 9) + 'A';
416 hex = ucs_ptr[1] & 0xF;
418 outspec[3] = hex + '0';
420 outspec[3] = (hex - 9) + 'A';
422 hex = (ucs_ptr[0] >> 4) & 0xf;
424 outspec[4] = hex + '0';
426 outspec[4] = (hex - 9) + 'A';
427 hex = ucs_ptr[1] & 0xF;
429 outspec[5] = hex + '0';
431 outspec[5] = (hex - 9) + 'A';
437 /* This handles the conversion of a UNIX extended character set to a ^
438 * escaped VMS character.
439 * in a UNIX file specification.
441 * The output count variable contains the number of characters added
442 * to the output string.
444 * The return value is the number of characters read from the input string
446 static int copy_expand_unix_filename_escape
447 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
455 utf8_flag = *utf8_fl;
459 if (*inspec >= 0x80) {
460 if (utf8_fl && vms_vtf7_filenames) {
461 unsigned long ucs_char;
465 if ((*inspec & 0xE0) == 0xC0) {
467 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
468 if (ucs_char >= 0x80) {
469 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
472 } else if ((*inspec & 0xF0) == 0xE0) {
474 ucs_char = ((inspec[0] & 0xF) << 12) +
475 ((inspec[1] & 0x3f) << 6) +
477 if (ucs_char >= 0x800) {
478 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
482 #if 0 /* I do not see longer sequences supported by OpenVMS */
483 /* Maybe some one can fix this later */
484 } else if ((*inspec & 0xF8) == 0xF0) {
487 } else if ((*inspec & 0xFC) == 0xF8) {
490 } else if ((*inspec & 0xFE) == 0xFC) {
497 /* High bit set, but not a Unicode character! */
499 /* Non printing DECMCS or ISO Latin-1 character? */
500 if (*inspec <= 0x9F) {
504 hex = (*inspec >> 4) & 0xF;
506 outspec[1] = hex + '0';
508 outspec[1] = (hex - 9) + 'A';
512 outspec[2] = hex + '0';
514 outspec[2] = (hex - 9) + 'A';
518 } else if (*inspec == 0xA0) {
524 } else if (*inspec == 0xFF) {
536 /* Is this a macro that needs to be passed through?
537 * Macros start with $( and an alpha character, followed
538 * by a string of alpha numeric characters ending with a )
539 * If this does not match, then encode it as ODS-5.
541 if ((inspec[0] == '$') && (inspec[1] == '(')) {
544 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
546 outspec[0] = inspec[0];
547 outspec[1] = inspec[1];
548 outspec[2] = inspec[2];
550 while(isalnum(inspec[tcnt]) ||
551 (inspec[2] == '.') || (inspec[2] == '_')) {
552 outspec[tcnt] = inspec[tcnt];
555 if (inspec[tcnt] == ')') {
556 outspec[tcnt] = inspec[tcnt];
573 if (decc_efs_charset == 0)
599 /* Don't escape again if following character is
600 * already something we escape.
602 if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) {
608 /* But otherwise fall through and escape it. */
610 /* Assume that this is to be escaped */
612 outspec[1] = *inspec;
616 case ' ': /* space */
617 /* Assume that this is to be escaped */
632 /* This handles the expansion of a '^' prefix to the proper character
633 * in a UNIX file specification.
635 * The output count variable contains the number of characters added
636 * to the output string.
638 * The return value is the number of characters read from the input
641 static int copy_expand_vms_filename_escape
642 (char *outspec, const char *inspec, int *output_cnt)
649 if (*inspec == '^') {
652 /* Spaces and non-trailing dots should just be passed through,
653 * but eat the escape character.
660 case '_': /* space */
666 /* Hmm. Better leave the escape escaped. */
672 case 'U': /* Unicode - FIX-ME this is wrong. */
675 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
678 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
679 outspec[0] == c1 & 0xff;
680 outspec[1] == c2 & 0xff;
687 /* Error - do best we can to continue */
697 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
701 scnt = sscanf(inspec, "%2x", &c1);
702 outspec[0] = c1 & 0xff;
726 (const struct dsc$descriptor_s * srcstr,
727 struct filescan_itmlst_2 * valuelist,
728 unsigned long * fldflags,
729 struct dsc$descriptor_s *auxout,
730 unsigned short * retlen);
733 /* vms_split_path - Verify that the input file specification is a
734 * VMS format file specification, and provide pointers to the components of
735 * it. With EFS format filenames, this is virtually the only way to
736 * parse a VMS path specification into components.
738 * If the sum of the components do not add up to the length of the
739 * string, then the passed file specification is probably a UNIX style
742 static int vms_split_path
757 struct dsc$descriptor path_desc;
761 struct filescan_itmlst_2 item_list[9];
762 const int filespec = 0;
763 const int nodespec = 1;
764 const int devspec = 2;
765 const int rootspec = 3;
766 const int dirspec = 4;
767 const int namespec = 5;
768 const int typespec = 6;
769 const int verspec = 7;
771 /* Assume the worst for an easy exit */
786 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
787 path_desc.dsc$w_length = strlen(path);
788 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
789 path_desc.dsc$b_class = DSC$K_CLASS_S;
791 /* Get the total length, if it is shorter than the string passed
792 * then this was probably not a VMS formatted file specification
794 item_list[filespec].itmcode = FSCN$_FILESPEC;
795 item_list[filespec].length = 0;
796 item_list[filespec].component = NULL;
798 /* If the node is present, then it gets considered as part of the
799 * volume name to hopefully make things simple.
801 item_list[nodespec].itmcode = FSCN$_NODE;
802 item_list[nodespec].length = 0;
803 item_list[nodespec].component = NULL;
805 item_list[devspec].itmcode = FSCN$_DEVICE;
806 item_list[devspec].length = 0;
807 item_list[devspec].component = NULL;
809 /* root is a special case, adding it to either the directory or
810 * the device components will probalby complicate things for the
811 * callers of this routine, so leave it separate.
813 item_list[rootspec].itmcode = FSCN$_ROOT;
814 item_list[rootspec].length = 0;
815 item_list[rootspec].component = NULL;
817 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
818 item_list[dirspec].length = 0;
819 item_list[dirspec].component = NULL;
821 item_list[namespec].itmcode = FSCN$_NAME;
822 item_list[namespec].length = 0;
823 item_list[namespec].component = NULL;
825 item_list[typespec].itmcode = FSCN$_TYPE;
826 item_list[typespec].length = 0;
827 item_list[typespec].component = NULL;
829 item_list[verspec].itmcode = FSCN$_VERSION;
830 item_list[verspec].length = 0;
831 item_list[verspec].component = NULL;
833 item_list[8].itmcode = 0;
834 item_list[8].length = 0;
835 item_list[8].component = NULL;
837 status = sys$filescan
838 ((const struct dsc$descriptor_s *)&path_desc, item_list,
840 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
842 /* If we parsed it successfully these two lengths should be the same */
843 if (path_desc.dsc$w_length != item_list[filespec].length)
846 /* If we got here, then it is a VMS file specification */
849 /* set the volume name */
850 if (item_list[nodespec].length > 0) {
851 *volume = item_list[nodespec].component;
852 *vol_len = item_list[nodespec].length + item_list[devspec].length;
855 *volume = item_list[devspec].component;
856 *vol_len = item_list[devspec].length;
859 *root = item_list[rootspec].component;
860 *root_len = item_list[rootspec].length;
862 *dir = item_list[dirspec].component;
863 *dir_len = item_list[dirspec].length;
865 /* Now fun with versions and EFS file specifications
866 * The parser can not tell the difference when a "." is a version
867 * delimiter or a part of the file specification.
869 if ((decc_efs_charset) &&
870 (item_list[verspec].length > 0) &&
871 (item_list[verspec].component[0] == '.')) {
872 *name = item_list[namespec].component;
873 *name_len = item_list[namespec].length + item_list[typespec].length;
874 *ext = item_list[verspec].component;
875 *ext_len = item_list[verspec].length;
880 *name = item_list[namespec].component;
881 *name_len = item_list[namespec].length;
882 *ext = item_list[typespec].component;
883 *ext_len = item_list[typespec].length;
884 *version = item_list[verspec].component;
885 *ver_len = item_list[verspec].length;
892 * Routine to retrieve the maximum equivalence index for an input
893 * logical name. Some calls to this routine have no knowledge if
894 * the variable is a logical or not. So on error we return a max
897 /*{{{int my_maxidx(const char *lnm) */
899 my_maxidx(const char *lnm)
903 int attr = LNM$M_CASE_BLIND;
904 struct dsc$descriptor lnmdsc;
905 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
908 lnmdsc.dsc$w_length = strlen(lnm);
909 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
910 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
911 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
913 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
914 if ((status & 1) == 0)
921 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
923 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
924 struct dsc$descriptor_s **tabvec, unsigned long int flags)
927 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
928 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
929 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
931 unsigned char acmode;
932 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
933 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
934 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
935 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
937 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
938 #if defined(PERL_IMPLICIT_CONTEXT)
941 aTHX = PERL_GET_INTERP;
947 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
948 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
950 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
951 *cp2 = _toupper(*cp1);
952 if (cp1 - lnm > LNM$C_NAMLENGTH) {
953 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
957 lnmdsc.dsc$w_length = cp1 - lnm;
958 lnmdsc.dsc$a_pointer = uplnm;
959 uplnm[lnmdsc.dsc$w_length] = '\0';
960 secure = flags & PERL__TRNENV_SECURE;
961 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
962 if (!tabvec || !*tabvec) tabvec = env_tables;
964 for (curtab = 0; tabvec[curtab]; curtab++) {
965 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
966 if (!ivenv && !secure) {
971 Perl_warn(aTHX_ "Can't read CRTL environ\n");
974 retsts = SS$_NOLOGNAM;
975 for (i = 0; environ[i]; i++) {
976 if ((eq = strchr(environ[i],'=')) &&
977 lnmdsc.dsc$w_length == (eq - environ[i]) &&
978 !strncmp(environ[i],uplnm,eq - environ[i])) {
980 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
981 if (!eqvlen) continue;
986 if (retsts != SS$_NOLOGNAM) break;
989 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
990 !str$case_blind_compare(&tmpdsc,&clisym)) {
991 if (!ivsym && !secure) {
992 unsigned short int deflen = LNM$C_NAMLENGTH;
993 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
994 /* dynamic dsc to accomodate possible long value */
995 _ckvmssts(lib$sget1_dd(&deflen,&eqvdsc));
996 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
998 if (eqvlen > MAX_DCL_SYMBOL) {
999 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1000 eqvlen = MAX_DCL_SYMBOL;
1001 /* Special hack--we might be called before the interpreter's */
1002 /* fully initialized, in which case either thr or PL_curcop */
1003 /* might be bogus. We have to check, since ckWARN needs them */
1004 /* both to be valid if running threaded */
1005 if (ckWARN(WARN_MISC)) {
1006 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1009 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1011 _ckvmssts(lib$sfree1_dd(&eqvdsc));
1012 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1013 if (retsts == LIB$_NOSUCHSYM) continue;
1018 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1019 midx = my_maxidx(lnm);
1020 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1021 lnmlst[1].bufadr = cp2;
1023 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1024 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1025 if (retsts == SS$_NOLOGNAM) break;
1026 /* PPFs have a prefix */
1029 *((int *)uplnm) == *((int *)"SYS$") &&
1031 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1032 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1033 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1034 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1035 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1036 memmove(eqv,eqv+4,eqvlen-4);
1042 if ((retsts == SS$_IVLOGNAM) ||
1043 (retsts == SS$_NOLOGNAM)) { continue; }
1046 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1047 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1048 if (retsts == SS$_NOLOGNAM) continue;
1051 eqvlen = strlen(eqv);
1055 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1056 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1057 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1058 retsts == SS$_NOLOGNAM) {
1059 set_errno(EINVAL); set_vaxc_errno(retsts);
1061 else _ckvmssts(retsts);
1063 } /* end of vmstrnenv */
1066 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1067 /* Define as a function so we can access statics. */
1068 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1070 return vmstrnenv(lnm,eqv,idx,fildev,
1071 #ifdef SECURE_INTERNAL_GETENV
1072 (PL_curinterp ? PL_tainting : will_taint) ? PERL__TRNENV_SECURE : 0
1081 * Note: Uses Perl temp to store result so char * can be returned to
1082 * caller; this pointer will be invalidated at next Perl statement
1084 * We define this as a function rather than a macro in terms of my_getenv_len()
1085 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1088 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1090 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1093 static char *__my_getenv_eqv = NULL;
1094 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1095 unsigned long int idx = 0;
1096 int trnsuccess, success, secure, saverr, savvmserr;
1100 midx = my_maxidx(lnm) + 1;
1102 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1103 /* Set up a temporary buffer for the return value; Perl will
1104 * clean it up at the next statement transition */
1105 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1106 if (!tmpsv) return NULL;
1110 /* Assume no interpreter ==> single thread */
1111 if (__my_getenv_eqv != NULL) {
1112 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1115 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1117 eqv = __my_getenv_eqv;
1120 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1121 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1123 getcwd(eqv,LNM$C_NAMLENGTH);
1127 /* Get rid of "000000/ in rooted filespecs */
1130 zeros = strstr(eqv, "/000000/");
1131 if (zeros != NULL) {
1133 mlen = len - (zeros - eqv) - 7;
1134 memmove(zeros, &zeros[7], mlen);
1142 /* Impose security constraints only if tainting */
1144 /* Impose security constraints only if tainting */
1145 secure = PL_curinterp ? PL_tainting : will_taint;
1146 saverr = errno; savvmserr = vaxc$errno;
1153 #ifdef SECURE_INTERNAL_GETENV
1154 secure ? PERL__TRNENV_SECURE : 0
1160 /* For the getenv interface we combine all the equivalence names
1161 * of a search list logical into one value to acquire a maximum
1162 * value length of 255*128 (assuming %ENV is using logicals).
1164 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1166 /* If the name contains a semicolon-delimited index, parse it
1167 * off and make sure we only retrieve the equivalence name for
1169 if ((cp2 = strchr(lnm,';')) != NULL) {
1171 uplnm[cp2-lnm] = '\0';
1172 idx = strtoul(cp2+1,NULL,0);
1174 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1177 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1179 /* Discard NOLOGNAM on internal calls since we're often looking
1180 * for an optional name, and this "error" often shows up as the
1181 * (bogus) exit status for a die() call later on. */
1182 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1183 return success ? eqv : NULL;
1186 } /* end of my_getenv() */
1190 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1192 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1196 unsigned long idx = 0;
1198 static char *__my_getenv_len_eqv = NULL;
1199 int secure, saverr, savvmserr;
1202 midx = my_maxidx(lnm) + 1;
1204 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1205 /* Set up a temporary buffer for the return value; Perl will
1206 * clean it up at the next statement transition */
1207 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1208 if (!tmpsv) return NULL;
1212 /* Assume no interpreter ==> single thread */
1213 if (__my_getenv_len_eqv != NULL) {
1214 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1217 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1219 buf = __my_getenv_len_eqv;
1222 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1223 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1226 getcwd(buf,LNM$C_NAMLENGTH);
1229 /* Get rid of "000000/ in rooted filespecs */
1231 zeros = strstr(buf, "/000000/");
1232 if (zeros != NULL) {
1234 mlen = *len - (zeros - buf) - 7;
1235 memmove(zeros, &zeros[7], mlen);
1244 /* Impose security constraints only if tainting */
1245 secure = PL_curinterp ? PL_tainting : will_taint;
1246 saverr = errno; savvmserr = vaxc$errno;
1253 #ifdef SECURE_INTERNAL_GETENV
1254 secure ? PERL__TRNENV_SECURE : 0
1260 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1262 if ((cp2 = strchr(lnm,';')) != NULL) {
1264 buf[cp2-lnm] = '\0';
1265 idx = strtoul(cp2+1,NULL,0);
1267 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1270 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1272 /* Get rid of "000000/ in rooted filespecs */
1275 zeros = strstr(buf, "/000000/");
1276 if (zeros != NULL) {
1278 mlen = *len - (zeros - buf) - 7;
1279 memmove(zeros, &zeros[7], mlen);
1285 /* Discard NOLOGNAM on internal calls since we're often looking
1286 * for an optional name, and this "error" often shows up as the
1287 * (bogus) exit status for a die() call later on. */
1288 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1289 return *len ? buf : NULL;
1292 } /* end of my_getenv_len() */
1295 static void create_mbx(pTHX_ unsigned short int *, struct dsc$descriptor_s *);
1297 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1299 /*{{{ void prime_env_iter() */
1301 prime_env_iter(void)
1302 /* Fill the %ENV associative array with all logical names we can
1303 * find, in preparation for iterating over it.
1306 static int primed = 0;
1307 HV *seenhv = NULL, *envhv;
1309 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1310 unsigned short int chan;
1311 #ifndef CLI$M_TRUSTED
1312 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1314 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1315 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1317 bool have_sym = FALSE, have_lnm = FALSE;
1318 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1319 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1320 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1321 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1322 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1323 #if defined(PERL_IMPLICIT_CONTEXT)
1326 #if defined(USE_ITHREADS)
1327 static perl_mutex primenv_mutex;
1328 MUTEX_INIT(&primenv_mutex);
1331 #if defined(PERL_IMPLICIT_CONTEXT)
1332 /* We jump through these hoops because we can be called at */
1333 /* platform-specific initialization time, which is before anything is */
1334 /* set up--we can't even do a plain dTHX since that relies on the */
1335 /* interpreter structure to be initialized */
1337 aTHX = PERL_GET_INTERP;
1343 if (primed || !PL_envgv) return;
1344 MUTEX_LOCK(&primenv_mutex);
1345 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1346 envhv = GvHVn(PL_envgv);
1347 /* Perform a dummy fetch as an lval to insure that the hash table is
1348 * set up. Otherwise, the hv_store() will turn into a nullop. */
1349 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1351 for (i = 0; env_tables[i]; i++) {
1352 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1353 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1354 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1356 if (have_sym || have_lnm) {
1357 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1358 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1359 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1360 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1363 for (i--; i >= 0; i--) {
1364 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1367 for (j = 0; environ[j]; j++) {
1368 if (!(start = strchr(environ[j],'='))) {
1369 if (ckWARN(WARN_INTERNAL))
1370 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1374 sv = newSVpv(start,0);
1376 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1381 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1382 !str$case_blind_compare(&tmpdsc,&clisym)) {
1383 strcpy(cmd,"Show Symbol/Global *");
1384 cmddsc.dsc$w_length = 20;
1385 if (env_tables[i]->dsc$w_length == 12 &&
1386 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1387 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1388 flags = defflags | CLI$M_NOLOGNAM;
1391 strcpy(cmd,"Show Logical *");
1392 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1393 strcat(cmd," /Table=");
1394 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1395 cmddsc.dsc$w_length = strlen(cmd);
1397 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1398 flags = defflags | CLI$M_NOCLISYM;
1401 /* Create a new subprocess to execute each command, to exclude the
1402 * remote possibility that someone could subvert a mbx or file used
1403 * to write multiple commands to a single subprocess.
1406 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1407 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1408 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1409 defflags &= ~CLI$M_TRUSTED;
1410 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1412 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1413 if (seenhv) SvREFCNT_dec(seenhv);
1416 char *cp1, *cp2, *key;
1417 unsigned long int sts, iosb[2], retlen, keylen;
1420 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1421 if (sts & 1) sts = iosb[0] & 0xffff;
1422 if (sts == SS$_ENDOFFILE) {
1424 while (substs == 0) { sys$hiber(); wakect++;}
1425 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1430 retlen = iosb[0] >> 16;
1431 if (!retlen) continue; /* blank line */
1433 if (iosb[1] != subpid) {
1435 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1439 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1440 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1442 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1443 if (*cp1 == '(' || /* Logical name table name */
1444 *cp1 == '=' /* Next eqv of searchlist */) continue;
1445 if (*cp1 == '"') cp1++;
1446 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1447 key = cp1; keylen = cp2 - cp1;
1448 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1449 while (*cp2 && *cp2 != '=') cp2++;
1450 while (*cp2 && *cp2 == '=') cp2++;
1451 while (*cp2 && *cp2 == ' ') cp2++;
1452 if (*cp2 == '"') { /* String translation; may embed "" */
1453 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1454 cp2++; cp1--; /* Skip "" surrounding translation */
1456 else { /* Numeric translation */
1457 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1458 cp1--; /* stop on last non-space char */
1460 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1461 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1464 PERL_HASH(hash,key,keylen);
1466 if (cp1 == cp2 && *cp2 == '.') {
1467 /* A single dot usually means an unprintable character, such as a null
1468 * to indicate a zero-length value. Get the actual value to make sure.
1470 char lnm[LNM$C_NAMLENGTH+1];
1471 char eqv[MAX_DCL_SYMBOL+1];
1473 strncpy(lnm, key, keylen);
1474 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1475 sv = newSVpvn(eqv, strlen(eqv));
1478 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1482 hv_store(envhv,key,keylen,sv,hash);
1483 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1485 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1486 /* get the PPFs for this process, not the subprocess */
1487 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1488 char eqv[LNM$C_NAMLENGTH+1];
1490 for (i = 0; ppfs[i]; i++) {
1491 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1492 sv = newSVpv(eqv,trnlen);
1494 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1499 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1500 if (buf) Safefree(buf);
1501 if (seenhv) SvREFCNT_dec(seenhv);
1502 MUTEX_UNLOCK(&primenv_mutex);
1505 } /* end of prime_env_iter */
1509 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1510 /* Define or delete an element in the same "environment" as
1511 * vmstrnenv(). If an element is to be deleted, it's removed from
1512 * the first place it's found. If it's to be set, it's set in the
1513 * place designated by the first element of the table vector.
1514 * Like setenv() returns 0 for success, non-zero on error.
1517 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1520 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1521 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1523 unsigned long int retsts, usermode = PSL$C_USER;
1524 struct itmlst_3 *ile, *ilist;
1525 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1526 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1527 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1528 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1529 $DESCRIPTOR(local,"_LOCAL");
1532 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1533 return SS$_IVLOGNAM;
1536 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1537 *cp2 = _toupper(*cp1);
1538 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1539 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1540 return SS$_IVLOGNAM;
1543 lnmdsc.dsc$w_length = cp1 - lnm;
1544 if (!tabvec || !*tabvec) tabvec = env_tables;
1546 if (!eqv) { /* we're deleting n element */
1547 for (curtab = 0; tabvec[curtab]; curtab++) {
1548 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1550 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1551 if ((cp1 = strchr(environ[i],'=')) &&
1552 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1553 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1555 return setenv(lnm,"",1) ? vaxc$errno : 0;
1558 ivenv = 1; retsts = SS$_NOLOGNAM;
1560 if (ckWARN(WARN_INTERNAL))
1561 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1562 ivenv = 1; retsts = SS$_NOSUCHPGM;
1568 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1569 !str$case_blind_compare(&tmpdsc,&clisym)) {
1570 unsigned int symtype;
1571 if (tabvec[curtab]->dsc$w_length == 12 &&
1572 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1573 !str$case_blind_compare(&tmpdsc,&local))
1574 symtype = LIB$K_CLI_LOCAL_SYM;
1575 else symtype = LIB$K_CLI_GLOBAL_SYM;
1576 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1577 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1578 if (retsts == LIB$_NOSUCHSYM) continue;
1582 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1583 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1584 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1585 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1586 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1590 else { /* we're defining a value */
1591 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1593 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1595 if (ckWARN(WARN_INTERNAL))
1596 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1597 retsts = SS$_NOSUCHPGM;
1601 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1602 eqvdsc.dsc$w_length = strlen(eqv);
1603 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1604 !str$case_blind_compare(&tmpdsc,&clisym)) {
1605 unsigned int symtype;
1606 if (tabvec[0]->dsc$w_length == 12 &&
1607 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1608 !str$case_blind_compare(&tmpdsc,&local))
1609 symtype = LIB$K_CLI_LOCAL_SYM;
1610 else symtype = LIB$K_CLI_GLOBAL_SYM;
1611 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1614 if (!*eqv) eqvdsc.dsc$w_length = 1;
1615 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1617 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1618 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1619 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1620 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1621 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1622 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1625 Newx(ilist,nseg+1,struct itmlst_3);
1628 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1631 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1633 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1634 ile->itmcode = LNM$_STRING;
1636 if ((j+1) == nseg) {
1637 ile->buflen = strlen(c);
1638 /* in case we are truncating one that's too long */
1639 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1642 ile->buflen = LNM$C_NAMLENGTH;
1646 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1650 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1655 if (!(retsts & 1)) {
1657 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1658 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1659 set_errno(EVMSERR); break;
1660 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1661 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1662 set_errno(EINVAL); break;
1664 set_errno(EACCES); break;
1669 set_vaxc_errno(retsts);
1670 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1673 /* We reset error values on success because Perl does an hv_fetch()
1674 * before each hv_store(), and if the thing we're setting didn't
1675 * previously exist, we've got a leftover error message. (Of course,
1676 * this fails in the face of
1677 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1678 * in that the error reported in $! isn't spurious,
1679 * but it's right more often than not.)
1681 set_errno(0); set_vaxc_errno(retsts);
1685 } /* end of vmssetenv() */
1688 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1689 /* This has to be a function since there's a prototype for it in proto.h */
1691 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1694 int len = strlen(lnm);
1698 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1699 if (!strcmp(uplnm,"DEFAULT")) {
1700 if (eqv && *eqv) my_chdir(eqv);
1704 #ifndef RTL_USES_UTC
1705 if (len == 6 || len == 2) {
1708 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1710 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1711 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1715 (void) vmssetenv(lnm,eqv,NULL);
1719 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1721 * sets a user-mode logical in the process logical name table
1722 * used for redirection of sys$error
1725 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1727 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1728 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1729 unsigned long int iss, attr = LNM$M_CONFINE;
1730 unsigned char acmode = PSL$C_USER;
1731 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1733 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1734 d_name.dsc$w_length = strlen(name);
1736 lnmlst[0].buflen = strlen(eqv);
1737 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1739 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1740 if (!(iss&1)) lib$signal(iss);
1745 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1746 /* my_crypt - VMS password hashing
1747 * my_crypt() provides an interface compatible with the Unix crypt()
1748 * C library function, and uses sys$hash_password() to perform VMS
1749 * password hashing. The quadword hashed password value is returned
1750 * as a NUL-terminated 8 character string. my_crypt() does not change
1751 * the case of its string arguments; in order to match the behavior
1752 * of LOGINOUT et al., alphabetic characters in both arguments must
1753 * be upcased by the caller.
1755 * - fix me to call ACM services when available
1758 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1760 # ifndef UAI$C_PREFERRED_ALGORITHM
1761 # define UAI$C_PREFERRED_ALGORITHM 127
1763 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1764 unsigned short int salt = 0;
1765 unsigned long int sts;
1767 unsigned short int dsc$w_length;
1768 unsigned char dsc$b_type;
1769 unsigned char dsc$b_class;
1770 const char * dsc$a_pointer;
1771 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1772 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1773 struct itmlst_3 uailst[3] = {
1774 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1775 { sizeof salt, UAI$_SALT, &salt, 0},
1776 { 0, 0, NULL, NULL}};
1777 static char hash[9];
1779 usrdsc.dsc$w_length = strlen(usrname);
1780 usrdsc.dsc$a_pointer = usrname;
1781 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1783 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1787 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1792 set_vaxc_errno(sts);
1793 if (sts != RMS$_RNF) return NULL;
1796 txtdsc.dsc$w_length = strlen(textpasswd);
1797 txtdsc.dsc$a_pointer = textpasswd;
1798 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1799 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1802 return (char *) hash;
1804 } /* end of my_crypt() */
1808 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1809 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1810 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1812 /* fixup barenames that are directories for internal use.
1813 * There have been problems with the consistent handling of UNIX
1814 * style directory names when routines are presented with a name that
1815 * has no directory delimitors at all. So this routine will eventually
1818 static char * fixup_bare_dirnames(const char * name)
1820 if (decc_disable_to_vms_logname_translation) {
1826 /* 8.3, remove() is now broken on symbolic links */
1827 static int rms_erase(const char * vmsname);
1831 * A little hack to get around a bug in some implemenation of remove()
1832 * that do not know how to delete a directory
1834 * Delete any file to which user has control access, regardless of whether
1835 * delete access is explicitly allowed.
1836 * Limitations: User must have write access to parent directory.
1837 * Does not block signals or ASTs; if interrupted in midstream
1838 * may leave file with an altered ACL.
1841 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1843 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1847 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1848 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1849 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1851 unsigned char myace$b_length;
1852 unsigned char myace$b_type;
1853 unsigned short int myace$w_flags;
1854 unsigned long int myace$l_access;
1855 unsigned long int myace$l_ident;
1856 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1857 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1858 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1860 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1861 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1862 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1863 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1864 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1865 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1867 /* Expand the input spec using RMS, since the CRTL remove() and
1868 * system services won't do this by themselves, so we may miss
1869 * a file "hiding" behind a logical name or search list. */
1870 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1871 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
1873 rslt = do_rmsexpand(name,
1877 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
1881 PerlMem_free(vmsname);
1885 /* Erase the file */
1886 rmsts = rms_erase(vmsname);
1888 /* Did it succeed */
1889 if ($VMS_STATUS_SUCCESS(rmsts)) {
1890 PerlMem_free(vmsname);
1894 /* If not, can changing protections help? */
1895 if (rmsts != RMS$_PRV) {
1896 set_vaxc_errno(rmsts);
1897 PerlMem_free(vmsname);
1901 /* No, so we get our own UIC to use as a rights identifier,
1902 * and the insert an ACE at the head of the ACL which allows us
1903 * to delete the file.
1905 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1906 fildsc.dsc$w_length = strlen(vmsname);
1907 fildsc.dsc$a_pointer = vmsname;
1909 newace.myace$l_ident = oldace.myace$l_ident;
1911 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
1913 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
1914 set_errno(ENOENT); break;
1916 set_errno(ENOTDIR); break;
1918 set_errno(ENODEV); break;
1919 case RMS$_SYN: case SS$_INVFILFOROP:
1920 set_errno(EINVAL); break;
1922 set_errno(EACCES); break;
1926 set_vaxc_errno(aclsts);
1927 PerlMem_free(vmsname);
1930 /* Grab any existing ACEs with this identifier in case we fail */
1931 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
1932 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
1933 || fndsts == SS$_NOMOREACE ) {
1934 /* Add the new ACE . . . */
1935 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
1938 rmsts = rms_erase(vmsname);
1939 if ($VMS_STATUS_SUCCESS(rmsts)) {
1944 /* We blew it - dir with files in it, no write priv for
1945 * parent directory, etc. Put things back the way they were. */
1946 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
1949 addlst[0].bufadr = &oldace;
1950 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
1957 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
1958 /* We just deleted it, so of course it's not there. Some versions of
1959 * VMS seem to return success on the unlock operation anyhow (after all
1960 * the unlock is successful), but others don't.
1962 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
1963 if (aclsts & 1) aclsts = fndsts;
1964 if (!(aclsts & 1)) {
1966 set_vaxc_errno(aclsts);
1969 PerlMem_free(vmsname);
1972 } /* end of kill_file() */
1976 /*{{{int do_rmdir(char *name)*/
1978 Perl_do_rmdir(pTHX_ const char *name)
1984 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
1985 if (dirfile == NULL)
1986 _ckvmssts(SS$_INSFMEM);
1988 /* Force to a directory specification */
1989 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
1990 PerlMem_free(dirfile);
1993 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
1998 retval = mp_do_kill_file(aTHX_ dirfile, 1);
2000 PerlMem_free(dirfile);
2003 } /* end of do_rmdir */
2007 * Delete any file to which user has control access, regardless of whether
2008 * delete access is explicitly allowed.
2009 * Limitations: User must have write access to parent directory.
2010 * Does not block signals or ASTs; if interrupted in midstream
2011 * may leave file with an altered ACL.
2014 /*{{{int kill_file(char *name)*/
2016 Perl_kill_file(pTHX_ const char *name)
2018 char rspec[NAM$C_MAXRSS+1];
2023 /* Remove() is allowed to delete directories, according to the X/Open
2025 * This may need special handling to work with the ACL hacks.
2027 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2028 rmsts = Perl_do_rmdir(aTHX_ name);
2032 rmsts = mp_do_kill_file(aTHX_ name, 0);
2036 } /* end of kill_file() */
2040 /*{{{int my_mkdir(char *,Mode_t)*/
2042 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2044 STRLEN dirlen = strlen(dir);
2046 /* zero length string sometimes gives ACCVIO */
2047 if (dirlen == 0) return -1;
2049 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2050 * null file name/type. However, it's commonplace under Unix,
2051 * so we'll allow it for a gain in portability.
2053 if (dir[dirlen-1] == '/') {
2054 char *newdir = savepvn(dir,dirlen-1);
2055 int ret = mkdir(newdir,mode);
2059 else return mkdir(dir,mode);
2060 } /* end of my_mkdir */
2063 /*{{{int my_chdir(char *)*/
2065 Perl_my_chdir(pTHX_ const char *dir)
2067 STRLEN dirlen = strlen(dir);
2069 /* zero length string sometimes gives ACCVIO */
2070 if (dirlen == 0) return -1;
2073 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2074 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2075 * so that existing scripts do not need to be changed.
2078 while ((dirlen > 0) && (*dir1 == ' ')) {
2083 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2085 * null file name/type. However, it's commonplace under Unix,
2086 * so we'll allow it for a gain in portability.
2088 * - Preview- '/' will be valid soon on VMS
2090 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2091 char *newdir = savepvn(dir1,dirlen-1);
2092 int ret = chdir(newdir);
2096 else return chdir(dir1);
2097 } /* end of my_chdir */
2101 /*{{{int my_chmod(char *, mode_t)*/
2103 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2105 STRLEN speclen = strlen(file_spec);
2107 /* zero length string sometimes gives ACCVIO */
2108 if (speclen == 0) return -1;
2110 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2111 * that implies null file name/type. However, it's commonplace under Unix,
2112 * so we'll allow it for a gain in portability.
2114 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2115 * in VMS file.dir notation.
2117 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2118 char *vms_src, *vms_dir, *rslt;
2122 /* First convert this to a VMS format specification */
2123 vms_src = PerlMem_malloc(VMS_MAXRSS);
2124 if (vms_src == NULL)
2125 _ckvmssts(SS$_INSFMEM);
2127 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2129 /* If we fail, then not a file specification */
2130 PerlMem_free(vms_src);
2135 /* Now make it a directory spec so chmod is happy */
2136 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2137 if (vms_dir == NULL)
2138 _ckvmssts(SS$_INSFMEM);
2139 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2140 PerlMem_free(vms_src);
2144 ret = chmod(vms_dir, mode);
2148 PerlMem_free(vms_dir);
2151 else return chmod(file_spec, mode);
2152 } /* end of my_chmod */
2156 /*{{{FILE *my_tmpfile()*/
2163 if ((fp = tmpfile())) return fp;
2165 cp = PerlMem_malloc(L_tmpnam+24);
2166 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2168 if (decc_filename_unix_only == 0)
2169 strcpy(cp,"Sys$Scratch:");
2172 tmpnam(cp+strlen(cp));
2173 strcat(cp,".Perltmp");
2174 fp = fopen(cp,"w+","fop=dlt");
2181 #ifndef HOMEGROWN_POSIX_SIGNALS
2183 * The C RTL's sigaction fails to check for invalid signal numbers so we
2184 * help it out a bit. The docs are correct, but the actual routine doesn't
2185 * do what the docs say it will.
2187 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2189 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2190 struct sigaction* oact)
2192 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2193 SETERRNO(EINVAL, SS$_INVARG);
2196 return sigaction(sig, act, oact);
2201 #ifdef KILL_BY_SIGPRC
2202 #include <errnodef.h>
2204 /* We implement our own kill() using the undocumented system service
2205 sys$sigprc for one of two reasons:
2207 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2208 target process to do a sys$exit, which usually can't be handled
2209 gracefully...certainly not by Perl and the %SIG{} mechanism.
2211 2.) If the kill() in the CRTL can't be called from a signal
2212 handler without disappearing into the ether, i.e., the signal
2213 it purportedly sends is never trapped. Still true as of VMS 7.3.
2215 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2216 in the target process rather than calling sys$exit.
2218 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2219 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2220 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2221 with condition codes C$_SIG0+nsig*8, catching the exception on the
2222 target process and resignaling with appropriate arguments.
2224 But we don't have that VMS 7.0+ exception handler, so if you
2225 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2227 Also note that SIGTERM is listed in the docs as being "unimplemented",
2228 yet always seems to be signaled with a VMS condition code of 4 (and
2229 correctly handled for that code). So we hardwire it in.
2231 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2232 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2233 than signalling with an unrecognized (and unhandled by CRTL) code.
2236 #define _MY_SIG_MAX 28
2239 Perl_sig_to_vmscondition_int(int sig)
2241 static unsigned int sig_code[_MY_SIG_MAX+1] =
2244 SS$_HANGUP, /* 1 SIGHUP */
2245 SS$_CONTROLC, /* 2 SIGINT */
2246 SS$_CONTROLY, /* 3 SIGQUIT */
2247 SS$_RADRMOD, /* 4 SIGILL */
2248 SS$_BREAK, /* 5 SIGTRAP */
2249 SS$_OPCCUS, /* 6 SIGABRT */
2250 SS$_COMPAT, /* 7 SIGEMT */
2252 SS$_FLTOVF, /* 8 SIGFPE VAX */
2254 SS$_HPARITH, /* 8 SIGFPE AXP */
2256 SS$_ABORT, /* 9 SIGKILL */
2257 SS$_ACCVIO, /* 10 SIGBUS */
2258 SS$_ACCVIO, /* 11 SIGSEGV */
2259 SS$_BADPARAM, /* 12 SIGSYS */
2260 SS$_NOMBX, /* 13 SIGPIPE */
2261 SS$_ASTFLT, /* 14 SIGALRM */
2278 #if __VMS_VER >= 60200000
2279 static int initted = 0;
2282 sig_code[16] = C$_SIGUSR1;
2283 sig_code[17] = C$_SIGUSR2;
2284 #if __CRTL_VER >= 70000000
2285 sig_code[20] = C$_SIGCHLD;
2287 #if __CRTL_VER >= 70300000
2288 sig_code[28] = C$_SIGWINCH;
2293 if (sig < _SIG_MIN) return 0;
2294 if (sig > _MY_SIG_MAX) return 0;
2295 return sig_code[sig];
2299 Perl_sig_to_vmscondition(int sig)
2302 if (vms_debug_on_exception != 0)
2303 lib$signal(SS$_DEBUG);
2305 return Perl_sig_to_vmscondition_int(sig);
2310 Perl_my_kill(int pid, int sig)
2315 int sys$sigprc(unsigned int *pidadr,
2316 struct dsc$descriptor_s *prcname,
2319 /* sig 0 means validate the PID */
2320 /*------------------------------*/
2322 const unsigned long int jpicode = JPI$_PID;
2325 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2326 if ($VMS_STATUS_SUCCESS(status))
2329 case SS$_NOSUCHNODE:
2330 case SS$_UNREACHABLE:
2344 code = Perl_sig_to_vmscondition_int(sig);
2347 SETERRNO(EINVAL, SS$_BADPARAM);
2351 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2352 * signals are to be sent to multiple processes.
2353 * pid = 0 - all processes in group except ones that the system exempts
2354 * pid = -1 - all processes except ones that the system exempts
2355 * pid = -n - all processes in group (abs(n)) except ...
2356 * For now, just report as not supported.
2360 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2364 iss = sys$sigprc((unsigned int *)&pid,0,code);
2365 if (iss&1) return 0;
2369 set_errno(EPERM); break;
2371 case SS$_NOSUCHNODE:
2372 case SS$_UNREACHABLE:
2373 set_errno(ESRCH); break;
2375 set_errno(ENOMEM); break;
2380 set_vaxc_errno(iss);
2386 /* Routine to convert a VMS status code to a UNIX status code.
2387 ** More tricky than it appears because of conflicting conventions with
2390 ** VMS status codes are a bit mask, with the least significant bit set for
2393 ** Special UNIX status of EVMSERR indicates that no translation is currently
2394 ** available, and programs should check the VMS status code.
2396 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2400 #ifndef C_FACILITY_NO
2401 #define C_FACILITY_NO 0x350000
2404 #define DCL_IVVERB 0x38090
2407 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2415 /* Assume the best or the worst */
2416 if (vms_status & STS$M_SUCCESS)
2419 unix_status = EVMSERR;
2421 msg_status = vms_status & ~STS$M_CONTROL;
2423 facility = vms_status & STS$M_FAC_NO;
2424 fac_sp = vms_status & STS$M_FAC_SP;
2425 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2427 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2433 unix_status = EFAULT;
2435 case SS$_DEVOFFLINE:
2436 unix_status = EBUSY;
2439 unix_status = ENOTCONN;
2447 case SS$_INVFILFOROP:
2451 unix_status = EINVAL;
2453 case SS$_UNSUPPORTED:
2454 unix_status = ENOTSUP;
2459 unix_status = EACCES;
2461 case SS$_DEVICEFULL:
2462 unix_status = ENOSPC;
2465 unix_status = ENODEV;
2467 case SS$_NOSUCHFILE:
2468 case SS$_NOSUCHOBJECT:
2469 unix_status = ENOENT;
2471 case SS$_ABORT: /* Fatal case */
2472 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2473 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2474 unix_status = EINTR;
2477 unix_status = E2BIG;
2480 unix_status = ENOMEM;
2483 unix_status = EPERM;
2485 case SS$_NOSUCHNODE:
2486 case SS$_UNREACHABLE:
2487 unix_status = ESRCH;
2490 unix_status = ECHILD;
2493 if ((facility == 0) && (msg_no < 8)) {
2494 /* These are not real VMS status codes so assume that they are
2495 ** already UNIX status codes
2497 unix_status = msg_no;
2503 /* Translate a POSIX exit code to a UNIX exit code */
2504 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2505 unix_status = (msg_no & 0x07F8) >> 3;
2509 /* Documented traditional behavior for handling VMS child exits */
2510 /*--------------------------------------------------------------*/
2511 if (child_flag != 0) {
2513 /* Success / Informational return 0 */
2514 /*----------------------------------*/
2515 if (msg_no & STS$K_SUCCESS)
2518 /* Warning returns 1 */
2519 /*-------------------*/
2520 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2523 /* Everything else pass through the severity bits */
2524 /*------------------------------------------------*/
2525 return (msg_no & STS$M_SEVERITY);
2528 /* Normal VMS status to ERRNO mapping attempt */
2529 /*--------------------------------------------*/
2530 switch(msg_status) {
2531 /* case RMS$_EOF: */ /* End of File */
2532 case RMS$_FNF: /* File Not Found */
2533 case RMS$_DNF: /* Dir Not Found */
2534 unix_status = ENOENT;
2536 case RMS$_RNF: /* Record Not Found */
2537 unix_status = ESRCH;
2540 unix_status = ENOTDIR;
2543 unix_status = ENODEV;
2548 unix_status = EBADF;
2551 unix_status = EEXIST;
2555 case LIB$_INVSTRDES:
2557 case LIB$_NOSUCHSYM:
2558 case LIB$_INVSYMNAM:
2560 unix_status = EINVAL;
2566 unix_status = E2BIG;
2568 case RMS$_PRV: /* No privilege */
2569 case RMS$_ACC: /* ACP file access failed */
2570 case RMS$_WLK: /* Device write locked */
2571 unix_status = EACCES;
2573 case RMS$_MKD: /* Failed to mark for delete */
2574 unix_status = EPERM;
2576 /* case RMS$_NMF: */ /* No more files */
2584 /* Try to guess at what VMS error status should go with a UNIX errno
2585 * value. This is hard to do as there could be many possible VMS
2586 * error statuses that caused the errno value to be set.
2589 int Perl_unix_status_to_vms(int unix_status)
2591 int test_unix_status;
2593 /* Trivial cases first */
2594 /*---------------------*/
2595 if (unix_status == EVMSERR)
2598 /* Is vaxc$errno sane? */
2599 /*---------------------*/
2600 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2601 if (test_unix_status == unix_status)
2604 /* If way out of range, must be VMS code already */
2605 /*-----------------------------------------------*/
2606 if (unix_status > EVMSERR)
2609 /* If out of range, punt */
2610 /*-----------------------*/
2611 if (unix_status > __ERRNO_MAX)
2615 /* Ok, now we have to do it the hard way. */
2616 /*----------------------------------------*/
2617 switch(unix_status) {
2618 case 0: return SS$_NORMAL;
2619 case EPERM: return SS$_NOPRIV;
2620 case ENOENT: return SS$_NOSUCHOBJECT;
2621 case ESRCH: return SS$_UNREACHABLE;
2622 case EINTR: return SS$_ABORT;
2625 case E2BIG: return SS$_BUFFEROVF;
2627 case EBADF: return RMS$_IFI;
2628 case ECHILD: return SS$_NONEXPR;
2630 case ENOMEM: return SS$_INSFMEM;
2631 case EACCES: return SS$_FILACCERR;
2632 case EFAULT: return SS$_ACCVIO;
2634 case EBUSY: return SS$_DEVOFFLINE;
2635 case EEXIST: return RMS$_FEX;
2637 case ENODEV: return SS$_NOSUCHDEV;
2638 case ENOTDIR: return RMS$_DIR;
2640 case EINVAL: return SS$_INVARG;
2646 case ENOSPC: return SS$_DEVICEFULL;
2647 case ESPIPE: return LIB$_INVARG;
2652 case ERANGE: return LIB$_INVARG;
2653 /* case EWOULDBLOCK */
2654 /* case EINPROGRESS */
2657 /* case EDESTADDRREQ */
2659 /* case EPROTOTYPE */
2660 /* case ENOPROTOOPT */
2661 /* case EPROTONOSUPPORT */
2662 /* case ESOCKTNOSUPPORT */
2663 /* case EOPNOTSUPP */
2664 /* case EPFNOSUPPORT */
2665 /* case EAFNOSUPPORT */
2666 /* case EADDRINUSE */
2667 /* case EADDRNOTAVAIL */
2669 /* case ENETUNREACH */
2670 /* case ENETRESET */
2671 /* case ECONNABORTED */
2672 /* case ECONNRESET */
2675 case ENOTCONN: return SS$_CLEARED;
2676 /* case ESHUTDOWN */
2677 /* case ETOOMANYREFS */
2678 /* case ETIMEDOUT */
2679 /* case ECONNREFUSED */
2681 /* case ENAMETOOLONG */
2682 /* case EHOSTDOWN */
2683 /* case EHOSTUNREACH */
2684 /* case ENOTEMPTY */
2696 /* case ECANCELED */
2700 return SS$_UNSUPPORTED;
2706 /* case EABANDONED */
2708 return SS$_ABORT; /* punt */
2711 return SS$_ABORT; /* Should not get here */
2715 /* default piping mailbox size */
2716 #define PERL_BUFSIZ 512
2720 create_mbx(pTHX_ unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2722 unsigned long int mbxbufsiz;
2723 static unsigned long int syssize = 0;
2724 unsigned long int dviitm = DVI$_DEVNAM;
2725 char csize[LNM$C_NAMLENGTH+1];
2729 unsigned long syiitm = SYI$_MAXBUF;
2731 * Get the SYSGEN parameter MAXBUF
2733 * If the logical 'PERL_MBX_SIZE' is defined
2734 * use the value of the logical instead of PERL_BUFSIZ, but
2735 * keep the size between 128 and MAXBUF.
2738 _ckvmssts(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2741 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2742 mbxbufsiz = atoi(csize);
2744 mbxbufsiz = PERL_BUFSIZ;
2746 if (mbxbufsiz < 128) mbxbufsiz = 128;
2747 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2749 _ckvmssts(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2751 _ckvmssts(sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length));
2752 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2754 } /* end of create_mbx() */
2757 /*{{{ my_popen and my_pclose*/
2759 typedef struct _iosb IOSB;
2760 typedef struct _iosb* pIOSB;
2761 typedef struct _pipe Pipe;
2762 typedef struct _pipe* pPipe;
2763 typedef struct pipe_details Info;
2764 typedef struct pipe_details* pInfo;
2765 typedef struct _srqp RQE;
2766 typedef struct _srqp* pRQE;
2767 typedef struct _tochildbuf CBuf;
2768 typedef struct _tochildbuf* pCBuf;
2771 unsigned short status;
2772 unsigned short count;
2773 unsigned long dvispec;
2776 #pragma member_alignment save
2777 #pragma nomember_alignment quadword
2778 struct _srqp { /* VMS self-relative queue entry */
2779 unsigned long qptr[2];
2781 #pragma member_alignment restore
2782 static RQE RQE_ZERO = {0,0};
2784 struct _tochildbuf {
2787 unsigned short size;
2795 unsigned short chan_in;
2796 unsigned short chan_out;
2798 unsigned int bufsize;
2810 #if defined(PERL_IMPLICIT_CONTEXT)
2811 void *thx; /* Either a thread or an interpreter */
2812 /* pointer, depending on how we're built */
2820 PerlIO *fp; /* file pointer to pipe mailbox */
2821 int useFILE; /* using stdio, not perlio */
2822 int pid; /* PID of subprocess */
2823 int mode; /* == 'r' if pipe open for reading */
2824 int done; /* subprocess has completed */
2825 int waiting; /* waiting for completion/closure */
2826 int closing; /* my_pclose is closing this pipe */
2827 unsigned long completion; /* termination status of subprocess */
2828 pPipe in; /* pipe in to sub */
2829 pPipe out; /* pipe out of sub */
2830 pPipe err; /* pipe of sub's sys$error */
2831 int in_done; /* true when in pipe finished */
2834 unsigned short xchan; /* channel to debug xterm */
2835 unsigned short xchan_valid; /* channel is assigned */
2838 struct exit_control_block
2840 struct exit_control_block *flink;
2841 unsigned long int (*exit_routine)();
2842 unsigned long int arg_count;
2843 unsigned long int *status_address;
2844 unsigned long int exit_status;
2847 typedef struct _closed_pipes Xpipe;
2848 typedef struct _closed_pipes* pXpipe;
2850 struct _closed_pipes {
2851 int pid; /* PID of subprocess */
2852 unsigned long completion; /* termination status of subprocess */
2854 #define NKEEPCLOSED 50
2855 static Xpipe closed_list[NKEEPCLOSED];
2856 static int closed_index = 0;
2857 static int closed_num = 0;
2859 #define RETRY_DELAY "0 ::0.20"
2860 #define MAX_RETRY 50
2862 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2863 static unsigned long mypid;
2864 static unsigned long delaytime[2];
2866 static pInfo open_pipes = NULL;
2867 static $DESCRIPTOR(nl_desc, "NL:");
2869 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2873 static unsigned long int
2874 pipe_exit_routine(pTHX)
2877 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2878 int sts, did_stuff, need_eof, j;
2881 * Flush any pending i/o, but since we are in process run-down, be
2882 * careful about referencing PerlIO structures that may already have
2883 * been deallocated. We may not even have an interpreter anymore.
2889 #if defined(USE_ITHREADS)
2892 && PL_perlio_fd_refcnt)
2893 PerlIO_flush(info->fp);
2895 fflush((FILE *)info->fp);
2901 next we try sending an EOF...ignore if doesn't work, make sure we
2909 _ckvmssts_noperl(sys$setast(0));
2910 if (info->in && !info->in->shut_on_empty) {
2911 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
2916 _ckvmssts_noperl(sys$setast(1));
2920 /* wait for EOF to have effect, up to ~ 30 sec [default] */
2922 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2927 _ckvmssts_noperl(sys$setast(0));
2928 if (info->waiting && info->done)
2930 nwait += info->waiting;
2931 _ckvmssts_noperl(sys$setast(1));
2941 _ckvmssts_noperl(sys$setast(0));
2942 if (!info->done) { /* Tap them gently on the shoulder . . .*/
2943 sts = sys$forcex(&info->pid,0,&abort);
2944 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2947 _ckvmssts_noperl(sys$setast(1));
2951 /* again, wait for effect */
2953 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
2958 _ckvmssts_noperl(sys$setast(0));
2959 if (info->waiting && info->done)
2961 nwait += info->waiting;
2962 _ckvmssts_noperl(sys$setast(1));
2971 _ckvmssts_noperl(sys$setast(0));
2972 if (!info->done) { /* We tried to be nice . . . */
2973 sts = sys$delprc(&info->pid,0);
2974 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
2975 info->done = 1; /* sys$delprc is as done as we're going to get. */
2977 _ckvmssts_noperl(sys$setast(1));
2982 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
2983 else if (!(sts & 1)) retsts = sts;
2988 static struct exit_control_block pipe_exitblock =
2989 {(struct exit_control_block *) 0,
2990 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
2992 static void pipe_mbxtofd_ast(pPipe p);
2993 static void pipe_tochild1_ast(pPipe p);
2994 static void pipe_tochild2_ast(pPipe p);
2997 popen_completion_ast(pInfo info)
2999 pInfo i = open_pipes;
3004 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3005 closed_list[closed_index].pid = info->pid;
3006 closed_list[closed_index].completion = info->completion;
3008 if (closed_index == NKEEPCLOSED)
3013 if (i == info) break;
3016 if (!i) return; /* unlinked, probably freed too */
3021 Writing to subprocess ...
3022 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3024 chan_out may be waiting for "done" flag, or hung waiting
3025 for i/o completion to child...cancel the i/o. This will
3026 put it into "snarf mode" (done but no EOF yet) that discards
3029 Output from subprocess (stdout, stderr) needs to be flushed and
3030 shut down. We try sending an EOF, but if the mbx is full the pipe
3031 routine should still catch the "shut_on_empty" flag, telling it to
3032 use immediate-style reads so that "mbx empty" -> EOF.
3036 if (info->in && !info->in_done) { /* only for mode=w */
3037 if (info->in->shut_on_empty && info->in->need_wake) {
3038 info->in->need_wake = FALSE;
3039 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3041 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3045 if (info->out && !info->out_done) { /* were we also piping output? */
3046 info->out->shut_on_empty = TRUE;
3047 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3048 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3049 _ckvmssts_noperl(iss);
3052 if (info->err && !info->err_done) { /* we were piping stderr */
3053 info->err->shut_on_empty = TRUE;
3054 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3055 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3056 _ckvmssts_noperl(iss);
3058 _ckvmssts_noperl(sys$setef(pipe_ef));
3062 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3063 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3066 we actually differ from vmstrnenv since we use this to
3067 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3068 are pointing to the same thing
3071 static unsigned short
3072 popen_translate(pTHX_ char *logical, char *result)
3075 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3076 $DESCRIPTOR(d_log,"");
3078 unsigned short length;
3079 unsigned short code;
3081 unsigned short *retlenaddr;
3083 unsigned short l, ifi;
3085 d_log.dsc$a_pointer = logical;
3086 d_log.dsc$w_length = strlen(logical);
3088 itmlst[0].code = LNM$_STRING;
3089 itmlst[0].length = 255;
3090 itmlst[0].buffer_addr = result;
3091 itmlst[0].retlenaddr = &l;
3094 itmlst[1].length = 0;
3095 itmlst[1].buffer_addr = 0;
3096 itmlst[1].retlenaddr = 0;
3098 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3099 if (iss == SS$_NOLOGNAM) {
3103 if (!(iss&1)) lib$signal(iss);
3106 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3107 strip it off and return the ifi, if any
3110 if (result[0] == 0x1b && result[1] == 0x00) {
3111 memmove(&ifi,result+2,2);
3112 strcpy(result,result+4);
3114 return ifi; /* this is the RMS internal file id */
3117 static void pipe_infromchild_ast(pPipe p);
3120 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3121 inside an AST routine without worrying about reentrancy and which Perl
3122 memory allocator is being used.
3124 We read data and queue up the buffers, then spit them out one at a
3125 time to the output mailbox when the output mailbox is ready for one.
3128 #define INITIAL_TOCHILDQUEUE 2
3131 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3135 char mbx1[64], mbx2[64];
3136 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3137 DSC$K_CLASS_S, mbx1},
3138 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3139 DSC$K_CLASS_S, mbx2};
3140 unsigned int dviitm = DVI$_DEVBUFSIZ;
3144 _ckvmssts(lib$get_vm(&n, &p));
3146 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3147 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3148 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3151 p->shut_on_empty = FALSE;
3152 p->need_wake = FALSE;
3155 p->iosb.status = SS$_NORMAL;
3156 p->iosb2.status = SS$_NORMAL;
3162 #ifdef PERL_IMPLICIT_CONTEXT
3166 n = sizeof(CBuf) + p->bufsize;
3168 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3169 _ckvmssts(lib$get_vm(&n, &b));
3170 b->buf = (char *) b + sizeof(CBuf);
3171 _ckvmssts(lib$insqhi(b, &p->free));
3174 pipe_tochild2_ast(p);
3175 pipe_tochild1_ast(p);
3181 /* reads the MBX Perl is writing, and queues */
3184 pipe_tochild1_ast(pPipe p)
3187 int iss = p->iosb.status;
3188 int eof = (iss == SS$_ENDOFFILE);
3190 #ifdef PERL_IMPLICIT_CONTEXT
3196 p->shut_on_empty = TRUE;
3198 _ckvmssts(sys$dassgn(p->chan_in));
3204 b->size = p->iosb.count;
3205 _ckvmssts(sts = lib$insqhi(b, &p->wait));
3207 p->need_wake = FALSE;
3208 _ckvmssts(sys$dclast(pipe_tochild2_ast,p,0));
3211 p->retry = 1; /* initial call */
3214 if (eof) { /* flush the free queue, return when done */
3215 int n = sizeof(CBuf) + p->bufsize;
3217 iss = lib$remqti(&p->free, &b);
3218 if (iss == LIB$_QUEWASEMP) return;
3220 _ckvmssts(lib$free_vm(&n, &b));
3224 iss = lib$remqti(&p->free, &b);
3225 if (iss == LIB$_QUEWASEMP) {
3226 int n = sizeof(CBuf) + p->bufsize;
3227 _ckvmssts(lib$get_vm(&n, &b));
3228 b->buf = (char *) b + sizeof(CBuf);
3234 iss = sys$qio(0,p->chan_in,
3235 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3237 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3238 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3243 /* writes queued buffers to output, waits for each to complete before
3247 pipe_tochild2_ast(pPipe p)
3250 int iss = p->iosb2.status;
3251 int n = sizeof(CBuf) + p->bufsize;
3252 int done = (p->info && p->info->done) ||
3253 iss == SS$_CANCEL || iss == SS$_ABORT;
3254 #if defined(PERL_IMPLICIT_CONTEXT)
3259 if (p->type) { /* type=1 has old buffer, dispose */
3260 if (p->shut_on_empty) {
3261 _ckvmssts(lib$free_vm(&n, &b));
3263 _ckvmssts(lib$insqhi(b, &p->free));
3268 iss = lib$remqti(&p->wait, &b);
3269 if (iss == LIB$_QUEWASEMP) {
3270 if (p->shut_on_empty) {
3272 _ckvmssts(sys$dassgn(p->chan_out));
3273 *p->pipe_done = TRUE;
3274 _ckvmssts(sys$setef(pipe_ef));
3276 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3277 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3281 p->need_wake = TRUE;
3291 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF,
3292 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3294 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3295 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3304 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3307 char mbx1[64], mbx2[64];
3308 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3309 DSC$K_CLASS_S, mbx1},
3310 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3311 DSC$K_CLASS_S, mbx2};
3312 unsigned int dviitm = DVI$_DEVBUFSIZ;
3314 int n = sizeof(Pipe);
3315 _ckvmssts(lib$get_vm(&n, &p));
3316 create_mbx(aTHX_ &p->chan_in , &d_mbx1);
3317 create_mbx(aTHX_ &p->chan_out, &d_mbx2);
3319 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3320 n = p->bufsize * sizeof(char);
3321 _ckvmssts(lib$get_vm(&n, &p->buf));
3322 p->shut_on_empty = FALSE;
3325 p->iosb.status = SS$_NORMAL;
3326 #if defined(PERL_IMPLICIT_CONTEXT)
3329 pipe_infromchild_ast(p);
3337 pipe_infromchild_ast(pPipe p)
3339 int iss = p->iosb.status;
3340 int eof = (iss == SS$_ENDOFFILE);
3341 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3342 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3343 #if defined(PERL_IMPLICIT_CONTEXT)
3347 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3348 _ckvmssts(sys$dassgn(p->chan_out));
3353 input shutdown if EOF from self (done or shut_on_empty)
3354 output shutdown if closing flag set (my_pclose)
3355 send data/eof from child or eof from self
3356 otherwise, re-read (snarf of data from child)
3361 if (myeof && p->chan_in) { /* input shutdown */
3362 _ckvmssts(sys$dassgn(p->chan_in));
3367 if (myeof || kideof) { /* pass EOF to parent */
3368 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3369 pipe_infromchild_ast, p,
3372 } else if (eof) { /* eat EOF --- fall through to read*/
3374 } else { /* transmit data */
3375 _ckvmssts(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3376 pipe_infromchild_ast,p,
3377 p->buf, p->iosb.count, 0, 0, 0, 0));
3383 /* everything shut? flag as done */
3385 if (!p->chan_in && !p->chan_out) {
3386 *p->pipe_done = TRUE;
3387 _ckvmssts(sys$setef(pipe_ef));
3391 /* write completed (or read, if snarfing from child)
3392 if still have input active,
3393 queue read...immediate mode if shut_on_empty so we get EOF if empty
3395 check if Perl reading, generate EOFs as needed
3401 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3402 pipe_infromchild_ast,p,
3403 p->buf, p->bufsize, 0, 0, 0, 0);
3404 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3406 } else { /* send EOFs for extra reads */
3407 p->iosb.status = SS$_ENDOFFILE;
3408 p->iosb.dvispec = 0;
3409 _ckvmssts(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3411 pipe_infromchild_ast, p, 0, 0, 0, 0));
3417 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3421 unsigned long dviitm = DVI$_DEVBUFSIZ;
3423 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3424 DSC$K_CLASS_S, mbx};
3425 int n = sizeof(Pipe);
3427 /* things like terminals and mbx's don't need this filter */
3428 if (fd && fstat(fd,&s) == 0) {
3429 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3431 unsigned short dev_len;
3432 struct dsc$descriptor_s d_dev;
3434 struct item_list_3 items[3];
3436 unsigned short dvi_iosb[4];
3438 cptr = getname(fd, out, 1);
3439 if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV);
3440 d_dev.dsc$a_pointer = out;
3441 d_dev.dsc$w_length = strlen(out);
3442 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3443 d_dev.dsc$b_class = DSC$K_CLASS_S;
3446 items[0].code = DVI$_DEVCHAR;
3447 items[0].bufadr = &devchar;
3448 items[0].retadr = NULL;
3450 items[1].code = DVI$_FULLDEVNAM;
3451 items[1].bufadr = device;
3452 items[1].retadr = &dev_len;
3456 status = sys$getdviw
3457 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3459 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3460 device[dev_len] = 0;
3462 if (!(devchar & DEV$M_DIR)) {
3463 strcpy(out, device);
3469 _ckvmssts(lib$get_vm(&n, &p));
3470 p->fd_out = dup(fd);
3471 create_mbx(aTHX_ &p->chan_in, &d_mbx);
3472 _ckvmssts(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3473 n = (p->bufsize+1) * sizeof(char);
3474 _ckvmssts(lib$get_vm(&n, &p->buf));
3475 p->shut_on_empty = FALSE;
3480 _ckvmssts(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3481 pipe_mbxtofd_ast, p,
3482 p->buf, p->bufsize, 0, 0, 0, 0));
3488 pipe_mbxtofd_ast(pPipe p)
3490 int iss = p->iosb.status;
3491 int done = p->info->done;
3493 int eof = (iss == SS$_ENDOFFILE);
3494 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3495 int err = !(iss&1) && !eof;
3496 #if defined(PERL_IMPLICIT_CONTEXT)
3500 if (done && myeof) { /* end piping */
3502 sys$dassgn(p->chan_in);
3503 *p->pipe_done = TRUE;
3504 _ckvmssts(sys$setef(pipe_ef));
3508 if (!err && !eof) { /* good data to send to file */
3509 p->buf[p->iosb.count] = '\n';
3510 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3513 if (p->retry < MAX_RETRY) {
3514 _ckvmssts(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3524 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3525 pipe_mbxtofd_ast, p,
3526 p->buf, p->bufsize, 0, 0, 0, 0);
3527 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3532 typedef struct _pipeloc PLOC;
3533 typedef struct _pipeloc* pPLOC;
3537 char dir[NAM$C_MAXRSS+1];
3539 static pPLOC head_PLOC = 0;
3542 free_pipelocs(pTHX_ void *head)
3545 pPLOC *pHead = (pPLOC *)head;
3557 store_pipelocs(pTHX)
3566 char temp[NAM$C_MAXRSS+1];
3570 free_pipelocs(aTHX_ &head_PLOC);
3572 /* the . directory from @INC comes last */
3574 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3575 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3576 p->next = head_PLOC;
3578 strcpy(p->dir,"./");
3580 /* get the directory from $^X */
3582 unixdir = PerlMem_malloc(VMS_MAXRSS);
3583 if (unixdir == NULL) _ckvmssts(SS$_INSFMEM);
3585 #ifdef PERL_IMPLICIT_CONTEXT
3586 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3588 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3590 strcpy(temp, PL_origargv[0]);
3591 x = strrchr(temp,']');
3593 x = strrchr(temp,'>');
3595 /* It could be a UNIX path */
3596 x = strrchr(temp,'/');
3602 /* Got a bare name, so use default directory */
3607 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3608 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3609 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3610 p->next = head_PLOC;
3612 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3613 p->dir[NAM$C_MAXRSS] = '\0';
3617 /* reverse order of @INC entries, skip "." since entered above */
3619 #ifdef PERL_IMPLICIT_CONTEXT
3622 if (PL_incgv) av = GvAVn(PL_incgv);
3624 for (i = 0; av && i <= AvFILL(av); i++) {
3625 dirsv = *av_fetch(av,i,TRUE);
3627 if (SvROK(dirsv)) continue;
3628 dir = SvPVx(dirsv,n_a);
3629 if (strcmp(dir,".") == 0) continue;
3630 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3633 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3634 p->next = head_PLOC;
3636 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3637 p->dir[NAM$C_MAXRSS] = '\0';
3640 /* most likely spot (ARCHLIB) put first in the list */
3643 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3644 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3645 if (p == NULL) _ckvmssts(SS$_INSFMEM);
3646 p->next = head_PLOC;
3648 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3649 p->dir[NAM$C_MAXRSS] = '\0';
3652 PerlMem_free(unixdir);
3656 Perl_cando_by_name_int
3657 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3658 #if !defined(PERL_IMPLICIT_CONTEXT)
3659 #define cando_by_name_int Perl_cando_by_name_int
3661 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3667 static int vmspipe_file_status = 0;
3668 static char vmspipe_file[NAM$C_MAXRSS+1];
3670 /* already found? Check and use ... need read+execute permission */
3672 if (vmspipe_file_status == 1) {
3673 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3674 && cando_by_name_int
3675 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3676 return vmspipe_file;
3678 vmspipe_file_status = 0;
3681 /* scan through stored @INC, $^X */
3683 if (vmspipe_file_status == 0) {
3684 char file[NAM$C_MAXRSS+1];
3685 pPLOC p = head_PLOC;
3690 strcpy(file, p->dir);
3691 dirlen = strlen(file);
3692 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3693 file[NAM$C_MAXRSS] = '\0';
3696 exp_res = do_rmsexpand
3697 (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL);
3698 if (!exp_res) continue;
3700 if (cando_by_name_int
3701 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3702 && cando_by_name_int
3703 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3704 vmspipe_file_status = 1;
3705 return vmspipe_file;
3708 vmspipe_file_status = -1; /* failed, use tempfiles */
3715 vmspipe_tempfile(pTHX)
3717 char file[NAM$C_MAXRSS+1];
3719 static int index = 0;
3723 /* create a tempfile */
3725 /* we can't go from W, shr=get to R, shr=get without
3726 an intermediate vulnerable state, so don't bother trying...
3728 and lib$spawn doesn't shr=put, so have to close the write
3730 So... match up the creation date/time and the FID to
3731 make sure we're dealing with the same file
3736 if (!decc_filename_unix_only) {
3737 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3738 fp = fopen(file,"w");
3740 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3741 fp = fopen(file,"w");
3743 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3744 fp = fopen(file,"w");
3749 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3750 fp = fopen(file,"w");
3752 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3753 fp = fopen(file,"w");
3755 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3756 fp = fopen(file,"w");
3760 if (!fp) return 0; /* we're hosed */
3762 fprintf(fp,"$! 'f$verify(0)'\n");
3763 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3764 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3765 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3766 fprintf(fp,"$ perl_on = \"set noon\"\n");
3767 fprintf(fp,"$ perl_exit = \"exit\"\n");
3768 fprintf(fp,"$ perl_del = \"delete\"\n");
3769 fprintf(fp,"$ pif = \"if\"\n");
3770 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3771 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3772 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3773 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3774 fprintf(fp,"$! --- build command line to get max possible length\n");
3775 fprintf(fp,"$c=perl_popen_cmd0\n");
3776 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3777 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3778 fprintf(fp,"$x=perl_popen_cmd3\n");
3779 fprintf(fp,"$c=c+x\n");
3780 fprintf(fp,"$ perl_on\n");
3781 fprintf(fp,"$ 'c'\n");
3782 fprintf(fp,"$ perl_status = $STATUS\n");
3783 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3784 fprintf(fp,"$ perl_exit 'perl_status'\n");
3787 fgetname(fp, file, 1);
3788 fstat(fileno(fp), (struct stat *)&s0);
3791 if (decc_filename_unix_only)
3792 do_tounixspec(file, file, 0, NULL);
3793 fp = fopen(file,"r","shr=get");
3795 fstat(fileno(fp), (struct stat *)&s1);
3797 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3798 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3807 static int vms_is_syscommand_xterm(void)
3809 const static struct dsc$descriptor_s syscommand_dsc =
3810 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3812 const static struct dsc$descriptor_s decwdisplay_dsc =
3813 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3815 struct item_list_3 items[2];
3816 unsigned short dvi_iosb[4];
3817 unsigned long devchar;
3818 unsigned long devclass;
3821 /* Very simple check to guess if sys$command is a decterm? */
3822 /* First see if the DECW$DISPLAY: device exists */
3824 items[0].code = DVI$_DEVCHAR;
3825 items[0].bufadr = &devchar;
3826 items[0].retadr = NULL;
3830 status = sys$getdviw
3831 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3833 if ($VMS_STATUS_SUCCESS(status)) {
3834 status = dvi_iosb[0];
3837 if (!$VMS_STATUS_SUCCESS(status)) {
3838 SETERRNO(EVMSERR, status);
3842 /* If it does, then for now assume that we are on a workstation */
3843 /* Now verify that SYS$COMMAND is a terminal */
3844 /* for creating the debugger DECTerm */
3847 items[0].code = DVI$_DEVCLASS;
3848 items[0].bufadr = &devclass;
3849 items[0].retadr = NULL;
3853 status = sys$getdviw
3854 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3856 if ($VMS_STATUS_SUCCESS(status)) {
3857 status = dvi_iosb[0];
3860 if (!$VMS_STATUS_SUCCESS(status)) {
3861 SETERRNO(EVMSERR, status);
3865 if (devclass == DC$_TERM) {
3872 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3873 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3878 char device_name[65];
3879 unsigned short device_name_len;
3880 struct dsc$descriptor_s customization_dsc;
3881 struct dsc$descriptor_s device_name_dsc;
3884 char customization[200];
3888 unsigned short p_chan;
3890 unsigned short iosb[4];
3891 struct item_list_3 items[2];
3892 const char * cust_str =
3893 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
3894 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3895 DSC$K_CLASS_S, mbx1};
3897 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
3898 /*---------------------------------------*/
3899 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
3902 /* Make sure that this is from the Perl debugger */
3903 ret_char = strstr(cmd," xterm ");
3904 if (ret_char == NULL)
3906 cptr = ret_char + 7;
3907 ret_char = strstr(cmd,"tty");
3908 if (ret_char == NULL)
3910 ret_char = strstr(cmd,"sleep");
3911 if (ret_char == NULL)
3914 if (decw_term_port == 0) {
3915 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
3916 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
3917 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
3919 status = lib$find_image_symbol
3921 &decw_term_port_dsc,
3922 (void *)&decw_term_port,
3926 /* Try again with the other image name */
3927 if (!$VMS_STATUS_SUCCESS(status)) {
3929 status = lib$find_image_symbol
3931 &decw_term_port_dsc,
3932 (void *)&decw_term_port,
3941 /* No decw$term_port, give it up */
3942 if (!$VMS_STATUS_SUCCESS(status))
3945 /* Are we on a workstation? */
3946 /* to do: capture the rows / columns and pass their properties */
3947 ret_stat = vms_is_syscommand_xterm();
3951 /* Make the title: */
3952 ret_char = strstr(cptr,"-title");
3953 if (ret_char != NULL) {
3954 while ((*cptr != 0) && (*cptr != '\"')) {
3960 while ((*cptr != 0) && (*cptr != '\"')) {
3973 strcpy(title,"Perl Debug DECTerm");
3975 sprintf(customization, cust_str, title);
3977 customization_dsc.dsc$a_pointer = customization;
3978 customization_dsc.dsc$w_length = strlen(customization);
3979 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3980 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
3982 device_name_dsc.dsc$a_pointer = device_name;
3983 device_name_dsc.dsc$w_length = sizeof device_name -1;
3984 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
3985 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
3987 device_name_len = 0;
3989 /* Try to create the window */
3990 status = (*decw_term_port)
3999 if (!$VMS_STATUS_SUCCESS(status)) {
4000 SETERRNO(EVMSERR, status);
4004 device_name[device_name_len] = '\0';
4006 /* Need to set this up to look like a pipe for cleanup */
4008 status = lib$get_vm(&n, &info);
4009 if (!$VMS_STATUS_SUCCESS(status)) {
4010 SETERRNO(ENOMEM, status);
4016 info->completion = 0;
4017 info->closing = FALSE;
4024 info->in_done = TRUE;
4025 info->out_done = TRUE;
4026 info->err_done = TRUE;
4028 /* Assign a channel on this so that it will persist, and not login */
4029 /* We stash this channel in the info structure for reference. */
4030 /* The created xterm self destructs when the last channel is removed */
4031 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4032 /* So leave this assigned. */
4033 device_name_dsc.dsc$w_length = device_name_len;
4034 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4035 if (!$VMS_STATUS_SUCCESS(status)) {
4036 SETERRNO(EVMSERR, status);
4039 info->xchan_valid = 1;
4041 /* Now create a mailbox to be read by the application */
4043 create_mbx(aTHX_ &p_chan, &d_mbx1);
4045 /* write the name of the created terminal to the mailbox */
4046 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4047 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4049 if (!$VMS_STATUS_SUCCESS(status)) {
4050 SETERRNO(EVMSERR, status);
4054 info->fp = PerlIO_open(mbx1, mode);
4056 /* Done with this channel */
4059 /* If any errors, then clean up */
4062 _ckvmssts(lib$free_vm(&n, &info));
4071 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4073 static int handler_set_up = FALSE;
4074 unsigned long int sts, flags = CLI$M_NOWAIT;
4075 /* The use of a GLOBAL table (as was done previously) rendered
4076 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4077 * environment. Hence we've switched to LOCAL symbol table.
4079 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4081 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4082 char *in, *out, *err, mbx[512];
4084 char tfilebuf[NAM$C_MAXRSS+1];
4086 char cmd_sym_name[20];
4087 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4088 DSC$K_CLASS_S, symbol};
4089 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4091 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4092 DSC$K_CLASS_S, cmd_sym_name};
4093 struct dsc$descriptor_s *vmscmd;
4094 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4095 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4096 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4098 /* Check here for Xterm create request. This means looking for
4099 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4100 * is possible to create an xterm.
4102 if (*in_mode == 'r') {
4105 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4106 if (xterm_fd != NULL)
4110 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4112 /* once-per-program initialization...
4113 note that the SETAST calls and the dual test of pipe_ef
4114 makes sure that only the FIRST thread through here does
4115 the initialization...all other threads wait until it's
4118 Yeah, uglier than a pthread call, it's got all the stuff inline
4119 rather than in a separate routine.
4123 _ckvmssts(sys$setast(0));
4125 unsigned long int pidcode = JPI$_PID;
4126 $DESCRIPTOR(d_delay, RETRY_DELAY);
4127 _ckvmssts(lib$get_ef(&pipe_ef));
4128 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4129 _ckvmssts(sys$bintim(&d_delay, delaytime));
4131 if (!handler_set_up) {
4132 _ckvmssts(sys$dclexh(&pipe_exitblock));
4133 handler_set_up = TRUE;
4135 _ckvmssts(sys$setast(1));
4138 /* see if we can find a VMSPIPE.COM */
4141 vmspipe = find_vmspipe(aTHX);
4143 strcpy(tfilebuf+1,vmspipe);
4144 } else { /* uh, oh...we're in tempfile hell */
4145 tpipe = vmspipe_tempfile(aTHX);
4146 if (!tpipe) { /* a fish popular in Boston */
4147 if (ckWARN(WARN_PIPE)) {
4148 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4152 fgetname(tpipe,tfilebuf+1,1);
4154 vmspipedsc.dsc$a_pointer = tfilebuf;
4155 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4157 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4160 case RMS$_FNF: case RMS$_DNF:
4161 set_errno(ENOENT); break;
4163 set_errno(ENOTDIR); break;
4165 set_errno(ENODEV); break;
4167 set_errno(EACCES); break;
4169 set_errno(EINVAL); break;
4170 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4171 set_errno(E2BIG); break;
4172 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4173 _ckvmssts(sts); /* fall through */
4174 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4177 set_vaxc_errno(sts);
4178 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4179 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4185 _ckvmssts(lib$get_vm(&n, &info));
4187 strcpy(mode,in_mode);
4190 info->completion = 0;
4191 info->closing = FALSE;
4198 info->in_done = TRUE;
4199 info->out_done = TRUE;
4200 info->err_done = TRUE;
4202 info->xchan_valid = 0;
4204 in = PerlMem_malloc(VMS_MAXRSS);
4205 if (in == NULL) _ckvmssts(SS$_INSFMEM);
4206 out = PerlMem_malloc(VMS_MAXRSS);
4207 if (out == NULL) _ckvmssts(SS$_INSFMEM);
4208 err = PerlMem_malloc(VMS_MAXRSS);
4209 if (err == NULL) _ckvmssts(SS$_INSFMEM);
4211 in[0] = out[0] = err[0] = '\0';
4213 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4217 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4222 if (*mode == 'r') { /* piping from subroutine */
4224 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4226 info->out->pipe_done = &info->out_done;
4227 info->out_done = FALSE;
4228 info->out->info = info;
4230 if (!info->useFILE) {
4231 info->fp = PerlIO_open(mbx, mode);
4233 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4234 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4237 if (!info->fp && info->out) {
4238 sys$cancel(info->out->chan_out);
4240 while (!info->out_done) {
4242 _ckvmssts(sys$setast(0));
4243 done = info->out_done;
4244 if (!done) _ckvmssts(sys$clref(pipe_ef));
4245 _ckvmssts(sys$setast(1));
4246 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4249 if (info->out->buf) {
4250 n = info->out->bufsize * sizeof(char);
4251 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4254 _ckvmssts(lib$free_vm(&n, &info->out));
4256 _ckvmssts(lib$free_vm(&n, &info));
4261 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4263 info->err->pipe_done = &info->err_done;
4264 info->err_done = FALSE;
4265 info->err->info = info;
4268 } else if (*mode == 'w') { /* piping to subroutine */
4270 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4272 info->out->pipe_done = &info->out_done;
4273 info->out_done = FALSE;
4274 info->out->info = info;
4277 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4279 info->err->pipe_done = &info->err_done;
4280 info->err_done = FALSE;
4281 info->err->info = info;
4284 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4285 if (!info->useFILE) {
4286 info->fp = PerlIO_open(mbx, mode);
4288 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4289 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4293 info->in->pipe_done = &info->in_done;
4294 info->in_done = FALSE;
4295 info->in->info = info;
4299 if (!info->fp && info->in) {
4301 _ckvmssts(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4302 0, 0, 0, 0, 0, 0, 0, 0));
4304 while (!info->in_done) {
4306 _ckvmssts(sys$setast(0));
4307 done = info->in_done;
4308 if (!done) _ckvmssts(sys$clref(pipe_ef));
4309 _ckvmssts(sys$setast(1));
4310 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4313 if (info->in->buf) {
4314 n = info->in->bufsize * sizeof(char);
4315 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4318 _ckvmssts(lib$free_vm(&n, &info->in));
4320 _ckvmssts(lib$free_vm(&n, &info));
4326 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4327 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4329 info->out->pipe_done = &info->out_done;
4330 info->out_done = FALSE;
4331 info->out->info = info;
4334 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4336 info->err->pipe_done = &info->err_done;
4337 info->err_done = FALSE;
4338 info->err->info = info;
4342 symbol[MAX_DCL_SYMBOL] = '\0';
4344 strncpy(symbol, in, MAX_DCL_SYMBOL);
4345 d_symbol.dsc$w_length = strlen(symbol);
4346 _ckvmssts(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4348 strncpy(symbol, err, MAX_DCL_SYMBOL);
4349 d_symbol.dsc$w_length = strlen(symbol);
4350 _ckvmssts(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4352 strncpy(symbol, out, MAX_DCL_SYMBOL);
4353 d_symbol.dsc$w_length = strlen(symbol);
4354 _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4356 /* Done with the names for the pipes */
4361 p = vmscmd->dsc$a_pointer;
4362 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4363 if (*p == '$') p++; /* remove leading $ */
4364 while (*p == ' ' || *p == '\t') p++;
4366 for (j = 0; j < 4; j++) {
4367 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4368 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4370 strncpy(symbol, p, MAX_DCL_SYMBOL);
4371 d_symbol.dsc$w_length = strlen(symbol);
4372 _ckvmssts(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4374 if (strlen(p) > MAX_DCL_SYMBOL) {
4375 p += MAX_DCL_SYMBOL;
4380 _ckvmssts(sys$setast(0));
4381 info->next=open_pipes; /* prepend to list */
4383 _ckvmssts(sys$setast(1));
4384 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4385 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4386 * have SYS$COMMAND if we need it.
4388 _ckvmssts(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4389 0, &info->pid, &info->completion,
4390 0, popen_completion_ast,info,0,0,0));
4392 /* if we were using a tempfile, close it now */
4394 if (tpipe) fclose(tpipe);
4396 /* once the subprocess is spawned, it has copied the symbols and
4397 we can get rid of ours */
4399 for (j = 0; j < 4; j++) {
4400 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4401 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4402 _ckvmssts(lib$delete_symbol(&d_sym_cmd, &table));
4404 _ckvmssts(lib$delete_symbol(&d_sym_in, &table));
4405 _ckvmssts(lib$delete_symbol(&d_sym_err, &table));
4406 _ckvmssts(lib$delete_symbol(&d_sym_out, &table));
4407 vms_execfree(vmscmd);
4409 #ifdef PERL_IMPLICIT_CONTEXT
4412 PL_forkprocess = info->pid;
4417 _ckvmssts(sys$setast(0));
4419 if (!done) _ckvmssts(sys$clref(pipe_ef));
4420 _ckvmssts(sys$setast(1));
4421 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4423 *psts = info->completion;
4424 /* Caller thinks it is open and tries to close it. */
4425 /* This causes some problems, as it changes the error status */
4426 /* my_pclose(info->fp); */
4431 } /* end of safe_popen */
4434 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4436 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4440 TAINT_PROPER("popen");
4441 PERL_FLUSHALL_FOR_CHILD;
4442 return safe_popen(aTHX_ cmd,mode,&sts);
4447 /*{{{ I32 my_pclose(PerlIO *fp)*/
4448 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4450 pInfo info, last = NULL;
4451 unsigned long int retsts;
4455 for (info = open_pipes; info != NULL; last = info, info = info->next)
4456 if (info->fp == fp) break;
4458 if (info == NULL) { /* no such pipe open */
4459 set_errno(ECHILD); /* quoth POSIX */
4460 set_vaxc_errno(SS$_NONEXPR);
4464 /* If we were writing to a subprocess, insure that someone reading from
4465 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4466 * produce an EOF record in the mailbox.
4468 * well, at least sometimes it *does*, so we have to watch out for
4469 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4473 #if defined(USE_ITHREADS)
4476 && PL_perlio_fd_refcnt)
4477 PerlIO_flush(info->fp);
4479 fflush((FILE *)info->fp);
4482 _ckvmssts(sys$setast(0));
4483 info->closing = TRUE;
4484 done = info->done && info->in_done && info->out_done && info->err_done;
4485 /* hanging on write to Perl's input? cancel it */
4486 if (info->mode == 'r' && info->out && !info->out_done) {
4487 if (info->out->chan_out) {
4488 _ckvmssts(sys$cancel(info->out->chan_out));
4489 if (!info->out->chan_in) { /* EOF generation, need AST */
4490 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4494 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4495 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4497 _ckvmssts(sys$setast(1));
4500 #if defined(USE_ITHREADS)
4503 && PL_perlio_fd_refcnt)
4504 PerlIO_close(info->fp);
4506 fclose((FILE *)info->fp);
4509 we have to wait until subprocess completes, but ALSO wait until all
4510 the i/o completes...otherwise we'll be freeing the "info" structure
4511 that the i/o ASTs could still be using...
4515 _ckvmssts(sys$setast(0));
4516 done = info->done && info->in_done && info->out_done && info->err_done;
4517 if (!done) _ckvmssts(sys$clref(pipe_ef));
4518 _ckvmssts(sys$setast(1));
4519 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4521 retsts = info->completion;
4523 /* remove from list of open pipes */
4524 _ckvmssts(sys$setast(0));
4525 if (last) last->next = info->next;
4526 else open_pipes = info->next;
4527 _ckvmssts(sys$setast(1));
4529 /* free buffers and structures */
4532 if (info->in->buf) {
4533 n = info->in->bufsize * sizeof(char);
4534 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4537 _ckvmssts(lib$free_vm(&n, &info->in));
4540 if (info->out->buf) {
4541 n = info->out->bufsize * sizeof(char);
4542 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4545 _ckvmssts(lib$free_vm(&n, &info->out));
4548 if (info->err->buf) {
4549 n = info->err->bufsize * sizeof(char);
4550 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4553 _ckvmssts(lib$free_vm(&n, &info->err));
4556 _ckvmssts(lib$free_vm(&n, &info));
4560 } /* end of my_pclose() */
4562 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4563 /* Roll our own prototype because we want this regardless of whether
4564 * _VMS_WAIT is defined.
4566 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4568 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4569 created with popen(); otherwise partially emulate waitpid() unless
4570 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4571 Also check processes not considered by the CRTL waitpid().
4573 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4575 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4582 if (statusp) *statusp = 0;
4584 for (info = open_pipes; info != NULL; info = info->next)
4585 if (info->pid == pid) break;
4587 if (info != NULL) { /* we know about this child */
4588 while (!info->done) {
4589 _ckvmssts(sys$setast(0));
4591 if (!done) _ckvmssts(sys$clref(pipe_ef));
4592 _ckvmssts(sys$setast(1));
4593 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4596 if (statusp) *statusp = info->completion;
4600 /* child that already terminated? */
4602 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4603 if (closed_list[j].pid == pid) {
4604 if (statusp) *statusp = closed_list[j].completion;
4609 /* fall through if this child is not one of our own pipe children */
4611 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4613 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4614 * in 7.2 did we get a version that fills in the VMS completion
4615 * status as Perl has always tried to do.
4618 sts = __vms_waitpid( pid, statusp, flags );
4620 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4623 /* If the real waitpid tells us the child does not exist, we
4624 * fall through here to implement waiting for a child that
4625 * was created by some means other than exec() (say, spawned
4626 * from DCL) or to wait for a process that is not a subprocess
4627 * of the current process.
4630 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4633 $DESCRIPTOR(intdsc,"0 00:00:01");
4634 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4635 unsigned long int pidcode = JPI$_PID, mypid;
4636 unsigned long int interval[2];
4637 unsigned int jpi_iosb[2];
4638 struct itmlst_3 jpilist[2] = {
4639 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4644 /* Sorry folks, we don't presently implement rooting around for
4645 the first child we can find, and we definitely don't want to
4646 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4652 /* Get the owner of the child so I can warn if it's not mine. If the
4653 * process doesn't exist or I don't have the privs to look at it,
4654 * I can go home early.
4656 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4657 if (sts & 1) sts = jpi_iosb[0];
4669 set_vaxc_errno(sts);
4673 if (ckWARN(WARN_EXEC)) {
4674 /* remind folks they are asking for non-standard waitpid behavior */
4675 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4676 if (ownerpid != mypid)
4677 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4678 "waitpid: process %x is not a child of process %x",
4682 /* simply check on it once a second until it's not there anymore. */
4684 _ckvmssts(sys$bintim(&intdsc,interval));
4685 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4686 _ckvmssts(sys$schdwk(0,0,interval,0));
4687 _ckvmssts(sys$hiber());
4689 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4694 } /* end of waitpid() */
4699 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4701 my_gconvert(double val, int ndig, int trail, char *buf)
4703 static char __gcvtbuf[DBL_DIG+1];
4706 loc = buf ? buf : __gcvtbuf;
4708 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4710 sprintf(loc,"%.*g",ndig,val);
4716 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4717 return gcvt(val,ndig,loc);
4720 loc[0] = '0'; loc[1] = '\0';
4727 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4728 static int rms_free_search_context(struct FAB * fab)
4732 nam = fab->fab$l_nam;
4733 nam->nam$b_nop |= NAM$M_SYNCHK;
4734 nam->nam$l_rlf = NULL;
4736 return sys$parse(fab, NULL, NULL);
4739 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4740 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4741 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4742 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4743 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4744 #define rms_nam_esll(nam) nam.nam$b_esl
4745 #define rms_nam_esl(nam) nam.nam$b_esl
4746 #define rms_nam_name(nam) nam.nam$l_name
4747 #define rms_nam_namel(nam) nam.nam$l_name
4748 #define rms_nam_type(nam) nam.nam$l_type
4749 #define rms_nam_typel(nam) nam.nam$l_type
4750 #define rms_nam_ver(nam) nam.nam$l_ver
4751 #define rms_nam_verl(nam) nam.nam$l_ver
4752 #define rms_nam_rsll(nam) nam.nam$b_rsl
4753 #define rms_nam_rsl(nam) nam.nam$b_rsl
4754 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4755 #define rms_set_fna(fab, nam, name, size) \
4756 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4757 #define rms_get_fna(fab, nam) fab.fab$l_fna
4758 #define rms_set_dna(fab, nam, name, size) \
4759 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4760 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4761 #define rms_set_esa(nam, name, size) \
4762 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4763 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4764 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4765 #define rms_set_rsa(nam, name, size) \
4766 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4767 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4768 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4769 #define rms_nam_name_type_l_size(nam) \
4770 (nam.nam$b_name + nam.nam$b_type)
4772 static int rms_free_search_context(struct FAB * fab)
4776 nam = fab->fab$l_naml;
4777 nam->naml$b_nop |= NAM$M_SYNCHK;
4778 nam->naml$l_rlf = NULL;
4779 nam->naml$l_long_defname_size = 0;
4782 return sys$parse(fab, NULL, NULL);
4785 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4786 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4787 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4788 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4789 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4790 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4791 #define rms_nam_esl(nam) nam.naml$b_esl
4792 #define rms_nam_name(nam) nam.naml$l_name
4793 #define rms_nam_namel(nam) nam.naml$l_long_name
4794 #define rms_nam_type(nam) nam.naml$l_type
4795 #define rms_nam_typel(nam) nam.naml$l_long_type
4796 #define rms_nam_ver(nam) nam.naml$l_ver
4797 #define rms_nam_verl(nam) nam.naml$l_long_ver
4798 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4799 #define rms_nam_rsl(nam) nam.naml$b_rsl
4800 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4801 #define rms_set_fna(fab, nam, name, size) \
4802 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4803 nam.naml$l_long_filename_size = size; \
4804 nam.naml$l_long_filename = name;}
4805 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4806 #define rms_set_dna(fab, nam, name, size) \
4807 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4808 nam.naml$l_long_defname_size = size; \
4809 nam.naml$l_long_defname = name; }
4810 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4811 #define rms_set_esa(nam, name, size) \
4812 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4813 nam.naml$l_long_expand_alloc = size; \
4814 nam.naml$l_long_expand = name; }
4815 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4816 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4817 nam.naml$l_long_expand = l_name; \
4818 nam.naml$l_long_expand_alloc = l_size; }
4819 #define rms_set_rsa(nam, name, size) \
4820 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4821 nam.naml$l_long_result = name; \
4822 nam.naml$l_long_result_alloc = size; }
4823 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4824 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4825 nam.naml$l_long_result = l_name; \
4826 nam.naml$l_long_result_alloc = l_size; }
4827 #define rms_nam_name_type_l_size(nam) \
4828 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4833 * The CRTL for 8.3 and later can create symbolic links in any mode,
4834 * however in 8.3 the unlink/remove/delete routines will only properly handle
4835 * them if one of the PCP modes is active.
4837 static int rms_erase(const char * vmsname)
4840 struct FAB myfab = cc$rms_fab;
4841 rms_setup_nam(mynam);
4843 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4844 rms_bind_fab_nam(myfab, mynam);
4846 /* Are we removing all versions? */
4847 if (vms_unlink_all_versions == 1) {
4848 const char * defspec = ";*";
4849 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
4852 #ifdef NAML$M_OPEN_SPECIAL
4853 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
4856 status = sys$erase(&myfab, 0, 0);
4863 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
4864 const struct dsc$descriptor_s * vms_dst_dsc,
4865 unsigned long flags)
4867 /* VMS and UNIX handle file permissions differently and the
4868 * the same ACL trick may be needed for renaming files,
4869 * especially if they are directories.
4872 /* todo: get kill_file and rename to share common code */
4873 /* I can not find online documentation for $change_acl
4874 * it appears to be replaced by $set_security some time ago */
4876 const unsigned int access_mode = 0;
4877 $DESCRIPTOR(obj_file_dsc,"FILE");
4880 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
4881 int aclsts, fndsts, rnsts = -1;
4882 unsigned int ctx = 0;
4883 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
4884 struct dsc$descriptor_s * clean_dsc;
4887 unsigned char myace$b_length;
4888 unsigned char myace$b_type;
4889 unsigned short int myace$w_flags;
4890 unsigned long int myace$l_access;
4891 unsigned long int myace$l_ident;
4892 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
4893 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
4895 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
4898 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
4899 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
4901 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
4902 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
4906 /* Expand the input spec using RMS, since we do not want to put
4907 * ACLs on the target of a symbolic link */
4908 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
4909 if (vmsname == NULL)
4912 rslt = do_rmsexpand(vms_src_dsc->dsc$a_pointer,
4916 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_SYMLINK,
4920 PerlMem_free(vmsname);
4924 /* So we get our own UIC to use as a rights identifier,
4925 * and the insert an ACE at the head of the ACL which allows us
4926 * to delete the file.
4928 _ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
4930 fildsc.dsc$w_length = strlen(vmsname);
4931 fildsc.dsc$a_pointer = vmsname;
4933 newace.myace$l_ident = oldace.myace$l_ident;
4936 /* Grab any existing ACEs with this identifier in case we fail */
4937 clean_dsc = &fildsc;
4938 aclsts = fndsts = sys$get_security(&obj_file_dsc,
4946 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
4947 /* Add the new ACE . . . */
4949 /* if the sys$get_security succeeded, then ctx is valid, and the
4950 * object/file descriptors will be ignored. But otherwise they
4953 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
4954 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4955 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4957 set_vaxc_errno(aclsts);
4958 PerlMem_free(vmsname);
4962 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
4965 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
4967 if ($VMS_STATUS_SUCCESS(rnsts)) {
4968 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
4971 /* Put things back the way they were. */
4973 aclsts = sys$get_security(&obj_file_dsc,
4981 if ($VMS_STATUS_SUCCESS(aclsts)) {
4985 if (!$VMS_STATUS_SUCCESS(fndsts))
4986 sec_flags = OSS$M_RELCTX;
4988 /* Get rid of the new ACE */
4989 aclsts = sys$set_security(NULL, NULL, NULL,
4990 sec_flags, dellst, &ctx, &access_mode);
4992 /* If there was an old ACE, put it back */
4993 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
4994 addlst[0].bufadr = &oldace;
4995 aclsts = sys$set_security(NULL, NULL, NULL,
4996 OSS$M_RELCTX, addlst, &ctx, &access_mode);
4997 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
4999 set_vaxc_errno(aclsts);
5005 /* Try to clear the lock on the ACL list */
5006 aclsts2 = sys$set_security(NULL, NULL, NULL,
5007 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5009 /* Rename errors are most important */
5010 if (!$VMS_STATUS_SUCCESS(rnsts))
5013 set_vaxc_errno(aclsts);
5018 if (aclsts != SS$_ACLEMPTY)
5025 PerlMem_free(vmsname);
5030 /*{{{int rename(const char *, const char * */
5031 /* Not exactly what X/Open says to do, but doing it absolutely right
5032 * and efficiently would require a lot more work. This should be close
5033 * enough to pass all but the most strict X/Open compliance test.
5036 Perl_rename(pTHX_ const char *src, const char * dst)
5045 /* Validate the source file */
5046 src_sts = flex_lstat(src, &src_st);
5049 /* No source file or other problem */
5053 dst_sts = flex_lstat(dst, &dst_st);
5056 if (dst_st.st_dev != src_st.st_dev) {
5057 /* Must be on the same device */
5062 /* VMS_INO_T_COMPARE is true if the inodes are different
5063 * to match the output of memcmp
5066 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5067 /* That was easy, the files are the same! */
5071 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5072 /* If source is a directory, so must be dest */
5080 if ((dst_sts == 0) &&
5081 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5083 /* We have issues here if vms_unlink_all_versions is set
5084 * If the destination exists, and is not a directory, then
5085 * we must delete in advance.
5087 * If the src is a directory, then we must always pre-delete
5090 * If we successfully delete the dst in advance, and the rename fails
5091 * X/Open requires that errno be EIO.
5095 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5097 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5101 /* We killed the destination, so only errno now is EIO */
5106 /* Originally the idea was to call the CRTL rename() and only
5107 * try the lib$rename_file if it failed.
5108 * It turns out that there are too many variants in what the
5109 * the CRTL rename might do, so only use lib$rename_file
5114 /* Is the source and dest both in VMS format */
5115 /* if the source is a directory, then need to fileify */
5116 /* and dest must be a directory or non-existant. */
5122 unsigned long flags;
5123 struct dsc$descriptor_s old_file_dsc;
5124 struct dsc$descriptor_s new_file_dsc;
5126 /* We need to modify the src and dst depending
5127 * on if one or more of them are directories.
5130 vms_src = PerlMem_malloc(VMS_MAXRSS);
5131 if (vms_src == NULL)
5132 _ckvmssts(SS$_INSFMEM);
5134 /* Source is always a VMS format file */
5135 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5136 if (ret_str == NULL) {
5137 PerlMem_free(vms_src);
5142 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5143 if (vms_dst == NULL)
5144 _ckvmssts(SS$_INSFMEM);
5146 if (S_ISDIR(src_st.st_mode)) {
5148 char * vms_dir_file;
5150 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5151 if (vms_dir_file == NULL)
5152 _ckvmssts(SS$_INSFMEM);
5154 /* The source must be a file specification */
5155 ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5156 if (ret_str == NULL) {
5157 PerlMem_free(vms_src);
5158 PerlMem_free(vms_dst);
5159 PerlMem_free(vms_dir_file);
5163 PerlMem_free(vms_src);
5164 vms_src = vms_dir_file;
5166 /* If the dest is a directory, we must remove it
5169 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5171 PerlMem_free(vms_src);
5172 PerlMem_free(vms_dst);
5180 /* The dest must be a VMS file specification */
5181 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5182 if (ret_str == NULL) {
5183 PerlMem_free(vms_src);
5184 PerlMem_free(vms_dst);
5189 /* The source must be a file specification */
5190 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5191 if (vms_dir_file == NULL)
5192 _ckvmssts(SS$_INSFMEM);
5194 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5195 if (ret_str == NULL) {
5196 PerlMem_free(vms_src);
5197 PerlMem_free(vms_dst);
5198 PerlMem_free(vms_dir_file);
5202 PerlMem_free(vms_dst);
5203 vms_dst = vms_dir_file;
5206 /* File to file or file to new dir */
5208 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5209 /* VMS pathify a dir target */
5210 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5211 if (ret_str == NULL) {
5212 PerlMem_free(vms_src);
5213 PerlMem_free(vms_dst);
5219 /* fileify a target VMS file specification */
5220 ret_str = do_tovmsspec(dst, vms_dst, 0, NULL);
5221 if (ret_str == NULL) {
5222 PerlMem_free(vms_src);
5223 PerlMem_free(vms_dst);
5230 old_file_dsc.dsc$a_pointer = vms_src;
5231 old_file_dsc.dsc$w_length = strlen(vms_src);
5232 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5233 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5235 new_file_dsc.dsc$a_pointer = vms_dst;
5236 new_file_dsc.dsc$w_length = strlen(vms_dst);
5237 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5238 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5241 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5242 flags |= 2; /* LIB$M_FIL_LONG_NAMES */
5245 sts = lib$rename_file(&old_file_dsc,
5249 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5250 if (!$VMS_STATUS_SUCCESS(sts)) {
5252 /* We could have failed because VMS style permissions do not
5253 * permit renames that UNIX will allow. Just like the hack
5256 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5259 PerlMem_free(vms_src);
5260 PerlMem_free(vms_dst);
5261 if (!$VMS_STATUS_SUCCESS(sts)) {
5268 if (vms_unlink_all_versions) {
5269 /* Now get rid of any previous versions of the source file that
5274 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5278 /* We deleted the destination, so must force the error to be EIO */
5279 if ((retval != 0) && (pre_delete != 0))
5287 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5288 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5289 * to expand file specification. Allows for a single default file
5290 * specification and a simple mask of options. If outbuf is non-NULL,
5291 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5292 * the resultant file specification is placed. If outbuf is NULL, the
5293 * resultant file specification is placed into a static buffer.
5294 * The third argument, if non-NULL, is taken to be a default file
5295 * specification string. The fourth argument is unused at present.
5296 * rmesexpand() returns the address of the resultant string if
5297 * successful, and NULL on error.
5299 * New functionality for previously unused opts value:
5300 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5301 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5302 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5303 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5305 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5309 (pTHX_ const char *filespec,
5312 const char *defspec,
5317 static char __rmsexpand_retbuf[VMS_MAXRSS];
5318 char * vmsfspec, *tmpfspec;
5319 char * esa, *cp, *out = NULL;
5323 struct FAB myfab = cc$rms_fab;
5324 rms_setup_nam(mynam);
5326 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5329 /* temp hack until UTF8 is actually implemented */
5330 if (fs_utf8 != NULL)
5333 if (!filespec || !*filespec) {
5334 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5338 if (ts) out = Newx(outbuf,VMS_MAXRSS,char);
5339 else outbuf = __rmsexpand_retbuf;
5347 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5348 isunix = is_unix_filespec(filespec);
5350 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5351 if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM);
5352 if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) {
5353 PerlMem_free(vmsfspec);
5358 filespec = vmsfspec;
5360 /* Unless we are forcing to VMS format, a UNIX input means
5361 * UNIX output, and that requires long names to be used
5363 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5364 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5365 opts |= PERL_RMSEXPAND_M_LONG;
5372 rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */
5373 rms_bind_fab_nam(myfab, mynam);
5375 if (defspec && *defspec) {
5377 t_isunix = is_unix_filespec(defspec);
5379 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5380 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5381 if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) {
5382 PerlMem_free(tmpfspec);
5383 if (vmsfspec != NULL)
5384 PerlMem_free(vmsfspec);
5391 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5394 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5395 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5396 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5397 esal = PerlMem_malloc(VMS_MAXRSS);
5398 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5400 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5402 /* If a NAML block is used RMS always writes to the long and short
5403 * addresses unless you suppress the short name.
5405 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5406 outbufl = PerlMem_malloc(VMS_MAXRSS);
5407 if (outbufl == NULL) _ckvmssts(SS$_INSFMEM);
5409 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5411 #ifdef NAM$M_NO_SHORT_UPCASE
5412 if (decc_efs_case_preserve)
5413 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5416 /* We may not want to follow symbolic links */
5417 #ifdef NAML$M_OPEN_SPECIAL
5418 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5419 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5422 /* First attempt to parse as an existing file */
5423 retsts = sys$parse(&myfab,0,0);
5424 if (!(retsts & STS$K_SUCCESS)) {
5426 /* Could not find the file, try as syntax only if error is not fatal */
5427 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5428 if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) {
5429 retsts = sys$parse(&myfab,0,0);
5430 if (retsts & STS$K_SUCCESS) goto expanded;
5433 /* Still could not parse the file specification */
5434 /*----------------------------------------------*/
5435 sts = rms_free_search_context(&myfab); /* Free search context */
5436 if (out) Safefree(out);
5437 if (tmpfspec != NULL)
5438 PerlMem_free(tmpfspec);
5439 if (vmsfspec != NULL)
5440 PerlMem_free(vmsfspec);
5441 if (outbufl != NULL)
5442 PerlMem_free(outbufl);
5446 set_vaxc_errno(retsts);
5447 if (retsts == RMS$_PRV) set_errno(EACCES);
5448 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5449 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5450 else set_errno(EVMSERR);
5453 retsts = sys$search(&myfab,0,0);
5454 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5455 sts = rms_free_search_context(&myfab); /* Free search context */
5456 if (out) Safefree(out);
5457 if (tmpfspec != NULL)
5458 PerlMem_free(tmpfspec);
5459 if (vmsfspec != NULL)
5460 PerlMem_free(vmsfspec);
5461 if (outbufl != NULL)
5462 PerlMem_free(outbufl);
5466 set_vaxc_errno(retsts);
5467 if (retsts == RMS$_PRV) set_errno(EACCES);
5468 else set_errno(EVMSERR);
5472 /* If the input filespec contained any lowercase characters,
5473 * downcase the result for compatibility with Unix-minded code. */
5475 if (!decc_efs_case_preserve) {
5476 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5477 if (islower(*tbuf)) { haslower = 1; break; }
5480 /* Is a long or a short name expected */
5481 /*------------------------------------*/
5482 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5483 if (rms_nam_rsll(mynam)) {
5485 speclen = rms_nam_rsll(mynam);
5488 tbuf = esal; /* Not esa */
5489 speclen = rms_nam_esll(mynam);
5493 if (rms_nam_rsl(mynam)) {
5495 speclen = rms_nam_rsl(mynam);
5498 tbuf = esa; /* Not esal */
5499 speclen = rms_nam_esl(mynam);
5502 tbuf[speclen] = '\0';
5504 /* Trim off null fields added by $PARSE
5505 * If type > 1 char, must have been specified in original or default spec
5506 * (not true for version; $SEARCH may have added version of existing file).
5508 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5509 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5510 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5511 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5514 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5515 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5517 if (trimver || trimtype) {
5518 if (defspec && *defspec) {
5519 char *defesal = NULL;
5520 char *defesa = NULL;
5521 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5522 if (defesa != NULL) {
5523 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5524 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5525 if (defesal == NULL) _ckvmssts(SS$_INSFMEM);
5527 struct FAB deffab = cc$rms_fab;
5528 rms_setup_nam(defnam);
5530 rms_bind_fab_nam(deffab, defnam);
5534 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5536 /* RMS needs the esa/esal as a work area if wildcards are involved */
5537 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5539 rms_clear_nam_nop(defnam);
5540 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5541 #ifdef NAM$M_NO_SHORT_UPCASE
5542 if (decc_efs_case_preserve)
5543 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5545 #ifdef NAML$M_OPEN_SPECIAL
5546 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5547 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5549 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5551 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5554 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5557 if (defesal != NULL)
5558 PerlMem_free(defesal);
5559 PerlMem_free(defesa);
5563 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5564 if (*(rms_nam_verl(mynam)) != '\"')
5565 speclen = rms_nam_verl(mynam) - tbuf;
5568 if (*(rms_nam_ver(mynam)) != '\"')
5569 speclen = rms_nam_ver(mynam) - tbuf;
5573 /* If we didn't already trim version, copy down */
5574 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5575 if (speclen > rms_nam_verl(mynam) - tbuf)
5577 (rms_nam_typel(mynam),
5578 rms_nam_verl(mynam),
5579 speclen - (rms_nam_verl(mynam) - tbuf));
5580 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5583 if (speclen > rms_nam_ver(mynam) - tbuf)
5585 (rms_nam_type(mynam),
5587 speclen - (rms_nam_ver(mynam) - tbuf));
5588 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5593 /* Done with these copies of the input files */
5594 /*-------------------------------------------*/
5595 if (vmsfspec != NULL)
5596 PerlMem_free(vmsfspec);
5597 if (tmpfspec != NULL)
5598 PerlMem_free(tmpfspec);
5600 /* If we just had a directory spec on input, $PARSE "helpfully"
5601 * adds an empty name and type for us */
5602 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5603 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5604 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5605 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5606 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5607 speclen = rms_nam_namel(mynam) - tbuf;
5612 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5613 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5614 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5615 speclen = rms_nam_name(mynam) - tbuf;
5618 /* Posix format specifications must have matching quotes */
5619 if (speclen < (VMS_MAXRSS - 1)) {
5620 if (decc_posix_compliant_pathnames && (tbuf[0] == '\"')) {
5621 if ((speclen > 1) && (tbuf[speclen-1] != '\"')) {
5622 tbuf[speclen] = '\"';
5627 tbuf[speclen] = '\0';
5628 if (haslower && !decc_efs_case_preserve) __mystrtolower(tbuf);
5630 /* Have we been working with an expanded, but not resultant, spec? */
5631 /* Also, convert back to Unix syntax if necessary. */
5635 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5636 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5637 rsl = rms_nam_rsll(mynam);
5641 rsl = rms_nam_rsl(mynam);
5645 if (do_tounixspec(tbuf, outbuf ,0 , fs_utf8) == NULL) {
5646 if (out) Safefree(out);
5650 if (outbufl != NULL)
5651 PerlMem_free(outbufl);
5655 else strcpy(outbuf, tbuf);
5658 tmpfspec = PerlMem_malloc(VMS_MAXRSS);
5659 if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM);
5660 if (do_tounixspec(tbuf,tmpfspec,0,fs_utf8) == NULL) {
5661 if (out) Safefree(out);
5665 PerlMem_free(tmpfspec);
5666 if (outbufl != NULL)
5667 PerlMem_free(outbufl);
5670 strcpy(outbuf,tmpfspec);
5671 PerlMem_free(tmpfspec);
5674 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5675 sts = rms_free_search_context(&myfab); /* Free search context */
5679 if (outbufl != NULL)
5680 PerlMem_free(outbufl);
5684 /* External entry points */
5685 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5686 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5687 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5688 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5689 char *Perl_rmsexpand_utf8
5690 (pTHX_ const char *spec, char *buf, const char *def,
5691 unsigned opt, int * fs_utf8, int * dfs_utf8)
5692 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5693 char *Perl_rmsexpand_utf8_ts
5694 (pTHX_ const char *spec, char *buf, const char *def,
5695 unsigned opt, int * fs_utf8, int * dfs_utf8)
5696 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5700 ** The following routines are provided to make life easier when
5701 ** converting among VMS-style and Unix-style directory specifications.
5702 ** All will take input specifications in either VMS or Unix syntax. On
5703 ** failure, all return NULL. If successful, the routines listed below
5704 ** return a pointer to a buffer containing the appropriately
5705 ** reformatted spec (and, therefore, subsequent calls to that routine
5706 ** will clobber the result), while the routines of the same names with
5707 ** a _ts suffix appended will return a pointer to a mallocd string
5708 ** containing the appropriately reformatted spec.
5709 ** In all cases, only explicit syntax is altered; no check is made that
5710 ** the resulting string is valid or that the directory in question
5713 ** fileify_dirspec() - convert a directory spec into the name of the
5714 ** directory file (i.e. what you can stat() to see if it's a dir).
5715 ** The style (VMS or Unix) of the result is the same as the style
5716 ** of the parameter passed in.
5717 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5718 ** what you prepend to a filename to indicate what directory it's in).
5719 ** The style (VMS or Unix) of the result is the same as the style
5720 ** of the parameter passed in.
5721 ** tounixpath() - convert a directory spec into a Unix-style path.
5722 ** tovmspath() - convert a directory spec into a VMS-style path.
5723 ** tounixspec() - convert any file spec into a Unix-style file spec.
5724 ** tovmsspec() - convert any file spec into a VMS-style spec.
5725 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5727 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5728 ** Permission is given to distribute this code as part of the Perl
5729 ** standard distribution under the terms of the GNU General Public
5730 ** License or the Perl Artistic License. Copies of each may be
5731 ** found in the Perl standard distribution.
5734 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5735 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5737 static char __fileify_retbuf[VMS_MAXRSS];
5738 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5739 char *retspec, *cp1, *cp2, *lastdir;
5740 char *trndir, *vmsdir;
5741 unsigned short int trnlnm_iter_count;
5743 if (utf8_fl != NULL)
5746 if (!dir || !*dir) {
5747 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5749 dirlen = strlen(dir);
5750 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5751 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5752 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5759 if (dirlen > (VMS_MAXRSS - 1)) {
5760 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
5763 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
5764 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
5765 if (!strpbrk(dir+1,"/]>:") &&
5766 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
5767 strcpy(trndir,*dir == '/' ? dir + 1: dir);
5768 trnlnm_iter_count = 0;
5769 while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) {
5770 trnlnm_iter_count++;
5771 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
5773 dirlen = strlen(trndir);
5776 strncpy(trndir,dir,dirlen);
5777 trndir[dirlen] = '\0';
5780 /* At this point we are done with *dir and use *trndir which is a
5781 * copy that can be modified. *dir must not be modified.
5784 /* If we were handed a rooted logical name or spec, treat it like a
5785 * simple directory, so that
5786 * $ Define myroot dev:[dir.]
5787 * ... do_fileify_dirspec("myroot",buf,1) ...
5788 * does something useful.
5790 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
5791 trndir[--dirlen] = '\0';
5792 trndir[dirlen-1] = ']';
5794 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
5795 trndir[--dirlen] = '\0';
5796 trndir[dirlen-1] = '>';
5799 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
5800 /* If we've got an explicit filename, we can just shuffle the string. */
5801 if (*(cp1+1)) hasfilename = 1;
5802 /* Similarly, we can just back up a level if we've got multiple levels
5803 of explicit directories in a VMS spec which ends with directories. */
5805 for (cp2 = cp1; cp2 > trndir; cp2--) {
5807 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
5808 /* fix-me, can not scan EFS file specs backward like this */
5809 *cp2 = *cp1; *cp1 = '\0';
5814 if (*cp2 == '[' || *cp2 == '<') break;
5819 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
5820 if (vmsdir == NULL) _ckvmssts(SS$_INSFMEM);
5821 cp1 = strpbrk(trndir,"]:>");
5822 if (hasfilename || !cp1) { /* Unix-style path or filename */
5823 if (trndir[0] == '.') {
5824 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
5825 PerlMem_free(trndir);
5826 PerlMem_free(vmsdir);
5827 return do_fileify_dirspec("[]",buf,ts,NULL);
5829 else if (trndir[1] == '.' &&
5830 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
5831 PerlMem_free(trndir);
5832 PerlMem_free(vmsdir);
5833 return do_fileify_dirspec("[-]",buf,ts,NULL);
5836 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
5837 dirlen -= 1; /* to last element */
5838 lastdir = strrchr(trndir,'/');
5840 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
5841 /* If we have "/." or "/..", VMSify it and let the VMS code
5842 * below expand it, rather than repeating the code to handle
5843 * relative components of a filespec here */
5845 if (*(cp1+2) == '.') cp1++;
5846 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
5848 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5849 PerlMem_free(trndir);
5850 PerlMem_free(vmsdir);
5853 if (strchr(vmsdir,'/') != NULL) {
5854 /* If do_tovmsspec() returned it, it must have VMS syntax
5855 * delimiters in it, so it's a mixed VMS/Unix spec. We take
5856 * the time to check this here only so we avoid a recursion
5857 * loop; otherwise, gigo.
5859 PerlMem_free(trndir);
5860 PerlMem_free(vmsdir);
5861 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
5864 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5865 PerlMem_free(trndir);
5866 PerlMem_free(vmsdir);
5869 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5870 PerlMem_free(trndir);
5871 PerlMem_free(vmsdir);
5875 } while ((cp1 = strstr(cp1,"/.")) != NULL);
5876 lastdir = strrchr(trndir,'/');
5878 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
5880 /* Ditto for specs that end in an MFD -- let the VMS code
5881 * figure out whether it's a real device or a rooted logical. */
5883 /* This should not happen any more. Allowing the fake /000000
5884 * in a UNIX pathname causes all sorts of problems when trying
5885 * to run in UNIX emulation. So the VMS to UNIX conversions
5886 * now remove the fake /000000 directories.
5889 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
5890 if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) {
5891 PerlMem_free(trndir);
5892 PerlMem_free(vmsdir);
5895 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
5896 PerlMem_free(trndir);
5897 PerlMem_free(vmsdir);
5900 ret_chr = do_tounixspec(trndir,buf,ts,NULL);
5901 PerlMem_free(trndir);
5902 PerlMem_free(vmsdir);
5907 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
5908 !(lastdir = cp1 = strrchr(trndir,']')) &&
5909 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
5910 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
5913 /* For EFS or ODS-5 look for the last dot */
5914 if (decc_efs_charset) {
5915 cp2 = strrchr(cp1,'.');
5917 if (vms_process_case_tolerant) {
5918 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
5919 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
5920 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
5921 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5922 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5923 (ver || *cp3)))))) {
5924 PerlMem_free(trndir);
5925 PerlMem_free(vmsdir);
5927 set_vaxc_errno(RMS$_DIR);
5932 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
5933 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
5934 !*(cp2+3) || *(cp2+3) != 'R' ||
5935 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
5936 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
5937 (ver || *cp3)))))) {
5938 PerlMem_free(trndir);
5939 PerlMem_free(vmsdir);
5941 set_vaxc_errno(RMS$_DIR);
5945 dirlen = cp2 - trndir;
5949 retlen = dirlen + 6;
5950 if (buf) retspec = buf;
5951 else if (ts) Newx(retspec,retlen+1,char);
5952 else retspec = __fileify_retbuf;
5953 memcpy(retspec,trndir,dirlen);
5954 retspec[dirlen] = '\0';
5956 /* We've picked up everything up to the directory file name.
5957 Now just add the type and version, and we're set. */
5958 if ((!decc_efs_case_preserve) && vms_process_case_tolerant)
5959 strcat(retspec,".dir;1");
5961 strcat(retspec,".DIR;1");
5962 PerlMem_free(trndir);
5963 PerlMem_free(vmsdir);
5966 else { /* VMS-style directory spec */
5968 char *esa, *esal, term, *cp;
5971 unsigned long int sts, cmplen, haslower = 0;
5972 unsigned int nam_fnb;
5974 struct FAB dirfab = cc$rms_fab;
5975 rms_setup_nam(savnam);
5976 rms_setup_nam(dirnam);
5978 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5979 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
5981 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5982 esal = PerlMem_malloc(VMS_MAXRSS);
5983 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
5985 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
5986 rms_bind_fab_nam(dirfab, dirnam);
5987 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
5988 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
5989 #ifdef NAM$M_NO_SHORT_UPCASE
5990 if (decc_efs_case_preserve)
5991 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
5994 for (cp = trndir; *cp; cp++)
5995 if (islower(*cp)) { haslower = 1; break; }
5996 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
5997 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
5998 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
5999 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6005 PerlMem_free(trndir);
6006 PerlMem_free(vmsdir);
6008 set_vaxc_errno(dirfab.fab$l_sts);
6014 /* Does the file really exist? */
6015 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6016 /* Yes; fake the fnb bits so we'll check type below */
6017 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6019 else { /* No; just work with potential name */
6020 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6023 fab_sts = dirfab.fab$l_sts;
6024 sts = rms_free_search_context(&dirfab);
6028 PerlMem_free(trndir);
6029 PerlMem_free(vmsdir);
6030 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6036 /* Make sure we are using the right buffer */
6039 my_esa_len = rms_nam_esll(dirnam);
6042 my_esa_len = rms_nam_esl(dirnam);
6044 my_esa[my_esa_len] = '\0';
6045 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6046 cp1 = strchr(my_esa,']');
6047 if (!cp1) cp1 = strchr(my_esa,'>');
6048 if (cp1) { /* Should always be true */
6049 my_esa_len -= cp1 - my_esa - 1;
6050 memmove(my_esa, cp1 + 1, my_esa_len);
6053 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6054 /* Yep; check version while we're at it, if it's there. */
6055 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6056 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6057 /* Something other than .DIR[;1]. Bzzt. */
6058 sts = rms_free_search_context(&dirfab);
6062 PerlMem_free(trndir);
6063 PerlMem_free(vmsdir);
6065 set_vaxc_errno(RMS$_DIR);
6070 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6071 /* They provided at least the name; we added the type, if necessary, */
6072 if (buf) retspec = buf; /* in sys$parse() */
6073 else if (ts) Newx(retspec, my_esa_len + 1, char);
6074 else retspec = __fileify_retbuf;
6075 strcpy(retspec,my_esa);
6076 sts = rms_free_search_context(&dirfab);
6077 PerlMem_free(trndir);
6081 PerlMem_free(vmsdir);
6084 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6085 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6089 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6090 if (cp1 == NULL) { /* should never happen */
6091 sts = rms_free_search_context(&dirfab);
6092 PerlMem_free(trndir);
6096 PerlMem_free(vmsdir);
6101 retlen = strlen(my_esa);
6102 cp1 = strrchr(my_esa,'.');
6103 /* ODS-5 directory specifications can have extra "." in them. */
6104 /* Fix-me, can not scan EFS file specifications backwards */
6105 while (cp1 != NULL) {
6106 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6110 while ((cp1 > my_esa) && (*cp1 != '.'))
6117 if ((cp1) != NULL) {
6118 /* There's more than one directory in the path. Just roll back. */
6120 if (buf) retspec = buf;
6121 else if (ts) Newx(retspec,retlen+7,char);
6122 else retspec = __fileify_retbuf;
6123 strcpy(retspec,my_esa);
6126 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6127 /* Go back and expand rooted logical name */
6128 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6129 #ifdef NAM$M_NO_SHORT_UPCASE
6130 if (decc_efs_case_preserve)
6131 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6133 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6134 sts = rms_free_search_context(&dirfab);
6138 PerlMem_free(trndir);
6139 PerlMem_free(vmsdir);
6141 set_vaxc_errno(dirfab.fab$l_sts);
6145 /* This changes the length of the string of course */
6147 my_esa_len = rms_nam_esll(dirnam);
6149 my_esa_len = rms_nam_esl(dirnam);
6152 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6153 if (buf) retspec = buf;
6154 else if (ts) Newx(retspec,retlen+16,char);
6155 else retspec = __fileify_retbuf;
6156 cp1 = strstr(my_esa,"][");
6157 if (!cp1) cp1 = strstr(my_esa,"]<");
6158 dirlen = cp1 - my_esa;
6159 memcpy(retspec,my_esa,dirlen);
6160 if (!strncmp(cp1+2,"000000]",7)) {
6161 retspec[dirlen-1] = '\0';
6162 /* fix-me Not full ODS-5, just extra dots in directories for now */
6163 cp1 = retspec + dirlen - 1;
6164 while (cp1 > retspec)
6169 if (*(cp1-1) != '^')
6174 if (*cp1 == '.') *cp1 = ']';
6176 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6177 memmove(cp1+1,"000000]",7);
6181 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6182 retspec[retlen] = '\0';
6183 /* Convert last '.' to ']' */
6184 cp1 = retspec+retlen-1;
6185 while (*cp != '[') {
6188 /* Do not trip on extra dots in ODS-5 directories */
6189 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6193 if (*cp1 == '.') *cp1 = ']';
6195 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6196 memmove(cp1+1,"000000]",7);
6200 else { /* This is a top-level dir. Add the MFD to the path. */
6201 if (buf) retspec = buf;
6202 else if (ts) Newx(retspec,retlen+16,char);
6203 else retspec = __fileify_retbuf;
6206 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6207 strcpy(cp2,":[000000]");
6212 sts = rms_free_search_context(&dirfab);
6213 /* We've set up the string up through the filename. Add the
6214 type and version, and we're done. */
6215 strcat(retspec,".DIR;1");
6217 /* $PARSE may have upcased filespec, so convert output to lower
6218 * case if input contained any lowercase characters. */
6219 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6220 PerlMem_free(trndir);
6224 PerlMem_free(vmsdir);
6227 } /* end of do_fileify_dirspec() */
6229 /* External entry points */
6230 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6231 { return do_fileify_dirspec(dir,buf,0,NULL); }
6232 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6233 { return do_fileify_dirspec(dir,buf,1,NULL); }
6234 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6235 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6236 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6237 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6239 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6240 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6242 static char __pathify_retbuf[VMS_MAXRSS];
6243 unsigned long int retlen;
6244 char *retpath, *cp1, *cp2, *trndir;
6245 unsigned short int trnlnm_iter_count;
6248 if (utf8_fl != NULL)
6251 if (!dir || !*dir) {
6252 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6255 trndir = PerlMem_malloc(VMS_MAXRSS);
6256 if (trndir == NULL) _ckvmssts(SS$_INSFMEM);
6257 if (*dir) strcpy(trndir,dir);
6258 else getcwd(trndir,VMS_MAXRSS - 1);
6260 trnlnm_iter_count = 0;
6261 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6262 && my_trnlnm(trndir,trndir,0)) {
6263 trnlnm_iter_count++;
6264 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6265 trnlen = strlen(trndir);
6267 /* Trap simple rooted lnms, and return lnm:[000000] */
6268 if (!strcmp(trndir+trnlen-2,".]")) {
6269 if (buf) retpath = buf;
6270 else if (ts) Newx(retpath,strlen(dir)+10,char);
6271 else retpath = __pathify_retbuf;
6272 strcpy(retpath,dir);
6273 strcat(retpath,":[000000]");
6274 PerlMem_free(trndir);
6279 /* At this point we do not work with *dir, but the copy in
6280 * *trndir that is modifiable.
6283 if (!strpbrk(trndir,"]:>")) { /* Unix-style path or plain name */
6284 if (*trndir == '.' && (*(trndir+1) == '\0' ||
6285 (*(trndir+1) == '.' && *(trndir+2) == '\0')))
6286 retlen = 2 + (*(trndir+1) != '\0');
6288 if ( !(cp1 = strrchr(trndir,'/')) &&
6289 !(cp1 = strrchr(trndir,']')) &&
6290 !(cp1 = strrchr(trndir,'>')) ) cp1 = trndir;
6291 if ((cp2 = strchr(cp1,'.')) != NULL &&
6292 (*(cp2-1) != '/' || /* Trailing '.', '..', */
6293 !(*(cp2+1) == '\0' || /* or '...' are dirs. */
6294 (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
6295 (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
6298 /* For EFS or ODS-5 look for the last dot */
6299 if (decc_efs_charset) {
6300 cp2 = strrchr(cp1,'.');
6302 if (vms_process_case_tolerant) {
6303 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6304 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6305 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6306 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6307 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6308 (ver || *cp3)))))) {
6309 PerlMem_free(trndir);
6311 set_vaxc_errno(RMS$_DIR);
6316 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6317 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6318 !*(cp2+3) || *(cp2+3) != 'R' ||
6319 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6320 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6321 (ver || *cp3)))))) {
6322 PerlMem_free(trndir);
6324 set_vaxc_errno(RMS$_DIR);
6328 retlen = cp2 - trndir + 1;
6330 else { /* No file type present. Treat the filename as a directory. */
6331 retlen = strlen(trndir) + 1;
6334 if (buf) retpath = buf;
6335 else if (ts) Newx(retpath,retlen+1,char);
6336 else retpath = __pathify_retbuf;
6337 strncpy(retpath, trndir, retlen-1);
6338 if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
6339 retpath[retlen-1] = '/'; /* with '/', add it. */
6340 retpath[retlen] = '\0';
6342 else retpath[retlen-1] = '\0';
6344 else { /* VMS-style directory spec */
6345 char *esa, *esal, *cp;
6348 unsigned long int sts, cmplen, haslower;
6349 struct FAB dirfab = cc$rms_fab;
6351 rms_setup_nam(savnam);
6352 rms_setup_nam(dirnam);
6354 /* If we've got an explicit filename, we can just shuffle the string. */
6355 if ( ( (cp1 = strrchr(trndir,']')) != NULL ||
6356 (cp1 = strrchr(trndir,'>')) != NULL ) && *(cp1+1)) {
6357 if ((cp2 = strchr(cp1,'.')) != NULL) {
6359 if (vms_process_case_tolerant) {
6360 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6361 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6362 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6363 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6364 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6365 (ver || *cp3)))))) {
6366 PerlMem_free(trndir);
6368 set_vaxc_errno(RMS$_DIR);
6373 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6374 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6375 !*(cp2+3) || *(cp2+3) != 'R' ||
6376 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6377 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6378 (ver || *cp3)))))) {
6379 PerlMem_free(trndir);
6381 set_vaxc_errno(RMS$_DIR);
6386 else { /* No file type, so just draw name into directory part */
6387 for (cp2 = cp1; *cp2; cp2++) ;
6390 *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
6392 /* We've now got a VMS 'path'; fall through */
6395 dirlen = strlen(trndir);
6396 if (trndir[dirlen-1] == ']' ||
6397 trndir[dirlen-1] == '>' ||
6398 trndir[dirlen-1] == ':') { /* It's already a VMS 'path' */
6399 if (buf) retpath = buf;
6400 else if (ts) Newx(retpath,strlen(trndir)+1,char);
6401 else retpath = __pathify_retbuf;
6402 strcpy(retpath,trndir);
6403 PerlMem_free(trndir);
6406 rms_set_fna(dirfab, dirnam, trndir, dirlen);
6407 esa = PerlMem_malloc(VMS_MAXRSS);
6408 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
6410 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6411 esal = PerlMem_malloc(VMS_MAXRSS);
6412 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
6414 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6415 rms_bind_fab_nam(dirfab, dirnam);
6416 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
6417 #ifdef NAM$M_NO_SHORT_UPCASE
6418 if (decc_efs_case_preserve)
6419 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6422 for (cp = trndir; *cp; cp++)
6423 if (islower(*cp)) { haslower = 1; break; }
6425 if (!(sts = (sys$parse(&dirfab)& STS$K_SUCCESS))) {
6426 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6427 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6428 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6431 PerlMem_free(trndir);
6436 set_vaxc_errno(dirfab.fab$l_sts);
6442 /* Does the file really exist? */
6443 if (!(sys$search(&dirfab)&STS$K_SUCCESS)) {
6444 if (dirfab.fab$l_sts != RMS$_FNF) {
6446 sts1 = rms_free_search_context(&dirfab);
6447 PerlMem_free(trndir);
6452 set_vaxc_errno(dirfab.fab$l_sts);
6455 dirnam = savnam; /* No; just work with potential name */
6458 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6459 /* Yep; check version while we're at it, if it's there. */
6460 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6461 if (strncmp(rms_nam_typel(dirnam),".DIR;1",cmplen)) {
6463 /* Something other than .DIR[;1]. Bzzt. */
6464 sts2 = rms_free_search_context(&dirfab);
6465 PerlMem_free(trndir);
6470 set_vaxc_errno(RMS$_DIR);
6474 /* Make sure we are using the right buffer */
6476 /* We only need one, clean up the other */
6478 my_esa_len = rms_nam_esll(dirnam);
6481 my_esa_len = rms_nam_esl(dirnam);
6484 /* Null terminate the buffer */
6485 my_esa[my_esa_len] = '\0';
6487 /* OK, the type was fine. Now pull any file name into the
6489 if ((cp1 = strrchr(my_esa,']'))) *(rms_nam_typel(dirnam)) = ']';
6491 cp1 = strrchr(my_esa,'>');
6492 *(rms_nam_typel(dirnam)) = '>';
6495 *(rms_nam_typel(dirnam) + 1) = '\0';
6496 retlen = (rms_nam_typel(dirnam)) - my_esa + 2;
6497 if (buf) retpath = buf;
6498 else if (ts) Newx(retpath,retlen,char);
6499 else retpath = __pathify_retbuf;
6500 strcpy(retpath,my_esa);
6504 sts = rms_free_search_context(&dirfab);
6505 /* $PARSE may have upcased filespec, so convert output to lower
6506 * case if input contained any lowercase characters. */
6507 if (haslower && !decc_efs_case_preserve) __mystrtolower(retpath);
6510 PerlMem_free(trndir);
6512 } /* end of do_pathify_dirspec() */
6514 /* External entry points */
6515 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6516 { return do_pathify_dirspec(dir,buf,0,NULL); }
6517 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6518 { return do_pathify_dirspec(dir,buf,1,NULL); }
6519 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6520 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6521 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6522 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6524 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
6525 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
6527 static char __tounixspec_retbuf[VMS_MAXRSS];
6528 char *dirend, *rslt, *cp1, *cp3, *tmp;
6530 int devlen, dirlen, retlen = VMS_MAXRSS;
6531 int expand = 1; /* guarantee room for leading and trailing slashes */
6532 unsigned short int trnlnm_iter_count;
6534 if (utf8_fl != NULL)
6537 if (spec == NULL) return NULL;
6538 if (strlen(spec) > (VMS_MAXRSS-1)) return NULL;
6539 if (buf) rslt = buf;
6541 Newx(rslt, VMS_MAXRSS, char);
6543 else rslt = __tounixspec_retbuf;
6545 /* New VMS specific format needs translation
6546 * glob passes filenames with trailing '\n' and expects this preserved.
6548 if (decc_posix_compliant_pathnames) {
6549 if (strncmp(spec, "\"^UP^", 5) == 0) {
6555 tunix = PerlMem_malloc(VMS_MAXRSS);
6556 if (tunix == NULL) _ckvmssts(SS$_INSFMEM);
6557 strcpy(tunix, spec);
6558 tunix_len = strlen(tunix);
6560 if (tunix[tunix_len - 1] == '\n') {
6561 tunix[tunix_len - 1] = '\"';
6562 tunix[tunix_len] = '\0';
6566 uspec = decc$translate_vms(tunix);
6567 PerlMem_free(tunix);
6568 if ((int)uspec > 0) {
6574 /* If we can not translate it, makemaker wants as-is */
6582 cmp_rslt = 0; /* Presume VMS */
6583 cp1 = strchr(spec, '/');
6587 /* Look for EFS ^/ */
6588 if (decc_efs_charset) {
6589 while (cp1 != NULL) {
6592 /* Found illegal VMS, assume UNIX */
6597 cp1 = strchr(cp1, '/');
6601 /* Look for "." and ".." */
6602 if (decc_filename_unix_report) {
6603 if (spec[0] == '.') {
6604 if ((spec[1] == '\0') || (spec[1] == '\n')) {
6608 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
6614 /* This is already UNIX or at least nothing VMS understands */
6622 dirend = strrchr(spec,']');
6623 if (dirend == NULL) dirend = strrchr(spec,'>');
6624 if (dirend == NULL) dirend = strchr(spec,':');
6625 if (dirend == NULL) {
6630 /* Special case 1 - sys$posix_root = / */
6631 #if __CRTL_VER >= 70000000
6632 if (!decc_disable_posix_root) {
6633 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
6641 /* Special case 2 - Convert NLA0: to /dev/null */
6642 #if __CRTL_VER < 70000000
6643 cmp_rslt = strncmp(spec,"NLA0:", 5);
6645 cmp_rslt = strncmp(spec,"nla0:", 5);
6647 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
6649 if (cmp_rslt == 0) {
6650 strcpy(rslt, "/dev/null");
6653 if (spec[6] != '\0') {
6660 /* Also handle special case "SYS$SCRATCH:" */
6661 #if __CRTL_VER < 70000000
6662 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
6664 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
6666 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
6668 tmp = PerlMem_malloc(VMS_MAXRSS);
6669 if (tmp == NULL) _ckvmssts(SS$_INSFMEM);
6670 if (cmp_rslt == 0) {
6673 islnm = my_trnlnm(tmp, "TMP", 0);
6675 strcpy(rslt, "/tmp");
6678 if (spec[12] != '\0') {
6686 if (*cp2 != '[' && *cp2 != '<') {
6689 else { /* the VMS spec begins with directories */
6691 if (*cp2 == ']' || *cp2 == '>') {
6692 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
6696 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
6697 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
6698 if (ts) Safefree(rslt);
6702 trnlnm_iter_count = 0;
6705 while (*cp3 != ':' && *cp3) cp3++;
6707 if (strchr(cp3,']') != NULL) break;
6708 trnlnm_iter_count++;
6709 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
6710 } while (vmstrnenv(tmp,tmp,0,fildev,0));
6712 ((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
6713 retlen = devlen + dirlen;
6714 Renew(rslt,retlen+1+2*expand,char);
6720 *(cp1++) = *(cp3++);
6721 if (cp1 - rslt > (VMS_MAXRSS - 1) && !ts && !buf) {
6723 return NULL; /* No room */
6728 if ((*cp2 == '^')) {
6729 /* EFS file escape, pass the next character as is */
6730 /* Fix me: HEX encoding for Unicode not implemented */
6733 else if ( *cp2 == '.') {
6734 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
6735 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6742 for (; cp2 <= dirend; cp2++) {
6743 if ((*cp2 == '^')) {
6744 /* EFS file escape, pass the next character as is */
6745 /* Fix me: HEX encoding for Unicode not implemented */
6746 *(cp1++) = *(++cp2);
6747 /* An escaped dot stays as is -- don't convert to slash */
6748 if (*cp2 == '.') cp2++;
6752 if (*(cp2+1) == '[') cp2++;
6754 else if (*cp2 == ']' || *cp2 == '>') {
6755 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
6757 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
6759 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
6760 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
6761 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
6762 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
6763 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
6765 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
6766 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
6770 else if (*cp2 == '-') {
6771 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
6772 while (*cp2 == '-') {
6774 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
6776 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
6777 if (ts) Safefree(rslt); /* filespecs like */
6778 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
6782 else *(cp1++) = *cp2;
6784 else *(cp1++) = *cp2;
6787 if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */
6788 *(cp1++) = *(cp2++);
6792 /* This still leaves /000000/ when working with a
6793 * VMS device root or concealed root.
6799 ulen = strlen(rslt);
6801 /* Get rid of "000000/ in rooted filespecs */
6803 zeros = strstr(rslt, "/000000/");
6804 if (zeros != NULL) {
6806 mlen = ulen - (zeros - rslt) - 7;
6807 memmove(zeros, &zeros[7], mlen);
6816 } /* end of do_tounixspec() */
6818 /* External entry points */
6819 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
6820 { return do_tounixspec(spec,buf,0, NULL); }
6821 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
6822 { return do_tounixspec(spec,buf,1, NULL); }
6823 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
6824 { return do_tounixspec(spec,buf,0, utf8_fl); }
6825 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
6826 { return do_tounixspec(spec,buf,1, utf8_fl); }
6828 #if __CRTL_VER >= 70200000 && !defined(__VAX)
6831 This procedure is used to identify if a path is based in either
6832 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
6833 it returns the OpenVMS format directory for it.
6835 It is expecting specifications of only '/' or '/xxxx/'
6837 If a posix root does not exist, or 'xxxx' is not a directory
6838 in the posix root, it returns a failure.
6840 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
6842 It is used only internally by posix_to_vmsspec_hardway().
6845 static int posix_root_to_vms
6846 (char *vmspath, int vmspath_len,
6847 const char *unixpath,
6848 const int * utf8_fl)
6851 struct FAB myfab = cc$rms_fab;
6852 rms_setup_nam(mynam);
6853 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6854 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
6855 char * esa, * esal, * rsa, * rsal;
6862 unixlen = strlen(unixpath);
6867 #if __CRTL_VER >= 80200000
6868 /* If not a posix spec already, convert it */
6869 if (decc_posix_compliant_pathnames) {
6870 if (strncmp(unixpath,"\"^UP^",5) != 0) {
6871 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6874 /* This is already a VMS specification, no conversion */
6876 strncpy(vmspath,unixpath, vmspath_len);
6885 /* Check to see if this is under the POSIX root */
6886 if (decc_disable_posix_root) {
6890 /* Skip leading / */
6891 if (unixpath[0] == '/') {
6897 strcpy(vmspath,"SYS$POSIX_ROOT:");
6899 /* If this is only the / , or blank, then... */
6900 if (unixpath[0] == '\0') {
6901 /* by definition, this is the answer */
6905 /* Need to look up a directory */
6909 /* Copy and add '^' escape characters as needed */
6912 while (unixpath[i] != 0) {
6915 j += copy_expand_unix_filename_escape
6916 (&vmspath[j], &unixpath[i], &k, utf8_fl);
6920 path_len = strlen(vmspath);
6921 if (vmspath[path_len - 1] == '/')
6923 vmspath[path_len] = ']';
6925 vmspath[path_len] = '\0';
6928 vmspath[vmspath_len] = 0;
6929 if (unixpath[unixlen - 1] == '/')
6931 esal = PerlMem_malloc(VMS_MAXRSS);
6932 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6933 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6934 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6935 rsal = PerlMem_malloc(VMS_MAXRSS);
6936 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6937 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6938 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6939 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
6940 rms_bind_fab_nam(myfab, mynam);
6941 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
6942 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
6943 if (decc_efs_case_preserve)
6944 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
6945 #ifdef NAML$M_OPEN_SPECIAL
6946 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
6949 /* Set up the remaining naml fields */
6950 sts = sys$parse(&myfab);
6952 /* It failed! Try again as a UNIX filespec */
6961 /* get the Device ID and the FID */
6962 sts = sys$search(&myfab);
6964 /* These are no longer needed */
6969 /* on any failure, returned the POSIX ^UP^ filespec */
6974 specdsc.dsc$a_pointer = vmspath;
6975 specdsc.dsc$w_length = vmspath_len;
6977 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
6978 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
6979 sts = lib$fid_to_name
6980 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
6982 /* on any failure, returned the POSIX ^UP^ filespec */
6984 /* This can happen if user does not have permission to read directories */
6985 if (strncmp(unixpath,"\"^UP^",5) != 0)
6986 sprintf(vmspath,"\"^UP^%s\"",unixpath);
6988 strcpy(vmspath, unixpath);
6991 vmspath[specdsc.dsc$w_length] = 0;
6993 /* Are we expecting a directory? */
6994 if (dir_flag != 0) {
7000 i = specdsc.dsc$w_length - 1;
7004 /* Version must be '1' */
7005 if (vmspath[i--] != '1')
7007 /* Version delimiter is one of ".;" */
7008 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7011 if (vmspath[i--] != 'R')
7013 if (vmspath[i--] != 'I')
7015 if (vmspath[i--] != 'D')
7017 if (vmspath[i--] != '.')
7019 eptr = &vmspath[i+1];
7021 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7022 if (vmspath[i-1] != '^') {
7030 /* Get rid of 6 imaginary zero directory filename */
7031 vmspath[i+1] = '\0';
7035 if (vmspath[i] == '0')
7049 /* /dev/mumble needs to be handled special.
7050 /dev/null becomes NLA0:, And there is the potential for other stuff
7051 like /dev/tty which may need to be mapped to something.
7055 slash_dev_special_to_vms
7056 (const char * unixptr,
7066 nextslash = strchr(unixptr, '/');
7067 len = strlen(unixptr);
7068 if (nextslash != NULL)
7069 len = nextslash - unixptr;
7070 cmp = strncmp("null", unixptr, 5);
7072 if (vmspath_len >= 6) {
7073 strcpy(vmspath, "_NLA0:");
7080 /* The built in routines do not understand perl's special needs, so
7081 doing a manual conversion from UNIX to VMS
7083 If the utf8_fl is not null and points to a non-zero value, then
7084 treat 8 bit characters as UTF-8.
7086 The sequence starting with '$(' and ending with ')' will be passed
7087 through with out interpretation instead of being escaped.
7090 static int posix_to_vmsspec_hardway
7091 (char *vmspath, int vmspath_len,
7092 const char *unixpath,
7097 const char *unixptr;
7098 const char *unixend;
7100 const char *lastslash;
7101 const char *lastdot;
7107 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7108 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7110 if (utf8_fl != NULL)
7116 /* Ignore leading "/" characters */
7117 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7120 unixlen = strlen(unixptr);
7122 /* Do nothing with blank paths */
7129 /* This could have a "^UP^ on the front */
7130 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7136 lastslash = strrchr(unixptr,'/');
7137 lastdot = strrchr(unixptr,'.');
7138 unixend = strrchr(unixptr,'\"');
7139 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7140 unixend = unixptr + unixlen;
7143 /* last dot is last dot or past end of string */
7144 if (lastdot == NULL)
7145 lastdot = unixptr + unixlen;
7147 /* if no directories, set last slash to beginning of string */
7148 if (lastslash == NULL) {
7149 lastslash = unixptr;
7152 /* Watch out for trailing "." after last slash, still a directory */
7153 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7154 lastslash = unixptr + unixlen;
7157 /* Watch out for traiing ".." after last slash, still a directory */
7158 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7159 lastslash = unixptr + unixlen;
7162 /* dots in directories are aways escaped */
7163 if (lastdot < lastslash)
7164 lastdot = unixptr + unixlen;
7167 /* if (unixptr < lastslash) then we are in a directory */
7174 /* Start with the UNIX path */
7175 if (*unixptr != '/') {
7176 /* relative paths */
7178 /* If allowing logical names on relative pathnames, then handle here */
7179 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7180 !decc_posix_compliant_pathnames) {
7186 /* Find the next slash */
7187 nextslash = strchr(unixptr,'/');
7189 esa = PerlMem_malloc(vmspath_len);
7190 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7192 trn = PerlMem_malloc(VMS_MAXRSS);
7193 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7195 if (nextslash != NULL) {
7197 seg_len = nextslash - unixptr;
7198 strncpy(esa, unixptr, seg_len);
7202 strcpy(esa, unixptr);
7203 seg_len = strlen(unixptr);
7205 /* trnlnm(section) */
7206 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7209 /* Now fix up the directory */
7211 /* Split up the path to find the components */
7212 sts = vms_split_path
7231 /* A logical name must be a directory or the full
7232 specification. It is only a full specification if
7233 it is the only component */
7234 if ((unixptr[seg_len] == '\0') ||
7235 (unixptr[seg_len+1] == '\0')) {
7237 /* Is a directory being required? */
7238 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7239 /* Not a logical name */
7244 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7245 /* This must be a directory */
7246 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7247 strcpy(vmsptr, esa);
7248 vmslen=strlen(vmsptr);
7249 vmsptr[vmslen] = ':';
7251 vmsptr[vmslen] = '\0';
7259 /* must be dev/directory - ignore version */
7260 if ((n_len + e_len) != 0)
7263 /* transfer the volume */
7264 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7265 strncpy(vmsptr, v_spec, v_len);
7271 /* unroot the rooted directory */
7272 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7274 r_spec[r_len - 1] = ']';
7276 /* This should not be there, but nothing is perfect */
7278 cmp = strcmp(&r_spec[1], "000000.");
7288 strncpy(vmsptr, r_spec, r_len);
7294 /* Bring over the directory. */
7296 ((d_len + vmslen) < vmspath_len)) {
7298 d_spec[d_len - 1] = ']';
7300 cmp = strcmp(&d_spec[1], "000000.");
7311 /* Remove the redundant root */
7319 strncpy(vmsptr, d_spec, d_len);
7333 if (lastslash > unixptr) {
7336 /* skip leading ./ */
7338 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7344 /* Are we still in a directory? */
7345 if (unixptr <= lastslash) {
7350 /* if not backing up, then it is relative forward. */
7351 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7352 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7360 /* Perl wants an empty directory here to tell the difference
7361 * between a DCL commmand and a filename
7370 /* Handle two special files . and .. */
7371 if (unixptr[0] == '.') {
7372 if (&unixptr[1] == unixend) {
7379 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7390 else { /* Absolute PATH handling */
7394 /* Need to find out where root is */
7396 /* In theory, this procedure should never get an absolute POSIX pathname
7397 * that can not be found on the POSIX root.
7398 * In practice, that can not be relied on, and things will show up
7399 * here that are a VMS device name or concealed logical name instead.
7400 * So to make things work, this procedure must be tolerant.
7402 esa = PerlMem_malloc(vmspath_len);
7403 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7406 nextslash = strchr(&unixptr[1],'/');
7408 if (nextslash != NULL) {
7410 seg_len = nextslash - &unixptr[1];
7411 strncpy(vmspath, unixptr, seg_len + 1);
7412 vmspath[seg_len+1] = 0;
7415 cmp = strncmp(vmspath, "dev", 4);
7417 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7418 if (sts = SS$_NORMAL)
7422 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7425 if ($VMS_STATUS_SUCCESS(sts)) {
7426 /* This is verified to be a real path */
7428 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7429 if ($VMS_STATUS_SUCCESS(sts)) {
7430 strcpy(vmspath, esa);
7431 vmslen = strlen(vmspath);
7432 vmsptr = vmspath + vmslen;
7434 if (unixptr < lastslash) {
7443 cmp = strcmp(rptr,"000000.");
7448 } /* removing 6 zeros */
7449 } /* vmslen < 7, no 6 zeros possible */
7450 } /* Not in a directory */
7451 } /* Posix root found */
7453 /* No posix root, fall back to default directory */
7454 strcpy(vmspath, "SYS$DISK:[");
7455 vmsptr = &vmspath[10];
7457 if (unixptr > lastslash) {
7466 } /* end of verified real path handling */
7471 /* Ok, we have a device or a concealed root that is not in POSIX
7472 * or we have garbage. Make the best of it.
7475 /* Posix to VMS destroyed this, so copy it again */
7476 strncpy(vmspath, &unixptr[1], seg_len);
7477 vmspath[seg_len] = 0;
7479 vmsptr = &vmsptr[vmslen];
7482 /* Now do we need to add the fake 6 zero directory to it? */
7484 if ((*lastslash == '/') && (nextslash < lastslash)) {
7485 /* No there is another directory */
7492 /* now we have foo:bar or foo:[000000]bar to decide from */
7493 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
7495 if (!islnm && !decc_posix_compliant_pathnames) {
7497 cmp = strncmp("bin", vmspath, 4);
7499 /* bin => SYS$SYSTEM: */
7500 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
7503 /* tmp => SYS$SCRATCH: */
7504 cmp = strncmp("tmp", vmspath, 4);
7506 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
7511 trnend = islnm ? islnm - 1 : 0;
7513 /* if this was a logical name, ']' or '>' must be present */
7514 /* if not a logical name, then assume a device and hope. */
7515 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
7517 /* if log name and trailing '.' then rooted - treat as device */
7518 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
7520 /* Fix me, if not a logical name, a device lookup should be
7521 * done to see if the device is file structured. If the device
7522 * is not file structured, the 6 zeros should not be put on.
7524 * As it is, perl is occasionally looking for dev:[000000]tty.
7525 * which looks a little strange.
7527 * Not that easy to detect as "/dev" may be file structured with
7528 * special device files.
7531 if ((add_6zero == 0) && (*nextslash == '/') &&
7532 (&nextslash[1] == unixend)) {
7533 /* No real directory present */
7538 /* Put the device delimiter on */
7541 unixptr = nextslash;
7544 /* Start directory if needed */
7545 if (!islnm || add_6zero) {
7551 /* add fake 000000] if needed */
7564 } /* non-POSIX translation */
7566 } /* End of relative/absolute path handling */
7568 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
7575 if (dir_start != 0) {
7577 /* First characters in a directory are handled special */
7578 while ((*unixptr == '/') ||
7579 ((*unixptr == '.') &&
7580 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
7581 (&unixptr[1]==unixend)))) {
7586 /* Skip redundant / in specification */
7587 while ((*unixptr == '/') && (dir_start != 0)) {
7590 if (unixptr == lastslash)
7593 if (unixptr == lastslash)
7596 /* Skip redundant ./ characters */
7597 while ((*unixptr == '.') &&
7598 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
7601 if (unixptr == lastslash)
7603 if (*unixptr == '/')
7606 if (unixptr == lastslash)
7609 /* Skip redundant ../ characters */
7610 while ((*unixptr == '.') && (unixptr[1] == '.') &&
7611 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
7612 /* Set the backing up flag */
7618 unixptr++; /* first . */
7619 unixptr++; /* second . */
7620 if (unixptr == lastslash)
7622 if (*unixptr == '/') /* The slash */
7625 if (unixptr == lastslash)
7628 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7629 /* Not needed when VMS is pretending to be UNIX. */
7631 /* Is this loop stuck because of too many dots? */
7632 if (loop_flag == 0) {
7633 /* Exit the loop and pass the rest through */
7638 /* Are we done with directories yet? */
7639 if (unixptr >= lastslash) {
7641 /* Watch out for trailing dots */
7650 if (*unixptr == '/')
7654 /* Have we stopped backing up? */
7659 /* dir_start continues to be = 1 */
7661 if (*unixptr == '-') {
7663 *vmsptr++ = *unixptr++;
7667 /* Now are we done with directories yet? */
7668 if (unixptr >= lastslash) {
7670 /* Watch out for trailing dots */
7686 if (unixptr >= unixend)
7689 /* Normal characters - More EFS work probably needed */
7695 /* remove multiple / */
7696 while (unixptr[1] == '/') {
7699 if (unixptr == lastslash) {
7700 /* Watch out for trailing dots */
7712 /* To do: Perl expects /.../ to be translated to [...] on VMS */
7713 /* Not needed when VMS is pretending to be UNIX. */
7717 if (unixptr != unixend)
7722 if ((unixptr < lastdot) || (unixptr < lastslash) ||
7723 (&unixptr[1] == unixend)) {
7729 /* trailing dot ==> '^..' on VMS */
7730 if (unixptr == unixend) {
7738 *vmsptr++ = *unixptr++;
7742 if (quoted && (&unixptr[1] == unixend)) {
7746 in_cnt = copy_expand_unix_filename_escape
7747 (vmsptr, unixptr, &out_cnt, utf8_fl);
7757 in_cnt = copy_expand_unix_filename_escape
7758 (vmsptr, unixptr, &out_cnt, utf8_fl);
7765 /* Make sure directory is closed */
7766 if (unixptr == lastslash) {
7768 vmsptr2 = vmsptr - 1;
7770 if (*vmsptr2 != ']') {
7773 /* directories do not end in a dot bracket */
7774 if (*vmsptr2 == '.') {
7778 if (*vmsptr2 != '^') {
7779 vmsptr--; /* back up over the dot */
7787 /* Add a trailing dot if a file with no extension */
7788 vmsptr2 = vmsptr - 1;
7790 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
7791 (*vmsptr2 != ')') && (*lastdot != '.')) {
7802 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
7803 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
7808 /* If a UTF8 flag is being passed, honor it */
7810 if (utf8_fl != NULL) {
7811 utf8_flag = *utf8_fl;
7816 /* If there is a possibility of UTF8, then if any UTF8 characters
7817 are present, then they must be converted to VTF-7
7819 result = strcpy(rslt, path); /* FIX-ME */
7822 result = strcpy(rslt, path);
7828 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
7829 static char *mp_do_tovmsspec
7830 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
7831 static char __tovmsspec_retbuf[VMS_MAXRSS];
7832 char *rslt, *dirend;
7837 unsigned long int infront = 0, hasdir = 1;
7840 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7841 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7843 if (path == NULL) return NULL;
7844 rslt_len = VMS_MAXRSS-1;
7845 if (buf) rslt = buf;
7846 else if (ts) Newx(rslt, VMS_MAXRSS, char);
7847 else rslt = __tovmsspec_retbuf;
7849 /* '.' and '..' are "[]" and "[-]" for a quick check */
7850 if (path[0] == '.') {
7851 if (path[1] == '\0') {
7853 if (utf8_flag != NULL)
7858 if (path[1] == '.' && path[2] == '\0') {
7860 if (utf8_flag != NULL)
7867 /* Posix specifications are now a native VMS format */
7868 /*--------------------------------------------------*/
7869 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7870 if (decc_posix_compliant_pathnames) {
7871 if (strncmp(path,"\"^UP^",5) == 0) {
7872 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7878 /* This is really the only way to see if this is already in VMS format */
7879 sts = vms_split_path
7894 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
7895 replacement, because the above parse just took care of most of
7896 what is needed to do vmspath when the specification is already
7899 And if it is not already, it is easier to do the conversion as
7900 part of this routine than to call this routine and then work on
7904 /* If VMS punctuation was found, it is already VMS format */
7905 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
7906 if (utf8_flag != NULL)
7911 /* Now, what to do with trailing "." cases where there is no
7912 extension? If this is a UNIX specification, and EFS characters
7913 are enabled, then the trailing "." should be converted to a "^.".
7914 But if this was already a VMS specification, then it should be
7917 So in the case of ambiguity, leave the specification alone.
7921 /* If there is a possibility of UTF8, then if any UTF8 characters
7922 are present, then they must be converted to VTF-7
7924 if (utf8_flag != NULL)
7930 dirend = strrchr(path,'/');
7932 if (dirend == NULL) {
7933 /* If we get here with no UNIX directory delimiters, then this is
7934 not a complete file specification, either garbage a UNIX glob
7935 specification that can not be converted to a VMS wildcard, or
7936 it a UNIX shell macro. MakeMaker wants these passed through AS-IS,
7937 so apparently other programs expect this also.
7939 utf8 flag setting needs to be preserved.
7945 /* If POSIX mode active, handle the conversion */
7946 #if __CRTL_VER >= 80200000 && !defined(__VAX)
7947 if (decc_efs_charset) {
7948 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
7953 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
7954 if (!*(dirend+2)) dirend +=2;
7955 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
7956 if (decc_efs_charset == 0) {
7957 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
7963 lastdot = strrchr(cp2,'.');
7969 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
7971 if (decc_disable_posix_root) {
7972 strcpy(rslt,"sys$disk:[000000]");
7975 strcpy(rslt,"sys$posix_root:[000000]");
7977 if (utf8_flag != NULL)
7981 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
7983 trndev = PerlMem_malloc(VMS_MAXRSS);
7984 if (trndev == NULL) _ckvmssts(SS$_INSFMEM);
7985 islnm = my_trnlnm(rslt,trndev,0);
7987 /* DECC special handling */
7989 if (strcmp(rslt,"bin") == 0) {
7990 strcpy(rslt,"sys$system");
7993 islnm = my_trnlnm(rslt,trndev,0);
7995 else if (strcmp(rslt,"tmp") == 0) {
7996 strcpy(rslt,"sys$scratch");
7999 islnm = my_trnlnm(rslt,trndev,0);
8001 else if (!decc_disable_posix_root) {
8002 strcpy(rslt, "sys$posix_root");
8006 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8007 islnm = my_trnlnm(rslt,trndev,0);
8009 else if (strcmp(rslt,"dev") == 0) {
8010 if (strncmp(cp2,"/null", 5) == 0) {
8011 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8012 strcpy(rslt,"NLA0");
8016 islnm = my_trnlnm(rslt,trndev,0);
8022 trnend = islnm ? strlen(trndev) - 1 : 0;
8023 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8024 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8025 /* If the first element of the path is a logical name, determine
8026 * whether it has to be translated so we can add more directories. */
8027 if (!islnm || rooted) {
8030 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8034 if (cp2 != dirend) {
8035 strcpy(rslt,trndev);
8036 cp1 = rslt + trnend;
8043 if (decc_disable_posix_root) {
8049 PerlMem_free(trndev);
8054 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8055 cp2 += 2; /* skip over "./" - it's redundant */
8056 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8058 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8059 *(cp1++) = '-'; /* "../" --> "-" */
8062 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8063 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8064 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8065 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8068 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8069 /* Escape the extra dots in EFS file specifications */
8072 if (cp2 > dirend) cp2 = dirend;
8074 else *(cp1++) = '.';
8076 for (; cp2 < dirend; cp2++) {
8078 if (*(cp2-1) == '/') continue;
8079 if (*(cp1-1) != '.') *(cp1++) = '.';
8082 else if (!infront && *cp2 == '.') {
8083 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8084 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8085 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8086 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8087 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8088 else { /* back up over previous directory name */
8090 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8091 if (*(cp1-1) == '[') {
8092 memcpy(cp1,"000000.",7);
8097 if (cp2 == dirend) break;
8099 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8100 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8101 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8102 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8104 *(cp1++) = '.'; /* Simulate trailing '/' */
8105 cp2 += 2; /* for loop will incr this to == dirend */
8107 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8110 if (decc_efs_charset == 0)
8111 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8113 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8119 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8121 if (decc_efs_charset == 0)
8128 else *(cp1++) = *cp2;
8132 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8133 if (hasdir) *(cp1++) = ']';
8134 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8135 /* fixme for ODS5 */
8142 if (decc_efs_charset == 0)
8153 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8154 decc_readdir_dropdotnotype) {
8159 /* trailing dot ==> '^..' on VMS */
8166 *(cp1++) = *(cp2++);
8171 /* This could be a macro to be passed through */
8172 *(cp1++) = *(cp2++);
8174 const char * save_cp2;
8178 /* paranoid check */
8184 *(cp1++) = *(cp2++);
8185 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8186 *(cp1++) = *(cp2++);
8187 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8188 *(cp1++) = *(cp2++);
8191 *(cp1++) = *(cp2++);
8195 if (is_macro == 0) {
8196 /* Not really a macro - never mind */
8209 /* Don't escape again if following character is
8210 * already something we escape.
8212 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8213 *(cp1++) = *(cp2++);
8216 /* But otherwise fall through and escape it. */
8234 *(cp1++) = *(cp2++);
8237 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8238 * which is wrong. UNIX notation should be ".dir." unless
8239 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8240 * changing this behavior could break more things at this time.
8241 * efs character set effectively does not allow "." to be a version
8242 * delimiter as a further complication about changing this.
8244 if (decc_filename_unix_report != 0) {
8247 *(cp1++) = *(cp2++);
8250 *(cp1++) = *(cp2++);
8253 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8257 /* Fix me for "^]", but that requires making sure that you do
8258 * not back up past the start of the filename
8260 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8265 if (utf8_flag != NULL)
8269 } /* end of do_tovmsspec() */
8271 /* External entry points */
8272 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8273 { return do_tovmsspec(path,buf,0,NULL); }
8274 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8275 { return do_tovmsspec(path,buf,1,NULL); }
8276 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8277 { return do_tovmsspec(path,buf,0,utf8_fl); }
8278 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8279 { return do_tovmsspec(path,buf,1,utf8_fl); }
8281 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8282 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8283 static char __tovmspath_retbuf[VMS_MAXRSS];
8285 char *pathified, *vmsified, *cp;
8287 if (path == NULL) return NULL;
8288 pathified = PerlMem_malloc(VMS_MAXRSS);
8289 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8290 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8291 PerlMem_free(pathified);
8297 Newx(vmsified, VMS_MAXRSS, char);
8298 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8299 PerlMem_free(pathified);
8300 if (vmsified) Safefree(vmsified);
8303 PerlMem_free(pathified);
8308 vmslen = strlen(vmsified);
8309 Newx(cp,vmslen+1,char);
8310 memcpy(cp,vmsified,vmslen);
8316 strcpy(__tovmspath_retbuf,vmsified);
8318 return __tovmspath_retbuf;
8321 } /* end of do_tovmspath() */
8323 /* External entry points */
8324 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8325 { return do_tovmspath(path,buf,0, NULL); }
8326 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8327 { return do_tovmspath(path,buf,1, NULL); }
8328 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8329 { return do_tovmspath(path,buf,0,utf8_fl); }
8330 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8331 { return do_tovmspath(path,buf,1,utf8_fl); }
8334 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8335 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8336 static char __tounixpath_retbuf[VMS_MAXRSS];
8338 char *pathified, *unixified, *cp;
8340 if (path == NULL) return NULL;
8341 pathified = PerlMem_malloc(VMS_MAXRSS);
8342 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8343 if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) {
8344 PerlMem_free(pathified);
8350 Newx(unixified, VMS_MAXRSS, char);
8352 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8353 PerlMem_free(pathified);
8354 if (unixified) Safefree(unixified);
8357 PerlMem_free(pathified);
8362 unixlen = strlen(unixified);
8363 Newx(cp,unixlen+1,char);
8364 memcpy(cp,unixified,unixlen);
8366 Safefree(unixified);
8370 strcpy(__tounixpath_retbuf,unixified);
8371 Safefree(unixified);
8372 return __tounixpath_retbuf;
8375 } /* end of do_tounixpath() */
8377 /* External entry points */
8378 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8379 { return do_tounixpath(path,buf,0,NULL); }
8380 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8381 { return do_tounixpath(path,buf,1,NULL); }
8382 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8383 { return do_tounixpath(path,buf,0,utf8_fl); }
8384 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8385 { return do_tounixpath(path,buf,1,utf8_fl); }
8388 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
8390 *****************************************************************************
8392 * Copyright (C) 1989-1994, 2007 by *
8393 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
8395 * Permission is hereby granted for the reproduction of this software *
8396 * on condition that this copyright notice is included in source *
8397 * distributions of the software. The code may be modified and *
8398 * distributed under the same terms as Perl itself. *
8400 * 27-Aug-1994 Modified for inclusion in perl5 *
8401 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
8402 *****************************************************************************
8406 * getredirection() is intended to aid in porting C programs
8407 * to VMS (Vax-11 C). The native VMS environment does not support
8408 * '>' and '<' I/O redirection, or command line wild card expansion,
8409 * or a command line pipe mechanism using the '|' AND background
8410 * command execution '&'. All of these capabilities are provided to any
8411 * C program which calls this procedure as the first thing in the
8413 * The piping mechanism will probably work with almost any 'filter' type
8414 * of program. With suitable modification, it may useful for other
8415 * portability problems as well.
8417 * Author: Mark Pizzolato (mark AT infocomm DOT com)
8421 struct list_item *next;
8425 static void add_item(struct list_item **head,
8426 struct list_item **tail,
8430 static void mp_expand_wild_cards(pTHX_ char *item,
8431 struct list_item **head,
8432 struct list_item **tail,
8435 static int background_process(pTHX_ int argc, char **argv);
8437 static void pipe_and_fork(pTHX_ char **cmargv);
8439 /*{{{ void getredirection(int *ac, char ***av)*/
8441 mp_getredirection(pTHX_ int *ac, char ***av)
8443 * Process vms redirection arg's. Exit if any error is seen.
8444 * If getredirection() processes an argument, it is erased
8445 * from the vector. getredirection() returns a new argc and argv value.
8446 * In the event that a background command is requested (by a trailing "&"),
8447 * this routine creates a background subprocess, and simply exits the program.
8449 * Warning: do not try to simplify the code for vms. The code
8450 * presupposes that getredirection() is called before any data is
8451 * read from stdin or written to stdout.
8453 * Normal usage is as follows:
8459 * getredirection(&argc, &argv);
8463 int argc = *ac; /* Argument Count */
8464 char **argv = *av; /* Argument Vector */
8465 char *ap; /* Argument pointer */
8466 int j; /* argv[] index */
8467 int item_count = 0; /* Count of Items in List */
8468 struct list_item *list_head = 0; /* First Item in List */
8469 struct list_item *list_tail; /* Last Item in List */
8470 char *in = NULL; /* Input File Name */
8471 char *out = NULL; /* Output File Name */
8472 char *outmode = "w"; /* Mode to Open Output File */
8473 char *err = NULL; /* Error File Name */
8474 char *errmode = "w"; /* Mode to Open Error File */
8475 int cmargc = 0; /* Piped Command Arg Count */
8476 char **cmargv = NULL;/* Piped Command Arg Vector */
8479 * First handle the case where the last thing on the line ends with
8480 * a '&'. This indicates the desire for the command to be run in a
8481 * subprocess, so we satisfy that desire.
8484 if (0 == strcmp("&", ap))
8485 exit(background_process(aTHX_ --argc, argv));
8486 if (*ap && '&' == ap[strlen(ap)-1])
8488 ap[strlen(ap)-1] = '\0';
8489 exit(background_process(aTHX_ argc, argv));
8492 * Now we handle the general redirection cases that involve '>', '>>',
8493 * '<', and pipes '|'.
8495 for (j = 0; j < argc; ++j)
8497 if (0 == strcmp("<", argv[j]))
8501 fprintf(stderr,"No input file after < on command line");
8502 exit(LIB$_WRONUMARG);
8507 if ('<' == *(ap = argv[j]))
8512 if (0 == strcmp(">", ap))
8516 fprintf(stderr,"No output file after > on command line");
8517 exit(LIB$_WRONUMARG);
8536 fprintf(stderr,"No output file after > or >> on command line");
8537 exit(LIB$_WRONUMARG);
8541 if (('2' == *ap) && ('>' == ap[1]))
8558 fprintf(stderr,"No output file after 2> or 2>> on command line");
8559 exit(LIB$_WRONUMARG);
8563 if (0 == strcmp("|", argv[j]))
8567 fprintf(stderr,"No command into which to pipe on command line");
8568 exit(LIB$_WRONUMARG);
8570 cmargc = argc-(j+1);
8571 cmargv = &argv[j+1];
8575 if ('|' == *(ap = argv[j]))
8583 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
8586 * Allocate and fill in the new argument vector, Some Unix's terminate
8587 * the list with an extra null pointer.
8589 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
8590 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8592 for (j = 0; j < item_count; ++j, list_head = list_head->next)
8593 argv[j] = list_head->value;
8599 fprintf(stderr,"'|' and '>' may not both be specified on command line");
8600 exit(LIB$_INVARGORD);
8602 pipe_and_fork(aTHX_ cmargv);
8605 /* Check for input from a pipe (mailbox) */
8607 if (in == NULL && 1 == isapipe(0))
8609 char mbxname[L_tmpnam];
8611 long int dvi_item = DVI$_DEVBUFSIZ;
8612 $DESCRIPTOR(mbxnam, "");
8613 $DESCRIPTOR(mbxdevnam, "");
8615 /* Input from a pipe, reopen it in binary mode to disable */
8616 /* carriage control processing. */
8618 fgetname(stdin, mbxname);
8619 mbxnam.dsc$a_pointer = mbxname;
8620 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
8621 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
8622 mbxdevnam.dsc$a_pointer = mbxname;
8623 mbxdevnam.dsc$w_length = sizeof(mbxname);
8624 dvi_item = DVI$_DEVNAM;
8625 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
8626 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
8629 freopen(mbxname, "rb", stdin);
8632 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
8636 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
8638 fprintf(stderr,"Can't open input file %s as stdin",in);
8641 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
8643 fprintf(stderr,"Can't open output file %s as stdout",out);
8646 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
8649 if (strcmp(err,"&1") == 0) {
8650 dup2(fileno(stdout), fileno(stderr));
8651 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
8654 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
8656 fprintf(stderr,"Can't open error file %s as stderr",err);
8660 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
8664 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
8667 #ifdef ARGPROC_DEBUG
8668 PerlIO_printf(Perl_debug_log, "Arglist:\n");
8669 for (j = 0; j < *ac; ++j)
8670 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
8672 /* Clear errors we may have hit expanding wildcards, so they don't
8673 show up in Perl's $! later */
8674 set_errno(0); set_vaxc_errno(1);
8675 } /* end of getredirection() */
8678 static void add_item(struct list_item **head,
8679 struct list_item **tail,
8685 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8686 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8690 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
8691 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8692 *tail = (*tail)->next;
8694 (*tail)->value = value;
8698 static void mp_expand_wild_cards(pTHX_ char *item,
8699 struct list_item **head,
8700 struct list_item **tail,
8704 unsigned long int context = 0;
8712 $DESCRIPTOR(filespec, "");
8713 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
8714 $DESCRIPTOR(resultspec, "");
8715 unsigned long int lff_flags = 0;
8719 #ifdef VMS_LONGNAME_SUPPORT
8720 lff_flags = LIB$M_FIL_LONG_NAMES;
8723 for (cp = item; *cp; cp++) {
8724 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
8725 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
8727 if (!*cp || isspace(*cp))
8729 add_item(head, tail, item, count);
8734 /* "double quoted" wild card expressions pass as is */
8735 /* From DCL that means using e.g.: */
8736 /* perl program """perl.*""" */
8737 item_len = strlen(item);
8738 if ( '"' == *item && '"' == item[item_len-1] )
8741 item[item_len-2] = '\0';
8742 add_item(head, tail, item, count);
8746 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
8747 resultspec.dsc$b_class = DSC$K_CLASS_D;
8748 resultspec.dsc$a_pointer = NULL;
8749 vmsspec = PerlMem_malloc(VMS_MAXRSS);
8750 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8751 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
8752 filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL);
8753 if (!isunix || !filespec.dsc$a_pointer)
8754 filespec.dsc$a_pointer = item;
8755 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
8757 * Only return version specs, if the caller specified a version
8759 had_version = strchr(item, ';');
8761 * Only return device and directory specs, if the caller specifed either.
8763 had_device = strchr(item, ':');
8764 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
8766 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
8767 (&filespec, &resultspec, &context,
8768 &defaultspec, 0, &rms_sts, &lff_flags)))
8773 string = PerlMem_malloc(resultspec.dsc$w_length+1);
8774 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8775 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
8776 string[resultspec.dsc$w_length] = '\0';
8777 if (NULL == had_version)
8778 *(strrchr(string, ';')) = '\0';
8779 if ((!had_directory) && (had_device == NULL))
8781 if (NULL == (devdir = strrchr(string, ']')))
8782 devdir = strrchr(string, '>');
8783 strcpy(string, devdir + 1);
8786 * Be consistent with what the C RTL has already done to the rest of
8787 * the argv items and lowercase all of these names.
8789 if (!decc_efs_case_preserve) {
8790 for (c = string; *c; ++c)
8794 if (isunix) trim_unixpath(string,item,1);
8795 add_item(head, tail, string, count);
8798 PerlMem_free(vmsspec);
8799 if (sts != RMS$_NMF)
8801 set_vaxc_errno(sts);
8804 case RMS$_FNF: case RMS$_DNF:
8805 set_errno(ENOENT); break;
8807 set_errno(ENOTDIR); break;
8809 set_errno(ENODEV); break;
8810 case RMS$_FNM: case RMS$_SYN:
8811 set_errno(EINVAL); break;
8813 set_errno(EACCES); break;
8815 _ckvmssts_noperl(sts);
8819 add_item(head, tail, item, count);
8820 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
8821 _ckvmssts_noperl(lib$find_file_end(&context));
8824 static int child_st[2];/* Event Flag set when child process completes */
8826 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
8828 static unsigned long int exit_handler(int *status)
8832 if (0 == child_st[0])
8834 #ifdef ARGPROC_DEBUG
8835 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
8837 fflush(stdout); /* Have to flush pipe for binary data to */
8838 /* terminate properly -- <tp@mccall.com> */
8839 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
8840 sys$dassgn(child_chan);
8842 sys$synch(0, child_st);
8847 static void sig_child(int chan)
8849 #ifdef ARGPROC_DEBUG
8850 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
8852 if (child_st[0] == 0)
8856 static struct exit_control_block exit_block =
8861 &exit_block.exit_status,
8866 pipe_and_fork(pTHX_ char **cmargv)
8869 struct dsc$descriptor_s *vmscmd;
8870 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
8871 int sts, j, l, ismcr, quote, tquote = 0;
8873 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
8874 vms_execfree(vmscmd);
8879 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
8880 && toupper(*(q+2)) == 'R' && !*(q+3);
8882 while (q && l < MAX_DCL_LINE_LENGTH) {
8884 if (j > 0 && quote) {
8890 if (ismcr && j > 1) quote = 1;
8891 tquote = (strchr(q,' ')) != NULL || *q == '\0';
8894 if (quote || tquote) {
8900 if ((quote||tquote) && *q == '"') {
8910 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
8912 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
8916 static int background_process(pTHX_ int argc, char **argv)
8918 char command[MAX_DCL_SYMBOL + 1] = "$";
8919 $DESCRIPTOR(value, "");
8920 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
8921 static $DESCRIPTOR(null, "NLA0:");
8922 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
8924 $DESCRIPTOR(pidstr, "");
8926 unsigned long int flags = 17, one = 1, retsts;
8929 strcat(command, argv[0]);
8930 len = strlen(command);
8931 while (--argc && (len < MAX_DCL_SYMBOL))
8933 strcat(command, " \"");
8934 strcat(command, *(++argv));
8935 strcat(command, "\"");
8936 len = strlen(command);
8938 value.dsc$a_pointer = command;
8939 value.dsc$w_length = strlen(value.dsc$a_pointer);
8940 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
8941 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
8942 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
8943 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
8946 _ckvmssts_noperl(retsts);
8948 #ifdef ARGPROC_DEBUG
8949 PerlIO_printf(Perl_debug_log, "%s\n", command);
8951 sprintf(pidstring, "%08X", pid);
8952 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
8953 pidstr.dsc$a_pointer = pidstring;
8954 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
8955 lib$set_symbol(&pidsymbol, &pidstr);
8959 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
8962 /* OS-specific initialization at image activation (not thread startup) */
8963 /* Older VAXC header files lack these constants */
8964 #ifndef JPI$_RIGHTS_SIZE
8965 # define JPI$_RIGHTS_SIZE 817
8967 #ifndef KGB$M_SUBSYSTEM
8968 # define KGB$M_SUBSYSTEM 0x8
8971 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
8973 /*{{{void vms_image_init(int *, char ***)*/
8975 vms_image_init(int *argcp, char ***argvp)
8977 char eqv[LNM$C_NAMLENGTH+1] = "";
8978 unsigned int len, tabct = 8, tabidx = 0;
8979 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
8980 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
8981 unsigned short int dummy, rlen;
8982 struct dsc$descriptor_s **tabvec;
8983 #if defined(PERL_IMPLICIT_CONTEXT)
8986 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
8987 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
8988 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
8991 #ifdef KILL_BY_SIGPRC
8992 Perl_csighandler_init();
8995 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
8996 _ckvmssts_noperl(iosb[0]);
8997 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
8998 if (iprv[i]) { /* Running image installed with privs? */
8999 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
9004 /* Rights identifiers might trigger tainting as well. */
9005 if (!will_taint && (rlen || rsz)) {
9006 while (rlen < rsz) {
9007 /* We didn't get all the identifiers on the first pass. Allocate a
9008 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9009 * were needed to hold all identifiers at time of last call; we'll
9010 * allocate that many unsigned long ints), and go back and get 'em.
9011 * If it gave us less than it wanted to despite ample buffer space,
9012 * something's broken. Is your system missing a system identifier?
9014 if (rsz <= jpilist[1].buflen) {
9015 /* Perl_croak accvios when used this early in startup. */
9016 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9017 rsz, (unsigned long) jpilist[1].buflen,
9018 "Check your rights database for corruption.\n");
9021 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9022 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9023 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9024 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9025 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9026 _ckvmssts_noperl(iosb[0]);
9028 mask = jpilist[1].bufadr;
9029 /* Check attribute flags for each identifier (2nd longword); protected
9030 * subsystem identifiers trigger tainting.
9032 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9033 if (mask[i] & KGB$M_SUBSYSTEM) {
9038 if (mask != rlst) PerlMem_free(mask);
9041 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9042 * logical, some versions of the CRTL will add a phanthom /000000/
9043 * directory. This needs to be removed.
9045 if (decc_filename_unix_report) {
9048 ulen = strlen(argvp[0][0]);
9050 zeros = strstr(argvp[0][0], "/000000/");
9051 if (zeros != NULL) {
9053 mlen = ulen - (zeros - argvp[0][0]) - 7;
9054 memmove(zeros, &zeros[7], mlen);
9056 argvp[0][0][ulen] = '\0';
9059 /* It also may have a trailing dot that needs to be removed otherwise
9060 * it will be converted to VMS mode incorrectly.
9063 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9064 argvp[0][0][ulen] = '\0';
9067 /* We need to use this hack to tell Perl it should run with tainting,
9068 * since its tainting flag may be part of the PL_curinterp struct, which
9069 * hasn't been allocated when vms_image_init() is called.
9072 char **newargv, **oldargv;
9074 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9075 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9076 newargv[0] = oldargv[0];
9077 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9078 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9079 strcpy(newargv[1], "-T");
9080 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9082 newargv[*argcp] = NULL;
9083 /* We orphan the old argv, since we don't know where it's come from,
9084 * so we don't know how to free it.
9088 else { /* Did user explicitly request tainting? */
9090 char *cp, **av = *argvp;
9091 for (i = 1; i < *argcp; i++) {
9092 if (*av[i] != '-') break;
9093 for (cp = av[i]+1; *cp; cp++) {
9094 if (*cp == 'T') { will_taint = 1; break; }
9095 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9096 strchr("DFIiMmx",*cp)) break;
9098 if (will_taint) break;
9103 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9106 tabvec = (struct dsc$descriptor_s **)
9107 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9108 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9110 else if (tabidx >= tabct) {
9112 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9113 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9115 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9116 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9117 tabvec[tabidx]->dsc$w_length = 0;
9118 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9119 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9120 tabvec[tabidx]->dsc$a_pointer = NULL;
9121 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9123 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9125 getredirection(argcp,argvp);
9126 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9128 # include <reentrancy.h>
9129 decc$set_reentrancy(C$C_MULTITHREAD);
9138 * Trim Unix-style prefix off filespec, so it looks like what a shell
9139 * glob expansion would return (i.e. from specified prefix on, not
9140 * full path). Note that returned filespec is Unix-style, regardless
9141 * of whether input filespec was VMS-style or Unix-style.
9143 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9144 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9145 * vector of options; at present, only bit 0 is used, and if set tells
9146 * trim unixpath to try the current default directory as a prefix when
9147 * presented with a possibly ambiguous ... wildcard.
9149 * Returns !=0 on success, with trimmed filespec replacing contents of
9150 * fspec, and 0 on failure, with contents of fpsec unchanged.
9152 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9154 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9156 char *unixified, *unixwild,
9157 *template, *base, *end, *cp1, *cp2;
9158 register int tmplen, reslen = 0, dirs = 0;
9160 unixwild = PerlMem_malloc(VMS_MAXRSS);
9161 if (unixwild == NULL) _ckvmssts(SS$_INSFMEM);
9162 if (!wildspec || !fspec) return 0;
9163 template = unixwild;
9164 if (strpbrk(wildspec,"]>:") != NULL) {
9165 if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) {
9166 PerlMem_free(unixwild);
9171 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9172 unixwild[VMS_MAXRSS-1] = 0;
9174 unixified = PerlMem_malloc(VMS_MAXRSS);
9175 if (unixified == NULL) _ckvmssts(SS$_INSFMEM);
9176 if (strpbrk(fspec,"]>:") != NULL) {
9177 if (do_tounixspec(fspec,unixified,0,NULL) == NULL) {
9178 PerlMem_free(unixwild);
9179 PerlMem_free(unixified);
9182 else base = unixified;
9183 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9184 * check to see that final result fits into (isn't longer than) fspec */
9185 reslen = strlen(fspec);
9189 /* No prefix or absolute path on wildcard, so nothing to remove */
9190 if (!*template || *template == '/') {
9191 PerlMem_free(unixwild);
9192 if (base == fspec) {
9193 PerlMem_free(unixified);
9196 tmplen = strlen(unixified);
9197 if (tmplen > reslen) {
9198 PerlMem_free(unixified);
9199 return 0; /* not enough space */
9201 /* Copy unixified resultant, including trailing NUL */
9202 memmove(fspec,unixified,tmplen+1);
9203 PerlMem_free(unixified);
9207 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9208 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9209 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9210 for (cp1 = end ;cp1 >= base; cp1--)
9211 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9213 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9214 PerlMem_free(unixified);
9215 PerlMem_free(unixwild);
9220 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9221 int ells = 1, totells, segdirs, match;
9222 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9223 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9225 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9227 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9228 tpl = PerlMem_malloc(VMS_MAXRSS);
9229 if (tpl == NULL) _ckvmssts(SS$_INSFMEM);
9230 if (ellipsis == template && opts & 1) {
9231 /* Template begins with an ellipsis. Since we can't tell how many
9232 * directory names at the front of the resultant to keep for an
9233 * arbitrary starting point, we arbitrarily choose the current
9234 * default directory as a starting point. If it's there as a prefix,
9235 * clip it off. If not, fall through and act as if the leading
9236 * ellipsis weren't there (i.e. return shortest possible path that
9237 * could match template).
9239 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9241 PerlMem_free(unixified);
9242 PerlMem_free(unixwild);
9245 if (!decc_efs_case_preserve) {
9246 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9247 if (_tolower(*cp1) != _tolower(*cp2)) break;
9249 segdirs = dirs - totells; /* Min # of dirs we must have left */
9250 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9251 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9252 memmove(fspec,cp2+1,end - cp2);
9254 PerlMem_free(unixified);
9255 PerlMem_free(unixwild);
9259 /* First off, back up over constant elements at end of path */
9261 for (front = end ; front >= base; front--)
9262 if (*front == '/' && !dirs--) { front++; break; }
9264 lcres = PerlMem_malloc(VMS_MAXRSS);
9265 if (lcres == NULL) _ckvmssts(SS$_INSFMEM);
9266 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9268 if (!decc_efs_case_preserve) {
9269 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9277 PerlMem_free(unixified);
9278 PerlMem_free(unixwild);
9279 PerlMem_free(lcres);
9280 return 0; /* Path too long. */
9283 *cp2 = '\0'; /* Pick up with memcpy later */
9284 lcfront = lcres + (front - base);
9285 /* Now skip over each ellipsis and try to match the path in front of it. */
9287 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9288 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9289 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9290 if (cp1 < template) break; /* template started with an ellipsis */
9291 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9292 ellipsis = cp1; continue;
9294 wilddsc.dsc$a_pointer = tpl;
9295 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9297 for (segdirs = 0, cp2 = tpl;
9298 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9300 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9302 if (!decc_efs_case_preserve) {
9303 *cp2 = _tolower(*cp1); /* else lowercase for match */
9306 *cp2 = *cp1; /* else preserve case for match */
9309 if (*cp2 == '/') segdirs++;
9311 if (cp1 != ellipsis - 1) {
9313 PerlMem_free(unixified);
9314 PerlMem_free(unixwild);
9315 PerlMem_free(lcres);
9316 return 0; /* Path too long */
9318 /* Back up at least as many dirs as in template before matching */
9319 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9320 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9321 for (match = 0; cp1 > lcres;) {
9322 resdsc.dsc$a_pointer = cp1;
9323 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9325 if (match == 1) lcfront = cp1;
9327 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9331 PerlMem_free(unixified);
9332 PerlMem_free(unixwild);
9333 PerlMem_free(lcres);
9334 return 0; /* Can't find prefix ??? */
9336 if (match > 1 && opts & 1) {
9337 /* This ... wildcard could cover more than one set of dirs (i.e.
9338 * a set of similar dir names is repeated). If the template
9339 * contains more than 1 ..., upstream elements could resolve the
9340 * ambiguity, but it's not worth a full backtracking setup here.
9341 * As a quick heuristic, clip off the current default directory
9342 * if it's present to find the trimmed spec, else use the
9343 * shortest string that this ... could cover.
9345 char def[NAM$C_MAXRSS+1], *st;
9347 if (getcwd(def, sizeof def,0) == NULL) {
9348 PerlMem_free(unixified);
9349 PerlMem_free(unixwild);
9350 PerlMem_free(lcres);
9354 if (!decc_efs_case_preserve) {
9355 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9356 if (_tolower(*cp1) != _tolower(*cp2)) break;
9358 segdirs = dirs - totells; /* Min # of dirs we must have left */
9359 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
9360 if (*cp1 == '\0' && *cp2 == '/') {
9361 memmove(fspec,cp2+1,end - cp2);
9363 PerlMem_free(unixified);
9364 PerlMem_free(unixwild);
9365 PerlMem_free(lcres);
9368 /* Nope -- stick with lcfront from above and keep going. */
9371 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
9373 PerlMem_free(unixified);
9374 PerlMem_free(unixwild);
9375 PerlMem_free(lcres);
9380 } /* end of trim_unixpath() */
9385 * VMS readdir() routines.
9386 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
9388 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
9389 * Minor modifications to original routines.
9392 /* readdir may have been redefined by reentr.h, so make sure we get
9393 * the local version for what we do here.
9398 #if !defined(PERL_IMPLICIT_CONTEXT)
9399 # define readdir Perl_readdir
9401 # define readdir(a) Perl_readdir(aTHX_ a)
9404 /* Number of elements in vms_versions array */
9405 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
9408 * Open a directory, return a handle for later use.
9410 /*{{{ DIR *opendir(char*name) */
9412 Perl_opendir(pTHX_ const char *name)
9418 Newx(dir, VMS_MAXRSS, char);
9419 if (do_tovmspath(name,dir,0,NULL) == NULL) {
9423 /* Check access before stat; otherwise stat does not
9424 * accurately report whether it's a directory.
9426 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
9427 /* cando_by_name has already set errno */
9431 if (flex_stat(dir,&sb) == -1) return NULL;
9432 if (!S_ISDIR(sb.st_mode)) {
9434 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
9437 /* Get memory for the handle, and the pattern. */
9439 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
9441 /* Fill in the fields; mainly playing with the descriptor. */
9442 sprintf(dd->pattern, "%s*.*",dir);
9447 /* By saying we always want the result of readdir() in unix format, we
9448 * are really saying we want all the escapes removed. Otherwise the caller,
9449 * having no way to know whether it's already in VMS format, might send it
9450 * through tovmsspec again, thus double escaping.
9452 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
9453 dd->pat.dsc$a_pointer = dd->pattern;
9454 dd->pat.dsc$w_length = strlen(dd->pattern);
9455 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
9456 dd->pat.dsc$b_class = DSC$K_CLASS_S;
9457 #if defined(USE_ITHREADS)
9458 Newx(dd->mutex,1,perl_mutex);
9459 MUTEX_INIT( (perl_mutex *) dd->mutex );
9465 } /* end of opendir() */
9469 * Set the flag to indicate we want versions or not.
9471 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
9473 vmsreaddirversions(DIR *dd, int flag)
9476 dd->flags |= PERL_VMSDIR_M_VERSIONS;
9478 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9483 * Free up an opened directory.
9485 /*{{{ void closedir(DIR *dd)*/
9487 Perl_closedir(DIR *dd)
9491 sts = lib$find_file_end(&dd->context);
9492 Safefree(dd->pattern);
9493 #if defined(USE_ITHREADS)
9494 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
9495 Safefree(dd->mutex);
9502 * Collect all the version numbers for the current file.
9505 collectversions(pTHX_ DIR *dd)
9507 struct dsc$descriptor_s pat;
9508 struct dsc$descriptor_s res;
9510 char *p, *text, *buff;
9512 unsigned long context, tmpsts;
9514 /* Convenient shorthand. */
9517 /* Add the version wildcard, ignoring the "*.*" put on before */
9518 i = strlen(dd->pattern);
9519 Newx(text,i + e->d_namlen + 3,char);
9520 strcpy(text, dd->pattern);
9521 sprintf(&text[i - 3], "%s;*", e->d_name);
9523 /* Set up the pattern descriptor. */
9524 pat.dsc$a_pointer = text;
9525 pat.dsc$w_length = i + e->d_namlen - 1;
9526 pat.dsc$b_dtype = DSC$K_DTYPE_T;
9527 pat.dsc$b_class = DSC$K_CLASS_S;
9529 /* Set up result descriptor. */
9530 Newx(buff, VMS_MAXRSS, char);
9531 res.dsc$a_pointer = buff;
9532 res.dsc$w_length = VMS_MAXRSS - 1;
9533 res.dsc$b_dtype = DSC$K_DTYPE_T;
9534 res.dsc$b_class = DSC$K_CLASS_S;
9536 /* Read files, collecting versions. */
9537 for (context = 0, e->vms_verscount = 0;
9538 e->vms_verscount < VERSIZE(e);
9539 e->vms_verscount++) {
9541 unsigned long flags = 0;
9543 #ifdef VMS_LONGNAME_SUPPORT
9544 flags = LIB$M_FIL_LONG_NAMES;
9546 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
9547 if (tmpsts == RMS$_NMF || context == 0) break;
9549 buff[VMS_MAXRSS - 1] = '\0';
9550 if ((p = strchr(buff, ';')))
9551 e->vms_versions[e->vms_verscount] = atoi(p + 1);
9553 e->vms_versions[e->vms_verscount] = -1;
9556 _ckvmssts(lib$find_file_end(&context));
9560 } /* end of collectversions() */
9563 * Read the next entry from the directory.
9565 /*{{{ struct dirent *readdir(DIR *dd)*/
9567 Perl_readdir(pTHX_ DIR *dd)
9569 struct dsc$descriptor_s res;
9571 unsigned long int tmpsts;
9573 unsigned long flags = 0;
9574 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
9575 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
9577 /* Set up result descriptor, and get next file. */
9578 Newx(buff, VMS_MAXRSS, char);
9579 res.dsc$a_pointer = buff;
9580 res.dsc$w_length = VMS_MAXRSS - 1;
9581 res.dsc$b_dtype = DSC$K_DTYPE_T;
9582 res.dsc$b_class = DSC$K_CLASS_S;
9584 #ifdef VMS_LONGNAME_SUPPORT
9585 flags = LIB$M_FIL_LONG_NAMES;
9588 tmpsts = lib$find_file
9589 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
9590 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
9591 if (!(tmpsts & 1)) {
9592 set_vaxc_errno(tmpsts);
9595 set_errno(EACCES); break;
9597 set_errno(ENODEV); break;
9599 set_errno(ENOTDIR); break;
9600 case RMS$_FNF: case RMS$_DNF:
9601 set_errno(ENOENT); break;
9609 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
9610 buff[res.dsc$w_length] = '\0';
9611 p = buff + res.dsc$w_length;
9612 while (--p >= buff) if (!isspace(*p)) break;
9614 if (!decc_efs_case_preserve) {
9615 for (p = buff; *p; p++) *p = _tolower(*p);
9618 /* Skip any directory component and just copy the name. */
9619 sts = vms_split_path
9634 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9636 /* In Unix report mode, remove the ".dir;1" from the name */
9637 /* if it is a real directory. */
9638 if (decc_filename_unix_report || decc_efs_charset) {
9639 if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
9640 if ((toupper(e_spec[1]) == 'D') &&
9641 (toupper(e_spec[2]) == 'I') &&
9642 (toupper(e_spec[3]) == 'R')) {
9646 ret_sts = stat(buff, (stat_t *)&statbuf);
9647 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
9655 /* Drop NULL extensions on UNIX file specification */
9656 if ((e_len == 1) && decc_readdir_dropdotnotype) {
9662 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
9663 dd->entry.d_name[n_len + e_len] = '\0';
9664 dd->entry.d_namlen = strlen(dd->entry.d_name);
9666 /* Convert the filename to UNIX format if needed */
9667 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
9669 /* Translate the encoded characters. */
9670 /* Fixme: Unicode handling could result in embedded 0 characters */
9671 if (strchr(dd->entry.d_name, '^') != NULL) {
9674 p = dd->entry.d_name;
9677 int inchars_read, outchars_added;
9678 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
9680 q += outchars_added;
9682 /* if outchars_added > 1, then this is a wide file specification */
9683 /* Wide file specifications need to be passed in Perl */
9684 /* counted strings apparently with a Unicode flag */
9687 strcpy(dd->entry.d_name, new_name);
9688 dd->entry.d_namlen = strlen(dd->entry.d_name);
9692 dd->entry.vms_verscount = 0;
9693 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
9697 } /* end of readdir() */
9701 * Read the next entry from the directory -- thread-safe version.
9703 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
9705 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
9709 MUTEX_LOCK( (perl_mutex *) dd->mutex );
9711 entry = readdir(dd);
9713 retval = ( *result == NULL ? errno : 0 );
9715 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
9719 } /* end of readdir_r() */
9723 * Return something that can be used in a seekdir later.
9725 /*{{{ long telldir(DIR *dd)*/
9727 Perl_telldir(DIR *dd)
9734 * Return to a spot where we used to be. Brute force.
9736 /*{{{ void seekdir(DIR *dd,long count)*/
9738 Perl_seekdir(pTHX_ DIR *dd, long count)
9742 /* If we haven't done anything yet... */
9746 /* Remember some state, and clear it. */
9747 old_flags = dd->flags;
9748 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
9749 _ckvmssts(lib$find_file_end(&dd->context));
9752 /* The increment is in readdir(). */
9753 for (dd->count = 0; dd->count < count; )
9756 dd->flags = old_flags;
9758 } /* end of seekdir() */
9761 /* VMS subprocess management
9763 * my_vfork() - just a vfork(), after setting a flag to record that
9764 * the current script is trying a Unix-style fork/exec.
9766 * vms_do_aexec() and vms_do_exec() are called in response to the
9767 * perl 'exec' function. If this follows a vfork call, then they
9768 * call out the regular perl routines in doio.c which do an
9769 * execvp (for those who really want to try this under VMS).
9770 * Otherwise, they do exactly what the perl docs say exec should
9771 * do - terminate the current script and invoke a new command
9772 * (See below for notes on command syntax.)
9774 * do_aspawn() and do_spawn() implement the VMS side of the perl
9775 * 'system' function.
9777 * Note on command arguments to perl 'exec' and 'system': When handled
9778 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
9779 * are concatenated to form a DCL command string. If the first non-numeric
9780 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
9781 * the command string is handed off to DCL directly. Otherwise,
9782 * the first token of the command is taken as the filespec of an image
9783 * to run. The filespec is expanded using a default type of '.EXE' and
9784 * the process defaults for device, directory, etc., and if found, the resultant
9785 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
9786 * the command string as parameters. This is perhaps a bit complicated,
9787 * but I hope it will form a happy medium between what VMS folks expect
9788 * from lib$spawn and what Unix folks expect from exec.
9791 static int vfork_called;
9793 /*{{{int my_vfork()*/
9804 vms_execfree(struct dsc$descriptor_s *vmscmd)
9807 if (vmscmd->dsc$a_pointer) {
9808 PerlMem_free(vmscmd->dsc$a_pointer);
9810 PerlMem_free(vmscmd);
9815 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
9817 char *junk, *tmps = NULL;
9818 register size_t cmdlen = 0;
9825 tmps = SvPV(really,rlen);
9832 for (idx++; idx <= sp; idx++) {
9834 junk = SvPVx(*idx,rlen);
9835 cmdlen += rlen ? rlen + 1 : 0;
9838 Newx(PL_Cmd, cmdlen+1, char);
9840 if (tmps && *tmps) {
9841 strcpy(PL_Cmd,tmps);
9844 else *PL_Cmd = '\0';
9845 while (++mark <= sp) {
9847 char *s = SvPVx(*mark,n_a);
9849 if (*PL_Cmd) strcat(PL_Cmd," ");
9855 } /* end of setup_argstr() */
9858 static unsigned long int
9859 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
9860 struct dsc$descriptor_s **pvmscmd)
9862 char vmsspec[NAM$C_MAXRSS+1], resspec[NAM$C_MAXRSS+1];
9863 char image_name[NAM$C_MAXRSS+1];
9864 char image_argv[NAM$C_MAXRSS+1];
9865 $DESCRIPTOR(defdsc,".EXE");
9866 $DESCRIPTOR(defdsc2,".");
9867 $DESCRIPTOR(resdsc,resspec);
9868 struct dsc$descriptor_s *vmscmd;
9869 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9870 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
9871 register char *s, *rest, *cp, *wordbreak;
9876 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9877 if (vmscmd == NULL) _ckvmssts(SS$_INSFMEM);
9879 /* Make a copy for modification */
9880 cmdlen = strlen(incmd);
9881 cmd = PerlMem_malloc(cmdlen+1);
9882 if (cmd == NULL) _ckvmssts(SS$_INSFMEM);
9883 strncpy(cmd, incmd, cmdlen);
9888 vmscmd->dsc$a_pointer = NULL;
9889 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
9890 vmscmd->dsc$b_class = DSC$K_CLASS_S;
9891 vmscmd->dsc$w_length = 0;
9892 if (pvmscmd) *pvmscmd = vmscmd;
9894 if (suggest_quote) *suggest_quote = 0;
9896 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
9898 return CLI$_BUFOVF; /* continuation lines currently unsupported */
9903 while (*s && isspace(*s)) s++;
9905 if (*s == '@' || *s == '$') {
9906 vmsspec[0] = *s; rest = s + 1;
9907 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
9909 else { cp = vmsspec; rest = s; }
9910 if (*rest == '.' || *rest == '/') {
9913 *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec;
9914 rest++, cp2++) *cp2 = *rest;
9916 if (do_tovmsspec(resspec,cp,0,NULL)) {
9919 /* When a UNIX spec with no file type is translated to VMS, */
9920 /* A trailing '.' is appended under ODS-5 rules. */
9921 /* Here we do not want that trailing "." as it prevents */
9922 /* Looking for a implied ".exe" type. */
9923 if (decc_efs_charset) {
9925 i = strlen(vmsspec);
9926 if (vmsspec[i-1] == '.') {
9927 vmsspec[i-1] = '\0';
9932 for (cp2 = vmsspec + strlen(vmsspec);
9933 *rest && cp2 - vmsspec < sizeof vmsspec;
9934 rest++, cp2++) *cp2 = *rest;
9939 /* Intuit whether verb (first word of cmd) is a DCL command:
9940 * - if first nonspace char is '@', it's a DCL indirection
9942 * - if verb contains a filespec separator, it's not a DCL command
9943 * - if it doesn't, caller tells us whether to default to a DCL
9944 * command, or to a local image unless told it's DCL (by leading '$')
9948 if (suggest_quote) *suggest_quote = 1;
9950 register char *filespec = strpbrk(s,":<[.;");
9951 rest = wordbreak = strpbrk(s," \"\t/");
9952 if (!wordbreak) wordbreak = s + strlen(s);
9953 if (*s == '$') check_img = 0;
9954 if (filespec && (filespec < wordbreak)) isdcl = 0;
9955 else isdcl = !check_img;
9960 imgdsc.dsc$a_pointer = s;
9961 imgdsc.dsc$w_length = wordbreak - s;
9962 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9964 _ckvmssts(lib$find_file_end(&cxt));
9965 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9966 if (!(retsts & 1) && *s == '$') {
9967 _ckvmssts(lib$find_file_end(&cxt));
9968 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
9969 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
9971 _ckvmssts(lib$find_file_end(&cxt));
9972 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
9976 _ckvmssts(lib$find_file_end(&cxt));
9981 while (*s && !isspace(*s)) s++;
9984 /* check that it's really not DCL with no file extension */
9985 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
9987 char b[256] = {0,0,0,0};
9988 read(fileno(fp), b, 256);
9989 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
9993 /* Check for script */
9995 if ((b[0] == '#') && (b[1] == '!'))
9997 #ifdef ALTERNATE_SHEBANG
9999 shebang_len = strlen(ALTERNATE_SHEBANG);
10000 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10002 perlstr = strstr("perl",b);
10003 if (perlstr == NULL)
10011 if (shebang_len > 0) {
10014 char tmpspec[NAM$C_MAXRSS + 1];
10017 /* Image is following after white space */
10018 /*--------------------------------------*/
10019 while (isprint(b[i]) && isspace(b[i]))
10023 while (isprint(b[i]) && !isspace(b[i])) {
10024 tmpspec[j++] = b[i++];
10025 if (j >= NAM$C_MAXRSS)
10030 /* There may be some default parameters to the image */
10031 /*---------------------------------------------------*/
10033 while (isprint(b[i])) {
10034 image_argv[j++] = b[i++];
10035 if (j >= NAM$C_MAXRSS)
10038 while ((j > 0) && !isprint(image_argv[j-1]))
10042 /* It will need to be converted to VMS format and validated */
10043 if (tmpspec[0] != '\0') {
10046 /* Try to find the exact program requested to be run */
10047 /*---------------------------------------------------*/
10048 iname = do_rmsexpand
10049 (tmpspec, image_name, 0, ".exe",
10050 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10051 if (iname != NULL) {
10052 if (cando_by_name_int
10053 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10054 /* MCR prefix needed */
10058 /* Try again with a null type */
10059 /*----------------------------*/
10060 iname = do_rmsexpand
10061 (tmpspec, image_name, 0, ".",
10062 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10063 if (iname != NULL) {
10064 if (cando_by_name_int
10065 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10066 /* MCR prefix needed */
10072 /* Did we find the image to run the script? */
10073 /*------------------------------------------*/
10077 /* Assume DCL or foreign command exists */
10078 /*--------------------------------------*/
10079 tchr = strrchr(tmpspec, '/');
10080 if (tchr != NULL) {
10086 strcpy(image_name, tchr);
10094 if (check_img && isdcl) return RMS$_FNF;
10096 if (cando_by_name(S_IXUSR,0,resspec)) {
10097 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10098 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
10100 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10101 if (image_name[0] != 0) {
10102 strcat(vmscmd->dsc$a_pointer, image_name);
10103 strcat(vmscmd->dsc$a_pointer, " ");
10105 } else if (image_name[0] != 0) {
10106 strcpy(vmscmd->dsc$a_pointer, image_name);
10107 strcat(vmscmd->dsc$a_pointer, " ");
10109 strcpy(vmscmd->dsc$a_pointer,"@");
10111 if (suggest_quote) *suggest_quote = 1;
10113 /* If there is an image name, use original command */
10114 if (image_name[0] == 0)
10115 strcat(vmscmd->dsc$a_pointer,resspec);
10118 while (*rest && isspace(*rest)) rest++;
10121 if (image_argv[0] != 0) {
10122 strcat(vmscmd->dsc$a_pointer,image_argv);
10123 strcat(vmscmd->dsc$a_pointer, " ");
10129 rest_len = strlen(rest);
10130 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10131 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10132 strcat(vmscmd->dsc$a_pointer,rest);
10134 retsts = CLI$_BUFOVF;
10136 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10138 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10144 /* It's either a DCL command or we couldn't find a suitable image */
10145 vmscmd->dsc$w_length = strlen(cmd);
10147 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10148 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10149 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10153 /* check if it's a symbol (for quoting purposes) */
10154 if (suggest_quote && !*suggest_quote) {
10156 char equiv[LNM$C_NAMLENGTH];
10157 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10158 eqvdsc.dsc$a_pointer = equiv;
10160 iss = lib$get_symbol(vmscmd,&eqvdsc);
10161 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10163 if (!(retsts & 1)) {
10164 /* just hand off status values likely to be due to user error */
10165 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10166 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10167 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10168 else { _ckvmssts(retsts); }
10171 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10173 } /* end of setup_cmddsc() */
10176 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10178 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10184 if (vfork_called) { /* this follows a vfork - act Unixish */
10186 if (vfork_called < 0) {
10187 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10190 else return do_aexec(really,mark,sp);
10192 /* no vfork - act VMSish */
10193 cmd = setup_argstr(aTHX_ really,mark,sp);
10194 exec_sts = vms_do_exec(cmd);
10195 Safefree(cmd); /* Clean up from setup_argstr() */
10200 } /* end of vms_do_aexec() */
10203 /* {{{bool vms_do_exec(char *cmd) */
10205 Perl_vms_do_exec(pTHX_ const char *cmd)
10207 struct dsc$descriptor_s *vmscmd;
10209 if (vfork_called) { /* this follows a vfork - act Unixish */
10211 if (vfork_called < 0) {
10212 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10215 else return do_exec(cmd);
10218 { /* no vfork - act VMSish */
10219 unsigned long int retsts;
10222 TAINT_PROPER("exec");
10223 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10224 retsts = lib$do_command(vmscmd);
10227 case RMS$_FNF: case RMS$_DNF:
10228 set_errno(ENOENT); break;
10230 set_errno(ENOTDIR); break;
10232 set_errno(ENODEV); break;
10234 set_errno(EACCES); break;
10236 set_errno(EINVAL); break;
10237 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10238 set_errno(E2BIG); break;
10239 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10240 _ckvmssts(retsts); /* fall through */
10241 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10242 set_errno(EVMSERR);
10244 set_vaxc_errno(retsts);
10245 if (ckWARN(WARN_EXEC)) {
10246 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10247 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10249 vms_execfree(vmscmd);
10254 } /* end of vms_do_exec() */
10257 int do_spawn2(pTHX_ const char *, int);
10260 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10262 unsigned long int sts;
10268 /* We'll copy the (undocumented?) Win32 behavior and allow a
10269 * numeric first argument. But the only value we'll support
10270 * through do_aspawn is a value of 1, which means spawn without
10271 * waiting for completion -- other values are ignored.
10273 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10275 flags = SvIVx(*mark);
10278 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10279 flags = CLI$M_NOWAIT;
10283 cmd = setup_argstr(aTHX_ really, mark, sp);
10284 sts = do_spawn2(aTHX_ cmd, flags);
10285 /* pp_sys will clean up cmd */
10289 } /* end of do_aspawn() */
10293 /* {{{int do_spawn(char* cmd) */
10295 Perl_do_spawn(pTHX_ char* cmd)
10297 PERL_ARGS_ASSERT_DO_SPAWN;
10299 return do_spawn2(aTHX_ cmd, 0);
10303 /* {{{int do_spawn_nowait(char* cmd) */
10305 Perl_do_spawn_nowait(pTHX_ char* cmd)
10307 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10309 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10313 /* {{{int do_spawn2(char *cmd) */
10315 do_spawn2(pTHX_ const char *cmd, int flags)
10317 unsigned long int sts, substs;
10319 /* The caller of this routine expects to Safefree(PL_Cmd) */
10320 Newx(PL_Cmd,10,char);
10323 TAINT_PROPER("spawn");
10324 if (!cmd || !*cmd) {
10325 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
10328 case RMS$_FNF: case RMS$_DNF:
10329 set_errno(ENOENT); break;
10331 set_errno(ENOTDIR); break;
10333 set_errno(ENODEV); break;
10335 set_errno(EACCES); break;
10337 set_errno(EINVAL); break;
10338 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10339 set_errno(E2BIG); break;
10340 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10341 _ckvmssts(sts); /* fall through */
10342 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10343 set_errno(EVMSERR);
10345 set_vaxc_errno(sts);
10346 if (ckWARN(WARN_EXEC)) {
10347 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
10356 if (flags & CLI$M_NOWAIT)
10359 strcpy(mode, "nW");
10361 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
10364 /* sts will be the pid in the nowait case */
10367 } /* end of do_spawn2() */
10371 static unsigned int *sockflags, sockflagsize;
10374 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
10375 * routines found in some versions of the CRTL can't deal with sockets.
10376 * We don't shim the other file open routines since a socket isn't
10377 * likely to be opened by a name.
10379 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
10380 FILE *my_fdopen(int fd, const char *mode)
10382 FILE *fp = fdopen(fd, mode);
10385 unsigned int fdoff = fd / sizeof(unsigned int);
10386 Stat_t sbuf; /* native stat; we don't need flex_stat */
10387 if (!sockflagsize || fdoff > sockflagsize) {
10388 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
10389 else Newx (sockflags,fdoff+2,unsigned int);
10390 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
10391 sockflagsize = fdoff + 2;
10393 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
10394 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
10403 * Clear the corresponding bit when the (possibly) socket stream is closed.
10404 * There still a small hole: we miss an implicit close which might occur
10405 * via freopen(). >> Todo
10407 /*{{{ int my_fclose(FILE *fp)*/
10408 int my_fclose(FILE *fp) {
10410 unsigned int fd = fileno(fp);
10411 unsigned int fdoff = fd / sizeof(unsigned int);
10413 if (sockflagsize && fdoff < sockflagsize)
10414 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
10422 * A simple fwrite replacement which outputs itmsz*nitm chars without
10423 * introducing record boundaries every itmsz chars.
10424 * We are using fputs, which depends on a terminating null. We may
10425 * well be writing binary data, so we need to accommodate not only
10426 * data with nulls sprinkled in the middle but also data with no null
10429 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
10431 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
10433 register char *cp, *end, *cpd, *data;
10434 register unsigned int fd = fileno(dest);
10435 register unsigned int fdoff = fd / sizeof(unsigned int);
10437 int bufsize = itmsz * nitm + 1;
10439 if (fdoff < sockflagsize &&
10440 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
10441 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
10445 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
10446 memcpy( data, src, itmsz*nitm );
10447 data[itmsz*nitm] = '\0';
10449 end = data + itmsz * nitm;
10450 retval = (int) nitm; /* on success return # items written */
10453 while (cpd <= end) {
10454 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
10455 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
10457 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
10461 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
10464 } /* end of my_fwrite() */
10467 /*{{{ int my_flush(FILE *fp)*/
10469 Perl_my_flush(pTHX_ FILE *fp)
10472 if ((res = fflush(fp)) == 0 && fp) {
10473 #ifdef VMS_DO_SOCKETS
10475 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
10477 res = fsync(fileno(fp));
10480 * If the flush succeeded but set end-of-file, we need to clear
10481 * the error because our caller may check ferror(). BTW, this
10482 * probably means we just flushed an empty file.
10484 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
10491 * Here are replacements for the following Unix routines in the VMS environment:
10492 * getpwuid Get information for a particular UIC or UID
10493 * getpwnam Get information for a named user
10494 * getpwent Get information for each user in the rights database
10495 * setpwent Reset search to the start of the rights database
10496 * endpwent Finish searching for users in the rights database
10498 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
10499 * (defined in pwd.h), which contains the following fields:-
10501 * char *pw_name; Username (in lower case)
10502 * char *pw_passwd; Hashed password
10503 * unsigned int pw_uid; UIC
10504 * unsigned int pw_gid; UIC group number
10505 * char *pw_unixdir; Default device/directory (VMS-style)
10506 * char *pw_gecos; Owner name
10507 * char *pw_dir; Default device/directory (Unix-style)
10508 * char *pw_shell; Default CLI name (eg. DCL)
10510 * If the specified user does not exist, getpwuid and getpwnam return NULL.
10512 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
10513 * not the UIC member number (eg. what's returned by getuid()),
10514 * getpwuid() can accept either as input (if uid is specified, the caller's
10515 * UIC group is used), though it won't recognise gid=0.
10517 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
10518 * information about other users in your group or in other groups, respectively.
10519 * If the required privilege is not available, then these routines fill only
10520 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
10523 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
10526 /* sizes of various UAF record fields */
10527 #define UAI$S_USERNAME 12
10528 #define UAI$S_IDENT 31
10529 #define UAI$S_OWNER 31
10530 #define UAI$S_DEFDEV 31
10531 #define UAI$S_DEFDIR 63
10532 #define UAI$S_DEFCLI 31
10533 #define UAI$S_PWD 8
10535 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
10536 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
10537 (uic).uic$v_group != UIC$K_WILD_GROUP)
10539 static char __empty[]= "";
10540 static struct passwd __passwd_empty=
10541 {(char *) __empty, (char *) __empty, 0, 0,
10542 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
10543 static int contxt= 0;
10544 static struct passwd __pwdcache;
10545 static char __pw_namecache[UAI$S_IDENT+1];
10548 * This routine does most of the work extracting the user information.
10550 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
10553 unsigned char length;
10554 char pw_gecos[UAI$S_OWNER+1];
10556 static union uicdef uic;
10558 unsigned char length;
10559 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
10562 unsigned char length;
10563 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
10566 unsigned char length;
10567 char pw_shell[UAI$S_DEFCLI+1];
10569 static char pw_passwd[UAI$S_PWD+1];
10571 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
10572 struct dsc$descriptor_s name_desc;
10573 unsigned long int sts;
10575 static struct itmlst_3 itmlst[]= {
10576 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
10577 {sizeof(uic), UAI$_UIC, &uic, &luic},
10578 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
10579 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
10580 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
10581 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
10582 {0, 0, NULL, NULL}};
10584 name_desc.dsc$w_length= strlen(name);
10585 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10586 name_desc.dsc$b_class= DSC$K_CLASS_S;
10587 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
10589 /* Note that sys$getuai returns many fields as counted strings. */
10590 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
10591 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
10592 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
10594 else { _ckvmssts(sts); }
10595 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
10597 if ((int) owner.length < lowner) lowner= (int) owner.length;
10598 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
10599 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
10600 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
10601 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
10602 owner.pw_gecos[lowner]= '\0';
10603 defdev.pw_dir[ldefdev+ldefdir]= '\0';
10604 defcli.pw_shell[ldefcli]= '\0';
10605 if (valid_uic(uic)) {
10606 pwd->pw_uid= uic.uic$l_uic;
10607 pwd->pw_gid= uic.uic$v_group;
10610 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
10611 pwd->pw_passwd= pw_passwd;
10612 pwd->pw_gecos= owner.pw_gecos;
10613 pwd->pw_dir= defdev.pw_dir;
10614 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
10615 pwd->pw_shell= defcli.pw_shell;
10616 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
10618 ldir= strlen(pwd->pw_unixdir) - 1;
10619 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
10622 strcpy(pwd->pw_unixdir, pwd->pw_dir);
10623 if (!decc_efs_case_preserve)
10624 __mystrtolower(pwd->pw_unixdir);
10629 * Get information for a named user.
10631 /*{{{struct passwd *getpwnam(char *name)*/
10632 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
10634 struct dsc$descriptor_s name_desc;
10636 unsigned long int status, sts;
10638 __pwdcache = __passwd_empty;
10639 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
10640 /* We still may be able to determine pw_uid and pw_gid */
10641 name_desc.dsc$w_length= strlen(name);
10642 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
10643 name_desc.dsc$b_class= DSC$K_CLASS_S;
10644 name_desc.dsc$a_pointer= (char *) name;
10645 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
10646 __pwdcache.pw_uid= uic.uic$l_uic;
10647 __pwdcache.pw_gid= uic.uic$v_group;
10650 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
10651 set_vaxc_errno(sts);
10652 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
10655 else { _ckvmssts(sts); }
10658 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
10659 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
10660 __pwdcache.pw_name= __pw_namecache;
10661 return &__pwdcache;
10662 } /* end of my_getpwnam() */
10666 * Get information for a particular UIC or UID.
10667 * Called by my_getpwent with uid=-1 to list all users.
10669 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
10670 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
10672 const $DESCRIPTOR(name_desc,__pw_namecache);
10673 unsigned short lname;
10675 unsigned long int status;
10677 if (uid == (unsigned int) -1) {
10679 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
10680 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
10681 set_vaxc_errno(status);
10682 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10686 else { _ckvmssts(status); }
10687 } while (!valid_uic (uic));
10690 uic.uic$l_uic= uid;
10691 if (!uic.uic$v_group)
10692 uic.uic$v_group= PerlProc_getgid();
10693 if (valid_uic(uic))
10694 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
10695 else status = SS$_IVIDENT;
10696 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
10697 status == RMS$_PRV) {
10698 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
10701 else { _ckvmssts(status); }
10703 __pw_namecache[lname]= '\0';
10704 __mystrtolower(__pw_namecache);
10706 __pwdcache = __passwd_empty;
10707 __pwdcache.pw_name = __pw_namecache;
10709 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
10710 The identifier's value is usually the UIC, but it doesn't have to be,
10711 so if we can, we let fillpasswd update this. */
10712 __pwdcache.pw_uid = uic.uic$l_uic;
10713 __pwdcache.pw_gid = uic.uic$v_group;
10715 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
10716 return &__pwdcache;
10718 } /* end of my_getpwuid() */
10722 * Get information for next user.
10724 /*{{{struct passwd *my_getpwent()*/
10725 struct passwd *Perl_my_getpwent(pTHX)
10727 return (my_getpwuid((unsigned int) -1));
10732 * Finish searching rights database for users.
10734 /*{{{void my_endpwent()*/
10735 void Perl_my_endpwent(pTHX)
10738 _ckvmssts(sys$finish_rdb(&contxt));
10744 #ifdef HOMEGROWN_POSIX_SIGNALS
10745 /* Signal handling routines, pulled into the core from POSIX.xs.
10747 * We need these for threads, so they've been rolled into the core,
10748 * rather than left in POSIX.xs.
10750 * (DRS, Oct 23, 1997)
10753 /* sigset_t is atomic under VMS, so these routines are easy */
10754 /*{{{int my_sigemptyset(sigset_t *) */
10755 int my_sigemptyset(sigset_t *set) {
10756 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10757 *set = 0; return 0;
10762 /*{{{int my_sigfillset(sigset_t *)*/
10763 int my_sigfillset(sigset_t *set) {
10765 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10766 for (i = 0; i < NSIG; i++) *set |= (1 << i);
10772 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
10773 int my_sigaddset(sigset_t *set, int sig) {
10774 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10775 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10776 *set |= (1 << (sig - 1));
10782 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
10783 int my_sigdelset(sigset_t *set, int sig) {
10784 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10785 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10786 *set &= ~(1 << (sig - 1));
10792 /*{{{int my_sigismember(sigset_t *set, int sig)*/
10793 int my_sigismember(sigset_t *set, int sig) {
10794 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
10795 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
10796 return *set & (1 << (sig - 1));
10801 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
10802 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
10805 /* If set and oset are both null, then things are badly wrong. Bail out. */
10806 if ((oset == NULL) && (set == NULL)) {
10807 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
10811 /* If set's null, then we're just handling a fetch. */
10813 tempmask = sigblock(0);
10818 tempmask = sigsetmask(*set);
10821 tempmask = sigblock(*set);
10824 tempmask = sigblock(0);
10825 sigsetmask(*oset & ~tempmask);
10828 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
10833 /* Did they pass us an oset? If so, stick our holding mask into it */
10840 #endif /* HOMEGROWN_POSIX_SIGNALS */
10843 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
10844 * my_utime(), and flex_stat(), all of which operate on UTC unless
10845 * VMSISH_TIMES is true.
10847 /* method used to handle UTC conversions:
10848 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
10850 static int gmtime_emulation_type;
10851 /* number of secs to add to UTC POSIX-style time to get local time */
10852 static long int utc_offset_secs;
10854 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
10855 * in vmsish.h. #undef them here so we can call the CRTL routines
10864 * DEC C previous to 6.0 corrupts the behavior of the /prefix
10865 * qualifier with the extern prefix pragma. This provisional
10866 * hack circumvents this prefix pragma problem in previous
10869 #if defined(__VMS_VER) && __VMS_VER >= 70000000
10870 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
10871 # pragma __extern_prefix save
10872 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
10873 # define gmtime decc$__utctz_gmtime
10874 # define localtime decc$__utctz_localtime
10875 # define time decc$__utc_time
10876 # pragma __extern_prefix restore
10878 struct tm *gmtime(), *localtime();
10884 static time_t toutc_dst(time_t loc) {
10887 if ((rsltmp = localtime(&loc)) == NULL) return -1;
10888 loc -= utc_offset_secs;
10889 if (rsltmp->tm_isdst) loc -= 3600;
10892 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10893 ((gmtime_emulation_type || my_time(NULL)), \
10894 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
10895 ((secs) - utc_offset_secs))))
10897 static time_t toloc_dst(time_t utc) {
10900 utc += utc_offset_secs;
10901 if ((rsltmp = localtime(&utc)) == NULL) return -1;
10902 if (rsltmp->tm_isdst) utc += 3600;
10905 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
10906 ((gmtime_emulation_type || my_time(NULL)), \
10907 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
10908 ((secs) + utc_offset_secs))))
10910 #ifndef RTL_USES_UTC
10913 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
10914 DST starts on 1st sun of april at 02:00 std time
10915 ends on last sun of october at 02:00 dst time
10916 see the UCX management command reference, SET CONFIG TIMEZONE
10917 for formatting info.
10919 No, it's not as general as it should be, but then again, NOTHING
10920 will handle UK times in a sensible way.
10925 parse the DST start/end info:
10926 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
10930 tz_parse_startend(char *s, struct tm *w, int *past)
10932 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
10933 int ly, dozjd, d, m, n, hour, min, sec, j, k;
10938 if (!past) return 0;
10941 if (w->tm_year % 4 == 0) ly = 1;
10942 if (w->tm_year % 100 == 0) ly = 0;
10943 if (w->tm_year+1900 % 400 == 0) ly = 1;
10946 dozjd = isdigit(*s);
10947 if (*s == 'J' || *s == 'j' || dozjd) {
10948 if (!dozjd && !isdigit(*++s)) return 0;
10951 d = d*10 + *s++ - '0';
10953 d = d*10 + *s++ - '0';
10956 if (d == 0) return 0;
10957 if (d > 366) return 0;
10959 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
10962 } else if (*s == 'M' || *s == 'm') {
10963 if (!isdigit(*++s)) return 0;
10965 if (isdigit(*s)) m = 10*m + *s++ - '0';
10966 if (*s != '.') return 0;
10967 if (!isdigit(*++s)) return 0;
10969 if (n < 1 || n > 5) return 0;
10970 if (*s != '.') return 0;
10971 if (!isdigit(*++s)) return 0;
10973 if (d > 6) return 0;
10977 if (!isdigit(*++s)) return 0;
10979 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
10981 if (!isdigit(*++s)) return 0;
10983 if (isdigit(*s)) min = 10*min + *s++ - '0';
10985 if (!isdigit(*++s)) return 0;
10987 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
10997 if (w->tm_yday < d) goto before;
10998 if (w->tm_yday > d) goto after;
11000 if (w->tm_mon+1 < m) goto before;
11001 if (w->tm_mon+1 > m) goto after;
11003 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
11004 k = d - j; /* mday of first d */
11005 if (k <= 0) k += 7;
11006 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
11007 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11008 if (w->tm_mday < k) goto before;
11009 if (w->tm_mday > k) goto after;
11012 if (w->tm_hour < hour) goto before;
11013 if (w->tm_hour > hour) goto after;
11014 if (w->tm_min < min) goto before;
11015 if (w->tm_min > min) goto after;
11016 if (w->tm_sec < sec) goto before;
11030 /* parse the offset: (+|-)hh[:mm[:ss]] */
11033 tz_parse_offset(char *s, int *offset)
11035 int hour = 0, min = 0, sec = 0;
11038 if (!offset) return 0;
11040 if (*s == '-') {neg++; s++;}
11041 if (*s == '+') s++;
11042 if (!isdigit(*s)) return 0;
11044 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11045 if (hour > 24) return 0;
11047 if (!isdigit(*++s)) return 0;
11049 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11050 if (min > 59) return 0;
11052 if (!isdigit(*++s)) return 0;
11054 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11055 if (sec > 59) return 0;
11059 *offset = (hour*60+min)*60 + sec;
11060 if (neg) *offset = -*offset;
11065 input time is w, whatever type of time the CRTL localtime() uses.
11066 sets dst, the zone, and the gmtoff (seconds)
11068 caches the value of TZ and UCX$TZ env variables; note that
11069 my_setenv looks for these and sets a flag if they're changed
11072 We have to watch out for the "australian" case (dst starts in
11073 october, ends in april)...flagged by "reverse" and checked by
11074 scanning through the months of the previous year.
11079 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11084 char *dstzone, *tz, *s_start, *s_end;
11085 int std_off, dst_off, isdst;
11086 int y, dststart, dstend;
11087 static char envtz[1025]; /* longer than any logical, symbol, ... */
11088 static char ucxtz[1025];
11089 static char reversed = 0;
11095 reversed = -1; /* flag need to check */
11096 envtz[0] = ucxtz[0] = '\0';
11097 tz = my_getenv("TZ",0);
11098 if (tz) strcpy(envtz, tz);
11099 tz = my_getenv("UCX$TZ",0);
11100 if (tz) strcpy(ucxtz, tz);
11101 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11104 if (!*tz) tz = ucxtz;
11107 while (isalpha(*s)) s++;
11108 s = tz_parse_offset(s, &std_off);
11110 if (!*s) { /* no DST, hurray we're done! */
11116 while (isalpha(*s)) s++;
11117 s2 = tz_parse_offset(s, &dst_off);
11121 dst_off = std_off - 3600;
11124 if (!*s) { /* default dst start/end?? */
11125 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11126 s = strchr(ucxtz,',');
11128 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11130 if (*s != ',') return 0;
11133 when = _toutc(when); /* convert to utc */
11134 when = when - std_off; /* convert to pseudolocal time*/
11136 w2 = localtime(&when);
11139 s = tz_parse_startend(s_start,w2,&dststart);
11141 if (*s != ',') return 0;
11144 when = _toutc(when); /* convert to utc */
11145 when = when - dst_off; /* convert to pseudolocal time*/
11146 w2 = localtime(&when);
11147 if (w2->tm_year != y) { /* spans a year, just check one time */
11148 when += dst_off - std_off;
11149 w2 = localtime(&when);
11152 s = tz_parse_startend(s_end,w2,&dstend);
11155 if (reversed == -1) { /* need to check if start later than end */
11159 if (when < 2*365*86400) {
11160 when += 2*365*86400;
11164 w2 =localtime(&when);
11165 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11167 for (j = 0; j < 12; j++) {
11168 w2 =localtime(&when);
11169 tz_parse_startend(s_start,w2,&ds);
11170 tz_parse_startend(s_end,w2,&de);
11171 if (ds != de) break;
11175 if (de && !ds) reversed = 1;
11178 isdst = dststart && !dstend;
11179 if (reversed) isdst = dststart || !dstend;
11182 if (dst) *dst = isdst;
11183 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11184 if (isdst) tz = dstzone;
11186 while(isalpha(*tz)) *zone++ = *tz++;
11192 #endif /* !RTL_USES_UTC */
11194 /* my_time(), my_localtime(), my_gmtime()
11195 * By default traffic in UTC time values, using CRTL gmtime() or
11196 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11197 * Note: We need to use these functions even when the CRTL has working
11198 * UTC support, since they also handle C<use vmsish qw(times);>
11200 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11201 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11204 /*{{{time_t my_time(time_t *timep)*/
11205 time_t Perl_my_time(pTHX_ time_t *timep)
11210 if (gmtime_emulation_type == 0) {
11212 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11213 /* results of calls to gmtime() and localtime() */
11214 /* for same &base */
11216 gmtime_emulation_type++;
11217 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11218 char off[LNM$C_NAMLENGTH+1];;
11220 gmtime_emulation_type++;
11221 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11222 gmtime_emulation_type++;
11223 utc_offset_secs = 0;
11224 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11226 else { utc_offset_secs = atol(off); }
11228 else { /* We've got a working gmtime() */
11229 struct tm gmt, local;
11232 tm_p = localtime(&base);
11234 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11235 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11236 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11237 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11242 # ifdef VMSISH_TIME
11243 # ifdef RTL_USES_UTC
11244 if (VMSISH_TIME) when = _toloc(when);
11246 if (!VMSISH_TIME) when = _toutc(when);
11249 if (timep != NULL) *timep = when;
11252 } /* end of my_time() */
11256 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11258 Perl_my_gmtime(pTHX_ const time_t *timep)
11264 if (timep == NULL) {
11265 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11268 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11271 # ifdef VMSISH_TIME
11272 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11274 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11275 return gmtime(&when);
11277 /* CRTL localtime() wants local time as input, so does no tz correction */
11278 rsltmp = localtime(&when);
11279 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11282 } /* end of my_gmtime() */
11286 /*{{{struct tm *my_localtime(const time_t *timep)*/
11288 Perl_my_localtime(pTHX_ const time_t *timep)
11290 time_t when, whenutc;
11294 if (timep == NULL) {
11295 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11298 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11299 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11302 # ifdef RTL_USES_UTC
11303 # ifdef VMSISH_TIME
11304 if (VMSISH_TIME) when = _toutc(when);
11306 /* CRTL localtime() wants UTC as input, does tz correction itself */
11307 return localtime(&when);
11309 # else /* !RTL_USES_UTC */
11311 # ifdef VMSISH_TIME
11312 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11313 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
11316 #ifndef RTL_USES_UTC
11317 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
11318 when = whenutc - offset; /* pseudolocal time*/
11321 /* CRTL localtime() wants local time as input, so does no tz correction */
11322 rsltmp = localtime(&when);
11323 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
11327 } /* end of my_localtime() */
11330 /* Reset definitions for later calls */
11331 #define gmtime(t) my_gmtime(t)
11332 #define localtime(t) my_localtime(t)
11333 #define time(t) my_time(t)
11336 /* my_utime - update modification/access time of a file
11338 * VMS 7.3 and later implementation
11339 * Only the UTC translation is home-grown. The rest is handled by the
11340 * CRTL utime(), which will take into account the relevant feature
11341 * logicals and ODS-5 volume characteristics for true access times.
11343 * pre VMS 7.3 implementation:
11344 * The calling sequence is identical to POSIX utime(), but under
11345 * VMS with ODS-2, only the modification time is changed; ODS-2 does
11346 * not maintain access times. Restrictions differ from the POSIX
11347 * definition in that the time can be changed as long as the
11348 * caller has permission to execute the necessary IO$_MODIFY $QIO;
11349 * no separate checks are made to insure that the caller is the
11350 * owner of the file or has special privs enabled.
11351 * Code here is based on Joe Meadows' FILE utility.
11355 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
11356 * to VMS epoch (01-JAN-1858 00:00:00.00)
11357 * in 100 ns intervals.
11359 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
11361 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
11362 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
11364 #if __CRTL_VER >= 70300000
11365 struct utimbuf utc_utimes, *utc_utimesp;
11367 if (utimes != NULL) {
11368 utc_utimes.actime = utimes->actime;
11369 utc_utimes.modtime = utimes->modtime;
11370 # ifdef VMSISH_TIME
11371 /* If input was local; convert to UTC for sys svc */
11373 utc_utimes.actime = _toutc(utimes->actime);
11374 utc_utimes.modtime = _toutc(utimes->modtime);
11377 utc_utimesp = &utc_utimes;
11380 utc_utimesp = NULL;
11383 return utime(file, utc_utimesp);
11385 #else /* __CRTL_VER < 70300000 */
11389 long int bintime[2], len = 2, lowbit, unixtime,
11390 secscale = 10000000; /* seconds --> 100 ns intervals */
11391 unsigned long int chan, iosb[2], retsts;
11392 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
11393 struct FAB myfab = cc$rms_fab;
11394 struct NAM mynam = cc$rms_nam;
11395 #if defined (__DECC) && defined (__VAX)
11396 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
11397 * at least through VMS V6.1, which causes a type-conversion warning.
11399 # pragma message save
11400 # pragma message disable cvtdiftypes
11402 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
11403 struct fibdef myfib;
11404 #if defined (__DECC) && defined (__VAX)
11405 /* This should be right after the declaration of myatr, but due
11406 * to a bug in VAX DEC C, this takes effect a statement early.
11408 # pragma message restore
11410 /* cast ok for read only parameter */
11411 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
11412 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
11413 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
11415 if (file == NULL || *file == '\0') {
11416 SETERRNO(ENOENT, LIB$_INVARG);
11420 /* Convert to VMS format ensuring that it will fit in 255 characters */
11421 if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) {
11422 SETERRNO(ENOENT, LIB$_INVARG);
11425 if (utimes != NULL) {
11426 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
11427 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
11428 * Since time_t is unsigned long int, and lib$emul takes a signed long int
11429 * as input, we force the sign bit to be clear by shifting unixtime right
11430 * one bit, then multiplying by an extra factor of 2 in lib$emul().
11432 lowbit = (utimes->modtime & 1) ? secscale : 0;
11433 unixtime = (long int) utimes->modtime;
11434 # ifdef VMSISH_TIME
11435 /* If input was UTC; convert to local for sys svc */
11436 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
11438 unixtime >>= 1; secscale <<= 1;
11439 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
11440 if (!(retsts & 1)) {
11441 SETERRNO(EVMSERR, retsts);
11444 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
11445 if (!(retsts & 1)) {
11446 SETERRNO(EVMSERR, retsts);
11451 /* Just get the current time in VMS format directly */
11452 retsts = sys$gettim(bintime);
11453 if (!(retsts & 1)) {
11454 SETERRNO(EVMSERR, retsts);
11459 myfab.fab$l_fna = vmsspec;
11460 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
11461 myfab.fab$l_nam = &mynam;
11462 mynam.nam$l_esa = esa;
11463 mynam.nam$b_ess = (unsigned char) sizeof esa;
11464 mynam.nam$l_rsa = rsa;
11465 mynam.nam$b_rss = (unsigned char) sizeof rsa;
11466 if (decc_efs_case_preserve)
11467 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
11469 /* Look for the file to be affected, letting RMS parse the file
11470 * specification for us as well. I have set errno using only
11471 * values documented in the utime() man page for VMS POSIX.
11473 retsts = sys$parse(&myfab,0,0);
11474 if (!(retsts & 1)) {
11475 set_vaxc_errno(retsts);
11476 if (retsts == RMS$_PRV) set_errno(EACCES);
11477 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
11478 else set_errno(EVMSERR);
11481 retsts = sys$search(&myfab,0,0);
11482 if (!(retsts & 1)) {
11483 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11484 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11485 set_vaxc_errno(retsts);
11486 if (retsts == RMS$_PRV) set_errno(EACCES);
11487 else if (retsts == RMS$_FNF) set_errno(ENOENT);
11488 else set_errno(EVMSERR);
11492 devdsc.dsc$w_length = mynam.nam$b_dev;
11493 /* cast ok for read only parameter */
11494 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
11496 retsts = sys$assign(&devdsc,&chan,0,0);
11497 if (!(retsts & 1)) {
11498 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11499 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11500 set_vaxc_errno(retsts);
11501 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
11502 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
11503 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
11504 else set_errno(EVMSERR);
11508 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
11509 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
11511 memset((void *) &myfib, 0, sizeof myfib);
11512 #if defined(__DECC) || defined(__DECCXX)
11513 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
11514 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
11515 /* This prevents the revision time of the file being reset to the current
11516 * time as a result of our IO$_MODIFY $QIO. */
11517 myfib.fib$l_acctl = FIB$M_NORECORD;
11519 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
11520 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
11521 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
11523 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
11524 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
11525 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
11526 _ckvmssts(sys$dassgn(chan));
11527 if (retsts & 1) retsts = iosb[0];
11528 if (!(retsts & 1)) {
11529 set_vaxc_errno(retsts);
11530 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11531 else set_errno(EVMSERR);
11537 #endif /* #if __CRTL_VER >= 70300000 */
11539 } /* end of my_utime() */
11543 * flex_stat, flex_lstat, flex_fstat
11544 * basic stat, but gets it right when asked to stat
11545 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
11548 #ifndef _USE_STD_STAT
11549 /* encode_dev packs a VMS device name string into an integer to allow
11550 * simple comparisons. This can be used, for example, to check whether two
11551 * files are located on the same device, by comparing their encoded device
11552 * names. Even a string comparison would not do, because stat() reuses the
11553 * device name buffer for each call; so without encode_dev, it would be
11554 * necessary to save the buffer and use strcmp (this would mean a number of
11555 * changes to the standard Perl code, to say nothing of what a Perl script
11556 * would have to do.
11558 * The device lock id, if it exists, should be unique (unless perhaps compared
11559 * with lock ids transferred from other nodes). We have a lock id if the disk is
11560 * mounted cluster-wide, which is when we tend to get long (host-qualified)
11561 * device names. Thus we use the lock id in preference, and only if that isn't
11562 * available, do we try to pack the device name into an integer (flagged by
11563 * the sign bit (LOCKID_MASK) being set).
11565 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
11566 * name and its encoded form, but it seems very unlikely that we will find
11567 * two files on different disks that share the same encoded device names,
11568 * and even more remote that they will share the same file id (if the test
11569 * is to check for the same file).
11571 * A better method might be to use sys$device_scan on the first call, and to
11572 * search for the device, returning an index into the cached array.
11573 * The number returned would be more intelligible.
11574 * This is probably not worth it, and anyway would take quite a bit longer
11575 * on the first call.
11577 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
11578 static mydev_t encode_dev (pTHX_ const char *dev)
11581 unsigned long int f;
11586 if (!dev || !dev[0]) return 0;
11590 struct dsc$descriptor_s dev_desc;
11591 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
11593 /* For cluster-mounted disks, the disk lock identifier is unique, so we
11594 can try that first. */
11595 dev_desc.dsc$w_length = strlen (dev);
11596 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
11597 dev_desc.dsc$b_class = DSC$K_CLASS_S;
11598 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
11599 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
11600 if (!$VMS_STATUS_SUCCESS(status)) {
11602 case SS$_NOSUCHDEV:
11603 SETERRNO(ENODEV, status);
11609 if (lockid) return (lockid & ~LOCKID_MASK);
11613 /* Otherwise we try to encode the device name */
11617 for (q = dev + strlen(dev); q--; q >= dev) {
11622 else if (isalpha (toupper (*q)))
11623 c= toupper (*q) - 'A' + (char)10;
11625 continue; /* Skip '$'s */
11627 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
11629 enc += f * (unsigned long int) c;
11631 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
11633 } /* end of encode_dev() */
11634 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11635 device_no = encode_dev(aTHX_ devname)
11637 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
11638 device_no = new_dev_no
11642 is_null_device(name)
11645 if (decc_bug_devnull != 0) {
11646 if (strncmp("/dev/null", name, 9) == 0)
11649 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
11650 The underscore prefix, controller letter, and unit number are
11651 independently optional; for our purposes, the colon punctuation
11652 is not. The colon can be trailed by optional directory and/or
11653 filename, but two consecutive colons indicates a nodename rather
11654 than a device. [pr] */
11655 if (*name == '_') ++name;
11656 if (tolower(*name++) != 'n') return 0;
11657 if (tolower(*name++) != 'l') return 0;
11658 if (tolower(*name) == 'a') ++name;
11659 if (*name == '0') ++name;
11660 return (*name++ == ':') && (*name != ':');
11665 Perl_cando_by_name_int
11666 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
11668 char usrname[L_cuserid];
11669 struct dsc$descriptor_s usrdsc =
11670 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
11671 char *vmsname = NULL, *fileified = NULL;
11672 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
11673 unsigned short int retlen, trnlnm_iter_count;
11674 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11675 union prvdef curprv;
11676 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
11677 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
11678 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
11679 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
11680 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
11682 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
11684 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11686 static int profile_context = -1;
11688 if (!fname || !*fname) return FALSE;
11690 /* Make sure we expand logical names, since sys$check_access doesn't */
11691 fileified = PerlMem_malloc(VMS_MAXRSS);
11692 if (fileified == NULL) _ckvmssts(SS$_INSFMEM);
11693 if (!strpbrk(fname,"/]>:")) {
11694 strcpy(fileified,fname);
11695 trnlnm_iter_count = 0;
11696 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
11697 trnlnm_iter_count++;
11698 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
11703 vmsname = PerlMem_malloc(VMS_MAXRSS);
11704 if (vmsname == NULL) _ckvmssts(SS$_INSFMEM);
11705 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
11706 /* Don't know if already in VMS format, so make sure */
11707 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
11708 PerlMem_free(fileified);
11709 PerlMem_free(vmsname);
11714 strcpy(vmsname,fname);
11717 /* sys$check_access needs a file spec, not a directory spec.
11718 * Don't use flex_stat here, as that depends on thread context
11719 * having been initialized, and we may get here during startup.
11722 retlen = namdsc.dsc$w_length = strlen(vmsname);
11723 if (vmsname[retlen-1] == ']'
11724 || vmsname[retlen-1] == '>'
11725 || vmsname[retlen-1] == ':'
11726 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
11728 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
11729 PerlMem_free(fileified);
11730 PerlMem_free(vmsname);
11739 retlen = namdsc.dsc$w_length = strlen(fname);
11740 namdsc.dsc$a_pointer = (char *)fname;
11743 case S_IXUSR: case S_IXGRP: case S_IXOTH:
11744 access = ARM$M_EXECUTE;
11745 flags = CHP$M_READ;
11747 case S_IRUSR: case S_IRGRP: case S_IROTH:
11748 access = ARM$M_READ;
11749 flags = CHP$M_READ | CHP$M_USEREADALL;
11751 case S_IWUSR: case S_IWGRP: case S_IWOTH:
11752 access = ARM$M_WRITE;
11753 flags = CHP$M_READ | CHP$M_WRITE;
11755 case S_IDUSR: case S_IDGRP: case S_IDOTH:
11756 access = ARM$M_DELETE;
11757 flags = CHP$M_READ | CHP$M_WRITE;
11760 if (fileified != NULL)
11761 PerlMem_free(fileified);
11762 if (vmsname != NULL)
11763 PerlMem_free(vmsname);
11767 /* Before we call $check_access, create a user profile with the current
11768 * process privs since otherwise it just uses the default privs from the
11769 * UAF and might give false positives or negatives. This only works on
11770 * VMS versions v6.0 and later since that's when sys$create_user_profile
11771 * became available.
11774 /* get current process privs and username */
11775 _ckvmssts(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
11776 _ckvmssts(iosb[0]);
11778 #if defined(__VMS_VER) && __VMS_VER >= 60000000
11780 /* find out the space required for the profile */
11781 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
11782 &usrprodsc.dsc$w_length,&profile_context));
11784 /* allocate space for the profile and get it filled in */
11785 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
11786 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM);
11787 _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
11788 &usrprodsc.dsc$w_length,&profile_context));
11790 /* use the profile to check access to the file; free profile & analyze results */
11791 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
11792 PerlMem_free(usrprodsc.dsc$a_pointer);
11793 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
11797 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
11801 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
11802 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
11803 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
11804 set_vaxc_errno(retsts);
11805 if (retsts == SS$_NOPRIV) set_errno(EACCES);
11806 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
11807 else set_errno(ENOENT);
11808 if (fileified != NULL)
11809 PerlMem_free(fileified);
11810 if (vmsname != NULL)
11811 PerlMem_free(vmsname);
11814 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
11815 if (fileified != NULL)
11816 PerlMem_free(fileified);
11817 if (vmsname != NULL)
11818 PerlMem_free(vmsname);
11823 if (fileified != NULL)
11824 PerlMem_free(fileified);
11825 if (vmsname != NULL)
11826 PerlMem_free(vmsname);
11827 return FALSE; /* Should never get here */
11831 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
11832 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
11833 * subset of the applicable information.
11836 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
11838 return cando_by_name_int
11839 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
11840 } /* end of cando() */
11844 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
11846 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
11848 return cando_by_name_int(bit, effective, fname, 0);
11850 } /* end of cando_by_name() */
11854 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
11856 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
11858 if (!fstat(fd,(stat_t *) statbufp)) {
11860 char *vms_filename;
11861 vms_filename = PerlMem_malloc(VMS_MAXRSS);
11862 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
11864 /* Save name for cando by name in VMS format */
11865 cptr = getname(fd, vms_filename, 1);
11867 /* This should not happen, but just in case */
11868 if (cptr == NULL) {
11869 statbufp->st_devnam[0] = 0;
11872 /* Make sure that the saved name fits in 255 characters */
11873 cptr = do_rmsexpand
11875 statbufp->st_devnam,
11878 PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN,
11882 statbufp->st_devnam[0] = 0;
11884 PerlMem_free(vms_filename);
11886 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
11888 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
11890 # ifdef RTL_USES_UTC
11891 # ifdef VMSISH_TIME
11893 statbufp->st_mtime = _toloc(statbufp->st_mtime);
11894 statbufp->st_atime = _toloc(statbufp->st_atime);
11895 statbufp->st_ctime = _toloc(statbufp->st_ctime);
11899 # ifdef VMSISH_TIME
11900 if (!VMSISH_TIME) { /* Return UTC instead of local time */
11904 statbufp->st_mtime = _toutc(statbufp->st_mtime);
11905 statbufp->st_atime = _toutc(statbufp->st_atime);
11906 statbufp->st_ctime = _toutc(statbufp->st_ctime);
11913 } /* end of flex_fstat() */
11916 #if !defined(__VAX) && __CRTL_VER >= 80200000
11924 #define lstat(_x, _y) stat(_x, _y)
11927 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
11930 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
11932 char fileified[VMS_MAXRSS];
11933 char temp_fspec[VMS_MAXRSS];
11938 if (!fspec) return retval;
11940 strcpy(temp_fspec, fspec);
11942 if (decc_bug_devnull != 0) {
11943 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
11944 memset(statbufp,0,sizeof *statbufp);
11945 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
11946 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
11947 statbufp->st_uid = 0x00010001;
11948 statbufp->st_gid = 0x0001;
11949 time((time_t *)&statbufp->st_mtime);
11950 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
11955 /* Try for a directory name first. If fspec contains a filename without
11956 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
11957 * and sea:[wine.dark]water. exist, we prefer the directory here.
11958 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
11959 * not sea:[wine.dark]., if the latter exists. If the intended target is
11960 * the file with null type, specify this by calling flex_stat() with
11961 * a '.' at the end of fspec.
11963 * If we are in Posix filespec mode, accept the filename as is.
11967 #if __CRTL_VER >= 70300000 && !defined(__VAX)
11968 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
11969 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
11971 if (!decc_efs_charset)
11972 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
11975 #if __CRTL_VER >= 80200000 && !defined(__VAX)
11976 if (decc_posix_compliant_pathnames == 0) {
11978 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
11979 if (lstat_flag == 0)
11980 retval = stat(fileified,(stat_t *) statbufp);
11982 retval = lstat(fileified,(stat_t *) statbufp);
11983 save_spec = fileified;
11986 if (lstat_flag == 0)
11987 retval = stat(temp_fspec,(stat_t *) statbufp);
11989 retval = lstat(temp_fspec,(stat_t *) statbufp);
11990 save_spec = temp_fspec;
11993 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
11994 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
11995 * and lstat was working correctly for the same file.
11996 * The only syntax that was working for stat was "foo:[bar]t.dir".
11998 * Other directories with the same syntax worked fine.
11999 * So work around the problem when it shows up here.
12002 int save_errno = errno;
12003 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12004 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12005 retval = stat(fileified, (stat_t *) statbufp);
12006 save_spec = fileified;
12009 /* Restore the errno value if third stat does not succeed */
12011 errno = save_errno;
12013 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12015 if (lstat_flag == 0)
12016 retval = stat(temp_fspec,(stat_t *) statbufp);
12018 retval = lstat(temp_fspec,(stat_t *) statbufp);
12019 save_spec = temp_fspec;
12023 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12024 /* As you were... */
12025 if (!decc_efs_charset)
12026 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12031 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12033 /* If this is an lstat, do not follow the link */
12035 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12037 cptr = do_rmsexpand
12038 (save_spec, statbufp->st_devnam, 0, NULL, rmsex_flags, NULL, NULL);
12040 statbufp->st_devnam[0] = 0;
12042 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12044 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12045 # ifdef RTL_USES_UTC
12046 # ifdef VMSISH_TIME
12048 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12049 statbufp->st_atime = _toloc(statbufp->st_atime);
12050 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12054 # ifdef VMSISH_TIME
12055 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12059 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12060 statbufp->st_atime = _toutc(statbufp->st_atime);
12061 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12065 /* If we were successful, leave errno where we found it */
12066 if (retval == 0) RESTORE_ERRNO;
12069 } /* end of flex_stat_int() */
12072 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12074 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12076 return flex_stat_int(fspec, statbufp, 0);
12080 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12082 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12084 return flex_stat_int(fspec, statbufp, 1);
12089 /*{{{char *my_getlogin()*/
12090 /* VMS cuserid == Unix getlogin, except calling sequence */
12094 static char user[L_cuserid];
12095 return cuserid(user);
12100 /* rmscopy - copy a file using VMS RMS routines
12102 * Copies contents and attributes of spec_in to spec_out, except owner
12103 * and protection information. Name and type of spec_in are used as
12104 * defaults for spec_out. The third parameter specifies whether rmscopy()
12105 * should try to propagate timestamps from the input file to the output file.
12106 * If it is less than 0, no timestamps are preserved. If it is 0, then
12107 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12108 * propagated to the output file at creation iff the output file specification
12109 * did not contain an explicit name or type, and the revision date is always
12110 * updated at the end of the copy operation. If it is greater than 0, then
12111 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12112 * other than the revision date should be propagated, and bit 1 indicates
12113 * that the revision date should be propagated.
12115 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12117 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12118 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12119 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12120 * as part of the Perl standard distribution under the terms of the
12121 * GNU General Public License or the Perl Artistic License. Copies
12122 * of each may be found in the Perl standard distribution.
12124 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12126 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12128 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12129 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12130 unsigned long int i, sts, sts2;
12132 struct FAB fab_in, fab_out;
12133 struct RAB rab_in, rab_out;
12134 rms_setup_nam(nam);
12135 rms_setup_nam(nam_out);
12136 struct XABDAT xabdat;
12137 struct XABFHC xabfhc;
12138 struct XABRDT xabrdt;
12139 struct XABSUM xabsum;
12141 vmsin = PerlMem_malloc(VMS_MAXRSS);
12142 if (vmsin == NULL) _ckvmssts(SS$_INSFMEM);
12143 vmsout = PerlMem_malloc(VMS_MAXRSS);
12144 if (vmsout == NULL) _ckvmssts(SS$_INSFMEM);
12145 if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) ||
12146 !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) {
12147 PerlMem_free(vmsin);
12148 PerlMem_free(vmsout);
12149 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12153 esa = PerlMem_malloc(VMS_MAXRSS);
12154 if (esa == NULL) _ckvmssts(SS$_INSFMEM);
12156 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12157 esal = PerlMem_malloc(VMS_MAXRSS);
12158 if (esal == NULL) _ckvmssts(SS$_INSFMEM);
12160 fab_in = cc$rms_fab;
12161 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12162 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12163 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12164 fab_in.fab$l_fop = FAB$M_SQO;
12165 rms_bind_fab_nam(fab_in, nam);
12166 fab_in.fab$l_xab = (void *) &xabdat;
12168 rsa = PerlMem_malloc(VMS_MAXRSS);
12169 if (rsa == NULL) _ckvmssts(SS$_INSFMEM);
12171 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12172 rsal = PerlMem_malloc(VMS_MAXRSS);
12173 if (rsal == NULL) _ckvmssts(SS$_INSFMEM);
12175 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12176 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12177 rms_nam_esl(nam) = 0;
12178 rms_nam_rsl(nam) = 0;
12179 rms_nam_esll(nam) = 0;
12180 rms_nam_rsll(nam) = 0;
12181 #ifdef NAM$M_NO_SHORT_UPCASE
12182 if (decc_efs_case_preserve)
12183 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12186 xabdat = cc$rms_xabdat; /* To get creation date */
12187 xabdat.xab$l_nxt = (void *) &xabfhc;
12189 xabfhc = cc$rms_xabfhc; /* To get record length */
12190 xabfhc.xab$l_nxt = (void *) &xabsum;
12192 xabsum = cc$rms_xabsum; /* To get key and area information */
12194 if (!((sts = sys$open(&fab_in)) & 1)) {
12195 PerlMem_free(vmsin);
12196 PerlMem_free(vmsout);
12199 PerlMem_free(esal);
12202 PerlMem_free(rsal);
12203 set_vaxc_errno(sts);
12205 case RMS$_FNF: case RMS$_DNF:
12206 set_errno(ENOENT); break;
12208 set_errno(ENOTDIR); break;
12210 set_errno(ENODEV); break;
12212 set_errno(EINVAL); break;
12214 set_errno(EACCES); break;
12216 set_errno(EVMSERR);
12223 fab_out.fab$w_ifi = 0;
12224 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12225 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12226 fab_out.fab$l_fop = FAB$M_SQO;
12227 rms_bind_fab_nam(fab_out, nam_out);
12228 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12229 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12230 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12231 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12232 if (esa_out == NULL) _ckvmssts(SS$_INSFMEM);
12233 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12234 if (rsa_out == NULL) _ckvmssts(SS$_INSFMEM);
12237 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12238 esal_out = PerlMem_malloc(VMS_MAXRSS);
12239 if (esal_out == NULL) _ckvmssts(SS$_INSFMEM);
12240 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12241 if (rsal_out == NULL) _ckvmssts(SS$_INSFMEM);
12243 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12244 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12246 if (preserve_dates == 0) { /* Act like DCL COPY */
12247 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12248 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12249 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12250 PerlMem_free(vmsin);
12251 PerlMem_free(vmsout);
12254 PerlMem_free(esal);
12257 PerlMem_free(rsal);
12258 PerlMem_free(esa_out);
12259 if (esal_out != NULL)
12260 PerlMem_free(esal_out);
12261 PerlMem_free(rsa_out);
12262 if (rsal_out != NULL)
12263 PerlMem_free(rsal_out);
12264 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12265 set_vaxc_errno(sts);
12268 fab_out.fab$l_xab = (void *) &xabdat;
12269 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12270 preserve_dates = 1;
12272 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12273 preserve_dates =0; /* bitmask from this point forward */
12275 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12276 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12277 PerlMem_free(vmsin);
12278 PerlMem_free(vmsout);
12281 PerlMem_free(esal);
12284 PerlMem_free(rsal);
12285 PerlMem_free(esa_out);
12286 if (esal_out != NULL)
12287 PerlMem_free(esal_out);
12288 PerlMem_free(rsa_out);
12289 if (rsal_out != NULL)
12290 PerlMem_free(rsal_out);
12291 set_vaxc_errno(sts);
12294 set_errno(ENOENT); break;
12296 set_errno(ENOTDIR); break;
12298 set_errno(ENODEV); break;
12300 set_errno(EINVAL); break;
12302 set_errno(EACCES); break;
12304 set_errno(EVMSERR);
12308 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12309 if (preserve_dates & 2) {
12310 /* sys$close() will process xabrdt, not xabdat */
12311 xabrdt = cc$rms_xabrdt;
12313 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12315 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12316 * is unsigned long[2], while DECC & VAXC use a struct */
12317 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12319 fab_out.fab$l_xab = (void *) &xabrdt;
12322 ubf = PerlMem_malloc(32256);
12323 if (ubf == NULL) _ckvmssts(SS$_INSFMEM);
12324 rab_in = cc$rms_rab;
12325 rab_in.rab$l_fab = &fab_in;
12326 rab_in.rab$l_rop = RAB$M_BIO;
12327 rab_in.rab$l_ubf = ubf;
12328 rab_in.rab$w_usz = 32256;
12329 if (!((sts = sys$connect(&rab_in)) & 1)) {
12330 sys$close(&fab_in); sys$close(&fab_out);
12331 PerlMem_free(vmsin);
12332 PerlMem_free(vmsout);
12336 PerlMem_free(esal);
12339 PerlMem_free(rsal);
12340 PerlMem_free(esa_out);
12341 if (esal_out != NULL)
12342 PerlMem_free(esal_out);
12343 PerlMem_free(rsa_out);
12344 if (rsal_out != NULL)
12345 PerlMem_free(rsal_out);
12346 set_errno(EVMSERR); set_vaxc_errno(sts);
12350 rab_out = cc$rms_rab;
12351 rab_out.rab$l_fab = &fab_out;
12352 rab_out.rab$l_rbf = ubf;
12353 if (!((sts = sys$connect(&rab_out)) & 1)) {
12354 sys$close(&fab_in); sys$close(&fab_out);
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);
12370 set_errno(EVMSERR); set_vaxc_errno(sts);
12374 while ((sts = sys$read(&rab_in))) { /* always true */
12375 if (sts == RMS$_EOF) break;
12376 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
12377 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
12378 sys$close(&fab_in); sys$close(&fab_out);
12379 PerlMem_free(vmsin);
12380 PerlMem_free(vmsout);
12384 PerlMem_free(esal);
12387 PerlMem_free(rsal);
12388 PerlMem_free(esa_out);
12389 if (esal_out != NULL)
12390 PerlMem_free(esal_out);
12391 PerlMem_free(rsa_out);
12392 if (rsal_out != NULL)
12393 PerlMem_free(rsal_out);
12394 set_errno(EVMSERR); set_vaxc_errno(sts);
12400 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
12401 sys$close(&fab_in); sys$close(&fab_out);
12402 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
12404 PerlMem_free(vmsin);
12405 PerlMem_free(vmsout);
12409 PerlMem_free(esal);
12412 PerlMem_free(rsal);
12413 PerlMem_free(esa_out);
12414 if (esal_out != NULL)
12415 PerlMem_free(esal_out);
12416 PerlMem_free(rsa_out);
12417 if (rsal_out != NULL)
12418 PerlMem_free(rsal_out);
12421 set_errno(EVMSERR); set_vaxc_errno(sts);
12427 } /* end of rmscopy() */
12431 /*** The following glue provides 'hooks' to make some of the routines
12432 * from this file available from Perl. These routines are sufficiently
12433 * basic, and are required sufficiently early in the build process,
12434 * that's it's nice to have them available to miniperl as well as the
12435 * full Perl, so they're set up here instead of in an extension. The
12436 * Perl code which handles importation of these names into a given
12437 * package lives in [.VMS]Filespec.pm in @INC.
12441 rmsexpand_fromperl(pTHX_ CV *cv)
12444 char *fspec, *defspec = NULL, *rslt;
12446 int fs_utf8, dfs_utf8;
12450 if (!items || items > 2)
12451 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
12452 fspec = SvPV(ST(0),n_a);
12453 fs_utf8 = SvUTF8(ST(0));
12454 if (!fspec || !*fspec) XSRETURN_UNDEF;
12456 defspec = SvPV(ST(1),n_a);
12457 dfs_utf8 = SvUTF8(ST(1));
12459 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
12460 ST(0) = sv_newmortal();
12461 if (rslt != NULL) {
12462 sv_usepvn(ST(0),rslt,strlen(rslt));
12471 vmsify_fromperl(pTHX_ CV *cv)
12478 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
12479 utf8_fl = SvUTF8(ST(0));
12480 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12481 ST(0) = sv_newmortal();
12482 if (vmsified != NULL) {
12483 sv_usepvn(ST(0),vmsified,strlen(vmsified));
12492 unixify_fromperl(pTHX_ CV *cv)
12499 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
12500 utf8_fl = SvUTF8(ST(0));
12501 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12502 ST(0) = sv_newmortal();
12503 if (unixified != NULL) {
12504 sv_usepvn(ST(0),unixified,strlen(unixified));
12513 fileify_fromperl(pTHX_ CV *cv)
12520 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
12521 utf8_fl = SvUTF8(ST(0));
12522 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12523 ST(0) = sv_newmortal();
12524 if (fileified != NULL) {
12525 sv_usepvn(ST(0),fileified,strlen(fileified));
12534 pathify_fromperl(pTHX_ CV *cv)
12541 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
12542 utf8_fl = SvUTF8(ST(0));
12543 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12544 ST(0) = sv_newmortal();
12545 if (pathified != NULL) {
12546 sv_usepvn(ST(0),pathified,strlen(pathified));
12555 vmspath_fromperl(pTHX_ CV *cv)
12562 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
12563 utf8_fl = SvUTF8(ST(0));
12564 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12565 ST(0) = sv_newmortal();
12566 if (vmspath != NULL) {
12567 sv_usepvn(ST(0),vmspath,strlen(vmspath));
12576 unixpath_fromperl(pTHX_ CV *cv)
12583 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
12584 utf8_fl = SvUTF8(ST(0));
12585 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
12586 ST(0) = sv_newmortal();
12587 if (unixpath != NULL) {
12588 sv_usepvn(ST(0),unixpath,strlen(unixpath));
12597 candelete_fromperl(pTHX_ CV *cv)
12605 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
12607 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12608 Newx(fspec, VMS_MAXRSS, char);
12609 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
12610 if (SvTYPE(mysv) == SVt_PVGV) {
12611 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
12612 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12620 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
12621 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12628 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
12634 rmscopy_fromperl(pTHX_ CV *cv)
12637 char *inspec, *outspec, *inp, *outp;
12639 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
12640 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12641 unsigned long int sts;
12646 if (items < 2 || items > 3)
12647 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
12649 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
12650 Newx(inspec, VMS_MAXRSS, char);
12651 if (SvTYPE(mysv) == SVt_PVGV) {
12652 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
12653 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12661 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
12662 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12668 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
12669 Newx(outspec, VMS_MAXRSS, char);
12670 if (SvTYPE(mysv) == SVt_PVGV) {
12671 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
12672 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12681 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
12682 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12689 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
12691 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
12697 /* The mod2fname is limited to shorter filenames by design, so it should
12698 * not be modified to support longer EFS pathnames
12701 mod2fname(pTHX_ CV *cv)
12704 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
12705 workbuff[NAM$C_MAXRSS*1 + 1];
12706 int total_namelen = 3, counter, num_entries;
12707 /* ODS-5 ups this, but we want to be consistent, so... */
12708 int max_name_len = 39;
12709 AV *in_array = (AV *)SvRV(ST(0));
12711 num_entries = av_len(in_array);
12713 /* All the names start with PL_. */
12714 strcpy(ultimate_name, "PL_");
12716 /* Clean up our working buffer */
12717 Zero(work_name, sizeof(work_name), char);
12719 /* Run through the entries and build up a working name */
12720 for(counter = 0; counter <= num_entries; counter++) {
12721 /* If it's not the first name then tack on a __ */
12723 strcat(work_name, "__");
12725 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
12728 /* Check to see if we actually have to bother...*/
12729 if (strlen(work_name) + 3 <= max_name_len) {
12730 strcat(ultimate_name, work_name);
12732 /* It's too darned big, so we need to go strip. We use the same */
12733 /* algorithm as xsubpp does. First, strip out doubled __ */
12734 char *source, *dest, last;
12737 for (source = work_name; *source; source++) {
12738 if (last == *source && last == '_') {
12744 /* Go put it back */
12745 strcpy(work_name, workbuff);
12746 /* Is it still too big? */
12747 if (strlen(work_name) + 3 > max_name_len) {
12748 /* Strip duplicate letters */
12751 for (source = work_name; *source; source++) {
12752 if (last == toupper(*source)) {
12756 last = toupper(*source);
12758 strcpy(work_name, workbuff);
12761 /* Is it *still* too big? */
12762 if (strlen(work_name) + 3 > max_name_len) {
12763 /* Too bad, we truncate */
12764 work_name[max_name_len - 2] = 0;
12766 strcat(ultimate_name, work_name);
12769 /* Okay, return it */
12770 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
12775 hushexit_fromperl(pTHX_ CV *cv)
12780 VMSISH_HUSHED = SvTRUE(ST(0));
12782 ST(0) = boolSV(VMSISH_HUSHED);
12788 Perl_vms_start_glob
12789 (pTHX_ SV *tmpglob,
12793 struct vs_str_st *rslt;
12797 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
12800 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12801 struct dsc$descriptor_vs rsdsc;
12802 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
12803 unsigned long hasver = 0, isunix = 0;
12804 unsigned long int lff_flags = 0;
12807 if (!SvOK(tmpglob)) {
12808 SETERRNO(ENOENT,RMS$_FNF);
12812 #ifdef VMS_LONGNAME_SUPPORT
12813 lff_flags = LIB$M_FIL_LONG_NAMES;
12815 /* The Newx macro will not allow me to assign a smaller array
12816 * to the rslt pointer, so we will assign it to the begin char pointer
12817 * and then copy the value into the rslt pointer.
12819 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
12820 rslt = (struct vs_str_st *)begin;
12822 rstr = &rslt->str[0];
12823 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
12824 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
12825 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
12826 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
12828 Newx(vmsspec, VMS_MAXRSS, char);
12830 /* We could find out if there's an explicit dev/dir or version
12831 by peeking into lib$find_file's internal context at
12832 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
12833 but that's unsupported, so I don't want to do it now and
12834 have it bite someone in the future. */
12835 /* Fix-me: vms_split_path() is the only way to do this, the
12836 existing method will fail with many legal EFS or UNIX specifications
12839 cp = SvPV(tmpglob,i);
12842 if (cp[i] == ';') hasver = 1;
12843 if (cp[i] == '.') {
12844 if (sts) hasver = 1;
12847 if (cp[i] == '/') {
12848 hasdir = isunix = 1;
12851 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
12856 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
12860 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
12861 if (!stat_sts && S_ISDIR(st.st_mode)) {
12862 wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL);
12863 ok = (wilddsc.dsc$a_pointer != NULL);
12864 /* maybe passed 'foo' rather than '[.foo]', thus not detected above */
12868 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
12869 ok = (wilddsc.dsc$a_pointer != NULL);
12872 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
12874 /* If not extended character set, replace ? with % */
12875 /* With extended character set, ? is a wildcard single character */
12876 if (!decc_efs_case_preserve) {
12877 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++)
12878 if (*cp == '?') *cp = '%';
12881 while (ok && $VMS_STATUS_SUCCESS(sts)) {
12882 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
12883 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
12885 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
12886 &dfltdsc,NULL,&rms_sts,&lff_flags);
12887 if (!$VMS_STATUS_SUCCESS(sts))
12892 /* with varying string, 1st word of buffer contains result length */
12893 rstr[rslt->length] = '\0';
12895 /* Find where all the components are */
12896 v_sts = vms_split_path
12911 /* If no version on input, truncate the version on output */
12912 if (!hasver && (vs_len > 0)) {
12916 /* No version & a null extension on UNIX handling */
12917 if (isunix && (e_len == 1) && decc_readdir_dropdotnotype) {
12923 if (!decc_efs_case_preserve) {
12924 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
12928 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
12932 /* Start with the name */
12935 strcat(begin,"\n");
12936 ok = (PerlIO_puts(tmpfp,begin) != EOF);
12938 if (cxt) (void)lib$find_file_end(&cxt);
12941 /* Be POSIXish: return the input pattern when no matches */
12942 strcpy(rstr,SvPVX(tmpglob));
12944 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
12947 if (ok && sts != RMS$_NMF &&
12948 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
12951 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
12953 PerlIO_close(tmpfp);
12957 PerlIO_rewind(tmpfp);
12958 IoTYPE(io) = IoTYPE_RDONLY;
12959 IoIFP(io) = fp = tmpfp;
12960 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
12970 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
12974 unixrealpath_fromperl(pTHX_ CV *cv)
12977 char *fspec, *rslt_spec, *rslt;
12980 if (!items || items != 1)
12981 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
12983 fspec = SvPV(ST(0),n_a);
12984 if (!fspec || !*fspec) XSRETURN_UNDEF;
12986 Newx(rslt_spec, VMS_MAXRSS + 1, char);
12987 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
12989 ST(0) = sv_newmortal();
12991 sv_usepvn(ST(0),rslt,strlen(rslt));
12993 Safefree(rslt_spec);
12998 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13002 vmsrealpath_fromperl(pTHX_ CV *cv)
13005 char *fspec, *rslt_spec, *rslt;
13008 if (!items || items != 1)
13009 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13011 fspec = SvPV(ST(0),n_a);
13012 if (!fspec || !*fspec) XSRETURN_UNDEF;
13014 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13015 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13017 ST(0) = sv_newmortal();
13019 sv_usepvn(ST(0),rslt,strlen(rslt));
13021 Safefree(rslt_spec);
13027 * A thin wrapper around decc$symlink to make sure we follow the
13028 * standard and do not create a symlink with a zero-length name.
13030 * Also in ODS-2 mode, existing tests assume that the link target
13031 * will be converted to UNIX format.
13033 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13034 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13035 if (!link_name || !*link_name) {
13036 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13040 if (decc_efs_charset) {
13041 return symlink(contents, link_name);
13046 /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13047 /* because in order to work, the symlink target must be in UNIX format */
13049 /* As symbolic links can hold things other than files, we will only do */
13050 /* the conversion in in ODS-2 mode */
13052 Newx(utarget, VMS_MAXRSS + 1, char);
13053 if (do_tounixspec(contents, utarget, 0, NULL) == NULL) {
13055 /* This should not fail, as an untranslatable filename */
13056 /* should be passed through */
13057 utarget = (char *)contents;
13059 sts = symlink(utarget, link_name);
13067 #endif /* HAS_SYMLINK */
13069 int do_vms_case_tolerant(void);
13072 case_tolerant_process_fromperl(pTHX_ CV *cv)
13075 ST(0) = boolSV(do_vms_case_tolerant());
13079 #ifdef USE_ITHREADS
13082 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13083 struct interp_intern *dst)
13085 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13087 memcpy(dst,src,sizeof(struct interp_intern));
13093 Perl_sys_intern_clear(pTHX)
13098 Perl_sys_intern_init(pTHX)
13100 unsigned int ix = RAND_MAX;
13105 MY_POSIX_EXIT = vms_posix_exit;
13108 MY_INV_RAND_MAX = 1./x;
13112 init_os_extras(void)
13115 char* file = __FILE__;
13116 if (decc_disable_to_vms_logname_translation) {
13117 no_translate_barewords = TRUE;
13119 no_translate_barewords = FALSE;
13122 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13123 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13124 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13125 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13126 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13127 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13128 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13129 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13130 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13131 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13132 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13133 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13134 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13135 newXSproto("VMS::Filespec::case_tolerant_process",
13136 case_tolerant_process_fromperl,file,"");
13138 store_pipelocs(aTHX); /* will redo any earlier attempts */
13143 #if __CRTL_VER == 80200000
13144 /* This missed getting in to the DECC SDK for 8.2 */
13145 char *realpath(const char *file_name, char * resolved_name, ...);
13148 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13149 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13150 * The perl fallback routine to provide realpath() is not as efficient
13154 /* Hack, use old stat() as fastest way of getting ino_t and device */
13155 int decc$stat(const char *name, void * statbuf);
13158 /* Realpath is fragile. In 8.3 it does not work if the feature
13159 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13160 * links are implemented in RMS, not the CRTL. It also can fail if the
13161 * user does not have read/execute access to some of the directories.
13162 * So in order for Do What I Mean mode to work, if realpath() fails,
13163 * fall back to looking up the filename by the device name and FID.
13166 int vms_fid_to_name(char * outname, int outlen, const char * name)
13170 unsigned short st_ino[3];
13171 unsigned short padw;
13172 unsigned long padl[30]; /* plenty of room */
13175 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13176 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13178 sts = decc$stat(name, &statbuf);
13181 dvidsc.dsc$a_pointer=statbuf.st_dev;
13182 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13184 specdsc.dsc$a_pointer = outname;
13185 specdsc.dsc$w_length = outlen-1;
13187 sts = lib$fid_to_name
13188 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13189 if ($VMS_STATUS_SUCCESS(sts)) {
13190 outname[specdsc.dsc$w_length] = 0;
13200 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13203 char * rslt = NULL;
13206 if (decc_posix_compliant_pathnames > 0 ) {
13207 /* realpath currently only works if posix compliant pathnames are
13208 * enabled. It may start working when they are not, but in that
13209 * case we still want the fallback behavior for backwards compatibility
13211 rslt = realpath(filespec, outbuf);
13215 if (rslt == NULL) {
13217 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13218 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13221 /* Fall back to fid_to_name */
13223 Newx(vms_spec, VMS_MAXRSS + 1, char);
13225 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
13229 /* Now need to trim the version off */
13230 sts = vms_split_path
13250 /* Trim off the version */
13251 int file_len = v_len + r_len + d_len + n_len + e_len;
13252 vms_spec[file_len] = 0;
13254 /* The result is expected to be in UNIX format */
13255 rslt = do_tounixspec(vms_spec, outbuf, 0, utf8_fl);
13257 /* Downcase if input had any lower case letters and
13258 * case preservation is not in effect.
13260 if (!decc_efs_case_preserve) {
13261 for (cp = filespec; *cp; cp++)
13262 if (islower(*cp)) { haslower = 1; break; }
13264 if (haslower) __mystrtolower(rslt);
13269 /* Now for some hacks to deal with backwards and forward */
13271 if (!decc_efs_charset) {
13273 /* 1. ODS-2 mode wants to do a syntax only translation */
13274 rslt = do_rmsexpand(filespec, outbuf,
13275 0, NULL, 0, NULL, utf8_fl);
13278 if (decc_filename_unix_report) {
13280 char * vms_dir_name;
13283 /* 2. ODS-5 / UNIX report mode should return a failure */
13284 /* if the parent directory also does not exist */
13285 /* Otherwise, get the real path for the parent */
13286 /* and add the child to it.
13288 /* basename / dirname only available for VMS 7.0+ */
13289 /* So we may need to implement them as common routines */
13291 Newx(dir_name, VMS_MAXRSS + 1, char);
13292 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
13293 dir_name[0] = '\0';
13296 /* First try a VMS parse */
13297 sts = vms_split_path
13315 int dir_len = v_len + r_len + d_len + n_len;
13317 strncpy(dir_name, filespec, dir_len);
13318 dir_name[dir_len] = '\0';
13319 file_name = (char *)&filespec[dir_len + 1];
13322 /* This must be UNIX */
13325 tchar = strrchr(filespec, '/');
13327 if (tchar != NULL) {
13328 int dir_len = tchar - filespec;
13329 strncpy(dir_name, filespec, dir_len);
13330 dir_name[dir_len] = '\0';
13331 file_name = (char *) &filespec[dir_len + 1];
13335 /* Dir name is defaulted */
13336 if (dir_name[0] == 0) {
13338 dir_name[1] = '\0';
13341 /* Need realpath for the directory */
13342 sts = vms_fid_to_name(vms_dir_name,
13347 /* Now need to pathify it.
13348 char *tdir = do_pathify_dirspec(vms_dir_name,
13351 /* And now add the original filespec to it */
13352 if (file_name != NULL) {
13353 strcat(outbuf, file_name);
13357 Safefree(vms_dir_name);
13358 Safefree(dir_name);
13362 Safefree(vms_spec);
13368 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
13371 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13372 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13375 /* Fall back to fid_to_name */
13377 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
13384 /* Now need to trim the version off */
13385 sts = vms_split_path
13405 /* Trim off the version */
13406 int file_len = v_len + r_len + d_len + n_len + e_len;
13407 outbuf[file_len] = 0;
13409 /* Downcase if input had any lower case letters and
13410 * case preservation is not in effect.
13412 if (!decc_efs_case_preserve) {
13413 for (cp = filespec; *cp; cp++)
13414 if (islower(*cp)) { haslower = 1; break; }
13416 if (haslower) __mystrtolower(outbuf);
13425 /* External entry points */
13426 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13427 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
13429 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
13430 { return do_vms_realname(filespec, outbuf, utf8_fl); }
13432 /* case_tolerant */
13434 /*{{{int do_vms_case_tolerant(void)*/
13435 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
13436 * controlled by a process setting.
13438 int do_vms_case_tolerant(void)
13440 return vms_process_case_tolerant;
13443 /* External entry points */
13444 #if __CRTL_VER >= 70301000 && !defined(__VAX)
13445 int Perl_vms_case_tolerant(void)
13446 { return do_vms_case_tolerant(); }
13448 int Perl_vms_case_tolerant(void)
13449 { return vms_process_case_tolerant; }
13453 /* Start of DECC RTL Feature handling */
13455 static int sys_trnlnm
13456 (const char * logname,
13460 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
13461 const unsigned long attr = LNM$M_CASE_BLIND;
13462 struct dsc$descriptor_s name_dsc;
13464 unsigned short result;
13465 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
13468 name_dsc.dsc$w_length = strlen(logname);
13469 name_dsc.dsc$a_pointer = (char *)logname;
13470 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13471 name_dsc.dsc$b_class = DSC$K_CLASS_S;
13473 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
13475 if ($VMS_STATUS_SUCCESS(status)) {
13477 /* Null terminate and return the string */
13478 /*--------------------------------------*/
13485 static int sys_crelnm
13486 (const char * logname,
13487 const char * value)
13490 const char * proc_table = "LNM$PROCESS_TABLE";
13491 struct dsc$descriptor_s proc_table_dsc;
13492 struct dsc$descriptor_s logname_dsc;
13493 struct itmlst_3 item_list[2];
13495 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
13496 proc_table_dsc.dsc$w_length = strlen(proc_table);
13497 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13498 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
13500 logname_dsc.dsc$a_pointer = (char *) logname;
13501 logname_dsc.dsc$w_length = strlen(logname);
13502 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
13503 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
13505 item_list[0].buflen = strlen(value);
13506 item_list[0].itmcode = LNM$_STRING;
13507 item_list[0].bufadr = (char *)value;
13508 item_list[0].retlen = NULL;
13510 item_list[1].buflen = 0;
13511 item_list[1].itmcode = 0;
13513 ret_val = sys$crelnm
13515 (const struct dsc$descriptor_s *)&proc_table_dsc,
13516 (const struct dsc$descriptor_s *)&logname_dsc,
13518 (const struct item_list_3 *) item_list);
13523 /* C RTL Feature settings */
13525 static int set_features
13526 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
13527 int (* cli_routine)(void), /* Not documented */
13528 void *image_info) /* Not documented */
13535 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
13536 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
13537 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
13538 unsigned long case_perm;
13539 unsigned long case_image;
13542 /* Allow an exception to bring Perl into the VMS debugger */
13543 vms_debug_on_exception = 0;
13544 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
13545 if ($VMS_STATUS_SUCCESS(status)) {
13546 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13547 vms_debug_on_exception = 1;
13549 vms_debug_on_exception = 0;
13552 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
13553 vms_vtf7_filenames = 0;
13554 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
13555 if ($VMS_STATUS_SUCCESS(status)) {
13556 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13557 vms_vtf7_filenames = 1;
13559 vms_vtf7_filenames = 0;
13563 /* unlink all versions on unlink() or rename() */
13564 vms_unlink_all_versions = 0;
13565 status = sys_trnlnm
13566 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
13567 if ($VMS_STATUS_SUCCESS(status)) {
13568 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13569 vms_unlink_all_versions = 1;
13571 vms_unlink_all_versions = 0;
13574 /* Dectect running under GNV Bash or other UNIX like shell */
13575 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13576 gnv_unix_shell = 0;
13577 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
13578 if ($VMS_STATUS_SUCCESS(status)) {
13579 gnv_unix_shell = 1;
13580 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
13581 set_feature_default("DECC$EFS_CHARSET", 1);
13582 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
13583 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
13584 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
13585 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
13586 vms_unlink_all_versions = 1;
13587 vms_posix_exit = 1;
13591 /* hacks to see if known bugs are still present for testing */
13593 /* Readdir is returning filenames in VMS syntax always */
13594 decc_bug_readdir_efs1 = 1;
13595 status = sys_trnlnm("DECC_BUG_READDIR_EFS1", val_str, sizeof(val_str));
13596 if ($VMS_STATUS_SUCCESS(status)) {
13597 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13598 decc_bug_readdir_efs1 = 1;
13600 decc_bug_readdir_efs1 = 0;
13603 /* PCP mode requires creating /dev/null special device file */
13604 decc_bug_devnull = 0;
13605 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
13606 if ($VMS_STATUS_SUCCESS(status)) {
13607 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13608 decc_bug_devnull = 1;
13610 decc_bug_devnull = 0;
13613 /* fgetname returning a VMS name in UNIX mode */
13614 decc_bug_fgetname = 1;
13615 status = sys_trnlnm("DECC_BUG_FGETNAME", val_str, sizeof(val_str));
13616 if ($VMS_STATUS_SUCCESS(status)) {
13617 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13618 decc_bug_fgetname = 1;
13620 decc_bug_fgetname = 0;
13623 /* UNIX directory names with no paths are broken in a lot of places */
13624 decc_dir_barename = 1;
13625 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
13626 if ($VMS_STATUS_SUCCESS(status)) {
13627 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13628 decc_dir_barename = 1;
13630 decc_dir_barename = 0;
13633 #if __CRTL_VER >= 70300000 && !defined(__VAX)
13634 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
13636 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
13637 if (decc_disable_to_vms_logname_translation < 0)
13638 decc_disable_to_vms_logname_translation = 0;
13641 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
13643 decc_efs_case_preserve = decc$feature_get_value(s, 1);
13644 if (decc_efs_case_preserve < 0)
13645 decc_efs_case_preserve = 0;
13648 s = decc$feature_get_index("DECC$EFS_CHARSET");
13650 decc_efs_charset = decc$feature_get_value(s, 1);
13651 if (decc_efs_charset < 0)
13652 decc_efs_charset = 0;
13655 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
13657 decc_filename_unix_report = decc$feature_get_value(s, 1);
13658 if (decc_filename_unix_report > 0) {
13659 decc_filename_unix_report = 1;
13660 vms_posix_exit = 1;
13663 decc_filename_unix_report = 0;
13666 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
13668 decc_filename_unix_only = decc$feature_get_value(s, 1);
13669 if (decc_filename_unix_only > 0) {
13670 decc_filename_unix_only = 1;
13673 decc_filename_unix_only = 0;
13677 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
13679 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
13680 if (decc_filename_unix_no_version < 0)
13681 decc_filename_unix_no_version = 0;
13684 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
13686 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
13687 if (decc_readdir_dropdotnotype < 0)
13688 decc_readdir_dropdotnotype = 0;
13691 status = sys_trnlnm("SYS$POSIX_ROOT", val_str, sizeof(val_str));
13692 if ($VMS_STATUS_SUCCESS(status)) {
13693 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
13695 dflt = decc$feature_get_value(s, 4);
13697 decc_disable_posix_root = decc$feature_get_value(s, 1);
13698 if (decc_disable_posix_root <= 0) {
13699 decc$feature_set_value(s, 1, 1);
13700 decc_disable_posix_root = 1;
13704 /* Traditionally Perl assumes this is off */
13705 decc_disable_posix_root = 1;
13706 decc$feature_set_value(s, 1, 1);
13711 #if __CRTL_VER >= 80200000
13712 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
13714 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
13715 if (decc_posix_compliant_pathnames < 0)
13716 decc_posix_compliant_pathnames = 0;
13717 if (decc_posix_compliant_pathnames > 4)
13718 decc_posix_compliant_pathnames = 0;
13723 status = sys_trnlnm
13724 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
13725 if ($VMS_STATUS_SUCCESS(status)) {
13726 val_str[0] = _toupper(val_str[0]);
13727 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13728 decc_disable_to_vms_logname_translation = 1;
13733 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
13734 if ($VMS_STATUS_SUCCESS(status)) {
13735 val_str[0] = _toupper(val_str[0]);
13736 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13737 decc_efs_case_preserve = 1;
13742 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
13743 if ($VMS_STATUS_SUCCESS(status)) {
13744 val_str[0] = _toupper(val_str[0]);
13745 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13746 decc_filename_unix_report = 1;
13749 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
13750 if ($VMS_STATUS_SUCCESS(status)) {
13751 val_str[0] = _toupper(val_str[0]);
13752 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13753 decc_filename_unix_only = 1;
13754 decc_filename_unix_report = 1;
13757 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
13758 if ($VMS_STATUS_SUCCESS(status)) {
13759 val_str[0] = _toupper(val_str[0]);
13760 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13761 decc_filename_unix_no_version = 1;
13764 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
13765 if ($VMS_STATUS_SUCCESS(status)) {
13766 val_str[0] = _toupper(val_str[0]);
13767 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
13768 decc_readdir_dropdotnotype = 1;
13773 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
13775 /* Report true case tolerance */
13776 /*----------------------------*/
13777 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
13778 if (!$VMS_STATUS_SUCCESS(status))
13779 case_perm = PPROP$K_CASE_BLIND;
13780 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
13781 if (!$VMS_STATUS_SUCCESS(status))
13782 case_image = PPROP$K_CASE_BLIND;
13783 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
13784 (case_image == PPROP$K_CASE_SENSITIVE))
13785 vms_process_case_tolerant = 0;
13789 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
13790 /* for strict backward compatibilty */
13791 status = sys_trnlnm
13792 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
13793 if ($VMS_STATUS_SUCCESS(status)) {
13794 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
13795 vms_posix_exit = 1;
13797 vms_posix_exit = 0;
13801 /* CRTL can be initialized past this point, but not before. */
13802 /* DECC$CRTL_INIT(); */
13809 #pragma extern_model save
13810 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
13811 const __align (LONGWORD) int spare[8] = {0};
13813 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
13814 #if __DECC_VER >= 60560002
13815 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
13817 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
13819 #endif /* __DECC */
13821 const long vms_cc_features = (const long)set_features;
13824 ** Force a reference to LIB$INITIALIZE to ensure it
13825 ** exists in the image.
13827 int lib$initialize(void);
13829 #pragma extern_model strict_refdef
13831 int lib_init_ref = (int) lib$initialize;
13834 #pragma extern_model restore