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 #if !defined(__VAX) && __CRTL_VER >= 80200000
230 #define lstat(_x, _y) stat(_x, _y)
233 /* Routine to create a decterm for use with the Perl debugger */
234 /* No headers, this information was found in the Programming Concepts Manual */
236 static int (*decw_term_port)
237 (const struct dsc$descriptor_s * display,
238 const struct dsc$descriptor_s * setup_file,
239 const struct dsc$descriptor_s * customization,
240 struct dsc$descriptor_s * result_device_name,
241 unsigned short * result_device_name_length,
244 void * char_change_buffer) = 0;
246 /* gcc's header files don't #define direct access macros
247 * corresponding to VAXC's variant structs */
249 # define uic$v_format uic$r_uic_form.uic$v_format
250 # define uic$v_group uic$r_uic_form.uic$v_group
251 # define uic$v_member uic$r_uic_form.uic$v_member
252 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
253 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
254 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
255 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
258 #if defined(NEED_AN_H_ERRNO)
263 #pragma message disable pragma
264 #pragma member_alignment save
265 #pragma nomember_alignment longword
267 #pragma message disable misalgndmem
270 unsigned short int buflen;
271 unsigned short int itmcode;
273 unsigned short int *retlen;
276 struct filescan_itmlst_2 {
277 unsigned short length;
278 unsigned short itmcode;
283 unsigned short length;
288 #pragma message restore
289 #pragma member_alignment restore
292 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
293 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
294 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
295 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
296 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
297 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
298 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
299 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
300 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
301 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
302 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
303 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
305 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
306 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
307 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
308 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
310 static char * int_rmsexpand_vms(
311 const char * filespec, char * outbuf, unsigned opts);
312 static char * int_rmsexpand_tovms(
313 const char * filespec, char * outbuf, unsigned opts);
314 static char *int_tovmsspec
315 (const char *path, char *buf, int dir_flag, int * utf8_flag);
316 static char * int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl);
317 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
318 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl);
320 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
321 #define PERL_LNM_MAX_ALLOWED_INDEX 127
323 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
324 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
327 #define PERL_LNM_MAX_ITER 10
329 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
330 #if __CRTL_VER >= 70302000 && !defined(__VAX)
331 #define MAX_DCL_SYMBOL (8192)
332 #define MAX_DCL_LINE_LENGTH (4096 - 4)
334 #define MAX_DCL_SYMBOL (1024)
335 #define MAX_DCL_LINE_LENGTH (1024 - 4)
338 static char *__mystrtolower(char *str)
340 if (str) for (; *str; ++str) *str= tolower(*str);
344 static struct dsc$descriptor_s fildevdsc =
345 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
346 static struct dsc$descriptor_s crtlenvdsc =
347 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
348 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
349 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
350 static struct dsc$descriptor_s **env_tables = defenv;
351 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
353 /* True if we shouldn't treat barewords as logicals during directory */
355 static int no_translate_barewords;
358 static int tz_updated = 1;
361 /* DECC Features that may need to affect how Perl interprets
362 * displays filename information
364 static int decc_disable_to_vms_logname_translation = 1;
365 static int decc_disable_posix_root = 1;
366 int decc_efs_case_preserve = 0;
367 static int decc_efs_charset = 0;
368 static int decc_efs_charset_index = -1;
369 static int decc_filename_unix_no_version = 0;
370 static int decc_filename_unix_only = 0;
371 int decc_filename_unix_report = 0;
372 int decc_posix_compliant_pathnames = 0;
373 int decc_readdir_dropdotnotype = 0;
374 static int vms_process_case_tolerant = 1;
375 int vms_vtf7_filenames = 0;
376 int gnv_unix_shell = 0;
377 static int vms_unlink_all_versions = 0;
378 static int vms_posix_exit = 0;
380 /* bug workarounds if needed */
381 int decc_bug_devnull = 1;
382 int decc_dir_barename = 0;
383 int vms_bug_stat_filename = 0;
385 static int vms_debug_on_exception = 0;
386 static int vms_debug_fileify = 0;
388 /* Simple logical name translation */
389 static int simple_trnlnm
390 (const char * logname,
394 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
395 const unsigned long attr = LNM$M_CASE_BLIND;
396 struct dsc$descriptor_s name_dsc;
398 unsigned short result;
399 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
402 name_dsc.dsc$w_length = strlen(logname);
403 name_dsc.dsc$a_pointer = (char *)logname;
404 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
405 name_dsc.dsc$b_class = DSC$K_CLASS_S;
407 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
409 if ($VMS_STATUS_SUCCESS(status)) {
411 /* Null terminate and return the string */
412 /*--------------------------------------*/
421 /* Is this a UNIX file specification?
422 * No longer a simple check with EFS file specs
423 * For now, not a full check, but need to
424 * handle POSIX ^UP^ specifications
425 * Fixing to handle ^/ cases would require
426 * changes to many other conversion routines.
429 static int is_unix_filespec(const char *path)
435 if (strncmp(path,"\"^UP^",5) != 0) {
436 pch1 = strchr(path, '/');
441 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
442 if (decc_filename_unix_report || decc_filename_unix_only) {
443 if (strcmp(path,".") == 0)
451 /* This routine converts a UCS-2 character to be VTF-7 encoded.
454 static void ucs2_to_vtf7
456 unsigned long ucs2_char,
459 unsigned char * ucs_ptr;
462 ucs_ptr = (unsigned char *)&ucs2_char;
466 hex = (ucs_ptr[1] >> 4) & 0xf;
468 outspec[2] = hex + '0';
470 outspec[2] = (hex - 9) + 'A';
471 hex = ucs_ptr[1] & 0xF;
473 outspec[3] = hex + '0';
475 outspec[3] = (hex - 9) + 'A';
477 hex = (ucs_ptr[0] >> 4) & 0xf;
479 outspec[4] = hex + '0';
481 outspec[4] = (hex - 9) + 'A';
482 hex = ucs_ptr[1] & 0xF;
484 outspec[5] = hex + '0';
486 outspec[5] = (hex - 9) + 'A';
492 /* This handles the conversion of a UNIX extended character set to a ^
493 * escaped VMS character.
494 * in a UNIX file specification.
496 * The output count variable contains the number of characters added
497 * to the output string.
499 * The return value is the number of characters read from the input string
501 static int copy_expand_unix_filename_escape
502 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
510 utf8_flag = *utf8_fl;
514 if (*inspec >= 0x80) {
515 if (utf8_fl && vms_vtf7_filenames) {
516 unsigned long ucs_char;
520 if ((*inspec & 0xE0) == 0xC0) {
522 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
523 if (ucs_char >= 0x80) {
524 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
527 } else if ((*inspec & 0xF0) == 0xE0) {
529 ucs_char = ((inspec[0] & 0xF) << 12) +
530 ((inspec[1] & 0x3f) << 6) +
532 if (ucs_char >= 0x800) {
533 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
537 #if 0 /* I do not see longer sequences supported by OpenVMS */
538 /* Maybe some one can fix this later */
539 } else if ((*inspec & 0xF8) == 0xF0) {
542 } else if ((*inspec & 0xFC) == 0xF8) {
545 } else if ((*inspec & 0xFE) == 0xFC) {
552 /* High bit set, but not a Unicode character! */
554 /* Non printing DECMCS or ISO Latin-1 character? */
555 if (*inspec <= 0x9F) {
559 hex = (*inspec >> 4) & 0xF;
561 outspec[1] = hex + '0';
563 outspec[1] = (hex - 9) + 'A';
567 outspec[2] = hex + '0';
569 outspec[2] = (hex - 9) + 'A';
573 } else if (*inspec == 0xA0) {
579 } else if (*inspec == 0xFF) {
591 /* Is this a macro that needs to be passed through?
592 * Macros start with $( and an alpha character, followed
593 * by a string of alpha numeric characters ending with a )
594 * If this does not match, then encode it as ODS-5.
596 if ((inspec[0] == '$') && (inspec[1] == '(')) {
599 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
601 outspec[0] = inspec[0];
602 outspec[1] = inspec[1];
603 outspec[2] = inspec[2];
605 while(isalnum(inspec[tcnt]) ||
606 (inspec[2] == '.') || (inspec[2] == '_')) {
607 outspec[tcnt] = inspec[tcnt];
610 if (inspec[tcnt] == ')') {
611 outspec[tcnt] = inspec[tcnt];
628 if (decc_efs_charset == 0)
655 /* Don't escape again if following character is
656 * already something we escape.
658 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
664 /* But otherwise fall through and escape it. */
666 /* Assume that this is to be escaped */
668 outspec[1] = *inspec;
672 case ' ': /* space */
673 /* Assume that this is to be escaped */
688 /* This handles the expansion of a '^' prefix to the proper character
689 * in a UNIX file specification.
691 * The output count variable contains the number of characters added
692 * to the output string.
694 * The return value is the number of characters read from the input
697 static int copy_expand_vms_filename_escape
698 (char *outspec, const char *inspec, int *output_cnt)
705 if (*inspec == '^') {
708 /* Spaces and non-trailing dots should just be passed through,
709 * but eat the escape character.
716 case '_': /* space */
722 /* Hmm. Better leave the escape escaped. */
728 case 'U': /* Unicode - FIX-ME this is wrong. */
731 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
734 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
735 outspec[0] == c1 & 0xff;
736 outspec[1] == c2 & 0xff;
743 /* Error - do best we can to continue */
753 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
757 scnt = sscanf(inspec, "%2x", &c1);
758 outspec[0] = c1 & 0xff;
782 (const struct dsc$descriptor_s * srcstr,
783 struct filescan_itmlst_2 * valuelist,
784 unsigned long * fldflags,
785 struct dsc$descriptor_s *auxout,
786 unsigned short * retlen);
789 /* vms_split_path - Verify that the input file specification is a
790 * VMS format file specification, and provide pointers to the components of
791 * it. With EFS format filenames, this is virtually the only way to
792 * parse a VMS path specification into components.
794 * If the sum of the components do not add up to the length of the
795 * string, then the passed file specification is probably a UNIX style
798 static int vms_split_path
813 struct dsc$descriptor path_desc;
817 struct filescan_itmlst_2 item_list[9];
818 const int filespec = 0;
819 const int nodespec = 1;
820 const int devspec = 2;
821 const int rootspec = 3;
822 const int dirspec = 4;
823 const int namespec = 5;
824 const int typespec = 6;
825 const int verspec = 7;
827 /* Assume the worst for an easy exit */
842 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
843 path_desc.dsc$w_length = strlen(path);
844 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
845 path_desc.dsc$b_class = DSC$K_CLASS_S;
847 /* Get the total length, if it is shorter than the string passed
848 * then this was probably not a VMS formatted file specification
850 item_list[filespec].itmcode = FSCN$_FILESPEC;
851 item_list[filespec].length = 0;
852 item_list[filespec].component = NULL;
854 /* If the node is present, then it gets considered as part of the
855 * volume name to hopefully make things simple.
857 item_list[nodespec].itmcode = FSCN$_NODE;
858 item_list[nodespec].length = 0;
859 item_list[nodespec].component = NULL;
861 item_list[devspec].itmcode = FSCN$_DEVICE;
862 item_list[devspec].length = 0;
863 item_list[devspec].component = NULL;
865 /* root is a special case, adding it to either the directory or
866 * the device components will probalby complicate things for the
867 * callers of this routine, so leave it separate.
869 item_list[rootspec].itmcode = FSCN$_ROOT;
870 item_list[rootspec].length = 0;
871 item_list[rootspec].component = NULL;
873 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
874 item_list[dirspec].length = 0;
875 item_list[dirspec].component = NULL;
877 item_list[namespec].itmcode = FSCN$_NAME;
878 item_list[namespec].length = 0;
879 item_list[namespec].component = NULL;
881 item_list[typespec].itmcode = FSCN$_TYPE;
882 item_list[typespec].length = 0;
883 item_list[typespec].component = NULL;
885 item_list[verspec].itmcode = FSCN$_VERSION;
886 item_list[verspec].length = 0;
887 item_list[verspec].component = NULL;
889 item_list[8].itmcode = 0;
890 item_list[8].length = 0;
891 item_list[8].component = NULL;
893 status = sys$filescan
894 ((const struct dsc$descriptor_s *)&path_desc, item_list,
896 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
898 /* If we parsed it successfully these two lengths should be the same */
899 if (path_desc.dsc$w_length != item_list[filespec].length)
902 /* If we got here, then it is a VMS file specification */
905 /* set the volume name */
906 if (item_list[nodespec].length > 0) {
907 *volume = item_list[nodespec].component;
908 *vol_len = item_list[nodespec].length + item_list[devspec].length;
911 *volume = item_list[devspec].component;
912 *vol_len = item_list[devspec].length;
915 *root = item_list[rootspec].component;
916 *root_len = item_list[rootspec].length;
918 *dir = item_list[dirspec].component;
919 *dir_len = item_list[dirspec].length;
921 /* Now fun with versions and EFS file specifications
922 * The parser can not tell the difference when a "." is a version
923 * delimiter or a part of the file specification.
925 if ((decc_efs_charset) &&
926 (item_list[verspec].length > 0) &&
927 (item_list[verspec].component[0] == '.')) {
928 *name = item_list[namespec].component;
929 *name_len = item_list[namespec].length + item_list[typespec].length;
930 *ext = item_list[verspec].component;
931 *ext_len = item_list[verspec].length;
936 *name = item_list[namespec].component;
937 *name_len = item_list[namespec].length;
938 *ext = item_list[typespec].component;
939 *ext_len = item_list[typespec].length;
940 *version = item_list[verspec].component;
941 *ver_len = item_list[verspec].length;
946 /* Routine to determine if the file specification ends with .dir */
947 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
949 /* e_len must be 4, and version must be <= 2 characters */
950 if (e_len != 4 || vs_len > 2)
953 /* If a version number is present, it needs to be one */
954 if ((vs_len == 2) && (vs_spec[1] != '1'))
957 /* Look for the DIR on the extension */
958 if (vms_process_case_tolerant) {
959 if ((toupper(e_spec[1]) == 'D') &&
960 (toupper(e_spec[2]) == 'I') &&
961 (toupper(e_spec[3]) == 'R')) {
965 /* Directory extensions are supposed to be in upper case only */
966 /* I would not be surprised if this rule can not be enforced */
967 /* if and when someone fully debugs the case sensitive mode */
968 if ((e_spec[1] == 'D') &&
969 (e_spec[2] == 'I') &&
970 (e_spec[3] == 'R')) {
979 * Routine to retrieve the maximum equivalence index for an input
980 * logical name. Some calls to this routine have no knowledge if
981 * the variable is a logical or not. So on error we return a max
984 /*{{{int my_maxidx(const char *lnm) */
986 my_maxidx(const char *lnm)
990 int attr = LNM$M_CASE_BLIND;
991 struct dsc$descriptor lnmdsc;
992 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
995 lnmdsc.dsc$w_length = strlen(lnm);
996 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
997 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
998 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
1000 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
1001 if ((status & 1) == 0)
1008 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
1010 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
1011 struct dsc$descriptor_s **tabvec, unsigned long int flags)
1014 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1015 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1016 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1018 unsigned char acmode;
1019 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1020 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1021 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1022 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1024 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1025 #if defined(PERL_IMPLICIT_CONTEXT)
1028 aTHX = PERL_GET_INTERP;
1034 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1035 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1037 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1038 *cp2 = _toupper(*cp1);
1039 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1040 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1044 lnmdsc.dsc$w_length = cp1 - lnm;
1045 lnmdsc.dsc$a_pointer = uplnm;
1046 uplnm[lnmdsc.dsc$w_length] = '\0';
1047 secure = flags & PERL__TRNENV_SECURE;
1048 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1049 if (!tabvec || !*tabvec) tabvec = env_tables;
1051 for (curtab = 0; tabvec[curtab]; curtab++) {
1052 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1053 if (!ivenv && !secure) {
1058 #if defined(PERL_IMPLICIT_CONTEXT)
1061 "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1064 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1067 retsts = SS$_NOLOGNAM;
1068 for (i = 0; environ[i]; i++) {
1069 if ((eq = strchr(environ[i],'=')) &&
1070 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1071 !strncmp(environ[i],uplnm,eq - environ[i])) {
1073 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1074 if (!eqvlen) continue;
1075 retsts = SS$_NORMAL;
1079 if (retsts != SS$_NOLOGNAM) break;
1082 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1083 !str$case_blind_compare(&tmpdsc,&clisym)) {
1084 if (!ivsym && !secure) {
1085 unsigned short int deflen = LNM$C_NAMLENGTH;
1086 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1087 /* dynamic dsc to accomodate possible long value */
1088 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1089 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1091 if (eqvlen > MAX_DCL_SYMBOL) {
1092 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1093 eqvlen = MAX_DCL_SYMBOL;
1094 /* Special hack--we might be called before the interpreter's */
1095 /* fully initialized, in which case either thr or PL_curcop */
1096 /* might be bogus. We have to check, since ckWARN needs them */
1097 /* both to be valid if running threaded */
1098 #if defined(PERL_IMPLICIT_CONTEXT)
1101 "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1104 if (ckWARN(WARN_MISC)) {
1105 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1108 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1110 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1111 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1112 if (retsts == LIB$_NOSUCHSYM) continue;
1117 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1118 midx = my_maxidx(lnm);
1119 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1120 lnmlst[1].bufadr = cp2;
1122 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1123 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1124 if (retsts == SS$_NOLOGNAM) break;
1125 /* PPFs have a prefix */
1128 *((int *)uplnm) == *((int *)"SYS$") &&
1130 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1131 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1132 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1133 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1134 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1135 memmove(eqv,eqv+4,eqvlen-4);
1141 if ((retsts == SS$_IVLOGNAM) ||
1142 (retsts == SS$_NOLOGNAM)) { continue; }
1145 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1146 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1147 if (retsts == SS$_NOLOGNAM) continue;
1150 eqvlen = strlen(eqv);
1154 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1155 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1156 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1157 retsts == SS$_NOLOGNAM) {
1158 set_errno(EINVAL); set_vaxc_errno(retsts);
1160 else _ckvmssts_noperl(retsts);
1162 } /* end of vmstrnenv */
1165 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1166 /* Define as a function so we can access statics. */
1167 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1171 #if defined(PERL_IMPLICIT_CONTEXT)
1174 #ifdef SECURE_INTERNAL_GETENV
1175 flags = (PL_curinterp ? PL_tainting : will_taint) ?
1176 PERL__TRNENV_SECURE : 0;
1179 return vmstrnenv(lnm, eqv, idx, fildev, flags);
1184 * Note: Uses Perl temp to store result so char * can be returned to
1185 * caller; this pointer will be invalidated at next Perl statement
1187 * We define this as a function rather than a macro in terms of my_getenv_len()
1188 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1191 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1193 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1196 static char *__my_getenv_eqv = NULL;
1197 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1198 unsigned long int idx = 0;
1199 int trnsuccess, success, secure, saverr, savvmserr;
1203 midx = my_maxidx(lnm) + 1;
1205 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1206 /* Set up a temporary buffer for the return value; Perl will
1207 * clean it up at the next statement transition */
1208 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1209 if (!tmpsv) return NULL;
1213 /* Assume no interpreter ==> single thread */
1214 if (__my_getenv_eqv != NULL) {
1215 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1218 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1220 eqv = __my_getenv_eqv;
1223 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1224 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1226 getcwd(eqv,LNM$C_NAMLENGTH);
1230 /* Get rid of "000000/ in rooted filespecs */
1233 zeros = strstr(eqv, "/000000/");
1234 if (zeros != NULL) {
1236 mlen = len - (zeros - eqv) - 7;
1237 memmove(zeros, &zeros[7], mlen);
1245 /* Impose security constraints only if tainting */
1247 /* Impose security constraints only if tainting */
1248 secure = PL_curinterp ? PL_tainting : will_taint;
1249 saverr = errno; savvmserr = vaxc$errno;
1256 #ifdef SECURE_INTERNAL_GETENV
1257 secure ? PERL__TRNENV_SECURE : 0
1263 /* For the getenv interface we combine all the equivalence names
1264 * of a search list logical into one value to acquire a maximum
1265 * value length of 255*128 (assuming %ENV is using logicals).
1267 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1269 /* If the name contains a semicolon-delimited index, parse it
1270 * off and make sure we only retrieve the equivalence name for
1272 if ((cp2 = strchr(lnm,';')) != NULL) {
1274 uplnm[cp2-lnm] = '\0';
1275 idx = strtoul(cp2+1,NULL,0);
1277 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1280 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1282 /* Discard NOLOGNAM on internal calls since we're often looking
1283 * for an optional name, and this "error" often shows up as the
1284 * (bogus) exit status for a die() call later on. */
1285 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1286 return success ? eqv : NULL;
1289 } /* end of my_getenv() */
1293 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1295 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1299 unsigned long idx = 0;
1301 static char *__my_getenv_len_eqv = NULL;
1302 int secure, saverr, savvmserr;
1305 midx = my_maxidx(lnm) + 1;
1307 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1308 /* Set up a temporary buffer for the return value; Perl will
1309 * clean it up at the next statement transition */
1310 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1311 if (!tmpsv) return NULL;
1315 /* Assume no interpreter ==> single thread */
1316 if (__my_getenv_len_eqv != NULL) {
1317 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1320 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1322 buf = __my_getenv_len_eqv;
1325 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1326 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1329 getcwd(buf,LNM$C_NAMLENGTH);
1332 /* Get rid of "000000/ in rooted filespecs */
1334 zeros = strstr(buf, "/000000/");
1335 if (zeros != NULL) {
1337 mlen = *len - (zeros - buf) - 7;
1338 memmove(zeros, &zeros[7], mlen);
1347 /* Impose security constraints only if tainting */
1348 secure = PL_curinterp ? PL_tainting : will_taint;
1349 saverr = errno; savvmserr = vaxc$errno;
1356 #ifdef SECURE_INTERNAL_GETENV
1357 secure ? PERL__TRNENV_SECURE : 0
1363 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1365 if ((cp2 = strchr(lnm,';')) != NULL) {
1367 buf[cp2-lnm] = '\0';
1368 idx = strtoul(cp2+1,NULL,0);
1370 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1373 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1375 /* Get rid of "000000/ in rooted filespecs */
1378 zeros = strstr(buf, "/000000/");
1379 if (zeros != NULL) {
1381 mlen = *len - (zeros - buf) - 7;
1382 memmove(zeros, &zeros[7], mlen);
1388 /* Discard NOLOGNAM on internal calls since we're often looking
1389 * for an optional name, and this "error" often shows up as the
1390 * (bogus) exit status for a die() call later on. */
1391 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1392 return *len ? buf : NULL;
1395 } /* end of my_getenv_len() */
1398 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1400 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1402 /*{{{ void prime_env_iter() */
1404 prime_env_iter(void)
1405 /* Fill the %ENV associative array with all logical names we can
1406 * find, in preparation for iterating over it.
1409 static int primed = 0;
1410 HV *seenhv = NULL, *envhv;
1412 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1413 unsigned short int chan;
1414 #ifndef CLI$M_TRUSTED
1415 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1417 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1418 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1420 bool have_sym = FALSE, have_lnm = FALSE;
1421 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1422 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1423 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1424 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1425 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1426 #if defined(PERL_IMPLICIT_CONTEXT)
1429 #if defined(USE_ITHREADS)
1430 static perl_mutex primenv_mutex;
1431 MUTEX_INIT(&primenv_mutex);
1434 #if defined(PERL_IMPLICIT_CONTEXT)
1435 /* We jump through these hoops because we can be called at */
1436 /* platform-specific initialization time, which is before anything is */
1437 /* set up--we can't even do a plain dTHX since that relies on the */
1438 /* interpreter structure to be initialized */
1440 aTHX = PERL_GET_INTERP;
1442 /* we never get here because the NULL pointer will cause the */
1443 /* several of the routines called by this routine to access violate */
1445 /* This routine is only called by hv.c/hv_iterinit which has a */
1446 /* context, so the real fix may be to pass it through instead of */
1447 /* the hoops above */
1452 if (primed || !PL_envgv) return;
1453 MUTEX_LOCK(&primenv_mutex);
1454 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1455 envhv = GvHVn(PL_envgv);
1456 /* Perform a dummy fetch as an lval to insure that the hash table is
1457 * set up. Otherwise, the hv_store() will turn into a nullop. */
1458 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1460 for (i = 0; env_tables[i]; i++) {
1461 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1462 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1463 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1465 if (have_sym || have_lnm) {
1466 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1467 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1468 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1469 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1472 for (i--; i >= 0; i--) {
1473 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1476 for (j = 0; environ[j]; j++) {
1477 if (!(start = strchr(environ[j],'='))) {
1478 if (ckWARN(WARN_INTERNAL))
1479 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1483 sv = newSVpv(start,0);
1485 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1490 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1491 !str$case_blind_compare(&tmpdsc,&clisym)) {
1492 strcpy(cmd,"Show Symbol/Global *");
1493 cmddsc.dsc$w_length = 20;
1494 if (env_tables[i]->dsc$w_length == 12 &&
1495 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1496 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1497 flags = defflags | CLI$M_NOLOGNAM;
1500 strcpy(cmd,"Show Logical *");
1501 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1502 strcat(cmd," /Table=");
1503 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1504 cmddsc.dsc$w_length = strlen(cmd);
1506 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1507 flags = defflags | CLI$M_NOCLISYM;
1510 /* Create a new subprocess to execute each command, to exclude the
1511 * remote possibility that someone could subvert a mbx or file used
1512 * to write multiple commands to a single subprocess.
1515 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1516 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1517 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1518 defflags &= ~CLI$M_TRUSTED;
1519 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1521 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1522 if (seenhv) SvREFCNT_dec(seenhv);
1525 char *cp1, *cp2, *key;
1526 unsigned long int sts, iosb[2], retlen, keylen;
1529 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1530 if (sts & 1) sts = iosb[0] & 0xffff;
1531 if (sts == SS$_ENDOFFILE) {
1533 while (substs == 0) { sys$hiber(); wakect++;}
1534 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1539 retlen = iosb[0] >> 16;
1540 if (!retlen) continue; /* blank line */
1542 if (iosb[1] != subpid) {
1544 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1548 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1549 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1551 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1552 if (*cp1 == '(' || /* Logical name table name */
1553 *cp1 == '=' /* Next eqv of searchlist */) continue;
1554 if (*cp1 == '"') cp1++;
1555 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1556 key = cp1; keylen = cp2 - cp1;
1557 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1558 while (*cp2 && *cp2 != '=') cp2++;
1559 while (*cp2 && *cp2 == '=') cp2++;
1560 while (*cp2 && *cp2 == ' ') cp2++;
1561 if (*cp2 == '"') { /* String translation; may embed "" */
1562 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1563 cp2++; cp1--; /* Skip "" surrounding translation */
1565 else { /* Numeric translation */
1566 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1567 cp1--; /* stop on last non-space char */
1569 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1570 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1573 PERL_HASH(hash,key,keylen);
1575 if (cp1 == cp2 && *cp2 == '.') {
1576 /* A single dot usually means an unprintable character, such as a null
1577 * to indicate a zero-length value. Get the actual value to make sure.
1579 char lnm[LNM$C_NAMLENGTH+1];
1580 char eqv[MAX_DCL_SYMBOL+1];
1582 strncpy(lnm, key, keylen);
1583 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1584 sv = newSVpvn(eqv, strlen(eqv));
1587 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1591 hv_store(envhv,key,keylen,sv,hash);
1592 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1594 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1595 /* get the PPFs for this process, not the subprocess */
1596 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1597 char eqv[LNM$C_NAMLENGTH+1];
1599 for (i = 0; ppfs[i]; i++) {
1600 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1601 sv = newSVpv(eqv,trnlen);
1603 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1608 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1609 if (buf) Safefree(buf);
1610 if (seenhv) SvREFCNT_dec(seenhv);
1611 MUTEX_UNLOCK(&primenv_mutex);
1614 } /* end of prime_env_iter */
1618 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1619 /* Define or delete an element in the same "environment" as
1620 * vmstrnenv(). If an element is to be deleted, it's removed from
1621 * the first place it's found. If it's to be set, it's set in the
1622 * place designated by the first element of the table vector.
1623 * Like setenv() returns 0 for success, non-zero on error.
1626 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1629 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1630 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1632 unsigned long int retsts, usermode = PSL$C_USER;
1633 struct itmlst_3 *ile, *ilist;
1634 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1635 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1636 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1637 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1638 $DESCRIPTOR(local,"_LOCAL");
1641 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1642 return SS$_IVLOGNAM;
1645 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1646 *cp2 = _toupper(*cp1);
1647 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1648 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1649 return SS$_IVLOGNAM;
1652 lnmdsc.dsc$w_length = cp1 - lnm;
1653 if (!tabvec || !*tabvec) tabvec = env_tables;
1655 if (!eqv) { /* we're deleting n element */
1656 for (curtab = 0; tabvec[curtab]; curtab++) {
1657 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1659 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1660 if ((cp1 = strchr(environ[i],'=')) &&
1661 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1662 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1664 return setenv(lnm,"",1) ? vaxc$errno : 0;
1667 ivenv = 1; retsts = SS$_NOLOGNAM;
1669 if (ckWARN(WARN_INTERNAL))
1670 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1671 ivenv = 1; retsts = SS$_NOSUCHPGM;
1677 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1678 !str$case_blind_compare(&tmpdsc,&clisym)) {
1679 unsigned int symtype;
1680 if (tabvec[curtab]->dsc$w_length == 12 &&
1681 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1682 !str$case_blind_compare(&tmpdsc,&local))
1683 symtype = LIB$K_CLI_LOCAL_SYM;
1684 else symtype = LIB$K_CLI_GLOBAL_SYM;
1685 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1686 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1687 if (retsts == LIB$_NOSUCHSYM) continue;
1691 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1692 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1693 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1694 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1695 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1699 else { /* we're defining a value */
1700 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1702 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1704 if (ckWARN(WARN_INTERNAL))
1705 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1706 retsts = SS$_NOSUCHPGM;
1710 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1711 eqvdsc.dsc$w_length = strlen(eqv);
1712 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1713 !str$case_blind_compare(&tmpdsc,&clisym)) {
1714 unsigned int symtype;
1715 if (tabvec[0]->dsc$w_length == 12 &&
1716 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1717 !str$case_blind_compare(&tmpdsc,&local))
1718 symtype = LIB$K_CLI_LOCAL_SYM;
1719 else symtype = LIB$K_CLI_GLOBAL_SYM;
1720 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1723 if (!*eqv) eqvdsc.dsc$w_length = 1;
1724 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1726 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1727 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1728 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1729 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1730 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1731 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1734 Newx(ilist,nseg+1,struct itmlst_3);
1737 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1740 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1742 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1743 ile->itmcode = LNM$_STRING;
1745 if ((j+1) == nseg) {
1746 ile->buflen = strlen(c);
1747 /* in case we are truncating one that's too long */
1748 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1751 ile->buflen = LNM$C_NAMLENGTH;
1755 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1759 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1764 if (!(retsts & 1)) {
1766 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1767 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1768 set_errno(EVMSERR); break;
1769 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1770 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1771 set_errno(EINVAL); break;
1773 set_errno(EACCES); break;
1778 set_vaxc_errno(retsts);
1779 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1782 /* We reset error values on success because Perl does an hv_fetch()
1783 * before each hv_store(), and if the thing we're setting didn't
1784 * previously exist, we've got a leftover error message. (Of course,
1785 * this fails in the face of
1786 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1787 * in that the error reported in $! isn't spurious,
1788 * but it's right more often than not.)
1790 set_errno(0); set_vaxc_errno(retsts);
1794 } /* end of vmssetenv() */
1797 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1798 /* This has to be a function since there's a prototype for it in proto.h */
1800 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1803 int len = strlen(lnm);
1807 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1808 if (!strcmp(uplnm,"DEFAULT")) {
1809 if (eqv && *eqv) my_chdir(eqv);
1813 #ifndef RTL_USES_UTC
1814 if (len == 6 || len == 2) {
1817 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1819 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1820 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1824 (void) vmssetenv(lnm,eqv,NULL);
1828 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1830 * sets a user-mode logical in the process logical name table
1831 * used for redirection of sys$error
1833 * Fix-me: The pTHX is not needed for this routine, however doio.c
1834 * is calling it with one instead of using a macro.
1835 * A macro needs to be added to vmsish.h and doio.c updated to use it.
1839 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1841 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1842 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1843 unsigned long int iss, attr = LNM$M_CONFINE;
1844 unsigned char acmode = PSL$C_USER;
1845 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1847 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1848 d_name.dsc$w_length = strlen(name);
1850 lnmlst[0].buflen = strlen(eqv);
1851 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1853 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1854 if (!(iss&1)) lib$signal(iss);
1859 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1860 /* my_crypt - VMS password hashing
1861 * my_crypt() provides an interface compatible with the Unix crypt()
1862 * C library function, and uses sys$hash_password() to perform VMS
1863 * password hashing. The quadword hashed password value is returned
1864 * as a NUL-terminated 8 character string. my_crypt() does not change
1865 * the case of its string arguments; in order to match the behavior
1866 * of LOGINOUT et al., alphabetic characters in both arguments must
1867 * be upcased by the caller.
1869 * - fix me to call ACM services when available
1872 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1874 # ifndef UAI$C_PREFERRED_ALGORITHM
1875 # define UAI$C_PREFERRED_ALGORITHM 127
1877 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1878 unsigned short int salt = 0;
1879 unsigned long int sts;
1881 unsigned short int dsc$w_length;
1882 unsigned char dsc$b_type;
1883 unsigned char dsc$b_class;
1884 const char * dsc$a_pointer;
1885 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1886 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1887 struct itmlst_3 uailst[3] = {
1888 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1889 { sizeof salt, UAI$_SALT, &salt, 0},
1890 { 0, 0, NULL, NULL}};
1891 static char hash[9];
1893 usrdsc.dsc$w_length = strlen(usrname);
1894 usrdsc.dsc$a_pointer = usrname;
1895 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1897 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1901 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1906 set_vaxc_errno(sts);
1907 if (sts != RMS$_RNF) return NULL;
1910 txtdsc.dsc$w_length = strlen(textpasswd);
1911 txtdsc.dsc$a_pointer = textpasswd;
1912 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1913 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1916 return (char *) hash;
1918 } /* end of my_crypt() */
1922 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1923 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1924 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1926 /* fixup barenames that are directories for internal use.
1927 * There have been problems with the consistent handling of UNIX
1928 * style directory names when routines are presented with a name that
1929 * has no directory delimitors at all. So this routine will eventually
1932 static char * fixup_bare_dirnames(const char * name)
1934 if (decc_disable_to_vms_logname_translation) {
1940 /* 8.3, remove() is now broken on symbolic links */
1941 static int rms_erase(const char * vmsname);
1945 * A little hack to get around a bug in some implemenation of remove()
1946 * that do not know how to delete a directory
1948 * Delete any file to which user has control access, regardless of whether
1949 * delete access is explicitly allowed.
1950 * Limitations: User must have write access to parent directory.
1951 * Does not block signals or ASTs; if interrupted in midstream
1952 * may leave file with an altered ACL.
1955 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1957 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1961 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1962 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1963 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1965 unsigned char myace$b_length;
1966 unsigned char myace$b_type;
1967 unsigned short int myace$w_flags;
1968 unsigned long int myace$l_access;
1969 unsigned long int myace$l_ident;
1970 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1971 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1972 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1974 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1975 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1976 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1977 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1978 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1979 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1981 /* Expand the input spec using RMS, since the CRTL remove() and
1982 * system services won't do this by themselves, so we may miss
1983 * a file "hiding" behind a logical name or search list. */
1984 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1985 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1987 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1989 PerlMem_free(vmsname);
1993 /* Erase the file */
1994 rmsts = rms_erase(vmsname);
1996 /* Did it succeed */
1997 if ($VMS_STATUS_SUCCESS(rmsts)) {
1998 PerlMem_free(vmsname);
2002 /* If not, can changing protections help? */
2003 if (rmsts != RMS$_PRV) {
2004 set_vaxc_errno(rmsts);
2005 PerlMem_free(vmsname);
2009 /* No, so we get our own UIC to use as a rights identifier,
2010 * and the insert an ACE at the head of the ACL which allows us
2011 * to delete the file.
2013 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
2014 fildsc.dsc$w_length = strlen(vmsname);
2015 fildsc.dsc$a_pointer = vmsname;
2017 newace.myace$l_ident = oldace.myace$l_ident;
2019 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2021 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2022 set_errno(ENOENT); break;
2024 set_errno(ENOTDIR); break;
2026 set_errno(ENODEV); break;
2027 case RMS$_SYN: case SS$_INVFILFOROP:
2028 set_errno(EINVAL); break;
2030 set_errno(EACCES); break;
2032 _ckvmssts_noperl(aclsts);
2034 set_vaxc_errno(aclsts);
2035 PerlMem_free(vmsname);
2038 /* Grab any existing ACEs with this identifier in case we fail */
2039 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2040 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2041 || fndsts == SS$_NOMOREACE ) {
2042 /* Add the new ACE . . . */
2043 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2046 rmsts = rms_erase(vmsname);
2047 if ($VMS_STATUS_SUCCESS(rmsts)) {
2052 /* We blew it - dir with files in it, no write priv for
2053 * parent directory, etc. Put things back the way they were. */
2054 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2057 addlst[0].bufadr = &oldace;
2058 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2065 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2066 /* We just deleted it, so of course it's not there. Some versions of
2067 * VMS seem to return success on the unlock operation anyhow (after all
2068 * the unlock is successful), but others don't.
2070 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2071 if (aclsts & 1) aclsts = fndsts;
2072 if (!(aclsts & 1)) {
2074 set_vaxc_errno(aclsts);
2077 PerlMem_free(vmsname);
2080 } /* end of kill_file() */
2084 /*{{{int do_rmdir(char *name)*/
2086 Perl_do_rmdir(pTHX_ const char *name)
2092 /* lstat returns a VMS fileified specification of the name */
2093 /* that is looked up, and also lets verifies that this is a directory */
2095 retval = flex_lstat(name, &st);
2099 /* Due to a historical feature, flex_stat/lstat can not see some */
2100 /* Unix format file names that the rest of the CRTL can see */
2101 /* Fixing that feature will cause some perl tests to fail */
2102 /* So try this one more time. */
2104 retval = lstat(name, &st.crtl_stat);
2108 /* force it to a file spec for the kill file to work. */
2109 ret_spec = do_fileify_dirspec(name, st.st_devnam, 0, NULL);
2110 if (ret_spec == NULL) {
2116 if (!S_ISDIR(st.st_mode)) {
2121 dirfile = st.st_devnam;
2123 /* It may be possible for flex_stat to find a file and vmsify() to */
2124 /* fail with ODS-2 specifications. mp_do_kill_file can not deal */
2125 /* with that case, so fail it */
2126 if (dirfile[0] == 0) {
2131 retval = mp_do_kill_file(aTHX_ dirfile, 1);
2136 } /* end of do_rmdir */
2140 * Delete any file to which user has control access, regardless of whether
2141 * delete access is explicitly allowed.
2142 * Limitations: User must have write access to parent directory.
2143 * Does not block signals or ASTs; if interrupted in midstream
2144 * may leave file with an altered ACL.
2147 /*{{{int kill_file(char *name)*/
2149 Perl_kill_file(pTHX_ const char *name)
2155 /* Convert the filename to VMS format and see if it is a directory */
2156 /* flex_lstat returns a vmsified file specification */
2157 rmsts = flex_lstat(name, &st);
2160 /* Due to a historical feature, flex_stat/lstat can not see some */
2161 /* Unix format file names that the rest of the CRTL can see when */
2162 /* ODS-2 file specifications are in use. */
2163 /* Fixing that feature will cause some perl tests to fail */
2164 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2166 vmsfile = (char *) name; /* cast ok */
2169 vmsfile = st.st_devnam;
2170 if (vmsfile[0] == 0) {
2171 /* It may be possible for flex_stat to find a file and vmsify() */
2172 /* to fail with ODS-2 specifications. mp_do_kill_file can not */
2173 /* deal with that case, so fail it */
2179 /* Remove() is allowed to delete directories, according to the X/Open
2181 * This may need special handling to work with the ACL hacks.
2183 if (S_ISDIR(st.st_mode)) {
2184 rmsts = mp_do_kill_file(aTHX_ vmsfile, 1);
2188 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2190 /* Need to delete all versions ? */
2191 if ((rmsts == 0) && (vms_unlink_all_versions == 1)) {
2194 /* Just use lstat() here as do not need st_dev */
2195 /* and we know that the file is in VMS format or that */
2196 /* because of a historical bug, flex_stat can not see the file */
2197 while (lstat(vmsfile, (stat_t *)&st) == 0) {
2198 rmsts = mp_do_kill_file(aTHX_ vmsfile, 0);
2203 /* Make sure that we do not loop forever */
2214 } /* end of kill_file() */
2218 /*{{{int my_mkdir(char *,Mode_t)*/
2220 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2222 STRLEN dirlen = strlen(dir);
2224 /* zero length string sometimes gives ACCVIO */
2225 if (dirlen == 0) return -1;
2227 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2228 * null file name/type. However, it's commonplace under Unix,
2229 * so we'll allow it for a gain in portability.
2231 if (dir[dirlen-1] == '/') {
2232 char *newdir = savepvn(dir,dirlen-1);
2233 int ret = mkdir(newdir,mode);
2237 else return mkdir(dir,mode);
2238 } /* end of my_mkdir */
2241 /*{{{int my_chdir(char *)*/
2243 Perl_my_chdir(pTHX_ const char *dir)
2245 STRLEN dirlen = strlen(dir);
2247 /* zero length string sometimes gives ACCVIO */
2248 if (dirlen == 0) return -1;
2251 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2252 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2253 * so that existing scripts do not need to be changed.
2256 while ((dirlen > 0) && (*dir1 == ' ')) {
2261 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2263 * null file name/type. However, it's commonplace under Unix,
2264 * so we'll allow it for a gain in portability.
2266 * '/' is valid when SYS$POSIX_ROOT or POSIX compliant pathnames are active.
2268 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2271 newdir = PerlMem_malloc(dirlen);
2273 _ckvmssts_noperl(SS$_INSFMEM);
2274 strncpy(newdir, dir1, dirlen-1);
2275 newdir[dirlen-1] = '\0';
2276 ret = chdir(newdir);
2277 PerlMem_free(newdir);
2280 else return chdir(dir1);
2281 } /* end of my_chdir */
2285 /*{{{int my_chmod(char *, mode_t)*/
2287 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2292 STRLEN speclen = strlen(file_spec);
2294 /* zero length string sometimes gives ACCVIO */
2295 if (speclen == 0) return -1;
2297 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2298 * that implies null file name/type. However, it's commonplace under Unix,
2299 * so we'll allow it for a gain in portability.
2301 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2302 * in VMS file.dir notation.
2304 changefile = (char *) file_spec; /* cast ok */
2305 ret = flex_lstat(file_spec, &st);
2308 /* Due to a historical feature, flex_stat/lstat can not see some */
2309 /* Unix format file names that the rest of the CRTL can see when */
2310 /* ODS-2 file specifications are in use. */
2311 /* Fixing that feature will cause some perl tests to fail */
2312 /* [.lib.ExtUtils.t]Manifest.t is one of them */
2316 /* It may be possible to get here with nothing in st_devname */
2317 /* chmod still may work though */
2318 if (st.st_devnam[0] != 0) {
2319 changefile = st.st_devnam;
2322 ret = chmod(changefile, mode);
2324 } /* end of my_chmod */
2328 /*{{{FILE *my_tmpfile()*/
2335 if ((fp = tmpfile())) return fp;
2337 cp = PerlMem_malloc(L_tmpnam+24);
2338 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2340 if (decc_filename_unix_only == 0)
2341 strcpy(cp,"Sys$Scratch:");
2344 tmpnam(cp+strlen(cp));
2345 strcat(cp,".Perltmp");
2346 fp = fopen(cp,"w+","fop=dlt");
2353 #ifndef HOMEGROWN_POSIX_SIGNALS
2355 * The C RTL's sigaction fails to check for invalid signal numbers so we
2356 * help it out a bit. The docs are correct, but the actual routine doesn't
2357 * do what the docs say it will.
2359 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2361 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2362 struct sigaction* oact)
2364 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2365 SETERRNO(EINVAL, SS$_INVARG);
2368 return sigaction(sig, act, oact);
2373 #ifdef KILL_BY_SIGPRC
2374 #include <errnodef.h>
2376 /* We implement our own kill() using the undocumented system service
2377 sys$sigprc for one of two reasons:
2379 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2380 target process to do a sys$exit, which usually can't be handled
2381 gracefully...certainly not by Perl and the %SIG{} mechanism.
2383 2.) If the kill() in the CRTL can't be called from a signal
2384 handler without disappearing into the ether, i.e., the signal
2385 it purportedly sends is never trapped. Still true as of VMS 7.3.
2387 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2388 in the target process rather than calling sys$exit.
2390 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2391 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2392 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2393 with condition codes C$_SIG0+nsig*8, catching the exception on the
2394 target process and resignaling with appropriate arguments.
2396 But we don't have that VMS 7.0+ exception handler, so if you
2397 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2399 Also note that SIGTERM is listed in the docs as being "unimplemented",
2400 yet always seems to be signaled with a VMS condition code of 4 (and
2401 correctly handled for that code). So we hardwire it in.
2403 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2404 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2405 than signalling with an unrecognized (and unhandled by CRTL) code.
2408 #define _MY_SIG_MAX 28
2411 Perl_sig_to_vmscondition_int(int sig)
2413 static unsigned int sig_code[_MY_SIG_MAX+1] =
2416 SS$_HANGUP, /* 1 SIGHUP */
2417 SS$_CONTROLC, /* 2 SIGINT */
2418 SS$_CONTROLY, /* 3 SIGQUIT */
2419 SS$_RADRMOD, /* 4 SIGILL */
2420 SS$_BREAK, /* 5 SIGTRAP */
2421 SS$_OPCCUS, /* 6 SIGABRT */
2422 SS$_COMPAT, /* 7 SIGEMT */
2424 SS$_FLTOVF, /* 8 SIGFPE VAX */
2426 SS$_HPARITH, /* 8 SIGFPE AXP */
2428 SS$_ABORT, /* 9 SIGKILL */
2429 SS$_ACCVIO, /* 10 SIGBUS */
2430 SS$_ACCVIO, /* 11 SIGSEGV */
2431 SS$_BADPARAM, /* 12 SIGSYS */
2432 SS$_NOMBX, /* 13 SIGPIPE */
2433 SS$_ASTFLT, /* 14 SIGALRM */
2450 #if __VMS_VER >= 60200000
2451 static int initted = 0;
2454 sig_code[16] = C$_SIGUSR1;
2455 sig_code[17] = C$_SIGUSR2;
2456 #if __CRTL_VER >= 70000000
2457 sig_code[20] = C$_SIGCHLD;
2459 #if __CRTL_VER >= 70300000
2460 sig_code[28] = C$_SIGWINCH;
2465 if (sig < _SIG_MIN) return 0;
2466 if (sig > _MY_SIG_MAX) return 0;
2467 return sig_code[sig];
2471 Perl_sig_to_vmscondition(int sig)
2474 if (vms_debug_on_exception != 0)
2475 lib$signal(SS$_DEBUG);
2477 return Perl_sig_to_vmscondition_int(sig);
2482 Perl_my_kill(int pid, int sig)
2487 int sys$sigprc(unsigned int *pidadr,
2488 struct dsc$descriptor_s *prcname,
2491 /* sig 0 means validate the PID */
2492 /*------------------------------*/
2494 const unsigned long int jpicode = JPI$_PID;
2497 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2498 if ($VMS_STATUS_SUCCESS(status))
2501 case SS$_NOSUCHNODE:
2502 case SS$_UNREACHABLE:
2516 code = Perl_sig_to_vmscondition_int(sig);
2519 SETERRNO(EINVAL, SS$_BADPARAM);
2523 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2524 * signals are to be sent to multiple processes.
2525 * pid = 0 - all processes in group except ones that the system exempts
2526 * pid = -1 - all processes except ones that the system exempts
2527 * pid = -n - all processes in group (abs(n)) except ...
2528 * For now, just report as not supported.
2532 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2536 iss = sys$sigprc((unsigned int *)&pid,0,code);
2537 if (iss&1) return 0;
2541 set_errno(EPERM); break;
2543 case SS$_NOSUCHNODE:
2544 case SS$_UNREACHABLE:
2545 set_errno(ESRCH); break;
2547 set_errno(ENOMEM); break;
2549 _ckvmssts_noperl(iss);
2552 set_vaxc_errno(iss);
2558 /* Routine to convert a VMS status code to a UNIX status code.
2559 ** More tricky than it appears because of conflicting conventions with
2562 ** VMS status codes are a bit mask, with the least significant bit set for
2565 ** Special UNIX status of EVMSERR indicates that no translation is currently
2566 ** available, and programs should check the VMS status code.
2568 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2572 #ifndef C_FACILITY_NO
2573 #define C_FACILITY_NO 0x350000
2576 #define DCL_IVVERB 0x38090
2579 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2587 /* Assume the best or the worst */
2588 if (vms_status & STS$M_SUCCESS)
2591 unix_status = EVMSERR;
2593 msg_status = vms_status & ~STS$M_CONTROL;
2595 facility = vms_status & STS$M_FAC_NO;
2596 fac_sp = vms_status & STS$M_FAC_SP;
2597 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2599 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2605 unix_status = EFAULT;
2607 case SS$_DEVOFFLINE:
2608 unix_status = EBUSY;
2611 unix_status = ENOTCONN;
2619 case SS$_INVFILFOROP:
2623 unix_status = EINVAL;
2625 case SS$_UNSUPPORTED:
2626 unix_status = ENOTSUP;
2631 unix_status = EACCES;
2633 case SS$_DEVICEFULL:
2634 unix_status = ENOSPC;
2637 unix_status = ENODEV;
2639 case SS$_NOSUCHFILE:
2640 case SS$_NOSUCHOBJECT:
2641 unix_status = ENOENT;
2643 case SS$_ABORT: /* Fatal case */
2644 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2645 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2646 unix_status = EINTR;
2649 unix_status = E2BIG;
2652 unix_status = ENOMEM;
2655 unix_status = EPERM;
2657 case SS$_NOSUCHNODE:
2658 case SS$_UNREACHABLE:
2659 unix_status = ESRCH;
2662 unix_status = ECHILD;
2665 if ((facility == 0) && (msg_no < 8)) {
2666 /* These are not real VMS status codes so assume that they are
2667 ** already UNIX status codes
2669 unix_status = msg_no;
2675 /* Translate a POSIX exit code to a UNIX exit code */
2676 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2677 unix_status = (msg_no & 0x07F8) >> 3;
2681 /* Documented traditional behavior for handling VMS child exits */
2682 /*--------------------------------------------------------------*/
2683 if (child_flag != 0) {
2685 /* Success / Informational return 0 */
2686 /*----------------------------------*/
2687 if (msg_no & STS$K_SUCCESS)
2690 /* Warning returns 1 */
2691 /*-------------------*/
2692 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2695 /* Everything else pass through the severity bits */
2696 /*------------------------------------------------*/
2697 return (msg_no & STS$M_SEVERITY);
2700 /* Normal VMS status to ERRNO mapping attempt */
2701 /*--------------------------------------------*/
2702 switch(msg_status) {
2703 /* case RMS$_EOF: */ /* End of File */
2704 case RMS$_FNF: /* File Not Found */
2705 case RMS$_DNF: /* Dir Not Found */
2706 unix_status = ENOENT;
2708 case RMS$_RNF: /* Record Not Found */
2709 unix_status = ESRCH;
2712 unix_status = ENOTDIR;
2715 unix_status = ENODEV;
2720 unix_status = EBADF;
2723 unix_status = EEXIST;
2727 case LIB$_INVSTRDES:
2729 case LIB$_NOSUCHSYM:
2730 case LIB$_INVSYMNAM:
2732 unix_status = EINVAL;
2738 unix_status = E2BIG;
2740 case RMS$_PRV: /* No privilege */
2741 case RMS$_ACC: /* ACP file access failed */
2742 case RMS$_WLK: /* Device write locked */
2743 unix_status = EACCES;
2745 case RMS$_MKD: /* Failed to mark for delete */
2746 unix_status = EPERM;
2748 /* case RMS$_NMF: */ /* No more files */
2756 /* Try to guess at what VMS error status should go with a UNIX errno
2757 * value. This is hard to do as there could be many possible VMS
2758 * error statuses that caused the errno value to be set.
2761 int Perl_unix_status_to_vms(int unix_status)
2763 int test_unix_status;
2765 /* Trivial cases first */
2766 /*---------------------*/
2767 if (unix_status == EVMSERR)
2770 /* Is vaxc$errno sane? */
2771 /*---------------------*/
2772 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2773 if (test_unix_status == unix_status)
2776 /* If way out of range, must be VMS code already */
2777 /*-----------------------------------------------*/
2778 if (unix_status > EVMSERR)
2781 /* If out of range, punt */
2782 /*-----------------------*/
2783 if (unix_status > __ERRNO_MAX)
2787 /* Ok, now we have to do it the hard way. */
2788 /*----------------------------------------*/
2789 switch(unix_status) {
2790 case 0: return SS$_NORMAL;
2791 case EPERM: return SS$_NOPRIV;
2792 case ENOENT: return SS$_NOSUCHOBJECT;
2793 case ESRCH: return SS$_UNREACHABLE;
2794 case EINTR: return SS$_ABORT;
2797 case E2BIG: return SS$_BUFFEROVF;
2799 case EBADF: return RMS$_IFI;
2800 case ECHILD: return SS$_NONEXPR;
2802 case ENOMEM: return SS$_INSFMEM;
2803 case EACCES: return SS$_FILACCERR;
2804 case EFAULT: return SS$_ACCVIO;
2806 case EBUSY: return SS$_DEVOFFLINE;
2807 case EEXIST: return RMS$_FEX;
2809 case ENODEV: return SS$_NOSUCHDEV;
2810 case ENOTDIR: return RMS$_DIR;
2812 case EINVAL: return SS$_INVARG;
2818 case ENOSPC: return SS$_DEVICEFULL;
2819 case ESPIPE: return LIB$_INVARG;
2824 case ERANGE: return LIB$_INVARG;
2825 /* case EWOULDBLOCK */
2826 /* case EINPROGRESS */
2829 /* case EDESTADDRREQ */
2831 /* case EPROTOTYPE */
2832 /* case ENOPROTOOPT */
2833 /* case EPROTONOSUPPORT */
2834 /* case ESOCKTNOSUPPORT */
2835 /* case EOPNOTSUPP */
2836 /* case EPFNOSUPPORT */
2837 /* case EAFNOSUPPORT */
2838 /* case EADDRINUSE */
2839 /* case EADDRNOTAVAIL */
2841 /* case ENETUNREACH */
2842 /* case ENETRESET */
2843 /* case ECONNABORTED */
2844 /* case ECONNRESET */
2847 case ENOTCONN: return SS$_CLEARED;
2848 /* case ESHUTDOWN */
2849 /* case ETOOMANYREFS */
2850 /* case ETIMEDOUT */
2851 /* case ECONNREFUSED */
2853 /* case ENAMETOOLONG */
2854 /* case EHOSTDOWN */
2855 /* case EHOSTUNREACH */
2856 /* case ENOTEMPTY */
2868 /* case ECANCELED */
2872 return SS$_UNSUPPORTED;
2878 /* case EABANDONED */
2880 return SS$_ABORT; /* punt */
2883 return SS$_ABORT; /* Should not get here */
2887 /* default piping mailbox size */
2888 #define PERL_BUFSIZ 512
2892 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2894 unsigned long int mbxbufsiz;
2895 static unsigned long int syssize = 0;
2896 unsigned long int dviitm = DVI$_DEVNAM;
2897 char csize[LNM$C_NAMLENGTH+1];
2901 unsigned long syiitm = SYI$_MAXBUF;
2903 * Get the SYSGEN parameter MAXBUF
2905 * If the logical 'PERL_MBX_SIZE' is defined
2906 * use the value of the logical instead of PERL_BUFSIZ, but
2907 * keep the size between 128 and MAXBUF.
2910 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2913 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2914 mbxbufsiz = atoi(csize);
2916 mbxbufsiz = PERL_BUFSIZ;
2918 if (mbxbufsiz < 128) mbxbufsiz = 128;
2919 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2921 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2923 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2924 _ckvmssts_noperl(sts);
2925 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2927 } /* end of create_mbx() */
2930 /*{{{ my_popen and my_pclose*/
2932 typedef struct _iosb IOSB;
2933 typedef struct _iosb* pIOSB;
2934 typedef struct _pipe Pipe;
2935 typedef struct _pipe* pPipe;
2936 typedef struct pipe_details Info;
2937 typedef struct pipe_details* pInfo;
2938 typedef struct _srqp RQE;
2939 typedef struct _srqp* pRQE;
2940 typedef struct _tochildbuf CBuf;
2941 typedef struct _tochildbuf* pCBuf;
2944 unsigned short status;
2945 unsigned short count;
2946 unsigned long dvispec;
2949 #pragma member_alignment save
2950 #pragma nomember_alignment quadword
2951 struct _srqp { /* VMS self-relative queue entry */
2952 unsigned long qptr[2];
2954 #pragma member_alignment restore
2955 static RQE RQE_ZERO = {0,0};
2957 struct _tochildbuf {
2960 unsigned short size;
2968 unsigned short chan_in;
2969 unsigned short chan_out;
2971 unsigned int bufsize;
2983 #if defined(PERL_IMPLICIT_CONTEXT)
2984 void *thx; /* Either a thread or an interpreter */
2985 /* pointer, depending on how we're built */
2993 PerlIO *fp; /* file pointer to pipe mailbox */
2994 int useFILE; /* using stdio, not perlio */
2995 int pid; /* PID of subprocess */
2996 int mode; /* == 'r' if pipe open for reading */
2997 int done; /* subprocess has completed */
2998 int waiting; /* waiting for completion/closure */
2999 int closing; /* my_pclose is closing this pipe */
3000 unsigned long completion; /* termination status of subprocess */
3001 pPipe in; /* pipe in to sub */
3002 pPipe out; /* pipe out of sub */
3003 pPipe err; /* pipe of sub's sys$error */
3004 int in_done; /* true when in pipe finished */
3007 unsigned short xchan; /* channel to debug xterm */
3008 unsigned short xchan_valid; /* channel is assigned */
3011 struct exit_control_block
3013 struct exit_control_block *flink;
3014 unsigned long int (*exit_routine)();
3015 unsigned long int arg_count;
3016 unsigned long int *status_address;
3017 unsigned long int exit_status;
3020 typedef struct _closed_pipes Xpipe;
3021 typedef struct _closed_pipes* pXpipe;
3023 struct _closed_pipes {
3024 int pid; /* PID of subprocess */
3025 unsigned long completion; /* termination status of subprocess */
3027 #define NKEEPCLOSED 50
3028 static Xpipe closed_list[NKEEPCLOSED];
3029 static int closed_index = 0;
3030 static int closed_num = 0;
3032 #define RETRY_DELAY "0 ::0.20"
3033 #define MAX_RETRY 50
3035 static int pipe_ef = 0; /* first call to safe_popen inits these*/
3036 static unsigned long mypid;
3037 static unsigned long delaytime[2];
3039 static pInfo open_pipes = NULL;
3040 static $DESCRIPTOR(nl_desc, "NL:");
3042 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
3046 static unsigned long int
3050 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
3051 int sts, did_stuff, need_eof, j;
3054 * Flush any pending i/o, but since we are in process run-down, be
3055 * careful about referencing PerlIO structures that may already have
3056 * been deallocated. We may not even have an interpreter anymore.
3061 #if defined(PERL_IMPLICIT_CONTEXT)
3062 /* We need to use the Perl context of the thread that created */
3066 aTHX = info->err->thx;
3068 aTHX = info->out->thx;
3070 aTHX = info->in->thx;
3073 #if defined(USE_ITHREADS)
3076 && PL_perlio_fd_refcnt)
3077 PerlIO_flush(info->fp);
3079 fflush((FILE *)info->fp);
3085 next we try sending an EOF...ignore if doesn't work, make sure we
3093 _ckvmssts_noperl(sys$setast(0));
3094 if (info->in && !info->in->shut_on_empty) {
3095 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3100 _ckvmssts_noperl(sys$setast(1));
3104 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3106 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3111 _ckvmssts_noperl(sys$setast(0));
3112 if (info->waiting && info->done)
3114 nwait += info->waiting;
3115 _ckvmssts_noperl(sys$setast(1));
3125 _ckvmssts_noperl(sys$setast(0));
3126 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3127 sts = sys$forcex(&info->pid,0,&abort);
3128 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3131 _ckvmssts_noperl(sys$setast(1));
3135 /* again, wait for effect */
3137 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3142 _ckvmssts_noperl(sys$setast(0));
3143 if (info->waiting && info->done)
3145 nwait += info->waiting;
3146 _ckvmssts_noperl(sys$setast(1));
3155 _ckvmssts_noperl(sys$setast(0));
3156 if (!info->done) { /* We tried to be nice . . . */
3157 sts = sys$delprc(&info->pid,0);
3158 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3159 info->done = 1; /* sys$delprc is as done as we're going to get. */
3161 _ckvmssts_noperl(sys$setast(1));
3167 #if defined(PERL_IMPLICIT_CONTEXT)
3168 /* We need to use the Perl context of the thread that created */
3171 if (open_pipes->err)
3172 aTHX = open_pipes->err->thx;
3173 else if (open_pipes->out)
3174 aTHX = open_pipes->out->thx;
3175 else if (open_pipes->in)
3176 aTHX = open_pipes->in->thx;
3178 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3179 else if (!(sts & 1)) retsts = sts;
3184 static struct exit_control_block pipe_exitblock =
3185 {(struct exit_control_block *) 0,
3186 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3188 static void pipe_mbxtofd_ast(pPipe p);
3189 static void pipe_tochild1_ast(pPipe p);
3190 static void pipe_tochild2_ast(pPipe p);
3193 popen_completion_ast(pInfo info)
3195 pInfo i = open_pipes;
3200 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3201 closed_list[closed_index].pid = info->pid;
3202 closed_list[closed_index].completion = info->completion;
3204 if (closed_index == NKEEPCLOSED)
3209 if (i == info) break;
3212 if (!i) return; /* unlinked, probably freed too */
3217 Writing to subprocess ...
3218 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3220 chan_out may be waiting for "done" flag, or hung waiting
3221 for i/o completion to child...cancel the i/o. This will
3222 put it into "snarf mode" (done but no EOF yet) that discards
3225 Output from subprocess (stdout, stderr) needs to be flushed and
3226 shut down. We try sending an EOF, but if the mbx is full the pipe
3227 routine should still catch the "shut_on_empty" flag, telling it to
3228 use immediate-style reads so that "mbx empty" -> EOF.
3232 if (info->in && !info->in_done) { /* only for mode=w */
3233 if (info->in->shut_on_empty && info->in->need_wake) {
3234 info->in->need_wake = FALSE;
3235 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3237 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3241 if (info->out && !info->out_done) { /* were we also piping output? */
3242 info->out->shut_on_empty = TRUE;
3243 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3244 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3245 _ckvmssts_noperl(iss);
3248 if (info->err && !info->err_done) { /* we were piping stderr */
3249 info->err->shut_on_empty = TRUE;
3250 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3251 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3252 _ckvmssts_noperl(iss);
3254 _ckvmssts_noperl(sys$setef(pipe_ef));
3258 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3259 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3262 we actually differ from vmstrnenv since we use this to
3263 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3264 are pointing to the same thing
3267 static unsigned short
3268 popen_translate(pTHX_ char *logical, char *result)
3271 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3272 $DESCRIPTOR(d_log,"");
3274 unsigned short length;
3275 unsigned short code;
3277 unsigned short *retlenaddr;
3279 unsigned short l, ifi;
3281 d_log.dsc$a_pointer = logical;
3282 d_log.dsc$w_length = strlen(logical);
3284 itmlst[0].code = LNM$_STRING;
3285 itmlst[0].length = 255;
3286 itmlst[0].buffer_addr = result;
3287 itmlst[0].retlenaddr = &l;
3290 itmlst[1].length = 0;
3291 itmlst[1].buffer_addr = 0;
3292 itmlst[1].retlenaddr = 0;
3294 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3295 if (iss == SS$_NOLOGNAM) {
3299 if (!(iss&1)) lib$signal(iss);
3302 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3303 strip it off and return the ifi, if any
3306 if (result[0] == 0x1b && result[1] == 0x00) {
3307 memmove(&ifi,result+2,2);
3308 strcpy(result,result+4);
3310 return ifi; /* this is the RMS internal file id */
3313 static void pipe_infromchild_ast(pPipe p);
3316 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3317 inside an AST routine without worrying about reentrancy and which Perl
3318 memory allocator is being used.
3320 We read data and queue up the buffers, then spit them out one at a
3321 time to the output mailbox when the output mailbox is ready for one.
3324 #define INITIAL_TOCHILDQUEUE 2
3327 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3331 char mbx1[64], mbx2[64];
3332 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3333 DSC$K_CLASS_S, mbx1},
3334 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3335 DSC$K_CLASS_S, mbx2};
3336 unsigned int dviitm = DVI$_DEVBUFSIZ;
3340 _ckvmssts_noperl(lib$get_vm(&n, &p));
3342 create_mbx(&p->chan_in , &d_mbx1);
3343 create_mbx(&p->chan_out, &d_mbx2);
3344 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3347 p->shut_on_empty = FALSE;
3348 p->need_wake = FALSE;
3351 p->iosb.status = SS$_NORMAL;
3352 p->iosb2.status = SS$_NORMAL;
3358 #ifdef PERL_IMPLICIT_CONTEXT
3362 n = sizeof(CBuf) + p->bufsize;
3364 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3365 _ckvmssts_noperl(lib$get_vm(&n, &b));
3366 b->buf = (char *) b + sizeof(CBuf);
3367 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3370 pipe_tochild2_ast(p);
3371 pipe_tochild1_ast(p);
3377 /* reads the MBX Perl is writing, and queues */
3380 pipe_tochild1_ast(pPipe p)
3383 int iss = p->iosb.status;
3384 int eof = (iss == SS$_ENDOFFILE);
3386 #ifdef PERL_IMPLICIT_CONTEXT
3392 p->shut_on_empty = TRUE;
3394 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3396 _ckvmssts_noperl(iss);
3400 b->size = p->iosb.count;
3401 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3403 p->need_wake = FALSE;
3404 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3407 p->retry = 1; /* initial call */
3410 if (eof) { /* flush the free queue, return when done */
3411 int n = sizeof(CBuf) + p->bufsize;
3413 iss = lib$remqti(&p->free, &b);
3414 if (iss == LIB$_QUEWASEMP) return;
3415 _ckvmssts_noperl(iss);
3416 _ckvmssts_noperl(lib$free_vm(&n, &b));
3420 iss = lib$remqti(&p->free, &b);
3421 if (iss == LIB$_QUEWASEMP) {
3422 int n = sizeof(CBuf) + p->bufsize;
3423 _ckvmssts_noperl(lib$get_vm(&n, &b));
3424 b->buf = (char *) b + sizeof(CBuf);
3426 _ckvmssts_noperl(iss);
3430 iss = sys$qio(0,p->chan_in,
3431 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3433 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3434 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3435 _ckvmssts_noperl(iss);
3439 /* writes queued buffers to output, waits for each to complete before
3443 pipe_tochild2_ast(pPipe p)
3446 int iss = p->iosb2.status;
3447 int n = sizeof(CBuf) + p->bufsize;
3448 int done = (p->info && p->info->done) ||
3449 iss == SS$_CANCEL || iss == SS$_ABORT;
3450 #if defined(PERL_IMPLICIT_CONTEXT)
3455 if (p->type) { /* type=1 has old buffer, dispose */
3456 if (p->shut_on_empty) {
3457 _ckvmssts_noperl(lib$free_vm(&n, &b));
3459 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3464 iss = lib$remqti(&p->wait, &b);
3465 if (iss == LIB$_QUEWASEMP) {
3466 if (p->shut_on_empty) {
3468 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3469 *p->pipe_done = TRUE;
3470 _ckvmssts_noperl(sys$setef(pipe_ef));
3472 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3473 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3477 p->need_wake = TRUE;
3480 _ckvmssts_noperl(iss);
3487 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3488 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3490 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3491 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3500 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3503 char mbx1[64], mbx2[64];
3504 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3505 DSC$K_CLASS_S, mbx1},
3506 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3507 DSC$K_CLASS_S, mbx2};
3508 unsigned int dviitm = DVI$_DEVBUFSIZ;
3510 int n = sizeof(Pipe);
3511 _ckvmssts_noperl(lib$get_vm(&n, &p));
3512 create_mbx(&p->chan_in , &d_mbx1);
3513 create_mbx(&p->chan_out, &d_mbx2);
3515 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3516 n = p->bufsize * sizeof(char);
3517 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3518 p->shut_on_empty = FALSE;
3521 p->iosb.status = SS$_NORMAL;
3522 #if defined(PERL_IMPLICIT_CONTEXT)
3525 pipe_infromchild_ast(p);
3533 pipe_infromchild_ast(pPipe p)
3535 int iss = p->iosb.status;
3536 int eof = (iss == SS$_ENDOFFILE);
3537 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3538 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3539 #if defined(PERL_IMPLICIT_CONTEXT)
3543 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3544 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3549 input shutdown if EOF from self (done or shut_on_empty)
3550 output shutdown if closing flag set (my_pclose)
3551 send data/eof from child or eof from self
3552 otherwise, re-read (snarf of data from child)
3557 if (myeof && p->chan_in) { /* input shutdown */
3558 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3563 if (myeof || kideof) { /* pass EOF to parent */
3564 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3565 pipe_infromchild_ast, p,
3568 } else if (eof) { /* eat EOF --- fall through to read*/
3570 } else { /* transmit data */
3571 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3572 pipe_infromchild_ast,p,
3573 p->buf, p->iosb.count, 0, 0, 0, 0));
3579 /* everything shut? flag as done */
3581 if (!p->chan_in && !p->chan_out) {
3582 *p->pipe_done = TRUE;
3583 _ckvmssts_noperl(sys$setef(pipe_ef));
3587 /* write completed (or read, if snarfing from child)
3588 if still have input active,
3589 queue read...immediate mode if shut_on_empty so we get EOF if empty
3591 check if Perl reading, generate EOFs as needed
3597 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3598 pipe_infromchild_ast,p,
3599 p->buf, p->bufsize, 0, 0, 0, 0);
3600 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3601 _ckvmssts_noperl(iss);
3602 } else { /* send EOFs for extra reads */
3603 p->iosb.status = SS$_ENDOFFILE;
3604 p->iosb.dvispec = 0;
3605 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3607 pipe_infromchild_ast, p, 0, 0, 0, 0));
3613 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3617 unsigned long dviitm = DVI$_DEVBUFSIZ;
3619 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3620 DSC$K_CLASS_S, mbx};
3621 int n = sizeof(Pipe);
3623 /* things like terminals and mbx's don't need this filter */
3624 if (fd && fstat(fd,&s) == 0) {
3625 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3627 unsigned short dev_len;
3628 struct dsc$descriptor_s d_dev;
3630 struct item_list_3 items[3];
3632 unsigned short dvi_iosb[4];
3634 cptr = getname(fd, out, 1);
3635 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3636 d_dev.dsc$a_pointer = out;
3637 d_dev.dsc$w_length = strlen(out);
3638 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3639 d_dev.dsc$b_class = DSC$K_CLASS_S;
3642 items[0].code = DVI$_DEVCHAR;
3643 items[0].bufadr = &devchar;
3644 items[0].retadr = NULL;
3646 items[1].code = DVI$_FULLDEVNAM;
3647 items[1].bufadr = device;
3648 items[1].retadr = &dev_len;
3652 status = sys$getdviw
3653 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3654 _ckvmssts_noperl(status);
3655 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3656 device[dev_len] = 0;
3658 if (!(devchar & DEV$M_DIR)) {
3659 strcpy(out, device);
3665 _ckvmssts_noperl(lib$get_vm(&n, &p));
3666 p->fd_out = dup(fd);
3667 create_mbx(&p->chan_in, &d_mbx);
3668 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3669 n = (p->bufsize+1) * sizeof(char);
3670 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3671 p->shut_on_empty = FALSE;
3676 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3677 pipe_mbxtofd_ast, p,
3678 p->buf, p->bufsize, 0, 0, 0, 0));
3684 pipe_mbxtofd_ast(pPipe p)
3686 int iss = p->iosb.status;
3687 int done = p->info->done;
3689 int eof = (iss == SS$_ENDOFFILE);
3690 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3691 int err = !(iss&1) && !eof;
3692 #if defined(PERL_IMPLICIT_CONTEXT)
3696 if (done && myeof) { /* end piping */
3698 sys$dassgn(p->chan_in);
3699 *p->pipe_done = TRUE;
3700 _ckvmssts_noperl(sys$setef(pipe_ef));
3704 if (!err && !eof) { /* good data to send to file */
3705 p->buf[p->iosb.count] = '\n';
3706 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3709 if (p->retry < MAX_RETRY) {
3710 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3716 _ckvmssts_noperl(iss);
3720 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3721 pipe_mbxtofd_ast, p,
3722 p->buf, p->bufsize, 0, 0, 0, 0);
3723 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3724 _ckvmssts_noperl(iss);
3728 typedef struct _pipeloc PLOC;
3729 typedef struct _pipeloc* pPLOC;
3733 char dir[NAM$C_MAXRSS+1];
3735 static pPLOC head_PLOC = 0;
3738 free_pipelocs(pTHX_ void *head)
3741 pPLOC *pHead = (pPLOC *)head;
3753 store_pipelocs(pTHX)
3762 char temp[NAM$C_MAXRSS+1];
3766 free_pipelocs(aTHX_ &head_PLOC);
3768 /* the . directory from @INC comes last */
3770 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3771 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3772 p->next = head_PLOC;
3774 strcpy(p->dir,"./");
3776 /* get the directory from $^X */
3778 unixdir = PerlMem_malloc(VMS_MAXRSS);
3779 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3781 #ifdef PERL_IMPLICIT_CONTEXT
3782 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3784 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3786 strcpy(temp, PL_origargv[0]);
3787 x = strrchr(temp,']');
3789 x = strrchr(temp,'>');
3791 /* It could be a UNIX path */
3792 x = strrchr(temp,'/');
3798 /* Got a bare name, so use default directory */
3803 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3804 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3805 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3806 p->next = head_PLOC;
3808 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3809 p->dir[NAM$C_MAXRSS] = '\0';
3813 /* reverse order of @INC entries, skip "." since entered above */
3815 #ifdef PERL_IMPLICIT_CONTEXT
3818 if (PL_incgv) av = GvAVn(PL_incgv);
3820 for (i = 0; av && i <= AvFILL(av); i++) {
3821 dirsv = *av_fetch(av,i,TRUE);
3823 if (SvROK(dirsv)) continue;
3824 dir = SvPVx(dirsv,n_a);
3825 if (strcmp(dir,".") == 0) continue;
3826 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3829 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3830 p->next = head_PLOC;
3832 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3833 p->dir[NAM$C_MAXRSS] = '\0';
3836 /* most likely spot (ARCHLIB) put first in the list */
3839 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3840 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3841 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3842 p->next = head_PLOC;
3844 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3845 p->dir[NAM$C_MAXRSS] = '\0';
3848 PerlMem_free(unixdir);
3852 Perl_cando_by_name_int
3853 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3854 #if !defined(PERL_IMPLICIT_CONTEXT)
3855 #define cando_by_name_int Perl_cando_by_name_int
3857 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3863 static int vmspipe_file_status = 0;
3864 static char vmspipe_file[NAM$C_MAXRSS+1];
3866 /* already found? Check and use ... need read+execute permission */
3868 if (vmspipe_file_status == 1) {
3869 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3870 && cando_by_name_int
3871 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3872 return vmspipe_file;
3874 vmspipe_file_status = 0;
3877 /* scan through stored @INC, $^X */
3879 if (vmspipe_file_status == 0) {
3880 char file[NAM$C_MAXRSS+1];
3881 pPLOC p = head_PLOC;
3886 strcpy(file, p->dir);
3887 dirlen = strlen(file);
3888 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3889 file[NAM$C_MAXRSS] = '\0';
3892 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3893 if (!exp_res) continue;
3895 if (cando_by_name_int
3896 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3897 && cando_by_name_int
3898 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3899 vmspipe_file_status = 1;
3900 return vmspipe_file;
3903 vmspipe_file_status = -1; /* failed, use tempfiles */
3910 vmspipe_tempfile(pTHX)
3912 char file[NAM$C_MAXRSS+1];
3914 static int index = 0;
3918 /* create a tempfile */
3920 /* we can't go from W, shr=get to R, shr=get without
3921 an intermediate vulnerable state, so don't bother trying...
3923 and lib$spawn doesn't shr=put, so have to close the write
3925 So... match up the creation date/time and the FID to
3926 make sure we're dealing with the same file
3931 if (!decc_filename_unix_only) {
3932 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3933 fp = fopen(file,"w");
3935 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3936 fp = fopen(file,"w");
3938 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3939 fp = fopen(file,"w");
3944 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3945 fp = fopen(file,"w");
3947 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3948 fp = fopen(file,"w");
3950 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3951 fp = fopen(file,"w");
3955 if (!fp) return 0; /* we're hosed */
3957 fprintf(fp,"$! 'f$verify(0)'\n");
3958 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3959 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3960 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3961 fprintf(fp,"$ perl_on = \"set noon\"\n");
3962 fprintf(fp,"$ perl_exit = \"exit\"\n");
3963 fprintf(fp,"$ perl_del = \"delete\"\n");
3964 fprintf(fp,"$ pif = \"if\"\n");
3965 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3966 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3967 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3968 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3969 fprintf(fp,"$! --- build command line to get max possible length\n");
3970 fprintf(fp,"$c=perl_popen_cmd0\n");
3971 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3972 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3973 fprintf(fp,"$x=perl_popen_cmd3\n");
3974 fprintf(fp,"$c=c+x\n");
3975 fprintf(fp,"$ perl_on\n");
3976 fprintf(fp,"$ 'c'\n");
3977 fprintf(fp,"$ perl_status = $STATUS\n");
3978 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3979 fprintf(fp,"$ perl_exit 'perl_status'\n");
3982 fgetname(fp, file, 1);
3983 fstat(fileno(fp), &s0.crtl_stat);
3986 if (decc_filename_unix_only)
3987 int_tounixspec(file, file, NULL);
3988 fp = fopen(file,"r","shr=get");
3990 fstat(fileno(fp), &s1.crtl_stat);
3992 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3993 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
4002 static int vms_is_syscommand_xterm(void)
4004 const static struct dsc$descriptor_s syscommand_dsc =
4005 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
4007 const static struct dsc$descriptor_s decwdisplay_dsc =
4008 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
4010 struct item_list_3 items[2];
4011 unsigned short dvi_iosb[4];
4012 unsigned long devchar;
4013 unsigned long devclass;
4016 /* Very simple check to guess if sys$command is a decterm? */
4017 /* First see if the DECW$DISPLAY: device exists */
4019 items[0].code = DVI$_DEVCHAR;
4020 items[0].bufadr = &devchar;
4021 items[0].retadr = NULL;
4025 status = sys$getdviw
4026 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
4028 if ($VMS_STATUS_SUCCESS(status)) {
4029 status = dvi_iosb[0];
4032 if (!$VMS_STATUS_SUCCESS(status)) {
4033 SETERRNO(EVMSERR, status);
4037 /* If it does, then for now assume that we are on a workstation */
4038 /* Now verify that SYS$COMMAND is a terminal */
4039 /* for creating the debugger DECTerm */
4042 items[0].code = DVI$_DEVCLASS;
4043 items[0].bufadr = &devclass;
4044 items[0].retadr = NULL;
4048 status = sys$getdviw
4049 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
4051 if ($VMS_STATUS_SUCCESS(status)) {
4052 status = dvi_iosb[0];
4055 if (!$VMS_STATUS_SUCCESS(status)) {
4056 SETERRNO(EVMSERR, status);
4060 if (devclass == DC$_TERM) {
4067 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
4068 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
4073 char device_name[65];
4074 unsigned short device_name_len;
4075 struct dsc$descriptor_s customization_dsc;
4076 struct dsc$descriptor_s device_name_dsc;
4079 char customization[200];
4083 unsigned short p_chan;
4085 unsigned short iosb[4];
4086 struct item_list_3 items[2];
4087 const char * cust_str =
4088 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4089 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4090 DSC$K_CLASS_S, mbx1};
4092 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4093 /*---------------------------------------*/
4094 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4097 /* Make sure that this is from the Perl debugger */
4098 ret_char = strstr(cmd," xterm ");
4099 if (ret_char == NULL)
4101 cptr = ret_char + 7;
4102 ret_char = strstr(cmd,"tty");
4103 if (ret_char == NULL)
4105 ret_char = strstr(cmd,"sleep");
4106 if (ret_char == NULL)
4109 if (decw_term_port == 0) {
4110 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4111 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4112 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4114 status = lib$find_image_symbol
4116 &decw_term_port_dsc,
4117 (void *)&decw_term_port,
4121 /* Try again with the other image name */
4122 if (!$VMS_STATUS_SUCCESS(status)) {
4124 status = lib$find_image_symbol
4126 &decw_term_port_dsc,
4127 (void *)&decw_term_port,
4136 /* No decw$term_port, give it up */
4137 if (!$VMS_STATUS_SUCCESS(status))
4140 /* Are we on a workstation? */
4141 /* to do: capture the rows / columns and pass their properties */
4142 ret_stat = vms_is_syscommand_xterm();
4146 /* Make the title: */
4147 ret_char = strstr(cptr,"-title");
4148 if (ret_char != NULL) {
4149 while ((*cptr != 0) && (*cptr != '\"')) {
4155 while ((*cptr != 0) && (*cptr != '\"')) {
4168 strcpy(title,"Perl Debug DECTerm");
4170 sprintf(customization, cust_str, title);
4172 customization_dsc.dsc$a_pointer = customization;
4173 customization_dsc.dsc$w_length = strlen(customization);
4174 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4175 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4177 device_name_dsc.dsc$a_pointer = device_name;
4178 device_name_dsc.dsc$w_length = sizeof device_name -1;
4179 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4180 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4182 device_name_len = 0;
4184 /* Try to create the window */
4185 status = (*decw_term_port)
4194 if (!$VMS_STATUS_SUCCESS(status)) {
4195 SETERRNO(EVMSERR, status);
4199 device_name[device_name_len] = '\0';
4201 /* Need to set this up to look like a pipe for cleanup */
4203 status = lib$get_vm(&n, &info);
4204 if (!$VMS_STATUS_SUCCESS(status)) {
4205 SETERRNO(ENOMEM, status);
4211 info->completion = 0;
4212 info->closing = FALSE;
4219 info->in_done = TRUE;
4220 info->out_done = TRUE;
4221 info->err_done = TRUE;
4223 /* Assign a channel on this so that it will persist, and not login */
4224 /* We stash this channel in the info structure for reference. */
4225 /* The created xterm self destructs when the last channel is removed */
4226 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4227 /* So leave this assigned. */
4228 device_name_dsc.dsc$w_length = device_name_len;
4229 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4230 if (!$VMS_STATUS_SUCCESS(status)) {
4231 SETERRNO(EVMSERR, status);
4234 info->xchan_valid = 1;
4236 /* Now create a mailbox to be read by the application */
4238 create_mbx(&p_chan, &d_mbx1);
4240 /* write the name of the created terminal to the mailbox */
4241 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4242 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4244 if (!$VMS_STATUS_SUCCESS(status)) {
4245 SETERRNO(EVMSERR, status);
4249 info->fp = PerlIO_open(mbx1, mode);
4251 /* Done with this channel */
4254 /* If any errors, then clean up */
4257 _ckvmssts_noperl(lib$free_vm(&n, &info));
4265 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4268 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4270 static int handler_set_up = FALSE;
4272 unsigned long int sts, flags = CLI$M_NOWAIT;
4273 /* The use of a GLOBAL table (as was done previously) rendered
4274 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4275 * environment. Hence we've switched to LOCAL symbol table.
4277 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4279 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4280 char *in, *out, *err, mbx[512];
4282 char tfilebuf[NAM$C_MAXRSS+1];
4284 char cmd_sym_name[20];
4285 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4286 DSC$K_CLASS_S, symbol};
4287 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4289 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4290 DSC$K_CLASS_S, cmd_sym_name};
4291 struct dsc$descriptor_s *vmscmd;
4292 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4293 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4294 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4296 /* Check here for Xterm create request. This means looking for
4297 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4298 * is possible to create an xterm.
4300 if (*in_mode == 'r') {
4303 #if defined(PERL_IMPLICIT_CONTEXT)
4304 /* Can not fork an xterm with a NULL context */
4305 /* This probably could never happen */
4309 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4310 if (xterm_fd != NULL)
4314 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4316 /* once-per-program initialization...
4317 note that the SETAST calls and the dual test of pipe_ef
4318 makes sure that only the FIRST thread through here does
4319 the initialization...all other threads wait until it's
4322 Yeah, uglier than a pthread call, it's got all the stuff inline
4323 rather than in a separate routine.
4327 _ckvmssts_noperl(sys$setast(0));
4329 unsigned long int pidcode = JPI$_PID;
4330 $DESCRIPTOR(d_delay, RETRY_DELAY);
4331 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4332 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4333 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4335 if (!handler_set_up) {
4336 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4337 handler_set_up = TRUE;
4339 _ckvmssts_noperl(sys$setast(1));
4342 /* see if we can find a VMSPIPE.COM */
4345 vmspipe = find_vmspipe(aTHX);
4347 strcpy(tfilebuf+1,vmspipe);
4348 } else { /* uh, oh...we're in tempfile hell */
4349 tpipe = vmspipe_tempfile(aTHX);
4350 if (!tpipe) { /* a fish popular in Boston */
4351 if (ckWARN(WARN_PIPE)) {
4352 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4356 fgetname(tpipe,tfilebuf+1,1);
4358 vmspipedsc.dsc$a_pointer = tfilebuf;
4359 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4361 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4364 case RMS$_FNF: case RMS$_DNF:
4365 set_errno(ENOENT); break;
4367 set_errno(ENOTDIR); break;
4369 set_errno(ENODEV); break;
4371 set_errno(EACCES); break;
4373 set_errno(EINVAL); break;
4374 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4375 set_errno(E2BIG); break;
4376 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4377 _ckvmssts_noperl(sts); /* fall through */
4378 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4381 set_vaxc_errno(sts);
4382 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4383 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4389 _ckvmssts_noperl(lib$get_vm(&n, &info));
4391 strcpy(mode,in_mode);
4394 info->completion = 0;
4395 info->closing = FALSE;
4402 info->in_done = TRUE;
4403 info->out_done = TRUE;
4404 info->err_done = TRUE;
4406 info->xchan_valid = 0;
4408 in = PerlMem_malloc(VMS_MAXRSS);
4409 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4410 out = PerlMem_malloc(VMS_MAXRSS);
4411 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4412 err = PerlMem_malloc(VMS_MAXRSS);
4413 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4415 in[0] = out[0] = err[0] = '\0';
4417 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4421 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4426 if (*mode == 'r') { /* piping from subroutine */
4428 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4430 info->out->pipe_done = &info->out_done;
4431 info->out_done = FALSE;
4432 info->out->info = info;
4434 if (!info->useFILE) {
4435 info->fp = PerlIO_open(mbx, mode);
4437 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4438 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4441 if (!info->fp && info->out) {
4442 sys$cancel(info->out->chan_out);
4444 while (!info->out_done) {
4446 _ckvmssts_noperl(sys$setast(0));
4447 done = info->out_done;
4448 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4449 _ckvmssts_noperl(sys$setast(1));
4450 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4453 if (info->out->buf) {
4454 n = info->out->bufsize * sizeof(char);
4455 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4458 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4460 _ckvmssts_noperl(lib$free_vm(&n, &info));
4465 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4467 info->err->pipe_done = &info->err_done;
4468 info->err_done = FALSE;
4469 info->err->info = info;
4472 } else if (*mode == 'w') { /* piping to subroutine */
4474 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4476 info->out->pipe_done = &info->out_done;
4477 info->out_done = FALSE;
4478 info->out->info = info;
4481 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4483 info->err->pipe_done = &info->err_done;
4484 info->err_done = FALSE;
4485 info->err->info = info;
4488 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4489 if (!info->useFILE) {
4490 info->fp = PerlIO_open(mbx, mode);
4492 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4493 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4497 info->in->pipe_done = &info->in_done;
4498 info->in_done = FALSE;
4499 info->in->info = info;
4503 if (!info->fp && info->in) {
4505 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4506 0, 0, 0, 0, 0, 0, 0, 0));
4508 while (!info->in_done) {
4510 _ckvmssts_noperl(sys$setast(0));
4511 done = info->in_done;
4512 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4513 _ckvmssts_noperl(sys$setast(1));
4514 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4517 if (info->in->buf) {
4518 n = info->in->bufsize * sizeof(char);
4519 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4522 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4524 _ckvmssts_noperl(lib$free_vm(&n, &info));
4530 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4531 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4533 info->out->pipe_done = &info->out_done;
4534 info->out_done = FALSE;
4535 info->out->info = info;
4538 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4540 info->err->pipe_done = &info->err_done;
4541 info->err_done = FALSE;
4542 info->err->info = info;
4546 symbol[MAX_DCL_SYMBOL] = '\0';
4548 strncpy(symbol, in, MAX_DCL_SYMBOL);
4549 d_symbol.dsc$w_length = strlen(symbol);
4550 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4552 strncpy(symbol, err, MAX_DCL_SYMBOL);
4553 d_symbol.dsc$w_length = strlen(symbol);
4554 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4556 strncpy(symbol, out, MAX_DCL_SYMBOL);
4557 d_symbol.dsc$w_length = strlen(symbol);
4558 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4560 /* Done with the names for the pipes */
4565 p = vmscmd->dsc$a_pointer;
4566 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4567 if (*p == '$') p++; /* remove leading $ */
4568 while (*p == ' ' || *p == '\t') p++;
4570 for (j = 0; j < 4; j++) {
4571 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4572 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4574 strncpy(symbol, p, MAX_DCL_SYMBOL);
4575 d_symbol.dsc$w_length = strlen(symbol);
4576 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4578 if (strlen(p) > MAX_DCL_SYMBOL) {
4579 p += MAX_DCL_SYMBOL;
4584 _ckvmssts_noperl(sys$setast(0));
4585 info->next=open_pipes; /* prepend to list */
4587 _ckvmssts_noperl(sys$setast(1));
4588 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4589 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4590 * have SYS$COMMAND if we need it.
4592 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4593 0, &info->pid, &info->completion,
4594 0, popen_completion_ast,info,0,0,0));
4596 /* if we were using a tempfile, close it now */
4598 if (tpipe) fclose(tpipe);
4600 /* once the subprocess is spawned, it has copied the symbols and
4601 we can get rid of ours */
4603 for (j = 0; j < 4; j++) {
4604 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4605 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4606 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4608 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4609 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4610 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4611 vms_execfree(vmscmd);
4613 #ifdef PERL_IMPLICIT_CONTEXT
4616 PL_forkprocess = info->pid;
4623 _ckvmssts_noperl(sys$setast(0));
4625 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4626 _ckvmssts_noperl(sys$setast(1));
4627 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4629 *psts = info->completion;
4630 /* Caller thinks it is open and tries to close it. */
4631 /* This causes some problems, as it changes the error status */
4632 /* my_pclose(info->fp); */
4634 /* If we did not have a file pointer open, then we have to */
4635 /* clean up here or eventually we will run out of something */
4637 if (info->fp == NULL) {
4638 my_pclose_pinfo(aTHX_ info);
4646 } /* end of safe_popen */
4649 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4651 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4655 TAINT_PROPER("popen");
4656 PERL_FLUSHALL_FOR_CHILD;
4657 return safe_popen(aTHX_ cmd,mode,&sts);
4663 /* Routine to close and cleanup a pipe info structure */
4665 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4667 unsigned long int retsts;
4672 /* If we were writing to a subprocess, insure that someone reading from
4673 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4674 * produce an EOF record in the mailbox.
4676 * well, at least sometimes it *does*, so we have to watch out for
4677 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4681 #if defined(USE_ITHREADS)
4684 && PL_perlio_fd_refcnt)
4685 PerlIO_flush(info->fp);
4687 fflush((FILE *)info->fp);
4690 _ckvmssts(sys$setast(0));
4691 info->closing = TRUE;
4692 done = info->done && info->in_done && info->out_done && info->err_done;
4693 /* hanging on write to Perl's input? cancel it */
4694 if (info->mode == 'r' && info->out && !info->out_done) {
4695 if (info->out->chan_out) {
4696 _ckvmssts(sys$cancel(info->out->chan_out));
4697 if (!info->out->chan_in) { /* EOF generation, need AST */
4698 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4702 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4703 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4705 _ckvmssts(sys$setast(1));
4708 #if defined(USE_ITHREADS)
4711 && PL_perlio_fd_refcnt)
4712 PerlIO_close(info->fp);
4714 fclose((FILE *)info->fp);
4717 we have to wait until subprocess completes, but ALSO wait until all
4718 the i/o completes...otherwise we'll be freeing the "info" structure
4719 that the i/o ASTs could still be using...
4723 _ckvmssts(sys$setast(0));
4724 done = info->done && info->in_done && info->out_done && info->err_done;
4725 if (!done) _ckvmssts(sys$clref(pipe_ef));
4726 _ckvmssts(sys$setast(1));
4727 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4729 retsts = info->completion;
4731 /* remove from list of open pipes */
4732 _ckvmssts(sys$setast(0));
4734 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4740 last->next = info->next;
4742 open_pipes = info->next;
4743 _ckvmssts(sys$setast(1));
4745 /* free buffers and structures */
4748 if (info->in->buf) {
4749 n = info->in->bufsize * sizeof(char);
4750 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4753 _ckvmssts(lib$free_vm(&n, &info->in));
4756 if (info->out->buf) {
4757 n = info->out->bufsize * sizeof(char);
4758 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4761 _ckvmssts(lib$free_vm(&n, &info->out));
4764 if (info->err->buf) {
4765 n = info->err->bufsize * sizeof(char);
4766 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4769 _ckvmssts(lib$free_vm(&n, &info->err));
4772 _ckvmssts(lib$free_vm(&n, &info));
4778 /*{{{ I32 my_pclose(PerlIO *fp)*/
4779 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4781 pInfo info, last = NULL;
4784 /* Fixme - need ast and mutex protection here */
4785 for (info = open_pipes; info != NULL; last = info, info = info->next)
4786 if (info->fp == fp) break;
4788 if (info == NULL) { /* no such pipe open */
4789 set_errno(ECHILD); /* quoth POSIX */
4790 set_vaxc_errno(SS$_NONEXPR);
4794 ret_status = my_pclose_pinfo(aTHX_ info);
4798 } /* end of my_pclose() */
4800 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4801 /* Roll our own prototype because we want this regardless of whether
4802 * _VMS_WAIT is defined.
4804 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4806 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4807 created with popen(); otherwise partially emulate waitpid() unless
4808 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4809 Also check processes not considered by the CRTL waitpid().
4811 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4813 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4820 if (statusp) *statusp = 0;
4822 for (info = open_pipes; info != NULL; info = info->next)
4823 if (info->pid == pid) break;
4825 if (info != NULL) { /* we know about this child */
4826 while (!info->done) {
4827 _ckvmssts(sys$setast(0));
4829 if (!done) _ckvmssts(sys$clref(pipe_ef));
4830 _ckvmssts(sys$setast(1));
4831 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4834 if (statusp) *statusp = info->completion;
4838 /* child that already terminated? */
4840 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4841 if (closed_list[j].pid == pid) {
4842 if (statusp) *statusp = closed_list[j].completion;
4847 /* fall through if this child is not one of our own pipe children */
4849 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4851 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4852 * in 7.2 did we get a version that fills in the VMS completion
4853 * status as Perl has always tried to do.
4856 sts = __vms_waitpid( pid, statusp, flags );
4858 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4861 /* If the real waitpid tells us the child does not exist, we
4862 * fall through here to implement waiting for a child that
4863 * was created by some means other than exec() (say, spawned
4864 * from DCL) or to wait for a process that is not a subprocess
4865 * of the current process.
4868 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4871 $DESCRIPTOR(intdsc,"0 00:00:01");
4872 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4873 unsigned long int pidcode = JPI$_PID, mypid;
4874 unsigned long int interval[2];
4875 unsigned int jpi_iosb[2];
4876 struct itmlst_3 jpilist[2] = {
4877 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4882 /* Sorry folks, we don't presently implement rooting around for
4883 the first child we can find, and we definitely don't want to
4884 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4890 /* Get the owner of the child so I can warn if it's not mine. If the
4891 * process doesn't exist or I don't have the privs to look at it,
4892 * I can go home early.
4894 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4895 if (sts & 1) sts = jpi_iosb[0];
4907 set_vaxc_errno(sts);
4911 if (ckWARN(WARN_EXEC)) {
4912 /* remind folks they are asking for non-standard waitpid behavior */
4913 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4914 if (ownerpid != mypid)
4915 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4916 "waitpid: process %x is not a child of process %x",
4920 /* simply check on it once a second until it's not there anymore. */
4922 _ckvmssts(sys$bintim(&intdsc,interval));
4923 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4924 _ckvmssts(sys$schdwk(0,0,interval,0));
4925 _ckvmssts(sys$hiber());
4927 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4932 } /* end of waitpid() */
4937 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4939 my_gconvert(double val, int ndig, int trail, char *buf)
4941 static char __gcvtbuf[DBL_DIG+1];
4944 loc = buf ? buf : __gcvtbuf;
4946 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4948 sprintf(loc,"%.*g",ndig,val);
4954 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4955 return gcvt(val,ndig,loc);
4958 loc[0] = '0'; loc[1] = '\0';
4965 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4966 static int rms_free_search_context(struct FAB * fab)
4970 nam = fab->fab$l_nam;
4971 nam->nam$b_nop |= NAM$M_SYNCHK;
4972 nam->nam$l_rlf = NULL;
4974 return sys$parse(fab, NULL, NULL);
4977 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4978 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4979 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4980 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4981 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4982 #define rms_nam_esll(nam) nam.nam$b_esl
4983 #define rms_nam_esl(nam) nam.nam$b_esl
4984 #define rms_nam_name(nam) nam.nam$l_name
4985 #define rms_nam_namel(nam) nam.nam$l_name
4986 #define rms_nam_type(nam) nam.nam$l_type
4987 #define rms_nam_typel(nam) nam.nam$l_type
4988 #define rms_nam_ver(nam) nam.nam$l_ver
4989 #define rms_nam_verl(nam) nam.nam$l_ver
4990 #define rms_nam_rsll(nam) nam.nam$b_rsl
4991 #define rms_nam_rsl(nam) nam.nam$b_rsl
4992 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4993 #define rms_set_fna(fab, nam, name, size) \
4994 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4995 #define rms_get_fna(fab, nam) fab.fab$l_fna
4996 #define rms_set_dna(fab, nam, name, size) \
4997 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4998 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4999 #define rms_set_esa(nam, name, size) \
5000 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
5001 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5002 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
5003 #define rms_set_rsa(nam, name, size) \
5004 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
5005 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5006 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
5007 #define rms_nam_name_type_l_size(nam) \
5008 (nam.nam$b_name + nam.nam$b_type)
5010 static int rms_free_search_context(struct FAB * fab)
5014 nam = fab->fab$l_naml;
5015 nam->naml$b_nop |= NAM$M_SYNCHK;
5016 nam->naml$l_rlf = NULL;
5017 nam->naml$l_long_defname_size = 0;
5020 return sys$parse(fab, NULL, NULL);
5023 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
5024 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
5025 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
5026 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
5027 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
5028 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
5029 #define rms_nam_esl(nam) nam.naml$b_esl
5030 #define rms_nam_name(nam) nam.naml$l_name
5031 #define rms_nam_namel(nam) nam.naml$l_long_name
5032 #define rms_nam_type(nam) nam.naml$l_type
5033 #define rms_nam_typel(nam) nam.naml$l_long_type
5034 #define rms_nam_ver(nam) nam.naml$l_ver
5035 #define rms_nam_verl(nam) nam.naml$l_long_ver
5036 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
5037 #define rms_nam_rsl(nam) nam.naml$b_rsl
5038 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
5039 #define rms_set_fna(fab, nam, name, size) \
5040 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
5041 nam.naml$l_long_filename_size = size; \
5042 nam.naml$l_long_filename = name;}
5043 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
5044 #define rms_set_dna(fab, nam, name, size) \
5045 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
5046 nam.naml$l_long_defname_size = size; \
5047 nam.naml$l_long_defname = name; }
5048 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
5049 #define rms_set_esa(nam, name, size) \
5050 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
5051 nam.naml$l_long_expand_alloc = size; \
5052 nam.naml$l_long_expand = name; }
5053 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
5054 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
5055 nam.naml$l_long_expand = l_name; \
5056 nam.naml$l_long_expand_alloc = l_size; }
5057 #define rms_set_rsa(nam, name, size) \
5058 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
5059 nam.naml$l_long_result = name; \
5060 nam.naml$l_long_result_alloc = size; }
5061 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
5062 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
5063 nam.naml$l_long_result = l_name; \
5064 nam.naml$l_long_result_alloc = l_size; }
5065 #define rms_nam_name_type_l_size(nam) \
5066 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
5071 * The CRTL for 8.3 and later can create symbolic links in any mode,
5072 * however in 8.3 the unlink/remove/delete routines will only properly handle
5073 * them if one of the PCP modes is active.
5075 static int rms_erase(const char * vmsname)
5078 struct FAB myfab = cc$rms_fab;
5079 rms_setup_nam(mynam);
5081 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
5082 rms_bind_fab_nam(myfab, mynam);
5084 #ifdef NAML$M_OPEN_SPECIAL
5085 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5088 status = sys$erase(&myfab, 0, 0);
5095 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5096 const struct dsc$descriptor_s * vms_dst_dsc,
5097 unsigned long flags)
5099 /* VMS and UNIX handle file permissions differently and the
5100 * the same ACL trick may be needed for renaming files,
5101 * especially if they are directories.
5104 /* todo: get kill_file and rename to share common code */
5105 /* I can not find online documentation for $change_acl
5106 * it appears to be replaced by $set_security some time ago */
5108 const unsigned int access_mode = 0;
5109 $DESCRIPTOR(obj_file_dsc,"FILE");
5112 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5113 int aclsts, fndsts, rnsts = -1;
5114 unsigned int ctx = 0;
5115 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5116 struct dsc$descriptor_s * clean_dsc;
5119 unsigned char myace$b_length;
5120 unsigned char myace$b_type;
5121 unsigned short int myace$w_flags;
5122 unsigned long int myace$l_access;
5123 unsigned long int myace$l_ident;
5124 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5125 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5127 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5130 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5131 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5133 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5134 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5138 /* Expand the input spec using RMS, since we do not want to put
5139 * ACLs on the target of a symbolic link */
5140 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5141 if (vmsname == NULL)
5144 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5146 PERL_RMSEXPAND_M_SYMLINK);
5148 PerlMem_free(vmsname);
5152 /* So we get our own UIC to use as a rights identifier,
5153 * and the insert an ACE at the head of the ACL which allows us
5154 * to delete the file.
5156 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5158 fildsc.dsc$w_length = strlen(vmsname);
5159 fildsc.dsc$a_pointer = vmsname;
5161 newace.myace$l_ident = oldace.myace$l_ident;
5164 /* Grab any existing ACEs with this identifier in case we fail */
5165 clean_dsc = &fildsc;
5166 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5174 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5175 /* Add the new ACE . . . */
5177 /* if the sys$get_security succeeded, then ctx is valid, and the
5178 * object/file descriptors will be ignored. But otherwise they
5181 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5182 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5183 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5185 set_vaxc_errno(aclsts);
5186 PerlMem_free(vmsname);
5190 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5193 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5195 if ($VMS_STATUS_SUCCESS(rnsts)) {
5196 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5199 /* Put things back the way they were. */
5201 aclsts = sys$get_security(&obj_file_dsc,
5209 if ($VMS_STATUS_SUCCESS(aclsts)) {
5213 if (!$VMS_STATUS_SUCCESS(fndsts))
5214 sec_flags = OSS$M_RELCTX;
5216 /* Get rid of the new ACE */
5217 aclsts = sys$set_security(NULL, NULL, NULL,
5218 sec_flags, dellst, &ctx, &access_mode);
5220 /* If there was an old ACE, put it back */
5221 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5222 addlst[0].bufadr = &oldace;
5223 aclsts = sys$set_security(NULL, NULL, NULL,
5224 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5225 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5227 set_vaxc_errno(aclsts);
5233 /* Try to clear the lock on the ACL list */
5234 aclsts2 = sys$set_security(NULL, NULL, NULL,
5235 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5237 /* Rename errors are most important */
5238 if (!$VMS_STATUS_SUCCESS(rnsts))
5241 set_vaxc_errno(aclsts);
5246 if (aclsts != SS$_ACLEMPTY)
5253 PerlMem_free(vmsname);
5258 /*{{{int rename(const char *, const char * */
5259 /* Not exactly what X/Open says to do, but doing it absolutely right
5260 * and efficiently would require a lot more work. This should be close
5261 * enough to pass all but the most strict X/Open compliance test.
5264 Perl_rename(pTHX_ const char *src, const char * dst)
5273 /* Validate the source file */
5274 src_sts = flex_lstat(src, &src_st);
5277 /* No source file or other problem */
5280 if (src_st.st_devnam[0] == 0) {
5281 /* This may be possible so fail if it is seen. */
5286 dst_sts = flex_lstat(dst, &dst_st);
5289 if (dst_st.st_dev != src_st.st_dev) {
5290 /* Must be on the same device */
5295 /* VMS_INO_T_COMPARE is true if the inodes are different
5296 * to match the output of memcmp
5299 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5300 /* That was easy, the files are the same! */
5304 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5305 /* If source is a directory, so must be dest */
5313 if ((dst_sts == 0) &&
5314 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5316 /* We have issues here if vms_unlink_all_versions is set
5317 * If the destination exists, and is not a directory, then
5318 * we must delete in advance.
5320 * If the src is a directory, then we must always pre-delete
5323 * If we successfully delete the dst in advance, and the rename fails
5324 * X/Open requires that errno be EIO.
5328 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5330 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam,
5331 S_ISDIR(dst_st.st_mode));
5333 /* Need to delete all versions ? */
5334 if ((d_sts == 0) && (vms_unlink_all_versions == 1)) {
5337 while (lstat(dst_st.st_devnam, &dst_st.crtl_stat) == 0) {
5338 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 0);
5343 /* Make sure that we do not loop forever */
5355 /* We killed the destination, so only errno now is EIO */
5360 /* Originally the idea was to call the CRTL rename() and only
5361 * try the lib$rename_file if it failed.
5362 * It turns out that there are too many variants in what the
5363 * the CRTL rename might do, so only use lib$rename_file
5368 /* Is the source and dest both in VMS format */
5369 /* if the source is a directory, then need to fileify */
5370 /* and dest must be a directory or non-existant. */
5375 unsigned long flags;
5376 struct dsc$descriptor_s old_file_dsc;
5377 struct dsc$descriptor_s new_file_dsc;
5379 /* We need to modify the src and dst depending
5380 * on if one or more of them are directories.
5383 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5384 if (vms_dst == NULL)
5385 _ckvmssts_noperl(SS$_INSFMEM);
5387 if (S_ISDIR(src_st.st_mode)) {
5389 char * vms_dir_file;
5391 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5392 if (vms_dir_file == NULL)
5393 _ckvmssts_noperl(SS$_INSFMEM);
5395 /* If the dest is a directory, we must remove it
5398 d_sts = mp_do_kill_file(aTHX_ dst_st.st_devnam, 1);
5400 PerlMem_free(vms_dst);
5408 /* The dest must be a VMS file specification */
5409 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5410 if (ret_str == NULL) {
5411 PerlMem_free(vms_dst);
5416 /* The source must be a file specification */
5417 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5418 if (vms_dir_file == NULL)
5419 _ckvmssts_noperl(SS$_INSFMEM);
5421 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5422 if (ret_str == NULL) {
5423 PerlMem_free(vms_dst);
5424 PerlMem_free(vms_dir_file);
5428 PerlMem_free(vms_dst);
5429 vms_dst = vms_dir_file;
5432 /* File to file or file to new dir */
5434 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5435 /* VMS pathify a dir target */
5436 ret_str = int_tovmspath(dst, vms_dst, NULL);
5437 if (ret_str == NULL) {
5438 PerlMem_free(vms_dst);
5443 char * v_spec, * r_spec, * d_spec, * n_spec;
5444 char * e_spec, * vs_spec;
5445 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5447 /* fileify a target VMS file specification */
5448 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5449 if (ret_str == NULL) {
5450 PerlMem_free(vms_dst);
5455 sts = vms_split_path(vms_dst, &v_spec, &v_len, &r_spec, &r_len,
5456 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5457 &e_len, &vs_spec, &vs_len);
5460 /* Get rid of the version */
5464 /* Need to specify a '.' so that the extension */
5465 /* is not inherited */
5466 strcat(vms_dst,".");
5472 old_file_dsc.dsc$a_pointer = src_st.st_devnam;
5473 old_file_dsc.dsc$w_length = strlen(src_st.st_devnam);
5474 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5475 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5477 new_file_dsc.dsc$a_pointer = vms_dst;
5478 new_file_dsc.dsc$w_length = strlen(vms_dst);
5479 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5480 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5483 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5484 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5487 sts = lib$rename_file(&old_file_dsc,
5491 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5492 if (!$VMS_STATUS_SUCCESS(sts)) {
5494 /* We could have failed because VMS style permissions do not
5495 * permit renames that UNIX will allow. Just like the hack
5498 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5501 PerlMem_free(vms_dst);
5502 if (!$VMS_STATUS_SUCCESS(sts)) {
5509 if (vms_unlink_all_versions) {
5510 /* Now get rid of any previous versions of the source file that
5516 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5517 S_ISDIR(src_st.st_mode));
5518 while (lstat(src_st.st_devnam, &src_st.crtl_stat) == 0) {
5519 src_sts = mp_do_kill_file(aTHX_ src_st.st_devnam,
5520 S_ISDIR(src_st.st_mode));
5525 /* Make sure that we do not loop forever */
5534 /* We deleted the destination, so must force the error to be EIO */
5535 if ((retval != 0) && (pre_delete != 0))
5543 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5544 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5545 * to expand file specification. Allows for a single default file
5546 * specification and a simple mask of options. If outbuf is non-NULL,
5547 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5548 * the resultant file specification is placed. If outbuf is NULL, the
5549 * resultant file specification is placed into a static buffer.
5550 * The third argument, if non-NULL, is taken to be a default file
5551 * specification string. The fourth argument is unused at present.
5552 * rmesexpand() returns the address of the resultant string if
5553 * successful, and NULL on error.
5555 * New functionality for previously unused opts value:
5556 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5557 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5558 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5559 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5561 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5565 (const char *filespec,
5567 const char *defspec,
5573 const char * in_spec;
5575 const char * def_spec;
5576 char * vmsfspec, *vmsdefspec;
5580 struct FAB myfab = cc$rms_fab;
5581 rms_setup_nam(mynam);
5583 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5586 /* temp hack until UTF8 is actually implemented */
5587 if (fs_utf8 != NULL)
5590 if (!filespec || !*filespec) {
5591 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5601 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5602 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5603 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5605 /* If this is a UNIX file spec, convert it to VMS */
5606 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5607 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5608 &e_len, &vs_spec, &vs_len);
5613 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5614 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5615 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5616 if (ret_spec == NULL) {
5617 PerlMem_free(vmsfspec);
5620 in_spec = (const char *)vmsfspec;
5622 /* Unless we are forcing to VMS format, a UNIX input means
5623 * UNIX output, and that requires long names to be used
5625 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5626 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5627 opts |= PERL_RMSEXPAND_M_LONG;
5637 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5638 rms_bind_fab_nam(myfab, mynam);
5640 /* Process the default file specification if present */
5642 if (defspec && *defspec) {
5644 t_isunix = is_unix_filespec(defspec);
5646 vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5647 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5648 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5650 if (ret_spec == NULL) {
5651 /* Clean up and bail */
5652 PerlMem_free(vmsdefspec);
5653 if (vmsfspec != NULL)
5654 PerlMem_free(vmsfspec);
5657 def_spec = (const char *)vmsdefspec;
5659 rms_set_dna(myfab, mynam,
5660 (char *)def_spec, strlen(def_spec)); /* cast ok */
5663 /* Now we need the expansion buffers */
5664 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5665 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5666 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5667 esal = PerlMem_malloc(VMS_MAXRSS);
5668 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5670 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5672 /* If a NAML block is used RMS always writes to the long and short
5673 * addresses unless you suppress the short name.
5675 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5676 outbufl = PerlMem_malloc(VMS_MAXRSS);
5677 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5679 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5681 #ifdef NAM$M_NO_SHORT_UPCASE
5682 if (decc_efs_case_preserve)
5683 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5686 /* We may not want to follow symbolic links */
5687 #ifdef NAML$M_OPEN_SPECIAL
5688 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5689 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5692 /* First attempt to parse as an existing file */
5693 retsts = sys$parse(&myfab,0,0);
5694 if (!(retsts & STS$K_SUCCESS)) {
5696 /* Could not find the file, try as syntax only if error is not fatal */
5697 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5698 if (retsts == RMS$_DNF ||
5699 retsts == RMS$_DIR ||
5700 retsts == RMS$_DEV ||
5701 retsts == RMS$_PRV) {
5702 retsts = sys$parse(&myfab,0,0);
5703 if (retsts & STS$K_SUCCESS) goto int_expanded;
5706 /* Still could not parse the file specification */
5707 /*----------------------------------------------*/
5708 sts = rms_free_search_context(&myfab); /* Free search context */
5709 if (vmsdefspec != NULL)
5710 PerlMem_free(vmsdefspec);
5711 if (vmsfspec != NULL)
5712 PerlMem_free(vmsfspec);
5713 if (outbufl != NULL)
5714 PerlMem_free(outbufl);
5718 set_vaxc_errno(retsts);
5719 if (retsts == RMS$_PRV) set_errno(EACCES);
5720 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5721 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5722 else set_errno(EVMSERR);
5725 retsts = sys$search(&myfab,0,0);
5726 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5727 sts = rms_free_search_context(&myfab); /* Free search context */
5728 if (vmsdefspec != NULL)
5729 PerlMem_free(vmsdefspec);
5730 if (vmsfspec != NULL)
5731 PerlMem_free(vmsfspec);
5732 if (outbufl != NULL)
5733 PerlMem_free(outbufl);
5737 set_vaxc_errno(retsts);
5738 if (retsts == RMS$_PRV) set_errno(EACCES);
5739 else set_errno(EVMSERR);
5743 /* If the input filespec contained any lowercase characters,
5744 * downcase the result for compatibility with Unix-minded code. */
5746 if (!decc_efs_case_preserve) {
5748 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5749 if (islower(*tbuf)) { haslower = 1; break; }
5752 /* Is a long or a short name expected */
5753 /*------------------------------------*/
5755 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5756 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5757 if (rms_nam_rsll(mynam)) {
5759 speclen = rms_nam_rsll(mynam);
5762 spec_buf = esal; /* Not esa */
5763 speclen = rms_nam_esll(mynam);
5768 if (rms_nam_rsl(mynam)) {
5770 speclen = rms_nam_rsl(mynam);
5773 spec_buf = esa; /* Not esal */
5774 speclen = rms_nam_esl(mynam);
5776 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5779 spec_buf[speclen] = '\0';
5781 /* Trim off null fields added by $PARSE
5782 * If type > 1 char, must have been specified in original or default spec
5783 * (not true for version; $SEARCH may have added version of existing file).
5785 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5786 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5787 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5788 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5791 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5792 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5794 if (trimver || trimtype) {
5795 if (defspec && *defspec) {
5796 char *defesal = NULL;
5797 char *defesa = NULL;
5798 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5799 if (defesa != NULL) {
5800 struct FAB deffab = cc$rms_fab;
5801 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5802 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5803 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5805 rms_setup_nam(defnam);
5807 rms_bind_fab_nam(deffab, defnam);
5811 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5813 /* RMS needs the esa/esal as a work area if wildcards are involved */
5814 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5816 rms_clear_nam_nop(defnam);
5817 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5818 #ifdef NAM$M_NO_SHORT_UPCASE
5819 if (decc_efs_case_preserve)
5820 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5822 #ifdef NAML$M_OPEN_SPECIAL
5823 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5824 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5826 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5828 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5831 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5834 if (defesal != NULL)
5835 PerlMem_free(defesal);
5836 PerlMem_free(defesa);
5838 _ckvmssts_noperl(SS$_INSFMEM);
5842 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5843 if (*(rms_nam_verl(mynam)) != '\"')
5844 speclen = rms_nam_verl(mynam) - spec_buf;
5847 if (*(rms_nam_ver(mynam)) != '\"')
5848 speclen = rms_nam_ver(mynam) - spec_buf;
5852 /* If we didn't already trim version, copy down */
5853 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5854 if (speclen > rms_nam_verl(mynam) - spec_buf)
5856 (rms_nam_typel(mynam),
5857 rms_nam_verl(mynam),
5858 speclen - (rms_nam_verl(mynam) - spec_buf));
5859 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5862 if (speclen > rms_nam_ver(mynam) - spec_buf)
5864 (rms_nam_type(mynam),
5866 speclen - (rms_nam_ver(mynam) - spec_buf));
5867 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5872 /* Done with these copies of the input files */
5873 /*-------------------------------------------*/
5874 if (vmsfspec != NULL)
5875 PerlMem_free(vmsfspec);
5876 if (vmsdefspec != NULL)
5877 PerlMem_free(vmsdefspec);
5879 /* If we just had a directory spec on input, $PARSE "helpfully"
5880 * adds an empty name and type for us */
5881 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5882 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5883 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5884 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5885 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5886 speclen = rms_nam_namel(mynam) - spec_buf;
5891 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5892 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5893 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5894 speclen = rms_nam_name(mynam) - spec_buf;
5897 /* Posix format specifications must have matching quotes */
5898 if (speclen < (VMS_MAXRSS - 1)) {
5899 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5900 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5901 spec_buf[speclen] = '\"';
5906 spec_buf[speclen] = '\0';
5907 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5909 /* Have we been working with an expanded, but not resultant, spec? */
5910 /* Also, convert back to Unix syntax if necessary. */
5914 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5915 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5916 rsl = rms_nam_rsll(mynam);
5920 rsl = rms_nam_rsl(mynam);
5923 /* rsl is not present, it means that spec_buf is either */
5924 /* esa or esal, and needs to be copied to outbuf */
5925 /* convert to Unix if desired */
5927 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5929 /* VMS file specs are not in UTF-8 */
5930 if (fs_utf8 != NULL)
5932 strcpy(outbuf, spec_buf);
5937 /* Now spec_buf is either outbuf or outbufl */
5938 /* We need the result into outbuf */
5940 /* If we need this in UNIX, then we need another buffer */
5941 /* to keep things in order */
5943 char * new_src = NULL;
5944 if (spec_buf == outbuf) {
5945 new_src = PerlMem_malloc(VMS_MAXRSS);
5946 strcpy(new_src, spec_buf);
5950 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5952 PerlMem_free(new_src);
5955 /* VMS file specs are not in UTF-8 */
5956 if (fs_utf8 != NULL)
5959 /* Copy the buffer if needed */
5960 if (outbuf != spec_buf)
5961 strcpy(outbuf, spec_buf);
5967 /* Need to clean up the search context */
5968 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5969 sts = rms_free_search_context(&myfab); /* Free search context */
5971 /* Clean up the extra buffers */
5975 if (outbufl != NULL)
5976 PerlMem_free(outbufl);
5978 /* Return the result */
5982 /* Common simple case - Expand an already VMS spec */
5984 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5985 opts |= PERL_RMSEXPAND_M_VMS_IN;
5986 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5989 /* Common simple case - Expand to a VMS spec */
5991 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5992 opts |= PERL_RMSEXPAND_M_VMS;
5993 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5997 /* Entry point used by perl routines */
6000 (pTHX_ const char *filespec,
6003 const char *defspec,
6008 static char __rmsexpand_retbuf[VMS_MAXRSS];
6009 char * expanded, *ret_spec, *ret_buf;
6013 if (ret_buf == NULL) {
6015 Newx(expanded, VMS_MAXRSS, char);
6016 if (expanded == NULL)
6017 _ckvmssts(SS$_INSFMEM);
6020 ret_buf = __rmsexpand_retbuf;
6025 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
6026 opts, fs_utf8, dfs_utf8);
6028 if (ret_spec == NULL) {
6029 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6037 /* External entry points */
6038 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6039 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
6040 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
6041 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
6042 char *Perl_rmsexpand_utf8
6043 (pTHX_ const char *spec, char *buf, const char *def,
6044 unsigned opt, int * fs_utf8, int * dfs_utf8)
6045 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
6046 char *Perl_rmsexpand_utf8_ts
6047 (pTHX_ const char *spec, char *buf, const char *def,
6048 unsigned opt, int * fs_utf8, int * dfs_utf8)
6049 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
6053 ** The following routines are provided to make life easier when
6054 ** converting among VMS-style and Unix-style directory specifications.
6055 ** All will take input specifications in either VMS or Unix syntax. On
6056 ** failure, all return NULL. If successful, the routines listed below
6057 ** return a pointer to a buffer containing the appropriately
6058 ** reformatted spec (and, therefore, subsequent calls to that routine
6059 ** will clobber the result), while the routines of the same names with
6060 ** a _ts suffix appended will return a pointer to a mallocd string
6061 ** containing the appropriately reformatted spec.
6062 ** In all cases, only explicit syntax is altered; no check is made that
6063 ** the resulting string is valid or that the directory in question
6066 ** fileify_dirspec() - convert a directory spec into the name of the
6067 ** directory file (i.e. what you can stat() to see if it's a dir).
6068 ** The style (VMS or Unix) of the result is the same as the style
6069 ** of the parameter passed in.
6070 ** pathify_dirspec() - convert a directory spec into a path (i.e.
6071 ** what you prepend to a filename to indicate what directory it's in).
6072 ** The style (VMS or Unix) of the result is the same as the style
6073 ** of the parameter passed in.
6074 ** tounixpath() - convert a directory spec into a Unix-style path.
6075 ** tovmspath() - convert a directory spec into a VMS-style path.
6076 ** tounixspec() - convert any file spec into a Unix-style file spec.
6077 ** tovmsspec() - convert any file spec into a VMS-style spec.
6078 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
6080 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
6081 ** Permission is given to distribute this code as part of the Perl
6082 ** standard distribution under the terms of the GNU General Public
6083 ** License or the Perl Artistic License. Copies of each may be
6084 ** found in the Perl standard distribution.
6087 /*{{{ char * int_fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6089 int_fileify_dirspec(const char *dir, char *buf, int *utf8_fl)
6091 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
6092 char *cp1, *cp2, *lastdir;
6093 char *trndir, *vmsdir;
6094 unsigned short int trnlnm_iter_count;
6098 if (utf8_fl != NULL)
6101 if (!dir || !*dir) {
6102 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
6104 dirlen = strlen(dir);
6105 while (dirlen && dir[dirlen-1] == '/') --dirlen;
6106 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
6107 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
6114 if (dirlen > (VMS_MAXRSS - 1)) {
6115 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6118 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6119 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6120 if (!strpbrk(dir+1,"/]>:") &&
6121 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6122 strcpy(trndir,*dir == '/' ? dir + 1: dir);
6123 trnlnm_iter_count = 0;
6124 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6125 trnlnm_iter_count++;
6126 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6128 dirlen = strlen(trndir);
6131 strncpy(trndir,dir,dirlen);
6132 trndir[dirlen] = '\0';
6135 /* At this point we are done with *dir and use *trndir which is a
6136 * copy that can be modified. *dir must not be modified.
6139 /* If we were handed a rooted logical name or spec, treat it like a
6140 * simple directory, so that
6141 * $ Define myroot dev:[dir.]
6142 * ... do_fileify_dirspec("myroot",buf,1) ...
6143 * does something useful.
6145 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6146 trndir[--dirlen] = '\0';
6147 trndir[dirlen-1] = ']';
6149 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6150 trndir[--dirlen] = '\0';
6151 trndir[dirlen-1] = '>';
6154 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6155 /* If we've got an explicit filename, we can just shuffle the string. */
6156 if (*(cp1+1)) hasfilename = 1;
6157 /* Similarly, we can just back up a level if we've got multiple levels
6158 of explicit directories in a VMS spec which ends with directories. */
6160 for (cp2 = cp1; cp2 > trndir; cp2--) {
6162 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6163 /* fix-me, can not scan EFS file specs backward like this */
6164 *cp2 = *cp1; *cp1 = '\0';
6169 if (*cp2 == '[' || *cp2 == '<') break;
6174 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6175 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6176 cp1 = strpbrk(trndir,"]:>");
6177 if (hasfilename || !cp1) { /* filename present or not VMS */
6179 if (decc_efs_charset && !cp1) {
6181 /* EFS handling for UNIX mode */
6183 /* Just remove the trailing '/' and we should be done */
6185 trndir_len = strlen(trndir);
6187 if (trndir_len > 1) {
6189 if (trndir[trndir_len] == '/') {
6190 trndir[trndir_len] = '\0';
6193 strcpy(buf, trndir);
6194 PerlMem_free(trndir);
6195 PerlMem_free(vmsdir);
6199 /* For non-EFS mode, this is left for backwards compatibility */
6200 /* For EFS mode, this is only done for VMS format filespecs as */
6201 /* Perl programs generally have problems when a UNIX format spec */
6202 /* returns a VMS format spec */
6203 if (trndir[0] == '.') {
6204 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6205 PerlMem_free(trndir);
6206 PerlMem_free(vmsdir);
6207 return int_fileify_dirspec("[]", buf, NULL);
6209 else if (trndir[1] == '.' &&
6210 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6211 PerlMem_free(trndir);
6212 PerlMem_free(vmsdir);
6213 return int_fileify_dirspec("[-]", buf, NULL);
6216 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
6217 dirlen -= 1; /* to last element */
6218 lastdir = strrchr(trndir,'/');
6220 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6221 /* If we have "/." or "/..", VMSify it and let the VMS code
6222 * below expand it, rather than repeating the code to handle
6223 * relative components of a filespec here */
6225 if (*(cp1+2) == '.') cp1++;
6226 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6228 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6229 PerlMem_free(trndir);
6230 PerlMem_free(vmsdir);
6233 if (strchr(vmsdir,'/') != NULL) {
6234 /* If int_tovmsspec() returned it, it must have VMS syntax
6235 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6236 * the time to check this here only so we avoid a recursion
6237 * loop; otherwise, gigo.
6239 PerlMem_free(trndir);
6240 PerlMem_free(vmsdir);
6241 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6244 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6245 PerlMem_free(trndir);
6246 PerlMem_free(vmsdir);
6249 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6250 PerlMem_free(trndir);
6251 PerlMem_free(vmsdir);
6255 } while ((cp1 = strstr(cp1,"/.")) != NULL);
6256 lastdir = strrchr(trndir,'/');
6258 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6260 /* Ditto for specs that end in an MFD -- let the VMS code
6261 * figure out whether it's a real device or a rooted logical. */
6263 /* This should not happen any more. Allowing the fake /000000
6264 * in a UNIX pathname causes all sorts of problems when trying
6265 * to run in UNIX emulation. So the VMS to UNIX conversions
6266 * now remove the fake /000000 directories.
6269 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6270 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6271 PerlMem_free(trndir);
6272 PerlMem_free(vmsdir);
6275 if (int_fileify_dirspec(vmsdir, trndir, NULL) == NULL) {
6276 PerlMem_free(trndir);
6277 PerlMem_free(vmsdir);
6280 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6281 PerlMem_free(trndir);
6282 PerlMem_free(vmsdir);
6287 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6288 !(lastdir = cp1 = strrchr(trndir,']')) &&
6289 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6291 cp2 = strrchr(cp1,'.');
6293 int e_len, vs_len = 0;
6296 cp3 = strchr(cp2,';');
6297 e_len = strlen(cp2);
6299 vs_len = strlen(cp3);
6300 e_len = e_len - vs_len;
6302 is_dir = is_dir_ext(cp2, e_len, cp3, vs_len);
6304 if (!decc_efs_charset) {
6305 /* If this is not EFS, then not a directory */
6306 PerlMem_free(trndir);
6307 PerlMem_free(vmsdir);
6309 set_vaxc_errno(RMS$_DIR);
6313 /* Ok, here we have an issue, technically if a .dir shows */
6314 /* from inside a directory, then we should treat it as */
6315 /* xxx^.dir.dir. But we do not have that context at this */
6316 /* point unless this is totally restructured, so we remove */
6317 /* The .dir for now, and fix this better later */
6318 dirlen = cp2 - trndir;
6324 retlen = dirlen + 6;
6325 memcpy(buf, trndir, dirlen);
6328 /* We've picked up everything up to the directory file name.
6329 Now just add the type and version, and we're set. */
6331 /* We should only add type for VMS syntax, but historically Perl
6332 has added it for UNIX style also */
6334 /* Fix me - we should not be using the same routine for VMS and
6335 UNIX format files. Things are too tangled so we need to lookup
6336 what syntax the output is */
6340 lastdir = strrchr(trndir,'/');
6344 lastdir = strpbrk(trndir,"]:>");
6350 if ((is_vms == 0) && (is_unix == 0)) {
6351 /* We still do not know? */
6352 is_unix = decc_filename_unix_report;
6357 if ((is_unix && !decc_efs_charset) || is_vms) {
6359 /* It is a bug to add a .dir to a UNIX format directory spec */
6360 /* However Perl on VMS may have programs that expect this so */
6361 /* If not using EFS character specifications allow it. */
6363 if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6364 /* Traditionally Perl expects filenames in lower case */
6365 strcat(buf, ".dir");
6367 /* VMS expects the .DIR to be in upper case */
6368 strcat(buf, ".DIR");
6371 /* It is also a bug to put a VMS format version on a UNIX file */
6372 /* specification. Perl self tests are looking for this */
6373 if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6376 PerlMem_free(trndir);
6377 PerlMem_free(vmsdir);
6380 else { /* VMS-style directory spec */
6382 char *esa, *esal, term, *cp;
6385 unsigned long int sts, cmplen, haslower = 0;
6386 unsigned int nam_fnb;
6388 struct FAB dirfab = cc$rms_fab;
6389 rms_setup_nam(savnam);
6390 rms_setup_nam(dirnam);
6392 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6393 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6395 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6396 esal = PerlMem_malloc(VMS_MAXRSS);
6397 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6399 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6400 rms_bind_fab_nam(dirfab, dirnam);
6401 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6402 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6403 #ifdef NAM$M_NO_SHORT_UPCASE
6404 if (decc_efs_case_preserve)
6405 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6408 for (cp = trndir; *cp; cp++)
6409 if (islower(*cp)) { haslower = 1; break; }
6410 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6411 if ((dirfab.fab$l_sts == RMS$_DIR) ||
6412 (dirfab.fab$l_sts == RMS$_DNF) ||
6413 (dirfab.fab$l_sts == RMS$_PRV)) {
6414 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6415 sts = sys$parse(&dirfab);
6421 PerlMem_free(trndir);
6422 PerlMem_free(vmsdir);
6424 set_vaxc_errno(dirfab.fab$l_sts);
6430 /* Does the file really exist? */
6431 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6432 /* Yes; fake the fnb bits so we'll check type below */
6433 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6435 else { /* No; just work with potential name */
6436 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6439 fab_sts = dirfab.fab$l_sts;
6440 sts = rms_free_search_context(&dirfab);
6444 PerlMem_free(trndir);
6445 PerlMem_free(vmsdir);
6446 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6452 /* Make sure we are using the right buffer */
6453 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6456 my_esa_len = rms_nam_esll(dirnam);
6460 my_esa_len = rms_nam_esl(dirnam);
6461 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6464 my_esa[my_esa_len] = '\0';
6465 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6466 cp1 = strchr(my_esa,']');
6467 if (!cp1) cp1 = strchr(my_esa,'>');
6468 if (cp1) { /* Should always be true */
6469 my_esa_len -= cp1 - my_esa - 1;
6470 memmove(my_esa, cp1 + 1, my_esa_len);
6473 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6474 /* Yep; check version while we're at it, if it's there. */
6475 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6476 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6477 /* Something other than .DIR[;1]. Bzzt. */
6478 sts = rms_free_search_context(&dirfab);
6482 PerlMem_free(trndir);
6483 PerlMem_free(vmsdir);
6485 set_vaxc_errno(RMS$_DIR);
6490 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6491 /* They provided at least the name; we added the type, if necessary, */
6492 strcpy(buf, my_esa);
6493 sts = rms_free_search_context(&dirfab);
6494 PerlMem_free(trndir);
6498 PerlMem_free(vmsdir);
6501 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6502 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6506 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6507 if (cp1 == NULL) { /* should never happen */
6508 sts = rms_free_search_context(&dirfab);
6509 PerlMem_free(trndir);
6513 PerlMem_free(vmsdir);
6518 retlen = strlen(my_esa);
6519 cp1 = strrchr(my_esa,'.');
6520 /* ODS-5 directory specifications can have extra "." in them. */
6521 /* Fix-me, can not scan EFS file specifications backwards */
6522 while (cp1 != NULL) {
6523 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6527 while ((cp1 > my_esa) && (*cp1 != '.'))
6534 if ((cp1) != NULL) {
6535 /* There's more than one directory in the path. Just roll back. */
6537 strcpy(buf, my_esa);
6540 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6541 /* Go back and expand rooted logical name */
6542 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6543 #ifdef NAM$M_NO_SHORT_UPCASE
6544 if (decc_efs_case_preserve)
6545 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6547 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6548 sts = rms_free_search_context(&dirfab);
6552 PerlMem_free(trndir);
6553 PerlMem_free(vmsdir);
6555 set_vaxc_errno(dirfab.fab$l_sts);
6559 /* This changes the length of the string of course */
6561 my_esa_len = rms_nam_esll(dirnam);
6563 my_esa_len = rms_nam_esl(dirnam);
6566 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6567 cp1 = strstr(my_esa,"][");
6568 if (!cp1) cp1 = strstr(my_esa,"]<");
6569 dirlen = cp1 - my_esa;
6570 memcpy(buf, my_esa, dirlen);
6571 if (!strncmp(cp1+2,"000000]",7)) {
6572 buf[dirlen-1] = '\0';
6573 /* fix-me Not full ODS-5, just extra dots in directories for now */
6574 cp1 = buf + dirlen - 1;
6580 if (*(cp1-1) != '^')
6585 if (*cp1 == '.') *cp1 = ']';
6587 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6588 memmove(cp1+1,"000000]",7);
6592 memmove(buf+dirlen, cp1+2, retlen-dirlen);
6594 /* Convert last '.' to ']' */
6596 while (*cp != '[') {
6599 /* Do not trip on extra dots in ODS-5 directories */
6600 if ((cp1 == buf) || (*(cp1-1) != '^'))
6604 if (*cp1 == '.') *cp1 = ']';
6606 memmove(cp1+8, cp1+1, buf+dirlen-cp1);
6607 memmove(cp1+1,"000000]",7);
6611 else { /* This is a top-level dir. Add the MFD to the path. */
6614 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6615 strcpy(cp2,":[000000]");
6620 sts = rms_free_search_context(&dirfab);
6621 /* We've set up the string up through the filename. Add the
6622 type and version, and we're done. */
6623 strcat(buf,".DIR;1");
6625 /* $PARSE may have upcased filespec, so convert output to lower
6626 * case if input contained any lowercase characters. */
6627 if (haslower && !decc_efs_case_preserve) __mystrtolower(buf);
6628 PerlMem_free(trndir);
6632 PerlMem_free(vmsdir);
6635 } /* end of int_fileify_dirspec() */
6638 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
6639 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
6641 static char __fileify_retbuf[VMS_MAXRSS];
6642 char * fileified, *ret_spec, *ret_buf;
6646 if (ret_buf == NULL) {
6648 Newx(fileified, VMS_MAXRSS, char);
6649 if (fileified == NULL)
6650 _ckvmssts(SS$_INSFMEM);
6651 ret_buf = fileified;
6653 ret_buf = __fileify_retbuf;
6657 ret_spec = int_fileify_dirspec(dir, ret_buf, utf8_fl);
6659 if (ret_spec == NULL) {
6660 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6662 Safefree(fileified);
6666 } /* end of do_fileify_dirspec() */
6669 /* External entry points */
6670 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6671 { return do_fileify_dirspec(dir,buf,0,NULL); }
6672 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6673 { return do_fileify_dirspec(dir,buf,1,NULL); }
6674 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6675 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6676 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6677 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6679 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6680 char * v_spec, int v_len, char * r_spec, int r_len,
6681 char * d_spec, int d_len, char * n_spec, int n_len,
6682 char * e_spec, int e_len, char * vs_spec, int vs_len) {
6684 /* VMS specification - Try to do this the simple way */
6685 if ((v_len + r_len > 0) || (d_len > 0)) {
6688 /* No name or extension component, already a directory */
6689 if ((n_len + e_len + vs_len) == 0) {
6694 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6695 /* This results from catfile() being used instead of catdir() */
6696 /* So even though it should not work, we need to allow it */
6698 /* If this is .DIR;1 then do a simple conversion */
6699 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6700 if (is_dir || (e_len == 0) && (d_len > 0)) {
6702 len = v_len + r_len + d_len - 1;
6703 char dclose = d_spec[d_len - 1];
6704 strncpy(buf, dir, len);
6707 strncpy(&buf[len], n_spec, n_len);
6710 buf[len + 1] = '\0';
6715 else if (d_len > 0) {
6716 /* In the olden days, a directory needed to have a .DIR */
6717 /* extension to be a valid directory, but now it could */
6718 /* be a symbolic link */
6720 len = v_len + r_len + d_len - 1;
6721 char dclose = d_spec[d_len - 1];
6722 strncpy(buf, dir, len);
6725 strncpy(&buf[len], n_spec, n_len);
6728 if (decc_efs_charset) {
6731 strncpy(&buf[len], e_spec, e_len);
6734 set_vaxc_errno(RMS$_DIR);
6740 buf[len + 1] = '\0';
6745 set_vaxc_errno(RMS$_DIR);
6751 set_vaxc_errno(RMS$_DIR);
6757 /* Internal routine to make sure or convert a directory to be in a */
6758 /* path specification. No utf8 flag because it is not changed or used */
6759 static char *int_pathify_dirspec(const char *dir, char *buf)
6761 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6762 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6763 char * exp_spec, *ret_spec;
6765 unsigned short int trnlnm_iter_count;
6769 if (vms_debug_fileify) {
6771 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6773 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6776 /* We may need to lower case the result if we translated */
6777 /* a logical name or got the current working directory */
6780 if (!dir || !*dir) {
6782 set_vaxc_errno(SS$_BADPARAM);
6786 trndir = PerlMem_malloc(VMS_MAXRSS);
6788 _ckvmssts_noperl(SS$_INSFMEM);
6790 /* If no directory specified use the current default */
6792 strcpy(trndir, dir);
6794 getcwd(trndir, VMS_MAXRSS - 1);
6798 /* now deal with bare names that could be logical names */
6799 trnlnm_iter_count = 0;
6800 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6801 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6802 trnlnm_iter_count++;
6804 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6806 trnlen = strlen(trndir);
6808 /* Trap simple rooted lnms, and return lnm:[000000] */
6809 if (!strcmp(trndir+trnlen-2,".]")) {
6811 strcat(buf, ":[000000]");
6812 PerlMem_free(trndir);
6814 if (vms_debug_fileify) {
6815 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6821 /* At this point we do not work with *dir, but the copy in *trndir */
6823 if (need_to_lower && !decc_efs_case_preserve) {
6824 /* Legacy mode, lower case the returned value */
6825 __mystrtolower(trndir);
6829 /* Some special cases, '..', '.' */
6831 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6832 /* Force UNIX filespec */
6836 /* Is this Unix or VMS format? */
6837 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6838 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6839 &e_len, &vs_spec, &vs_len);
6842 /* Just a filename? */
6843 if ((v_len + r_len + d_len) == 0) {
6845 /* Now we have a problem, this could be Unix or VMS */
6846 /* We have to guess. .DIR usually means VMS */
6848 /* In UNIX report mode, the .DIR extension is removed */
6849 /* if one shows up, it is for a non-directory or a directory */
6850 /* in EFS charset mode */
6852 /* So if we are in Unix report mode, assume that this */
6853 /* is a relative Unix directory specification */
6856 if (!decc_filename_unix_report && decc_efs_charset) {
6858 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6861 /* Traditional mode, assume .DIR is directory */
6864 strncpy(&buf[2], n_spec, n_len);
6865 buf[n_len + 2] = ']';
6866 buf[n_len + 3] = '\0';
6867 PerlMem_free(trndir);
6868 if (vms_debug_fileify) {
6870 "int_pathify_dirspec: buf = %s\n",
6880 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6881 v_spec, v_len, r_spec, r_len,
6882 d_spec, d_len, n_spec, n_len,
6883 e_spec, e_len, vs_spec, vs_len);
6885 if (ret_spec != NULL) {
6886 PerlMem_free(trndir);
6887 if (vms_debug_fileify) {
6889 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6894 /* Simple way did not work, which means that a logical name */
6895 /* was present for the directory specification. */
6896 /* Need to use an rmsexpand variant to decode it completely */
6897 exp_spec = PerlMem_malloc(VMS_MAXRSS);
6898 if (exp_spec == NULL)
6899 _ckvmssts_noperl(SS$_INSFMEM);
6901 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6902 if (ret_spec != NULL) {
6903 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6904 &r_spec, &r_len, &d_spec, &d_len,
6905 &n_spec, &n_len, &e_spec,
6906 &e_len, &vs_spec, &vs_len);
6908 ret_spec = int_pathify_dirspec_simple(
6909 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6910 d_spec, d_len, n_spec, n_len,
6911 e_spec, e_len, vs_spec, vs_len);
6913 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6914 /* Legacy mode, lower case the returned value */
6915 __mystrtolower(ret_spec);
6918 set_vaxc_errno(RMS$_DIR);
6923 PerlMem_free(exp_spec);
6924 PerlMem_free(trndir);
6925 if (vms_debug_fileify) {
6926 if (ret_spec == NULL)
6927 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6930 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6935 /* Unix specification, Could be trivial conversion */
6937 dir_len = strlen(trndir);
6939 /* If the extended file character set is in effect */
6940 /* then pathify is simple */
6942 if (!decc_efs_charset) {
6943 /* Have to deal with traiing '.dir' or extra '.' */
6944 /* that should not be there in legacy mode, but is */
6950 lastslash = strrchr(trndir, '/');
6951 if (lastslash == NULL)
6958 /* '..' or '.' are valid directory components */
6960 if (lastslash[0] == '.') {
6961 if (lastslash[1] == '\0') {
6963 } else if (lastslash[1] == '.') {
6964 if (lastslash[2] == '\0') {
6967 /* And finally allow '...' */
6968 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6976 lastdot = strrchr(lastslash, '.');
6978 if (lastdot != NULL) {
6981 /* '.dir' is discarded, and any other '.' is invalid */
6982 e_len = strlen(lastdot);
6984 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6987 dir_len = dir_len - 4;
6993 strcpy(buf, trndir);
6994 if (buf[dir_len - 1] != '/') {
6996 buf[dir_len + 1] = '\0';
6999 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
7000 if (!decc_efs_charset) {
7003 if (str[0] == '.') {
7006 while ((dots[cnt] == '.') && (cnt < 3))
7009 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
7015 for (; *str; ++str) {
7016 while (*str == '/') {
7022 /* Have to skip up to three dots which could be */
7023 /* directories, 3 dots being a VMS extension for Perl */
7026 while ((dots[cnt] == '.') && (cnt < 3)) {
7029 if (dots[cnt] == '\0')
7031 if ((cnt > 1) && (dots[cnt] != '/')) {
7037 /* too many dots? */
7038 if ((cnt == 0) || (cnt > 3)) {
7042 if (!dir_start && (*str == '.')) {
7047 PerlMem_free(trndir);
7049 if (vms_debug_fileify) {
7050 if (ret_spec == NULL)
7051 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
7054 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
7060 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
7061 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
7063 static char __pathify_retbuf[VMS_MAXRSS];
7064 char * pathified, *ret_spec, *ret_buf;
7068 if (ret_buf == NULL) {
7070 Newx(pathified, VMS_MAXRSS, char);
7071 if (pathified == NULL)
7072 _ckvmssts(SS$_INSFMEM);
7073 ret_buf = pathified;
7075 ret_buf = __pathify_retbuf;
7079 ret_spec = int_pathify_dirspec(dir, ret_buf);
7081 if (ret_spec == NULL) {
7082 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7084 Safefree(pathified);
7089 } /* end of do_pathify_dirspec() */
7092 /* External entry points */
7093 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
7094 { return do_pathify_dirspec(dir,buf,0,NULL); }
7095 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
7096 { return do_pathify_dirspec(dir,buf,1,NULL); }
7097 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
7098 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
7099 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
7100 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
7102 /* Internal tounixspec routine that does not use a thread context */
7103 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
7104 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
7106 char *dirend, *cp1, *cp3, *tmp;
7108 int devlen, dirlen, retlen = VMS_MAXRSS;
7109 int expand = 1; /* guarantee room for leading and trailing slashes */
7110 unsigned short int trnlnm_iter_count;
7112 if (utf8_fl != NULL)
7115 if (vms_debug_fileify) {
7117 fprintf(stderr, "int_tounixspec: spec = NULL\n");
7119 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
7125 set_vaxc_errno(SS$_BADPARAM);
7128 if (strlen(spec) > (VMS_MAXRSS-1)) {
7130 set_vaxc_errno(SS$_BUFFEROVF);
7134 /* New VMS specific format needs translation
7135 * glob passes filenames with trailing '\n' and expects this preserved.
7137 if (decc_posix_compliant_pathnames) {
7138 if (strncmp(spec, "\"^UP^", 5) == 0) {
7144 tunix = PerlMem_malloc(VMS_MAXRSS);
7145 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7146 strcpy(tunix, spec);
7147 tunix_len = strlen(tunix);
7149 if (tunix[tunix_len - 1] == '\n') {
7150 tunix[tunix_len - 1] = '\"';
7151 tunix[tunix_len] = '\0';
7155 uspec = decc$translate_vms(tunix);
7156 PerlMem_free(tunix);
7157 if ((int)uspec > 0) {
7163 /* If we can not translate it, makemaker wants as-is */
7171 cmp_rslt = 0; /* Presume VMS */
7172 cp1 = strchr(spec, '/');
7176 /* Look for EFS ^/ */
7177 if (decc_efs_charset) {
7178 while (cp1 != NULL) {
7181 /* Found illegal VMS, assume UNIX */
7186 cp1 = strchr(cp1, '/');
7190 /* Look for "." and ".." */
7191 if (decc_filename_unix_report) {
7192 if (spec[0] == '.') {
7193 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7197 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7203 /* This is already UNIX or at least nothing VMS understands */
7206 if (vms_debug_fileify) {
7207 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7214 dirend = strrchr(spec,']');
7215 if (dirend == NULL) dirend = strrchr(spec,'>');
7216 if (dirend == NULL) dirend = strchr(spec,':');
7217 if (dirend == NULL) {
7219 if (vms_debug_fileify) {
7220 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7225 /* Special case 1 - sys$posix_root = / */
7226 #if __CRTL_VER >= 70000000
7227 if (!decc_disable_posix_root) {
7228 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7236 /* Special case 2 - Convert NLA0: to /dev/null */
7237 #if __CRTL_VER < 70000000
7238 cmp_rslt = strncmp(spec,"NLA0:", 5);
7240 cmp_rslt = strncmp(spec,"nla0:", 5);
7242 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7244 if (cmp_rslt == 0) {
7245 strcpy(rslt, "/dev/null");
7248 if (spec[6] != '\0') {
7255 /* Also handle special case "SYS$SCRATCH:" */
7256 #if __CRTL_VER < 70000000
7257 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7259 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7261 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7263 tmp = PerlMem_malloc(VMS_MAXRSS);
7264 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7265 if (cmp_rslt == 0) {
7268 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7270 strcpy(rslt, "/tmp");
7273 if (spec[12] != '\0') {
7281 if (*cp2 != '[' && *cp2 != '<') {
7284 else { /* the VMS spec begins with directories */
7286 if (*cp2 == ']' || *cp2 == '>') {
7287 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7291 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7292 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7294 if (vms_debug_fileify) {
7295 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7299 trnlnm_iter_count = 0;
7302 while (*cp3 != ':' && *cp3) cp3++;
7304 if (strchr(cp3,']') != NULL) break;
7305 trnlnm_iter_count++;
7306 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7307 } while (vmstrnenv(tmp,tmp,0,fildev,0));
7312 *(cp1++) = *(cp3++);
7313 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7315 set_errno(ENAMETOOLONG);
7316 set_vaxc_errno(SS$_BUFFEROVF);
7317 if (vms_debug_fileify) {
7318 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7320 return NULL; /* No room */
7325 if ((*cp2 == '^')) {
7326 /* EFS file escape, pass the next character as is */
7327 /* Fix me: HEX encoding for Unicode not implemented */
7330 else if ( *cp2 == '.') {
7331 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7332 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7339 for (; cp2 <= dirend; cp2++) {
7340 if ((*cp2 == '^')) {
7341 /* EFS file escape, pass the next character as is */
7342 /* Fix me: HEX encoding for Unicode not implemented */
7343 *(cp1++) = *(++cp2);
7344 /* An escaped dot stays as is -- don't convert to slash */
7345 if (*cp2 == '.') cp2++;
7349 if (*(cp2+1) == '[') cp2++;
7351 else if (*cp2 == ']' || *cp2 == '>') {
7352 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7354 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7356 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7357 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7358 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7359 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7360 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7362 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7363 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7367 else if (*cp2 == '-') {
7368 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7369 while (*cp2 == '-') {
7371 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7373 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7374 /* filespecs like */
7375 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
7376 if (vms_debug_fileify) {
7377 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7382 else *(cp1++) = *cp2;
7384 else *(cp1++) = *cp2;
7386 /* Translate the rest of the filename. */
7391 /* Fixme - for compatibility with the CRTL we should be removing */
7392 /* spaces from the file specifications, but this may show that */
7393 /* some tests that were appearing to pass are not really passing */
7399 /* Fix me hex expansions not implemented */
7400 cp2++; /* '^.' --> '.' and other. */
7406 *(cp1++) = *(cp2++);
7411 if (decc_filename_unix_no_version) {
7412 /* Easy, drop the version */
7417 /* Punt - passing the version as a dot will probably */
7418 /* break perl in weird ways, but so did passing */
7419 /* through the ; as a version. Follow the CRTL and */
7420 /* hope for the best. */
7427 /* We will need to fix this properly later */
7428 /* As Perl may be installed on an ODS-5 volume, but not */
7429 /* have the EFS_CHARSET enabled, it still may encounter */
7430 /* filenames with extra dots in them, and a precedent got */
7431 /* set which allowed them to work, that we will uphold here */
7432 /* If extra dots are present in a name and no ^ is on them */
7433 /* VMS assumes that the first one is the extension delimiter */
7434 /* the rest have an implied ^. */
7436 /* this is also a conflict as the . is also a version */
7437 /* delimiter in VMS, */
7439 *(cp1++) = *(cp2++);
7443 /* This is an extension */
7444 if (decc_readdir_dropdotnotype) {
7446 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7447 /* Drop the dot for the extension */
7455 *(cp1++) = *(cp2++);
7460 /* This still leaves /000000/ when working with a
7461 * VMS device root or concealed root.
7467 ulen = strlen(rslt);
7469 /* Get rid of "000000/ in rooted filespecs */
7471 zeros = strstr(rslt, "/000000/");
7472 if (zeros != NULL) {
7474 mlen = ulen - (zeros - rslt) - 7;
7475 memmove(zeros, &zeros[7], mlen);
7482 if (vms_debug_fileify) {
7483 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7487 } /* end of int_tounixspec() */
7490 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7491 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7493 static char __tounixspec_retbuf[VMS_MAXRSS];
7494 char * unixspec, *ret_spec, *ret_buf;
7498 if (ret_buf == NULL) {
7500 Newx(unixspec, VMS_MAXRSS, char);
7501 if (unixspec == NULL)
7502 _ckvmssts(SS$_INSFMEM);
7505 ret_buf = __tounixspec_retbuf;
7509 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7511 if (ret_spec == NULL) {
7512 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7519 } /* end of do_tounixspec() */
7521 /* External entry points */
7522 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7523 { return do_tounixspec(spec,buf,0, NULL); }
7524 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7525 { return do_tounixspec(spec,buf,1, NULL); }
7526 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7527 { return do_tounixspec(spec,buf,0, utf8_fl); }
7528 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7529 { return do_tounixspec(spec,buf,1, utf8_fl); }
7531 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7534 This procedure is used to identify if a path is based in either
7535 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7536 it returns the OpenVMS format directory for it.
7538 It is expecting specifications of only '/' or '/xxxx/'
7540 If a posix root does not exist, or 'xxxx' is not a directory
7541 in the posix root, it returns a failure.
7543 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7545 It is used only internally by posix_to_vmsspec_hardway().
7548 static int posix_root_to_vms
7549 (char *vmspath, int vmspath_len,
7550 const char *unixpath,
7551 const int * utf8_fl)
7554 struct FAB myfab = cc$rms_fab;
7555 rms_setup_nam(mynam);
7556 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7557 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7558 char * esa, * esal, * rsa, * rsal;
7565 unixlen = strlen(unixpath);
7570 #if __CRTL_VER >= 80200000
7571 /* If not a posix spec already, convert it */
7572 if (decc_posix_compliant_pathnames) {
7573 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7574 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7577 /* This is already a VMS specification, no conversion */
7579 strncpy(vmspath,unixpath, vmspath_len);
7588 /* Check to see if this is under the POSIX root */
7589 if (decc_disable_posix_root) {
7593 /* Skip leading / */
7594 if (unixpath[0] == '/') {
7600 strcpy(vmspath,"SYS$POSIX_ROOT:");
7602 /* If this is only the / , or blank, then... */
7603 if (unixpath[0] == '\0') {
7604 /* by definition, this is the answer */
7608 /* Need to look up a directory */
7612 /* Copy and add '^' escape characters as needed */
7615 while (unixpath[i] != 0) {
7618 j += copy_expand_unix_filename_escape
7619 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7623 path_len = strlen(vmspath);
7624 if (vmspath[path_len - 1] == '/')
7626 vmspath[path_len] = ']';
7628 vmspath[path_len] = '\0';
7631 vmspath[vmspath_len] = 0;
7632 if (unixpath[unixlen - 1] == '/')
7634 esal = PerlMem_malloc(VMS_MAXRSS);
7635 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7636 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7637 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7638 rsal = PerlMem_malloc(VMS_MAXRSS);
7639 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7640 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7641 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7642 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7643 rms_bind_fab_nam(myfab, mynam);
7644 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7645 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7646 if (decc_efs_case_preserve)
7647 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7648 #ifdef NAML$M_OPEN_SPECIAL
7649 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7652 /* Set up the remaining naml fields */
7653 sts = sys$parse(&myfab);
7655 /* It failed! Try again as a UNIX filespec */
7664 /* get the Device ID and the FID */
7665 sts = sys$search(&myfab);
7667 /* These are no longer needed */
7672 /* on any failure, returned the POSIX ^UP^ filespec */
7677 specdsc.dsc$a_pointer = vmspath;
7678 specdsc.dsc$w_length = vmspath_len;
7680 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7681 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7682 sts = lib$fid_to_name
7683 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7685 /* on any failure, returned the POSIX ^UP^ filespec */
7687 /* This can happen if user does not have permission to read directories */
7688 if (strncmp(unixpath,"\"^UP^",5) != 0)
7689 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7691 strcpy(vmspath, unixpath);
7694 vmspath[specdsc.dsc$w_length] = 0;
7696 /* Are we expecting a directory? */
7697 if (dir_flag != 0) {
7703 i = specdsc.dsc$w_length - 1;
7707 /* Version must be '1' */
7708 if (vmspath[i--] != '1')
7710 /* Version delimiter is one of ".;" */
7711 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7714 if (vmspath[i--] != 'R')
7716 if (vmspath[i--] != 'I')
7718 if (vmspath[i--] != 'D')
7720 if (vmspath[i--] != '.')
7722 eptr = &vmspath[i+1];
7724 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7725 if (vmspath[i-1] != '^') {
7733 /* Get rid of 6 imaginary zero directory filename */
7734 vmspath[i+1] = '\0';
7738 if (vmspath[i] == '0')
7752 /* /dev/mumble needs to be handled special.
7753 /dev/null becomes NLA0:, And there is the potential for other stuff
7754 like /dev/tty which may need to be mapped to something.
7758 slash_dev_special_to_vms
7759 (const char * unixptr,
7769 nextslash = strchr(unixptr, '/');
7770 len = strlen(unixptr);
7771 if (nextslash != NULL)
7772 len = nextslash - unixptr;
7773 cmp = strncmp("null", unixptr, 5);
7775 if (vmspath_len >= 6) {
7776 strcpy(vmspath, "_NLA0:");
7783 /* The built in routines do not understand perl's special needs, so
7784 doing a manual conversion from UNIX to VMS
7786 If the utf8_fl is not null and points to a non-zero value, then
7787 treat 8 bit characters as UTF-8.
7789 The sequence starting with '$(' and ending with ')' will be passed
7790 through with out interpretation instead of being escaped.
7793 static int posix_to_vmsspec_hardway
7794 (char *vmspath, int vmspath_len,
7795 const char *unixpath,
7800 const char *unixptr;
7801 const char *unixend;
7803 const char *lastslash;
7804 const char *lastdot;
7810 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7811 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7813 if (utf8_fl != NULL)
7819 /* Ignore leading "/" characters */
7820 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7823 unixlen = strlen(unixptr);
7825 /* Do nothing with blank paths */
7832 /* This could have a "^UP^ on the front */
7833 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7839 lastslash = strrchr(unixptr,'/');
7840 lastdot = strrchr(unixptr,'.');
7841 unixend = strrchr(unixptr,'\"');
7842 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7843 unixend = unixptr + unixlen;
7846 /* last dot is last dot or past end of string */
7847 if (lastdot == NULL)
7848 lastdot = unixptr + unixlen;
7850 /* if no directories, set last slash to beginning of string */
7851 if (lastslash == NULL) {
7852 lastslash = unixptr;
7855 /* Watch out for trailing "." after last slash, still a directory */
7856 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7857 lastslash = unixptr + unixlen;
7860 /* Watch out for traiing ".." after last slash, still a directory */
7861 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7862 lastslash = unixptr + unixlen;
7865 /* dots in directories are aways escaped */
7866 if (lastdot < lastslash)
7867 lastdot = unixptr + unixlen;
7870 /* if (unixptr < lastslash) then we are in a directory */
7877 /* Start with the UNIX path */
7878 if (*unixptr != '/') {
7879 /* relative paths */
7881 /* If allowing logical names on relative pathnames, then handle here */
7882 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7883 !decc_posix_compliant_pathnames) {
7889 /* Find the next slash */
7890 nextslash = strchr(unixptr,'/');
7892 esa = PerlMem_malloc(vmspath_len);
7893 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7895 trn = PerlMem_malloc(VMS_MAXRSS);
7896 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7898 if (nextslash != NULL) {
7900 seg_len = nextslash - unixptr;
7901 strncpy(esa, unixptr, seg_len);
7905 strcpy(esa, unixptr);
7906 seg_len = strlen(unixptr);
7908 /* trnlnm(section) */
7909 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7912 /* Now fix up the directory */
7914 /* Split up the path to find the components */
7915 sts = vms_split_path
7934 /* A logical name must be a directory or the full
7935 specification. It is only a full specification if
7936 it is the only component */
7937 if ((unixptr[seg_len] == '\0') ||
7938 (unixptr[seg_len+1] == '\0')) {
7940 /* Is a directory being required? */
7941 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7942 /* Not a logical name */
7947 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7948 /* This must be a directory */
7949 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7950 strcpy(vmsptr, esa);
7951 vmslen=strlen(vmsptr);
7952 vmsptr[vmslen] = ':';
7954 vmsptr[vmslen] = '\0';
7962 /* must be dev/directory - ignore version */
7963 if ((n_len + e_len) != 0)
7966 /* transfer the volume */
7967 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7968 strncpy(vmsptr, v_spec, v_len);
7974 /* unroot the rooted directory */
7975 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7977 r_spec[r_len - 1] = ']';
7979 /* This should not be there, but nothing is perfect */
7981 cmp = strcmp(&r_spec[1], "000000.");
7991 strncpy(vmsptr, r_spec, r_len);
7997 /* Bring over the directory. */
7999 ((d_len + vmslen) < vmspath_len)) {
8001 d_spec[d_len - 1] = ']';
8003 cmp = strcmp(&d_spec[1], "000000.");
8014 /* Remove the redundant root */
8022 strncpy(vmsptr, d_spec, d_len);
8036 if (lastslash > unixptr) {
8039 /* skip leading ./ */
8041 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
8047 /* Are we still in a directory? */
8048 if (unixptr <= lastslash) {
8053 /* if not backing up, then it is relative forward. */
8054 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
8055 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
8063 /* Perl wants an empty directory here to tell the difference
8064 * between a DCL commmand and a filename
8073 /* Handle two special files . and .. */
8074 if (unixptr[0] == '.') {
8075 if (&unixptr[1] == unixend) {
8082 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
8093 else { /* Absolute PATH handling */
8097 /* Need to find out where root is */
8099 /* In theory, this procedure should never get an absolute POSIX pathname
8100 * that can not be found on the POSIX root.
8101 * In practice, that can not be relied on, and things will show up
8102 * here that are a VMS device name or concealed logical name instead.
8103 * So to make things work, this procedure must be tolerant.
8105 esa = PerlMem_malloc(vmspath_len);
8106 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8109 nextslash = strchr(&unixptr[1],'/');
8111 if (nextslash != NULL) {
8113 seg_len = nextslash - &unixptr[1];
8114 strncpy(vmspath, unixptr, seg_len + 1);
8115 vmspath[seg_len+1] = 0;
8118 cmp = strncmp(vmspath, "dev", 4);
8120 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
8121 if (sts = SS$_NORMAL)
8125 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
8128 if ($VMS_STATUS_SUCCESS(sts)) {
8129 /* This is verified to be a real path */
8131 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
8132 if ($VMS_STATUS_SUCCESS(sts)) {
8133 strcpy(vmspath, esa);
8134 vmslen = strlen(vmspath);
8135 vmsptr = vmspath + vmslen;
8137 if (unixptr < lastslash) {
8146 cmp = strcmp(rptr,"000000.");
8151 } /* removing 6 zeros */
8152 } /* vmslen < 7, no 6 zeros possible */
8153 } /* Not in a directory */
8154 } /* Posix root found */
8156 /* No posix root, fall back to default directory */
8157 strcpy(vmspath, "SYS$DISK:[");
8158 vmsptr = &vmspath[10];
8160 if (unixptr > lastslash) {
8169 } /* end of verified real path handling */
8174 /* Ok, we have a device or a concealed root that is not in POSIX
8175 * or we have garbage. Make the best of it.
8178 /* Posix to VMS destroyed this, so copy it again */
8179 strncpy(vmspath, &unixptr[1], seg_len);
8180 vmspath[seg_len] = 0;
8182 vmsptr = &vmsptr[vmslen];
8185 /* Now do we need to add the fake 6 zero directory to it? */
8187 if ((*lastslash == '/') && (nextslash < lastslash)) {
8188 /* No there is another directory */
8195 /* now we have foo:bar or foo:[000000]bar to decide from */
8196 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8198 if (!islnm && !decc_posix_compliant_pathnames) {
8200 cmp = strncmp("bin", vmspath, 4);
8202 /* bin => SYS$SYSTEM: */
8203 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8206 /* tmp => SYS$SCRATCH: */
8207 cmp = strncmp("tmp", vmspath, 4);
8209 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8214 trnend = islnm ? islnm - 1 : 0;
8216 /* if this was a logical name, ']' or '>' must be present */
8217 /* if not a logical name, then assume a device and hope. */
8218 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8220 /* if log name and trailing '.' then rooted - treat as device */
8221 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8223 /* Fix me, if not a logical name, a device lookup should be
8224 * done to see if the device is file structured. If the device
8225 * is not file structured, the 6 zeros should not be put on.
8227 * As it is, perl is occasionally looking for dev:[000000]tty.
8228 * which looks a little strange.
8230 * Not that easy to detect as "/dev" may be file structured with
8231 * special device files.
8234 if ((add_6zero == 0) && (*nextslash == '/') &&
8235 (&nextslash[1] == unixend)) {
8236 /* No real directory present */
8241 /* Put the device delimiter on */
8244 unixptr = nextslash;
8247 /* Start directory if needed */
8248 if (!islnm || add_6zero) {
8254 /* add fake 000000] if needed */
8267 } /* non-POSIX translation */
8269 } /* End of relative/absolute path handling */
8271 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8278 if (dir_start != 0) {
8280 /* First characters in a directory are handled special */
8281 while ((*unixptr == '/') ||
8282 ((*unixptr == '.') &&
8283 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8284 (&unixptr[1]==unixend)))) {
8289 /* Skip redundant / in specification */
8290 while ((*unixptr == '/') && (dir_start != 0)) {
8293 if (unixptr == lastslash)
8296 if (unixptr == lastslash)
8299 /* Skip redundant ./ characters */
8300 while ((*unixptr == '.') &&
8301 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8304 if (unixptr == lastslash)
8306 if (*unixptr == '/')
8309 if (unixptr == lastslash)
8312 /* Skip redundant ../ characters */
8313 while ((*unixptr == '.') && (unixptr[1] == '.') &&
8314 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8315 /* Set the backing up flag */
8321 unixptr++; /* first . */
8322 unixptr++; /* second . */
8323 if (unixptr == lastslash)
8325 if (*unixptr == '/') /* The slash */
8328 if (unixptr == lastslash)
8331 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8332 /* Not needed when VMS is pretending to be UNIX. */
8334 /* Is this loop stuck because of too many dots? */
8335 if (loop_flag == 0) {
8336 /* Exit the loop and pass the rest through */
8341 /* Are we done with directories yet? */
8342 if (unixptr >= lastslash) {
8344 /* Watch out for trailing dots */
8353 if (*unixptr == '/')
8357 /* Have we stopped backing up? */
8362 /* dir_start continues to be = 1 */
8364 if (*unixptr == '-') {
8366 *vmsptr++ = *unixptr++;
8370 /* Now are we done with directories yet? */
8371 if (unixptr >= lastslash) {
8373 /* Watch out for trailing dots */
8389 if (unixptr >= unixend)
8392 /* Normal characters - More EFS work probably needed */
8398 /* remove multiple / */
8399 while (unixptr[1] == '/') {
8402 if (unixptr == lastslash) {
8403 /* Watch out for trailing dots */
8415 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8416 /* Not needed when VMS is pretending to be UNIX. */
8420 if (unixptr != unixend)
8425 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8426 (&unixptr[1] == unixend)) {
8432 /* trailing dot ==> '^..' on VMS */
8433 if (unixptr == unixend) {
8441 *vmsptr++ = *unixptr++;
8445 if (quoted && (&unixptr[1] == unixend)) {
8449 in_cnt = copy_expand_unix_filename_escape
8450 (vmsptr, unixptr, &out_cnt, utf8_fl);
8460 in_cnt = copy_expand_unix_filename_escape
8461 (vmsptr, unixptr, &out_cnt, utf8_fl);
8468 /* Make sure directory is closed */
8469 if (unixptr == lastslash) {
8471 vmsptr2 = vmsptr - 1;
8473 if (*vmsptr2 != ']') {
8476 /* directories do not end in a dot bracket */
8477 if (*vmsptr2 == '.') {
8481 if (*vmsptr2 != '^') {
8482 vmsptr--; /* back up over the dot */
8490 /* Add a trailing dot if a file with no extension */
8491 vmsptr2 = vmsptr - 1;
8493 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8494 (*vmsptr2 != ')') && (*lastdot != '.')) {
8505 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8506 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8511 /* If a UTF8 flag is being passed, honor it */
8513 if (utf8_fl != NULL) {
8514 utf8_flag = *utf8_fl;
8519 /* If there is a possibility of UTF8, then if any UTF8 characters
8520 are present, then they must be converted to VTF-7
8522 result = strcpy(rslt, path); /* FIX-ME */
8525 result = strcpy(rslt, path);
8532 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8533 static char *int_tovmsspec
8534 (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8540 unsigned long int infront = 0, hasdir = 1;
8543 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8544 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8546 if (vms_debug_fileify) {
8548 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8550 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8554 /* If we fail, we should be setting errno */
8556 set_vaxc_errno(SS$_BADPARAM);
8559 rslt_len = VMS_MAXRSS-1;
8561 /* '.' and '..' are "[]" and "[-]" for a quick check */
8562 if (path[0] == '.') {
8563 if (path[1] == '\0') {
8565 if (utf8_flag != NULL)
8570 if (path[1] == '.' && path[2] == '\0') {
8572 if (utf8_flag != NULL)
8579 /* Posix specifications are now a native VMS format */
8580 /*--------------------------------------------------*/
8581 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8582 if (decc_posix_compliant_pathnames) {
8583 if (strncmp(path,"\"^UP^",5) == 0) {
8584 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8590 /* This is really the only way to see if this is already in VMS format */
8591 sts = vms_split_path
8606 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8607 replacement, because the above parse just took care of most of
8608 what is needed to do vmspath when the specification is already
8611 And if it is not already, it is easier to do the conversion as
8612 part of this routine than to call this routine and then work on
8616 /* If VMS punctuation was found, it is already VMS format */
8617 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8618 if (utf8_flag != NULL)
8621 if (vms_debug_fileify) {
8622 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8626 /* Now, what to do with trailing "." cases where there is no
8627 extension? If this is a UNIX specification, and EFS characters
8628 are enabled, then the trailing "." should be converted to a "^.".
8629 But if this was already a VMS specification, then it should be
8632 So in the case of ambiguity, leave the specification alone.
8636 /* If there is a possibility of UTF8, then if any UTF8 characters
8637 are present, then they must be converted to VTF-7
8639 if (utf8_flag != NULL)
8642 if (vms_debug_fileify) {
8643 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8648 dirend = strrchr(path,'/');
8650 if (dirend == NULL) {
8654 /* If we get here with no UNIX directory delimiters, then this is
8655 not a complete file specification, either garbage a UNIX glob
8656 specification that can not be converted to a VMS wildcard, or
8657 it a UNIX shell macro. MakeMaker wants shell macros passed
8660 utf8 flag setting needs to be preserved.
8665 macro_start = strchr(path,'$');
8666 if (macro_start != NULL) {
8667 if (macro_start[1] == '(') {
8671 if ((decc_efs_charset == 0) || (has_macro)) {
8673 if (vms_debug_fileify) {
8674 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8680 /* If POSIX mode active, handle the conversion */
8681 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8682 if (decc_efs_charset) {
8683 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8684 if (vms_debug_fileify) {
8685 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8691 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
8692 if (!*(dirend+2)) dirend +=2;
8693 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8694 if (decc_efs_charset == 0) {
8695 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8701 lastdot = strrchr(cp2,'.');
8707 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8709 if (decc_disable_posix_root) {
8710 strcpy(rslt,"sys$disk:[000000]");
8713 strcpy(rslt,"sys$posix_root:[000000]");
8715 if (utf8_flag != NULL)
8717 if (vms_debug_fileify) {
8718 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8722 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8724 trndev = PerlMem_malloc(VMS_MAXRSS);
8725 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8726 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8728 /* DECC special handling */
8730 if (strcmp(rslt,"bin") == 0) {
8731 strcpy(rslt,"sys$system");
8734 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8736 else if (strcmp(rslt,"tmp") == 0) {
8737 strcpy(rslt,"sys$scratch");
8740 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8742 else if (!decc_disable_posix_root) {
8743 strcpy(rslt, "sys$posix_root");
8747 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8748 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8750 else if (strcmp(rslt,"dev") == 0) {
8751 if (strncmp(cp2,"/null", 5) == 0) {
8752 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8753 strcpy(rslt,"NLA0");
8757 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8763 trnend = islnm ? strlen(trndev) - 1 : 0;
8764 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8765 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8766 /* If the first element of the path is a logical name, determine
8767 * whether it has to be translated so we can add more directories. */
8768 if (!islnm || rooted) {
8771 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8775 if (cp2 != dirend) {
8776 strcpy(rslt,trndev);
8777 cp1 = rslt + trnend;
8784 if (decc_disable_posix_root) {
8790 PerlMem_free(trndev);
8795 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8796 cp2 += 2; /* skip over "./" - it's redundant */
8797 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8799 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8800 *(cp1++) = '-'; /* "../" --> "-" */
8803 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8804 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8805 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8806 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8809 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8810 /* Escape the extra dots in EFS file specifications */
8813 if (cp2 > dirend) cp2 = dirend;
8815 else *(cp1++) = '.';
8817 for (; cp2 < dirend; cp2++) {
8819 if (*(cp2-1) == '/') continue;
8820 if (*(cp1-1) != '.') *(cp1++) = '.';
8823 else if (!infront && *cp2 == '.') {
8824 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8825 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8826 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8827 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8828 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8829 else { /* back up over previous directory name */
8831 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8832 if (*(cp1-1) == '[') {
8833 memcpy(cp1,"000000.",7);
8838 if (cp2 == dirend) break;
8840 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8841 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8842 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8843 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8845 *(cp1++) = '.'; /* Simulate trailing '/' */
8846 cp2 += 2; /* for loop will incr this to == dirend */
8848 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8851 if (decc_efs_charset == 0)
8852 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8854 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8860 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8862 if (decc_efs_charset == 0)
8869 else *(cp1++) = *cp2;
8873 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8874 if (hasdir) *(cp1++) = ']';
8875 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8876 /* fixme for ODS5 */
8883 if (decc_efs_charset == 0)
8894 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8895 decc_readdir_dropdotnotype) {
8900 /* trailing dot ==> '^..' on VMS */
8907 *(cp1++) = *(cp2++);
8912 /* This could be a macro to be passed through */
8913 *(cp1++) = *(cp2++);
8915 const char * save_cp2;
8919 /* paranoid check */
8925 *(cp1++) = *(cp2++);
8926 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8927 *(cp1++) = *(cp2++);
8928 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8929 *(cp1++) = *(cp2++);
8932 *(cp1++) = *(cp2++);
8936 if (is_macro == 0) {
8937 /* Not really a macro - never mind */
8950 /* Don't escape again if following character is
8951 * already something we escape.
8953 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8954 *(cp1++) = *(cp2++);
8957 /* But otherwise fall through and escape it. */
8975 *(cp1++) = *(cp2++);
8978 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8979 * which is wrong. UNIX notation should be ".dir." unless
8980 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8981 * changing this behavior could break more things at this time.
8982 * efs character set effectively does not allow "." to be a version
8983 * delimiter as a further complication about changing this.
8985 if (decc_filename_unix_report != 0) {
8988 *(cp1++) = *(cp2++);
8991 *(cp1++) = *(cp2++);
8994 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8998 /* Fix me for "^]", but that requires making sure that you do
8999 * not back up past the start of the filename
9001 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
9006 if (utf8_flag != NULL)
9008 if (vms_debug_fileify) {
9009 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
9013 } /* end of int_tovmsspec() */
9016 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
9017 static char *mp_do_tovmsspec
9018 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
9019 static char __tovmsspec_retbuf[VMS_MAXRSS];
9020 char * vmsspec, *ret_spec, *ret_buf;
9024 if (ret_buf == NULL) {
9026 Newx(vmsspec, VMS_MAXRSS, char);
9027 if (vmsspec == NULL)
9028 _ckvmssts(SS$_INSFMEM);
9031 ret_buf = __tovmsspec_retbuf;
9035 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
9037 if (ret_spec == NULL) {
9038 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
9045 } /* end of mp_do_tovmsspec() */
9047 /* External entry points */
9048 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
9049 { return do_tovmsspec(path,buf,0,NULL); }
9050 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
9051 { return do_tovmsspec(path,buf,1,NULL); }
9052 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9053 { return do_tovmsspec(path,buf,0,utf8_fl); }
9054 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9055 { return do_tovmsspec(path,buf,1,utf8_fl); }
9057 /*{{{ char *int_tovmspath(char *path, char *buf, const int *)*/
9058 /* Internal routine for use with out an explict context present */
9059 static char * int_tovmspath(const char *path, char *buf, int * utf8_fl) {
9061 char * ret_spec, *pathified;
9066 pathified = PerlMem_malloc(VMS_MAXRSS);
9067 if (pathified == NULL)
9068 _ckvmssts_noperl(SS$_INSFMEM);
9070 ret_spec = int_pathify_dirspec(path, pathified);
9072 if (ret_spec == NULL) {
9073 PerlMem_free(pathified);
9077 ret_spec = int_tovmsspec(pathified, buf, 0, utf8_fl);
9079 PerlMem_free(pathified);
9084 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
9085 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9086 static char __tovmspath_retbuf[VMS_MAXRSS];
9088 char *pathified, *vmsified, *cp;
9090 if (path == NULL) return NULL;
9091 pathified = PerlMem_malloc(VMS_MAXRSS);
9092 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9093 if (int_pathify_dirspec(path, pathified) == NULL) {
9094 PerlMem_free(pathified);
9100 Newx(vmsified, VMS_MAXRSS, char);
9101 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
9102 PerlMem_free(pathified);
9103 if (vmsified) Safefree(vmsified);
9106 PerlMem_free(pathified);
9111 vmslen = strlen(vmsified);
9112 Newx(cp,vmslen+1,char);
9113 memcpy(cp,vmsified,vmslen);
9119 strcpy(__tovmspath_retbuf,vmsified);
9121 return __tovmspath_retbuf;
9124 } /* end of do_tovmspath() */
9126 /* External entry points */
9127 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
9128 { return do_tovmspath(path,buf,0, NULL); }
9129 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
9130 { return do_tovmspath(path,buf,1, NULL); }
9131 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
9132 { return do_tovmspath(path,buf,0,utf8_fl); }
9133 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
9134 { return do_tovmspath(path,buf,1,utf8_fl); }
9137 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
9138 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
9139 static char __tounixpath_retbuf[VMS_MAXRSS];
9141 char *pathified, *unixified, *cp;
9143 if (path == NULL) return NULL;
9144 pathified = PerlMem_malloc(VMS_MAXRSS);
9145 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
9146 if (int_pathify_dirspec(path, pathified) == NULL) {
9147 PerlMem_free(pathified);
9153 Newx(unixified, VMS_MAXRSS, char);
9155 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
9156 PerlMem_free(pathified);
9157 if (unixified) Safefree(unixified);
9160 PerlMem_free(pathified);
9165 unixlen = strlen(unixified);
9166 Newx(cp,unixlen+1,char);
9167 memcpy(cp,unixified,unixlen);
9169 Safefree(unixified);
9173 strcpy(__tounixpath_retbuf,unixified);
9174 Safefree(unixified);
9175 return __tounixpath_retbuf;
9178 } /* end of do_tounixpath() */
9180 /* External entry points */
9181 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
9182 { return do_tounixpath(path,buf,0,NULL); }
9183 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
9184 { return do_tounixpath(path,buf,1,NULL); }
9185 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9186 { return do_tounixpath(path,buf,0,utf8_fl); }
9187 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9188 { return do_tounixpath(path,buf,1,utf8_fl); }
9191 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
9193 *****************************************************************************
9195 * Copyright (C) 1989-1994, 2007 by *
9196 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9198 * Permission is hereby granted for the reproduction of this software *
9199 * on condition that this copyright notice is included in source *
9200 * distributions of the software. The code may be modified and *
9201 * distributed under the same terms as Perl itself. *
9203 * 27-Aug-1994 Modified for inclusion in perl5 *
9204 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
9205 *****************************************************************************
9209 * getredirection() is intended to aid in porting C programs
9210 * to VMS (Vax-11 C). The native VMS environment does not support
9211 * '>' and '<' I/O redirection, or command line wild card expansion,
9212 * or a command line pipe mechanism using the '|' AND background
9213 * command execution '&'. All of these capabilities are provided to any
9214 * C program which calls this procedure as the first thing in the
9216 * The piping mechanism will probably work with almost any 'filter' type
9217 * of program. With suitable modification, it may useful for other
9218 * portability problems as well.
9220 * Author: Mark Pizzolato (mark AT infocomm DOT com)
9224 struct list_item *next;
9228 static void add_item(struct list_item **head,
9229 struct list_item **tail,
9233 static void mp_expand_wild_cards(pTHX_ char *item,
9234 struct list_item **head,
9235 struct list_item **tail,
9238 static int background_process(pTHX_ int argc, char **argv);
9240 static void pipe_and_fork(pTHX_ char **cmargv);
9242 /*{{{ void getredirection(int *ac, char ***av)*/
9244 mp_getredirection(pTHX_ int *ac, char ***av)
9246 * Process vms redirection arg's. Exit if any error is seen.
9247 * If getredirection() processes an argument, it is erased
9248 * from the vector. getredirection() returns a new argc and argv value.
9249 * In the event that a background command is requested (by a trailing "&"),
9250 * this routine creates a background subprocess, and simply exits the program.
9252 * Warning: do not try to simplify the code for vms. The code
9253 * presupposes that getredirection() is called before any data is
9254 * read from stdin or written to stdout.
9256 * Normal usage is as follows:
9262 * getredirection(&argc, &argv);
9266 int argc = *ac; /* Argument Count */
9267 char **argv = *av; /* Argument Vector */
9268 char *ap; /* Argument pointer */
9269 int j; /* argv[] index */
9270 int item_count = 0; /* Count of Items in List */
9271 struct list_item *list_head = 0; /* First Item in List */
9272 struct list_item *list_tail; /* Last Item in List */
9273 char *in = NULL; /* Input File Name */
9274 char *out = NULL; /* Output File Name */
9275 char *outmode = "w"; /* Mode to Open Output File */
9276 char *err = NULL; /* Error File Name */
9277 char *errmode = "w"; /* Mode to Open Error File */
9278 int cmargc = 0; /* Piped Command Arg Count */
9279 char **cmargv = NULL;/* Piped Command Arg Vector */
9282 * First handle the case where the last thing on the line ends with
9283 * a '&'. This indicates the desire for the command to be run in a
9284 * subprocess, so we satisfy that desire.
9287 if (0 == strcmp("&", ap))
9288 exit(background_process(aTHX_ --argc, argv));
9289 if (*ap && '&' == ap[strlen(ap)-1])
9291 ap[strlen(ap)-1] = '\0';
9292 exit(background_process(aTHX_ argc, argv));
9295 * Now we handle the general redirection cases that involve '>', '>>',
9296 * '<', and pipes '|'.
9298 for (j = 0; j < argc; ++j)
9300 if (0 == strcmp("<", argv[j]))
9304 fprintf(stderr,"No input file after < on command line");
9305 exit(LIB$_WRONUMARG);
9310 if ('<' == *(ap = argv[j]))
9315 if (0 == strcmp(">", ap))
9319 fprintf(stderr,"No output file after > on command line");
9320 exit(LIB$_WRONUMARG);
9339 fprintf(stderr,"No output file after > or >> on command line");
9340 exit(LIB$_WRONUMARG);
9344 if (('2' == *ap) && ('>' == ap[1]))
9361 fprintf(stderr,"No output file after 2> or 2>> on command line");
9362 exit(LIB$_WRONUMARG);
9366 if (0 == strcmp("|", argv[j]))
9370 fprintf(stderr,"No command into which to pipe on command line");
9371 exit(LIB$_WRONUMARG);
9373 cmargc = argc-(j+1);
9374 cmargv = &argv[j+1];
9378 if ('|' == *(ap = argv[j]))
9386 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9389 * Allocate and fill in the new argument vector, Some Unix's terminate
9390 * the list with an extra null pointer.
9392 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9393 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9395 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9396 argv[j] = list_head->value;
9402 fprintf(stderr,"'|' and '>' may not both be specified on command line");
9403 exit(LIB$_INVARGORD);
9405 pipe_and_fork(aTHX_ cmargv);
9408 /* Check for input from a pipe (mailbox) */
9410 if (in == NULL && 1 == isapipe(0))
9412 char mbxname[L_tmpnam];
9414 long int dvi_item = DVI$_DEVBUFSIZ;
9415 $DESCRIPTOR(mbxnam, "");
9416 $DESCRIPTOR(mbxdevnam, "");
9418 /* Input from a pipe, reopen it in binary mode to disable */
9419 /* carriage control processing. */
9421 fgetname(stdin, mbxname, 1);
9422 mbxnam.dsc$a_pointer = mbxname;
9423 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9424 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9425 mbxdevnam.dsc$a_pointer = mbxname;
9426 mbxdevnam.dsc$w_length = sizeof(mbxname);
9427 dvi_item = DVI$_DEVNAM;
9428 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9429 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9432 freopen(mbxname, "rb", stdin);
9435 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9439 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9441 fprintf(stderr,"Can't open input file %s as stdin",in);
9444 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9446 fprintf(stderr,"Can't open output file %s as stdout",out);
9449 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9452 if (strcmp(err,"&1") == 0) {
9453 dup2(fileno(stdout), fileno(stderr));
9454 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9457 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9459 fprintf(stderr,"Can't open error file %s as stderr",err);
9463 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9467 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9470 #ifdef ARGPROC_DEBUG
9471 PerlIO_printf(Perl_debug_log, "Arglist:\n");
9472 for (j = 0; j < *ac; ++j)
9473 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9475 /* Clear errors we may have hit expanding wildcards, so they don't
9476 show up in Perl's $! later */
9477 set_errno(0); set_vaxc_errno(1);
9478 } /* end of getredirection() */
9481 static void add_item(struct list_item **head,
9482 struct list_item **tail,
9488 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9489 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9493 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9494 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9495 *tail = (*tail)->next;
9497 (*tail)->value = value;
9501 static void mp_expand_wild_cards(pTHX_ char *item,
9502 struct list_item **head,
9503 struct list_item **tail,
9507 unsigned long int context = 0;
9515 $DESCRIPTOR(filespec, "");
9516 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9517 $DESCRIPTOR(resultspec, "");
9518 unsigned long int lff_flags = 0;
9522 #ifdef VMS_LONGNAME_SUPPORT
9523 lff_flags = LIB$M_FIL_LONG_NAMES;
9526 for (cp = item; *cp; cp++) {
9527 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9528 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9530 if (!*cp || isspace(*cp))
9532 add_item(head, tail, item, count);
9537 /* "double quoted" wild card expressions pass as is */
9538 /* From DCL that means using e.g.: */
9539 /* perl program """perl.*""" */
9540 item_len = strlen(item);
9541 if ( '"' == *item && '"' == item[item_len-1] )
9544 item[item_len-2] = '\0';
9545 add_item(head, tail, item, count);
9549 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9550 resultspec.dsc$b_class = DSC$K_CLASS_D;
9551 resultspec.dsc$a_pointer = NULL;
9552 vmsspec = PerlMem_malloc(VMS_MAXRSS);
9553 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9554 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9555 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9556 if (!isunix || !filespec.dsc$a_pointer)
9557 filespec.dsc$a_pointer = item;
9558 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9560 * Only return version specs, if the caller specified a version
9562 had_version = strchr(item, ';');
9564 * Only return device and directory specs, if the caller specifed either.
9566 had_device = strchr(item, ':');
9567 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9569 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9570 (&filespec, &resultspec, &context,
9571 &defaultspec, 0, &rms_sts, &lff_flags)))
9576 string = PerlMem_malloc(resultspec.dsc$w_length+1);
9577 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9578 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9579 string[resultspec.dsc$w_length] = '\0';
9580 if (NULL == had_version)
9581 *(strrchr(string, ';')) = '\0';
9582 if ((!had_directory) && (had_device == NULL))
9584 if (NULL == (devdir = strrchr(string, ']')))
9585 devdir = strrchr(string, '>');
9586 strcpy(string, devdir + 1);
9589 * Be consistent with what the C RTL has already done to the rest of
9590 * the argv items and lowercase all of these names.
9592 if (!decc_efs_case_preserve) {
9593 for (c = string; *c; ++c)
9597 if (isunix) trim_unixpath(string,item,1);
9598 add_item(head, tail, string, count);
9601 PerlMem_free(vmsspec);
9602 if (sts != RMS$_NMF)
9604 set_vaxc_errno(sts);
9607 case RMS$_FNF: case RMS$_DNF:
9608 set_errno(ENOENT); break;
9610 set_errno(ENOTDIR); break;
9612 set_errno(ENODEV); break;
9613 case RMS$_FNM: case RMS$_SYN:
9614 set_errno(EINVAL); break;
9616 set_errno(EACCES); break;
9618 _ckvmssts_noperl(sts);
9622 add_item(head, tail, item, count);
9623 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9624 _ckvmssts_noperl(lib$find_file_end(&context));
9627 static int child_st[2];/* Event Flag set when child process completes */
9629 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
9631 static unsigned long int exit_handler(int *status)
9635 if (0 == child_st[0])
9637 #ifdef ARGPROC_DEBUG
9638 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9640 fflush(stdout); /* Have to flush pipe for binary data to */
9641 /* terminate properly -- <tp@mccall.com> */
9642 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9643 sys$dassgn(child_chan);
9645 sys$synch(0, child_st);
9650 static void sig_child(int chan)
9652 #ifdef ARGPROC_DEBUG
9653 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9655 if (child_st[0] == 0)
9659 static struct exit_control_block exit_block =
9664 &exit_block.exit_status,
9669 pipe_and_fork(pTHX_ char **cmargv)
9672 struct dsc$descriptor_s *vmscmd;
9673 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9674 int sts, j, l, ismcr, quote, tquote = 0;
9676 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
9677 vms_execfree(vmscmd);
9682 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9683 && toupper(*(q+2)) == 'R' && !*(q+3);
9685 while (q && l < MAX_DCL_LINE_LENGTH) {
9687 if (j > 0 && quote) {
9693 if (ismcr && j > 1) quote = 1;
9694 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9697 if (quote || tquote) {
9703 if ((quote||tquote) && *q == '"') {
9713 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9715 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9719 static int background_process(pTHX_ int argc, char **argv)
9721 char command[MAX_DCL_SYMBOL + 1] = "$";
9722 $DESCRIPTOR(value, "");
9723 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9724 static $DESCRIPTOR(null, "NLA0:");
9725 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9727 $DESCRIPTOR(pidstr, "");
9729 unsigned long int flags = 17, one = 1, retsts;
9732 strcat(command, argv[0]);
9733 len = strlen(command);
9734 while (--argc && (len < MAX_DCL_SYMBOL))
9736 strcat(command, " \"");
9737 strcat(command, *(++argv));
9738 strcat(command, "\"");
9739 len = strlen(command);
9741 value.dsc$a_pointer = command;
9742 value.dsc$w_length = strlen(value.dsc$a_pointer);
9743 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9744 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9745 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9746 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9749 _ckvmssts_noperl(retsts);
9751 #ifdef ARGPROC_DEBUG
9752 PerlIO_printf(Perl_debug_log, "%s\n", command);
9754 sprintf(pidstring, "%08X", pid);
9755 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9756 pidstr.dsc$a_pointer = pidstring;
9757 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9758 lib$set_symbol(&pidsymbol, &pidstr);
9762 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9765 /* OS-specific initialization at image activation (not thread startup) */
9766 /* Older VAXC header files lack these constants */
9767 #ifndef JPI$_RIGHTS_SIZE
9768 # define JPI$_RIGHTS_SIZE 817
9770 #ifndef KGB$M_SUBSYSTEM
9771 # define KGB$M_SUBSYSTEM 0x8
9774 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9776 /*{{{void vms_image_init(int *, char ***)*/
9778 vms_image_init(int *argcp, char ***argvp)
9781 char eqv[LNM$C_NAMLENGTH+1] = "";
9782 unsigned int len, tabct = 8, tabidx = 0;
9783 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9784 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9785 unsigned short int dummy, rlen;
9786 struct dsc$descriptor_s **tabvec;
9787 #if defined(PERL_IMPLICIT_CONTEXT)
9790 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9791 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9792 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9795 #ifdef KILL_BY_SIGPRC
9796 Perl_csighandler_init();
9799 #if __CRTL_VER >= 70300000 && !defined(__VAX)
9800 /* This was moved from the pre-image init handler because on threaded */
9801 /* Perl it was always returning 0 for the default value. */
9802 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9805 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9808 initial = decc$feature_get_value(s, 4);
9810 /* initial is: 0 if nothing has set the feature */
9811 /* -1 if initialized to default */
9812 /* 1 if set by logical name */
9813 /* 2 if set by decc$feature_set_value */
9814 decc_disable_posix_root = decc$feature_get_value(s, 1);
9816 /* If the value is not valid, force the feature off */
9817 if (decc_disable_posix_root < 0) {
9818 decc$feature_set_value(s, 1, 1);
9819 decc_disable_posix_root = 1;
9823 /* Nothing has asked for it explicitly, so use our own default. */
9824 decc_disable_posix_root = 1;
9825 decc$feature_set_value(s, 1, 1);
9831 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9832 _ckvmssts_noperl(iosb[0]);
9833 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9834 if (iprv[i]) { /* Running image installed with privs? */
9835 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
9840 /* Rights identifiers might trigger tainting as well. */
9841 if (!will_taint && (rlen || rsz)) {
9842 while (rlen < rsz) {
9843 /* We didn't get all the identifiers on the first pass. Allocate a
9844 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9845 * were needed to hold all identifiers at time of last call; we'll
9846 * allocate that many unsigned long ints), and go back and get 'em.
9847 * If it gave us less than it wanted to despite ample buffer space,
9848 * something's broken. Is your system missing a system identifier?
9850 if (rsz <= jpilist[1].buflen) {
9851 /* Perl_croak accvios when used this early in startup. */
9852 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9853 rsz, (unsigned long) jpilist[1].buflen,
9854 "Check your rights database for corruption.\n");
9857 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9858 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9859 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9860 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9861 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9862 _ckvmssts_noperl(iosb[0]);
9864 mask = jpilist[1].bufadr;
9865 /* Check attribute flags for each identifier (2nd longword); protected
9866 * subsystem identifiers trigger tainting.
9868 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9869 if (mask[i] & KGB$M_SUBSYSTEM) {
9874 if (mask != rlst) PerlMem_free(mask);
9877 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9878 * logical, some versions of the CRTL will add a phanthom /000000/
9879 * directory. This needs to be removed.
9881 if (decc_filename_unix_report) {
9884 ulen = strlen(argvp[0][0]);
9886 zeros = strstr(argvp[0][0], "/000000/");
9887 if (zeros != NULL) {
9889 mlen = ulen - (zeros - argvp[0][0]) - 7;
9890 memmove(zeros, &zeros[7], mlen);
9892 argvp[0][0][ulen] = '\0';
9895 /* It also may have a trailing dot that needs to be removed otherwise
9896 * it will be converted to VMS mode incorrectly.
9899 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9900 argvp[0][0][ulen] = '\0';
9903 /* We need to use this hack to tell Perl it should run with tainting,
9904 * since its tainting flag may be part of the PL_curinterp struct, which
9905 * hasn't been allocated when vms_image_init() is called.
9908 char **newargv, **oldargv;
9910 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9911 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9912 newargv[0] = oldargv[0];
9913 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9914 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9915 strcpy(newargv[1], "-T");
9916 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9918 newargv[*argcp] = NULL;
9919 /* We orphan the old argv, since we don't know where it's come from,
9920 * so we don't know how to free it.
9924 else { /* Did user explicitly request tainting? */
9926 char *cp, **av = *argvp;
9927 for (i = 1; i < *argcp; i++) {
9928 if (*av[i] != '-') break;
9929 for (cp = av[i]+1; *cp; cp++) {
9930 if (*cp == 'T') { will_taint = 1; break; }
9931 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9932 strchr("DFIiMmx",*cp)) break;
9934 if (will_taint) break;
9939 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9942 tabvec = (struct dsc$descriptor_s **)
9943 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9944 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9946 else if (tabidx >= tabct) {
9948 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9949 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9951 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9952 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9953 tabvec[tabidx]->dsc$w_length = 0;
9954 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9955 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9956 tabvec[tabidx]->dsc$a_pointer = NULL;
9957 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9959 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9961 getredirection(argcp,argvp);
9962 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9964 # include <reentrancy.h>
9965 decc$set_reentrancy(C$C_MULTITHREAD);
9974 * Trim Unix-style prefix off filespec, so it looks like what a shell
9975 * glob expansion would return (i.e. from specified prefix on, not
9976 * full path). Note that returned filespec is Unix-style, regardless
9977 * of whether input filespec was VMS-style or Unix-style.
9979 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9980 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9981 * vector of options; at present, only bit 0 is used, and if set tells
9982 * trim unixpath to try the current default directory as a prefix when
9983 * presented with a possibly ambiguous ... wildcard.
9985 * Returns !=0 on success, with trimmed filespec replacing contents of
9986 * fspec, and 0 on failure, with contents of fpsec unchanged.
9988 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9990 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9992 char *unixified, *unixwild,
9993 *template, *base, *end, *cp1, *cp2;
9994 register int tmplen, reslen = 0, dirs = 0;
9996 if (!wildspec || !fspec) return 0;
9998 unixwild = PerlMem_malloc(VMS_MAXRSS);
9999 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10000 template = unixwild;
10001 if (strpbrk(wildspec,"]>:") != NULL) {
10002 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
10003 PerlMem_free(unixwild);
10008 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
10009 unixwild[VMS_MAXRSS-1] = 0;
10011 unixified = PerlMem_malloc(VMS_MAXRSS);
10012 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10013 if (strpbrk(fspec,"]>:") != NULL) {
10014 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
10015 PerlMem_free(unixwild);
10016 PerlMem_free(unixified);
10019 else base = unixified;
10020 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
10021 * check to see that final result fits into (isn't longer than) fspec */
10022 reslen = strlen(fspec);
10026 /* No prefix or absolute path on wildcard, so nothing to remove */
10027 if (!*template || *template == '/') {
10028 PerlMem_free(unixwild);
10029 if (base == fspec) {
10030 PerlMem_free(unixified);
10033 tmplen = strlen(unixified);
10034 if (tmplen > reslen) {
10035 PerlMem_free(unixified);
10036 return 0; /* not enough space */
10038 /* Copy unixified resultant, including trailing NUL */
10039 memmove(fspec,unixified,tmplen+1);
10040 PerlMem_free(unixified);
10044 for (end = base; *end; end++) ; /* Find end of resultant filespec */
10045 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
10046 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
10047 for (cp1 = end ;cp1 >= base; cp1--)
10048 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
10050 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
10051 PerlMem_free(unixified);
10052 PerlMem_free(unixwild);
10057 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
10058 int ells = 1, totells, segdirs, match;
10059 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
10060 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10062 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
10064 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
10065 tpl = PerlMem_malloc(VMS_MAXRSS);
10066 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10067 if (ellipsis == template && opts & 1) {
10068 /* Template begins with an ellipsis. Since we can't tell how many
10069 * directory names at the front of the resultant to keep for an
10070 * arbitrary starting point, we arbitrarily choose the current
10071 * default directory as a starting point. If it's there as a prefix,
10072 * clip it off. If not, fall through and act as if the leading
10073 * ellipsis weren't there (i.e. return shortest possible path that
10074 * could match template).
10076 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
10078 PerlMem_free(unixified);
10079 PerlMem_free(unixwild);
10082 if (!decc_efs_case_preserve) {
10083 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10084 if (_tolower(*cp1) != _tolower(*cp2)) break;
10086 segdirs = dirs - totells; /* Min # of dirs we must have left */
10087 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
10088 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
10089 memmove(fspec,cp2+1,end - cp2);
10091 PerlMem_free(unixified);
10092 PerlMem_free(unixwild);
10096 /* First off, back up over constant elements at end of path */
10098 for (front = end ; front >= base; front--)
10099 if (*front == '/' && !dirs--) { front++; break; }
10101 lcres = PerlMem_malloc(VMS_MAXRSS);
10102 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10103 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
10105 if (!decc_efs_case_preserve) {
10106 *cp2 = _tolower(*cp1); /* Make lc copy for match */
10114 PerlMem_free(unixified);
10115 PerlMem_free(unixwild);
10116 PerlMem_free(lcres);
10117 return 0; /* Path too long. */
10120 *cp2 = '\0'; /* Pick up with memcpy later */
10121 lcfront = lcres + (front - base);
10122 /* Now skip over each ellipsis and try to match the path in front of it. */
10124 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
10125 if (*(cp1) == '.' && *(cp1+1) == '.' &&
10126 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
10127 if (cp1 < template) break; /* template started with an ellipsis */
10128 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
10129 ellipsis = cp1; continue;
10131 wilddsc.dsc$a_pointer = tpl;
10132 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
10134 for (segdirs = 0, cp2 = tpl;
10135 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
10137 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
10139 if (!decc_efs_case_preserve) {
10140 *cp2 = _tolower(*cp1); /* else lowercase for match */
10143 *cp2 = *cp1; /* else preserve case for match */
10146 if (*cp2 == '/') segdirs++;
10148 if (cp1 != ellipsis - 1) {
10150 PerlMem_free(unixified);
10151 PerlMem_free(unixwild);
10152 PerlMem_free(lcres);
10153 return 0; /* Path too long */
10155 /* Back up at least as many dirs as in template before matching */
10156 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
10157 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
10158 for (match = 0; cp1 > lcres;) {
10159 resdsc.dsc$a_pointer = cp1;
10160 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
10162 if (match == 1) lcfront = cp1;
10164 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
10168 PerlMem_free(unixified);
10169 PerlMem_free(unixwild);
10170 PerlMem_free(lcres);
10171 return 0; /* Can't find prefix ??? */
10173 if (match > 1 && opts & 1) {
10174 /* This ... wildcard could cover more than one set of dirs (i.e.
10175 * a set of similar dir names is repeated). If the template
10176 * contains more than 1 ..., upstream elements could resolve the
10177 * ambiguity, but it's not worth a full backtracking setup here.
10178 * As a quick heuristic, clip off the current default directory
10179 * if it's present to find the trimmed spec, else use the
10180 * shortest string that this ... could cover.
10182 char def[NAM$C_MAXRSS+1], *st;
10184 if (getcwd(def, sizeof def,0) == NULL) {
10185 PerlMem_free(unixified);
10186 PerlMem_free(unixwild);
10187 PerlMem_free(lcres);
10191 if (!decc_efs_case_preserve) {
10192 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10193 if (_tolower(*cp1) != _tolower(*cp2)) break;
10195 segdirs = dirs - totells; /* Min # of dirs we must have left */
10196 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10197 if (*cp1 == '\0' && *cp2 == '/') {
10198 memmove(fspec,cp2+1,end - cp2);
10200 PerlMem_free(unixified);
10201 PerlMem_free(unixwild);
10202 PerlMem_free(lcres);
10205 /* Nope -- stick with lcfront from above and keep going. */
10208 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10210 PerlMem_free(unixified);
10211 PerlMem_free(unixwild);
10212 PerlMem_free(lcres);
10214 ellipsis = nextell;
10217 } /* end of trim_unixpath() */
10222 * VMS readdir() routines.
10223 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10225 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
10226 * Minor modifications to original routines.
10229 /* readdir may have been redefined by reentr.h, so make sure we get
10230 * the local version for what we do here.
10235 #if !defined(PERL_IMPLICIT_CONTEXT)
10236 # define readdir Perl_readdir
10238 # define readdir(a) Perl_readdir(aTHX_ a)
10241 /* Number of elements in vms_versions array */
10242 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10245 * Open a directory, return a handle for later use.
10247 /*{{{ DIR *opendir(char*name) */
10249 Perl_opendir(pTHX_ const char *name)
10255 Newx(dir, VMS_MAXRSS, char);
10256 if (int_tovmspath(name, dir, NULL) == NULL) {
10260 /* Check access before stat; otherwise stat does not
10261 * accurately report whether it's a directory.
10263 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10264 /* cando_by_name has already set errno */
10268 if (flex_stat(dir,&sb) == -1) return NULL;
10269 if (!S_ISDIR(sb.st_mode)) {
10271 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10274 /* Get memory for the handle, and the pattern. */
10276 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10278 /* Fill in the fields; mainly playing with the descriptor. */
10279 sprintf(dd->pattern, "%s*.*",dir);
10284 /* By saying we always want the result of readdir() in unix format, we
10285 * are really saying we want all the escapes removed. Otherwise the caller,
10286 * having no way to know whether it's already in VMS format, might send it
10287 * through tovmsspec again, thus double escaping.
10289 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10290 dd->pat.dsc$a_pointer = dd->pattern;
10291 dd->pat.dsc$w_length = strlen(dd->pattern);
10292 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10293 dd->pat.dsc$b_class = DSC$K_CLASS_S;
10294 #if defined(USE_ITHREADS)
10295 Newx(dd->mutex,1,perl_mutex);
10296 MUTEX_INIT( (perl_mutex *) dd->mutex );
10302 } /* end of opendir() */
10306 * Set the flag to indicate we want versions or not.
10308 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10310 vmsreaddirversions(DIR *dd, int flag)
10313 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10315 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10320 * Free up an opened directory.
10322 /*{{{ void closedir(DIR *dd)*/
10324 Perl_closedir(DIR *dd)
10328 sts = lib$find_file_end(&dd->context);
10329 Safefree(dd->pattern);
10330 #if defined(USE_ITHREADS)
10331 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10332 Safefree(dd->mutex);
10339 * Collect all the version numbers for the current file.
10342 collectversions(pTHX_ DIR *dd)
10344 struct dsc$descriptor_s pat;
10345 struct dsc$descriptor_s res;
10347 char *p, *text, *buff;
10349 unsigned long context, tmpsts;
10351 /* Convenient shorthand. */
10354 /* Add the version wildcard, ignoring the "*.*" put on before */
10355 i = strlen(dd->pattern);
10356 Newx(text,i + e->d_namlen + 3,char);
10357 strcpy(text, dd->pattern);
10358 sprintf(&text[i - 3], "%s;*", e->d_name);
10360 /* Set up the pattern descriptor. */
10361 pat.dsc$a_pointer = text;
10362 pat.dsc$w_length = i + e->d_namlen - 1;
10363 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10364 pat.dsc$b_class = DSC$K_CLASS_S;
10366 /* Set up result descriptor. */
10367 Newx(buff, VMS_MAXRSS, char);
10368 res.dsc$a_pointer = buff;
10369 res.dsc$w_length = VMS_MAXRSS - 1;
10370 res.dsc$b_dtype = DSC$K_DTYPE_T;
10371 res.dsc$b_class = DSC$K_CLASS_S;
10373 /* Read files, collecting versions. */
10374 for (context = 0, e->vms_verscount = 0;
10375 e->vms_verscount < VERSIZE(e);
10376 e->vms_verscount++) {
10377 unsigned long rsts;
10378 unsigned long flags = 0;
10380 #ifdef VMS_LONGNAME_SUPPORT
10381 flags = LIB$M_FIL_LONG_NAMES;
10383 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10384 if (tmpsts == RMS$_NMF || context == 0) break;
10386 buff[VMS_MAXRSS - 1] = '\0';
10387 if ((p = strchr(buff, ';')))
10388 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10390 e->vms_versions[e->vms_verscount] = -1;
10393 _ckvmssts(lib$find_file_end(&context));
10397 } /* end of collectversions() */
10400 * Read the next entry from the directory.
10402 /*{{{ struct dirent *readdir(DIR *dd)*/
10404 Perl_readdir(pTHX_ DIR *dd)
10406 struct dsc$descriptor_s res;
10408 unsigned long int tmpsts;
10409 unsigned long rsts;
10410 unsigned long flags = 0;
10411 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10412 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10414 /* Set up result descriptor, and get next file. */
10415 Newx(buff, VMS_MAXRSS, char);
10416 res.dsc$a_pointer = buff;
10417 res.dsc$w_length = VMS_MAXRSS - 1;
10418 res.dsc$b_dtype = DSC$K_DTYPE_T;
10419 res.dsc$b_class = DSC$K_CLASS_S;
10421 #ifdef VMS_LONGNAME_SUPPORT
10422 flags = LIB$M_FIL_LONG_NAMES;
10425 tmpsts = lib$find_file
10426 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10427 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
10428 if (!(tmpsts & 1)) {
10429 set_vaxc_errno(tmpsts);
10432 set_errno(EACCES); break;
10434 set_errno(ENODEV); break;
10436 set_errno(ENOTDIR); break;
10437 case RMS$_FNF: case RMS$_DNF:
10438 set_errno(ENOENT); break;
10440 set_errno(EVMSERR);
10446 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10447 buff[res.dsc$w_length] = '\0';
10448 p = buff + res.dsc$w_length;
10449 while (--p >= buff) if (!isspace(*p)) break;
10451 if (!decc_efs_case_preserve) {
10452 for (p = buff; *p; p++) *p = _tolower(*p);
10455 /* Skip any directory component and just copy the name. */
10456 sts = vms_split_path
10471 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10473 /* In Unix report mode, remove the ".dir;1" from the name */
10474 /* if it is a real directory. */
10475 if (decc_filename_unix_report || decc_efs_charset) {
10476 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
10480 ret_sts = flex_lstat(buff, &statbuf);
10481 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10488 /* Drop NULL extensions on UNIX file specification */
10489 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10495 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10496 dd->entry.d_name[n_len + e_len] = '\0';
10497 dd->entry.d_namlen = strlen(dd->entry.d_name);
10499 /* Convert the filename to UNIX format if needed */
10500 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10502 /* Translate the encoded characters. */
10503 /* Fixme: Unicode handling could result in embedded 0 characters */
10504 if (strchr(dd->entry.d_name, '^') != NULL) {
10505 char new_name[256];
10507 p = dd->entry.d_name;
10510 int inchars_read, outchars_added;
10511 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10513 q += outchars_added;
10515 /* if outchars_added > 1, then this is a wide file specification */
10516 /* Wide file specifications need to be passed in Perl */
10517 /* counted strings apparently with a Unicode flag */
10520 strcpy(dd->entry.d_name, new_name);
10521 dd->entry.d_namlen = strlen(dd->entry.d_name);
10525 dd->entry.vms_verscount = 0;
10526 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10530 } /* end of readdir() */
10534 * Read the next entry from the directory -- thread-safe version.
10536 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10538 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10542 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10544 entry = readdir(dd);
10546 retval = ( *result == NULL ? errno : 0 );
10548 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10552 } /* end of readdir_r() */
10556 * Return something that can be used in a seekdir later.
10558 /*{{{ long telldir(DIR *dd)*/
10560 Perl_telldir(DIR *dd)
10567 * Return to a spot where we used to be. Brute force.
10569 /*{{{ void seekdir(DIR *dd,long count)*/
10571 Perl_seekdir(pTHX_ DIR *dd, long count)
10575 /* If we haven't done anything yet... */
10576 if (dd->count == 0)
10579 /* Remember some state, and clear it. */
10580 old_flags = dd->flags;
10581 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10582 _ckvmssts(lib$find_file_end(&dd->context));
10585 /* The increment is in readdir(). */
10586 for (dd->count = 0; dd->count < count; )
10589 dd->flags = old_flags;
10591 } /* end of seekdir() */
10594 /* VMS subprocess management
10596 * my_vfork() - just a vfork(), after setting a flag to record that
10597 * the current script is trying a Unix-style fork/exec.
10599 * vms_do_aexec() and vms_do_exec() are called in response to the
10600 * perl 'exec' function. If this follows a vfork call, then they
10601 * call out the regular perl routines in doio.c which do an
10602 * execvp (for those who really want to try this under VMS).
10603 * Otherwise, they do exactly what the perl docs say exec should
10604 * do - terminate the current script and invoke a new command
10605 * (See below for notes on command syntax.)
10607 * do_aspawn() and do_spawn() implement the VMS side of the perl
10608 * 'system' function.
10610 * Note on command arguments to perl 'exec' and 'system': When handled
10611 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10612 * are concatenated to form a DCL command string. If the first non-numeric
10613 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10614 * the command string is handed off to DCL directly. Otherwise,
10615 * the first token of the command is taken as the filespec of an image
10616 * to run. The filespec is expanded using a default type of '.EXE' and
10617 * the process defaults for device, directory, etc., and if found, the resultant
10618 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10619 * the command string as parameters. This is perhaps a bit complicated,
10620 * but I hope it will form a happy medium between what VMS folks expect
10621 * from lib$spawn and what Unix folks expect from exec.
10624 static int vfork_called;
10626 /*{{{int my_vfork()*/
10637 vms_execfree(struct dsc$descriptor_s *vmscmd)
10640 if (vmscmd->dsc$a_pointer) {
10641 PerlMem_free(vmscmd->dsc$a_pointer);
10643 PerlMem_free(vmscmd);
10648 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10650 char *junk, *tmps = NULL;
10651 register size_t cmdlen = 0;
10658 tmps = SvPV(really,rlen);
10660 cmdlen += rlen + 1;
10665 for (idx++; idx <= sp; idx++) {
10667 junk = SvPVx(*idx,rlen);
10668 cmdlen += rlen ? rlen + 1 : 0;
10671 Newx(PL_Cmd, cmdlen+1, char);
10673 if (tmps && *tmps) {
10674 strcpy(PL_Cmd,tmps);
10677 else *PL_Cmd = '\0';
10678 while (++mark <= sp) {
10680 char *s = SvPVx(*mark,n_a);
10682 if (*PL_Cmd) strcat(PL_Cmd," ");
10688 } /* end of setup_argstr() */
10691 static unsigned long int
10692 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10693 struct dsc$descriptor_s **pvmscmd)
10697 char image_name[NAM$C_MAXRSS+1];
10698 char image_argv[NAM$C_MAXRSS+1];
10699 $DESCRIPTOR(defdsc,".EXE");
10700 $DESCRIPTOR(defdsc2,".");
10701 struct dsc$descriptor_s resdsc;
10702 struct dsc$descriptor_s *vmscmd;
10703 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10704 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10705 register char *s, *rest, *cp, *wordbreak;
10708 register int isdcl;
10710 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10711 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10713 /* vmsspec is a DCL command buffer, not just a filename */
10714 vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10715 if (vmsspec == NULL)
10716 _ckvmssts_noperl(SS$_INSFMEM);
10718 resspec = PerlMem_malloc(VMS_MAXRSS);
10719 if (resspec == NULL)
10720 _ckvmssts_noperl(SS$_INSFMEM);
10722 /* Make a copy for modification */
10723 cmdlen = strlen(incmd);
10724 cmd = PerlMem_malloc(cmdlen+1);
10725 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10726 strncpy(cmd, incmd, cmdlen);
10731 resdsc.dsc$a_pointer = resspec;
10732 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10733 resdsc.dsc$b_class = DSC$K_CLASS_S;
10734 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10736 vmscmd->dsc$a_pointer = NULL;
10737 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10738 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10739 vmscmd->dsc$w_length = 0;
10740 if (pvmscmd) *pvmscmd = vmscmd;
10742 if (suggest_quote) *suggest_quote = 0;
10744 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10746 PerlMem_free(vmsspec);
10747 PerlMem_free(resspec);
10748 return CLI$_BUFOVF; /* continuation lines currently unsupported */
10753 while (*s && isspace(*s)) s++;
10755 if (*s == '@' || *s == '$') {
10756 vmsspec[0] = *s; rest = s + 1;
10757 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10759 else { cp = vmsspec; rest = s; }
10760 if (*rest == '.' || *rest == '/') {
10762 for (cp2 = resspec;
10763 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10764 rest++, cp2++) *cp2 = *rest;
10766 if (int_tovmsspec(resspec, cp, 0, NULL)) {
10769 /* When a UNIX spec with no file type is translated to VMS, */
10770 /* A trailing '.' is appended under ODS-5 rules. */
10771 /* Here we do not want that trailing "." as it prevents */
10772 /* Looking for a implied ".exe" type. */
10773 if (decc_efs_charset) {
10775 i = strlen(vmsspec);
10776 if (vmsspec[i-1] == '.') {
10777 vmsspec[i-1] = '\0';
10782 for (cp2 = vmsspec + strlen(vmsspec);
10783 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10784 rest++, cp2++) *cp2 = *rest;
10789 /* Intuit whether verb (first word of cmd) is a DCL command:
10790 * - if first nonspace char is '@', it's a DCL indirection
10792 * - if verb contains a filespec separator, it's not a DCL command
10793 * - if it doesn't, caller tells us whether to default to a DCL
10794 * command, or to a local image unless told it's DCL (by leading '$')
10798 if (suggest_quote) *suggest_quote = 1;
10800 register char *filespec = strpbrk(s,":<[.;");
10801 rest = wordbreak = strpbrk(s," \"\t/");
10802 if (!wordbreak) wordbreak = s + strlen(s);
10803 if (*s == '$') check_img = 0;
10804 if (filespec && (filespec < wordbreak)) isdcl = 0;
10805 else isdcl = !check_img;
10810 imgdsc.dsc$a_pointer = s;
10811 imgdsc.dsc$w_length = wordbreak - s;
10812 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10814 _ckvmssts_noperl(lib$find_file_end(&cxt));
10815 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10816 if (!(retsts & 1) && *s == '$') {
10817 _ckvmssts_noperl(lib$find_file_end(&cxt));
10818 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10819 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10821 _ckvmssts_noperl(lib$find_file_end(&cxt));
10822 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10826 _ckvmssts_noperl(lib$find_file_end(&cxt));
10831 while (*s && !isspace(*s)) s++;
10834 /* check that it's really not DCL with no file extension */
10835 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10837 char b[256] = {0,0,0,0};
10838 read(fileno(fp), b, 256);
10839 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10843 /* Check for script */
10845 if ((b[0] == '#') && (b[1] == '!'))
10847 #ifdef ALTERNATE_SHEBANG
10849 shebang_len = strlen(ALTERNATE_SHEBANG);
10850 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10852 perlstr = strstr("perl",b);
10853 if (perlstr == NULL)
10861 if (shebang_len > 0) {
10864 char tmpspec[NAM$C_MAXRSS + 1];
10867 /* Image is following after white space */
10868 /*--------------------------------------*/
10869 while (isprint(b[i]) && isspace(b[i]))
10873 while (isprint(b[i]) && !isspace(b[i])) {
10874 tmpspec[j++] = b[i++];
10875 if (j >= NAM$C_MAXRSS)
10880 /* There may be some default parameters to the image */
10881 /*---------------------------------------------------*/
10883 while (isprint(b[i])) {
10884 image_argv[j++] = b[i++];
10885 if (j >= NAM$C_MAXRSS)
10888 while ((j > 0) && !isprint(image_argv[j-1]))
10892 /* It will need to be converted to VMS format and validated */
10893 if (tmpspec[0] != '\0') {
10896 /* Try to find the exact program requested to be run */
10897 /*---------------------------------------------------*/
10898 iname = int_rmsexpand
10899 (tmpspec, image_name, ".exe",
10900 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10901 if (iname != NULL) {
10902 if (cando_by_name_int
10903 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10904 /* MCR prefix needed */
10908 /* Try again with a null type */
10909 /*----------------------------*/
10910 iname = int_rmsexpand
10911 (tmpspec, image_name, ".",
10912 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10913 if (iname != NULL) {
10914 if (cando_by_name_int
10915 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10916 /* MCR prefix needed */
10922 /* Did we find the image to run the script? */
10923 /*------------------------------------------*/
10927 /* Assume DCL or foreign command exists */
10928 /*--------------------------------------*/
10929 tchr = strrchr(tmpspec, '/');
10930 if (tchr != NULL) {
10936 strcpy(image_name, tchr);
10944 if (check_img && isdcl) {
10946 PerlMem_free(resspec);
10947 PerlMem_free(vmsspec);
10951 if (cando_by_name(S_IXUSR,0,resspec)) {
10952 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10953 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10955 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10956 if (image_name[0] != 0) {
10957 strcat(vmscmd->dsc$a_pointer, image_name);
10958 strcat(vmscmd->dsc$a_pointer, " ");
10960 } else if (image_name[0] != 0) {
10961 strcpy(vmscmd->dsc$a_pointer, image_name);
10962 strcat(vmscmd->dsc$a_pointer, " ");
10964 strcpy(vmscmd->dsc$a_pointer,"@");
10966 if (suggest_quote) *suggest_quote = 1;
10968 /* If there is an image name, use original command */
10969 if (image_name[0] == 0)
10970 strcat(vmscmd->dsc$a_pointer,resspec);
10973 while (*rest && isspace(*rest)) rest++;
10976 if (image_argv[0] != 0) {
10977 strcat(vmscmd->dsc$a_pointer,image_argv);
10978 strcat(vmscmd->dsc$a_pointer, " ");
10984 rest_len = strlen(rest);
10985 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10986 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10987 strcat(vmscmd->dsc$a_pointer,rest);
10989 retsts = CLI$_BUFOVF;
10991 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10993 PerlMem_free(vmsspec);
10994 PerlMem_free(resspec);
10995 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11001 /* It's either a DCL command or we couldn't find a suitable image */
11002 vmscmd->dsc$w_length = strlen(cmd);
11004 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
11005 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
11006 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
11009 PerlMem_free(resspec);
11010 PerlMem_free(vmsspec);
11012 /* check if it's a symbol (for quoting purposes) */
11013 if (suggest_quote && !*suggest_quote) {
11015 char equiv[LNM$C_NAMLENGTH];
11016 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
11017 eqvdsc.dsc$a_pointer = equiv;
11019 iss = lib$get_symbol(vmscmd,&eqvdsc);
11020 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
11022 if (!(retsts & 1)) {
11023 /* just hand off status values likely to be due to user error */
11024 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
11025 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
11026 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
11027 else { _ckvmssts_noperl(retsts); }
11030 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
11032 } /* end of setup_cmddsc() */
11035 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
11037 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
11043 if (vfork_called) { /* this follows a vfork - act Unixish */
11045 if (vfork_called < 0) {
11046 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11049 else return do_aexec(really,mark,sp);
11051 /* no vfork - act VMSish */
11052 cmd = setup_argstr(aTHX_ really,mark,sp);
11053 exec_sts = vms_do_exec(cmd);
11054 Safefree(cmd); /* Clean up from setup_argstr() */
11059 } /* end of vms_do_aexec() */
11062 /* {{{bool vms_do_exec(char *cmd) */
11064 Perl_vms_do_exec(pTHX_ const char *cmd)
11066 struct dsc$descriptor_s *vmscmd;
11068 if (vfork_called) { /* this follows a vfork - act Unixish */
11070 if (vfork_called < 0) {
11071 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
11074 else return do_exec(cmd);
11077 { /* no vfork - act VMSish */
11078 unsigned long int retsts;
11081 TAINT_PROPER("exec");
11082 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
11083 retsts = lib$do_command(vmscmd);
11086 case RMS$_FNF: case RMS$_DNF:
11087 set_errno(ENOENT); break;
11089 set_errno(ENOTDIR); break;
11091 set_errno(ENODEV); break;
11093 set_errno(EACCES); break;
11095 set_errno(EINVAL); break;
11096 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11097 set_errno(E2BIG); break;
11098 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11099 _ckvmssts_noperl(retsts); /* fall through */
11100 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11101 set_errno(EVMSERR);
11103 set_vaxc_errno(retsts);
11104 if (ckWARN(WARN_EXEC)) {
11105 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
11106 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
11108 vms_execfree(vmscmd);
11113 } /* end of vms_do_exec() */
11116 int do_spawn2(pTHX_ const char *, int);
11119 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
11121 unsigned long int sts;
11127 /* We'll copy the (undocumented?) Win32 behavior and allow a
11128 * numeric first argument. But the only value we'll support
11129 * through do_aspawn is a value of 1, which means spawn without
11130 * waiting for completion -- other values are ignored.
11132 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
11134 flags = SvIVx(*mark);
11137 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
11138 flags = CLI$M_NOWAIT;
11142 cmd = setup_argstr(aTHX_ really, mark, sp);
11143 sts = do_spawn2(aTHX_ cmd, flags);
11144 /* pp_sys will clean up cmd */
11148 } /* end of do_aspawn() */
11152 /* {{{int do_spawn(char* cmd) */
11154 Perl_do_spawn(pTHX_ char* cmd)
11156 PERL_ARGS_ASSERT_DO_SPAWN;
11158 return do_spawn2(aTHX_ cmd, 0);
11162 /* {{{int do_spawn_nowait(char* cmd) */
11164 Perl_do_spawn_nowait(pTHX_ char* cmd)
11166 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
11168 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
11172 /* {{{int do_spawn2(char *cmd) */
11174 do_spawn2(pTHX_ const char *cmd, int flags)
11176 unsigned long int sts, substs;
11178 /* The caller of this routine expects to Safefree(PL_Cmd) */
11179 Newx(PL_Cmd,10,char);
11182 TAINT_PROPER("spawn");
11183 if (!cmd || !*cmd) {
11184 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11187 case RMS$_FNF: case RMS$_DNF:
11188 set_errno(ENOENT); break;
11190 set_errno(ENOTDIR); break;
11192 set_errno(ENODEV); break;
11194 set_errno(EACCES); break;
11196 set_errno(EINVAL); break;
11197 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11198 set_errno(E2BIG); break;
11199 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11200 _ckvmssts_noperl(sts); /* fall through */
11201 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11202 set_errno(EVMSERR);
11204 set_vaxc_errno(sts);
11205 if (ckWARN(WARN_EXEC)) {
11206 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11215 if (flags & CLI$M_NOWAIT)
11218 strcpy(mode, "nW");
11220 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11223 /* sts will be the pid in the nowait case */
11226 } /* end of do_spawn2() */
11230 static unsigned int *sockflags, sockflagsize;
11233 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11234 * routines found in some versions of the CRTL can't deal with sockets.
11235 * We don't shim the other file open routines since a socket isn't
11236 * likely to be opened by a name.
11238 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11239 FILE *my_fdopen(int fd, const char *mode)
11241 FILE *fp = fdopen(fd, mode);
11244 unsigned int fdoff = fd / sizeof(unsigned int);
11245 Stat_t sbuf; /* native stat; we don't need flex_stat */
11246 if (!sockflagsize || fdoff > sockflagsize) {
11247 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
11248 else Newx (sockflags,fdoff+2,unsigned int);
11249 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11250 sockflagsize = fdoff + 2;
11252 if (fstat(fd, &sbuf.crtl_stat) == 0 && S_ISSOCK(sbuf.st_mode))
11253 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11262 * Clear the corresponding bit when the (possibly) socket stream is closed.
11263 * There still a small hole: we miss an implicit close which might occur
11264 * via freopen(). >> Todo
11266 /*{{{ int my_fclose(FILE *fp)*/
11267 int my_fclose(FILE *fp) {
11269 unsigned int fd = fileno(fp);
11270 unsigned int fdoff = fd / sizeof(unsigned int);
11272 if (sockflagsize && fdoff < sockflagsize)
11273 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11281 * A simple fwrite replacement which outputs itmsz*nitm chars without
11282 * introducing record boundaries every itmsz chars.
11283 * We are using fputs, which depends on a terminating null. We may
11284 * well be writing binary data, so we need to accommodate not only
11285 * data with nulls sprinkled in the middle but also data with no null
11288 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11290 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11292 register char *cp, *end, *cpd, *data;
11293 register unsigned int fd = fileno(dest);
11294 register unsigned int fdoff = fd / sizeof(unsigned int);
11296 int bufsize = itmsz * nitm + 1;
11298 if (fdoff < sockflagsize &&
11299 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11300 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11304 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11305 memcpy( data, src, itmsz*nitm );
11306 data[itmsz*nitm] = '\0';
11308 end = data + itmsz * nitm;
11309 retval = (int) nitm; /* on success return # items written */
11312 while (cpd <= end) {
11313 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11314 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11316 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11320 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11323 } /* end of my_fwrite() */
11326 /*{{{ int my_flush(FILE *fp)*/
11328 Perl_my_flush(pTHX_ FILE *fp)
11331 if ((res = fflush(fp)) == 0 && fp) {
11332 #ifdef VMS_DO_SOCKETS
11334 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11336 res = fsync(fileno(fp));
11339 * If the flush succeeded but set end-of-file, we need to clear
11340 * the error because our caller may check ferror(). BTW, this
11341 * probably means we just flushed an empty file.
11343 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11349 /* fgetname() is not returning the correct file specifications when
11350 * decc_filename_unix_report mode is active. So we have to have it
11351 * aways return filenames in VMS mode and convert it ourselves.
11354 /*{{{ char * my_fgetname(FILE *fp, buf)*/
11356 Perl_my_fgetname(FILE *fp, char * buf) {
11360 retname = fgetname(fp, buf, 1);
11362 /* If we are in VMS mode, then we are done */
11363 if (!decc_filename_unix_report || (retname == NULL)) {
11367 /* Convert this to Unix format */
11368 vms_name = PerlMem_malloc(VMS_MAXRSS + 1);
11369 strcpy(vms_name, retname);
11370 retname = int_tounixspec(vms_name, buf, NULL);
11371 PerlMem_free(vms_name);
11378 * Here are replacements for the following Unix routines in the VMS environment:
11379 * getpwuid Get information for a particular UIC or UID
11380 * getpwnam Get information for a named user
11381 * getpwent Get information for each user in the rights database
11382 * setpwent Reset search to the start of the rights database
11383 * endpwent Finish searching for users in the rights database
11385 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11386 * (defined in pwd.h), which contains the following fields:-
11388 * char *pw_name; Username (in lower case)
11389 * char *pw_passwd; Hashed password
11390 * unsigned int pw_uid; UIC
11391 * unsigned int pw_gid; UIC group number
11392 * char *pw_unixdir; Default device/directory (VMS-style)
11393 * char *pw_gecos; Owner name
11394 * char *pw_dir; Default device/directory (Unix-style)
11395 * char *pw_shell; Default CLI name (eg. DCL)
11397 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11399 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11400 * not the UIC member number (eg. what's returned by getuid()),
11401 * getpwuid() can accept either as input (if uid is specified, the caller's
11402 * UIC group is used), though it won't recognise gid=0.
11404 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11405 * information about other users in your group or in other groups, respectively.
11406 * If the required privilege is not available, then these routines fill only
11407 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11410 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11413 /* sizes of various UAF record fields */
11414 #define UAI$S_USERNAME 12
11415 #define UAI$S_IDENT 31
11416 #define UAI$S_OWNER 31
11417 #define UAI$S_DEFDEV 31
11418 #define UAI$S_DEFDIR 63
11419 #define UAI$S_DEFCLI 31
11420 #define UAI$S_PWD 8
11422 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11423 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11424 (uic).uic$v_group != UIC$K_WILD_GROUP)
11426 static char __empty[]= "";
11427 static struct passwd __passwd_empty=
11428 {(char *) __empty, (char *) __empty, 0, 0,
11429 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11430 static int contxt= 0;
11431 static struct passwd __pwdcache;
11432 static char __pw_namecache[UAI$S_IDENT+1];
11435 * This routine does most of the work extracting the user information.
11437 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11440 unsigned char length;
11441 char pw_gecos[UAI$S_OWNER+1];
11443 static union uicdef uic;
11445 unsigned char length;
11446 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11449 unsigned char length;
11450 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11453 unsigned char length;
11454 char pw_shell[UAI$S_DEFCLI+1];
11456 static char pw_passwd[UAI$S_PWD+1];
11458 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11459 struct dsc$descriptor_s name_desc;
11460 unsigned long int sts;
11462 static struct itmlst_3 itmlst[]= {
11463 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11464 {sizeof(uic), UAI$_UIC, &uic, &luic},
11465 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11466 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11467 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11468 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11469 {0, 0, NULL, NULL}};
11471 name_desc.dsc$w_length= strlen(name);
11472 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11473 name_desc.dsc$b_class= DSC$K_CLASS_S;
11474 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11476 /* Note that sys$getuai returns many fields as counted strings. */
11477 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11478 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11479 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11481 else { _ckvmssts(sts); }
11482 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
11484 if ((int) owner.length < lowner) lowner= (int) owner.length;
11485 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11486 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11487 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11488 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11489 owner.pw_gecos[lowner]= '\0';
11490 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11491 defcli.pw_shell[ldefcli]= '\0';
11492 if (valid_uic(uic)) {
11493 pwd->pw_uid= uic.uic$l_uic;
11494 pwd->pw_gid= uic.uic$v_group;
11497 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11498 pwd->pw_passwd= pw_passwd;
11499 pwd->pw_gecos= owner.pw_gecos;
11500 pwd->pw_dir= defdev.pw_dir;
11501 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11502 pwd->pw_shell= defcli.pw_shell;
11503 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11505 ldir= strlen(pwd->pw_unixdir) - 1;
11506 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11509 strcpy(pwd->pw_unixdir, pwd->pw_dir);
11510 if (!decc_efs_case_preserve)
11511 __mystrtolower(pwd->pw_unixdir);
11516 * Get information for a named user.
11518 /*{{{struct passwd *getpwnam(char *name)*/
11519 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11521 struct dsc$descriptor_s name_desc;
11523 unsigned long int status, sts;
11525 __pwdcache = __passwd_empty;
11526 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11527 /* We still may be able to determine pw_uid and pw_gid */
11528 name_desc.dsc$w_length= strlen(name);
11529 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11530 name_desc.dsc$b_class= DSC$K_CLASS_S;
11531 name_desc.dsc$a_pointer= (char *) name;
11532 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11533 __pwdcache.pw_uid= uic.uic$l_uic;
11534 __pwdcache.pw_gid= uic.uic$v_group;
11537 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11538 set_vaxc_errno(sts);
11539 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11542 else { _ckvmssts(sts); }
11545 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11546 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11547 __pwdcache.pw_name= __pw_namecache;
11548 return &__pwdcache;
11549 } /* end of my_getpwnam() */
11553 * Get information for a particular UIC or UID.
11554 * Called by my_getpwent with uid=-1 to list all users.
11556 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11557 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11559 const $DESCRIPTOR(name_desc,__pw_namecache);
11560 unsigned short lname;
11562 unsigned long int status;
11564 if (uid == (unsigned int) -1) {
11566 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11567 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11568 set_vaxc_errno(status);
11569 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11573 else { _ckvmssts(status); }
11574 } while (!valid_uic (uic));
11577 uic.uic$l_uic= uid;
11578 if (!uic.uic$v_group)
11579 uic.uic$v_group= PerlProc_getgid();
11580 if (valid_uic(uic))
11581 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11582 else status = SS$_IVIDENT;
11583 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11584 status == RMS$_PRV) {
11585 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11588 else { _ckvmssts(status); }
11590 __pw_namecache[lname]= '\0';
11591 __mystrtolower(__pw_namecache);
11593 __pwdcache = __passwd_empty;
11594 __pwdcache.pw_name = __pw_namecache;
11596 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11597 The identifier's value is usually the UIC, but it doesn't have to be,
11598 so if we can, we let fillpasswd update this. */
11599 __pwdcache.pw_uid = uic.uic$l_uic;
11600 __pwdcache.pw_gid = uic.uic$v_group;
11602 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11603 return &__pwdcache;
11605 } /* end of my_getpwuid() */
11609 * Get information for next user.
11611 /*{{{struct passwd *my_getpwent()*/
11612 struct passwd *Perl_my_getpwent(pTHX)
11614 return (my_getpwuid((unsigned int) -1));
11619 * Finish searching rights database for users.
11621 /*{{{void my_endpwent()*/
11622 void Perl_my_endpwent(pTHX)
11625 _ckvmssts(sys$finish_rdb(&contxt));
11631 #ifdef HOMEGROWN_POSIX_SIGNALS
11632 /* Signal handling routines, pulled into the core from POSIX.xs.
11634 * We need these for threads, so they've been rolled into the core,
11635 * rather than left in POSIX.xs.
11637 * (DRS, Oct 23, 1997)
11640 /* sigset_t is atomic under VMS, so these routines are easy */
11641 /*{{{int my_sigemptyset(sigset_t *) */
11642 int my_sigemptyset(sigset_t *set) {
11643 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11644 *set = 0; return 0;
11649 /*{{{int my_sigfillset(sigset_t *)*/
11650 int my_sigfillset(sigset_t *set) {
11652 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11653 for (i = 0; i < NSIG; i++) *set |= (1 << i);
11659 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11660 int my_sigaddset(sigset_t *set, int sig) {
11661 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11662 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11663 *set |= (1 << (sig - 1));
11669 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11670 int my_sigdelset(sigset_t *set, int sig) {
11671 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11672 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11673 *set &= ~(1 << (sig - 1));
11679 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11680 int my_sigismember(sigset_t *set, int sig) {
11681 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11682 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11683 return *set & (1 << (sig - 1));
11688 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11689 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11692 /* If set and oset are both null, then things are badly wrong. Bail out. */
11693 if ((oset == NULL) && (set == NULL)) {
11694 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11698 /* If set's null, then we're just handling a fetch. */
11700 tempmask = sigblock(0);
11705 tempmask = sigsetmask(*set);
11708 tempmask = sigblock(*set);
11711 tempmask = sigblock(0);
11712 sigsetmask(*oset & ~tempmask);
11715 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11720 /* Did they pass us an oset? If so, stick our holding mask into it */
11727 #endif /* HOMEGROWN_POSIX_SIGNALS */
11730 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11731 * my_utime(), and flex_stat(), all of which operate on UTC unless
11732 * VMSISH_TIMES is true.
11734 /* method used to handle UTC conversions:
11735 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
11737 static int gmtime_emulation_type;
11738 /* number of secs to add to UTC POSIX-style time to get local time */
11739 static long int utc_offset_secs;
11741 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11742 * in vmsish.h. #undef them here so we can call the CRTL routines
11751 * DEC C previous to 6.0 corrupts the behavior of the /prefix
11752 * qualifier with the extern prefix pragma. This provisional
11753 * hack circumvents this prefix pragma problem in previous
11756 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11757 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11758 # pragma __extern_prefix save
11759 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
11760 # define gmtime decc$__utctz_gmtime
11761 # define localtime decc$__utctz_localtime
11762 # define time decc$__utc_time
11763 # pragma __extern_prefix restore
11765 struct tm *gmtime(), *localtime();
11771 static time_t toutc_dst(time_t loc) {
11774 if ((rsltmp = localtime(&loc)) == NULL) return -1;
11775 loc -= utc_offset_secs;
11776 if (rsltmp->tm_isdst) loc -= 3600;
11779 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11780 ((gmtime_emulation_type || my_time(NULL)), \
11781 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11782 ((secs) - utc_offset_secs))))
11784 static time_t toloc_dst(time_t utc) {
11787 utc += utc_offset_secs;
11788 if ((rsltmp = localtime(&utc)) == NULL) return -1;
11789 if (rsltmp->tm_isdst) utc += 3600;
11792 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11793 ((gmtime_emulation_type || my_time(NULL)), \
11794 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11795 ((secs) + utc_offset_secs))))
11797 #ifndef RTL_USES_UTC
11800 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
11801 DST starts on 1st sun of april at 02:00 std time
11802 ends on last sun of october at 02:00 dst time
11803 see the UCX management command reference, SET CONFIG TIMEZONE
11804 for formatting info.
11806 No, it's not as general as it should be, but then again, NOTHING
11807 will handle UK times in a sensible way.
11812 parse the DST start/end info:
11813 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11817 tz_parse_startend(char *s, struct tm *w, int *past)
11819 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11820 int ly, dozjd, d, m, n, hour, min, sec, j, k;
11825 if (!past) return 0;
11828 if (w->tm_year % 4 == 0) ly = 1;
11829 if (w->tm_year % 100 == 0) ly = 0;
11830 if (w->tm_year+1900 % 400 == 0) ly = 1;
11833 dozjd = isdigit(*s);
11834 if (*s == 'J' || *s == 'j' || dozjd) {
11835 if (!dozjd && !isdigit(*++s)) return 0;
11838 d = d*10 + *s++ - '0';
11840 d = d*10 + *s++ - '0';
11843 if (d == 0) return 0;
11844 if (d > 366) return 0;
11846 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
11849 } else if (*s == 'M' || *s == 'm') {
11850 if (!isdigit(*++s)) return 0;
11852 if (isdigit(*s)) m = 10*m + *s++ - '0';
11853 if (*s != '.') return 0;
11854 if (!isdigit(*++s)) return 0;
11856 if (n < 1 || n > 5) return 0;
11857 if (*s != '.') return 0;
11858 if (!isdigit(*++s)) return 0;
11860 if (d > 6) return 0;
11864 if (!isdigit(*++s)) return 0;
11866 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11868 if (!isdigit(*++s)) return 0;
11870 if (isdigit(*s)) min = 10*min + *s++ - '0';
11872 if (!isdigit(*++s)) return 0;
11874 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11884 if (w->tm_yday < d) goto before;
11885 if (w->tm_yday > d) goto after;
11887 if (w->tm_mon+1 < m) goto before;
11888 if (w->tm_mon+1 > m) goto after;
11890 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
11891 k = d - j; /* mday of first d */
11892 if (k <= 0) k += 7;
11893 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
11894 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11895 if (w->tm_mday < k) goto before;
11896 if (w->tm_mday > k) goto after;
11899 if (w->tm_hour < hour) goto before;
11900 if (w->tm_hour > hour) goto after;
11901 if (w->tm_min < min) goto before;
11902 if (w->tm_min > min) goto after;
11903 if (w->tm_sec < sec) goto before;
11917 /* parse the offset: (+|-)hh[:mm[:ss]] */
11920 tz_parse_offset(char *s, int *offset)
11922 int hour = 0, min = 0, sec = 0;
11925 if (!offset) return 0;
11927 if (*s == '-') {neg++; s++;}
11928 if (*s == '+') s++;
11929 if (!isdigit(*s)) return 0;
11931 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11932 if (hour > 24) return 0;
11934 if (!isdigit(*++s)) return 0;
11936 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11937 if (min > 59) return 0;
11939 if (!isdigit(*++s)) return 0;
11941 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11942 if (sec > 59) return 0;
11946 *offset = (hour*60+min)*60 + sec;
11947 if (neg) *offset = -*offset;
11952 input time is w, whatever type of time the CRTL localtime() uses.
11953 sets dst, the zone, and the gmtoff (seconds)
11955 caches the value of TZ and UCX$TZ env variables; note that
11956 my_setenv looks for these and sets a flag if they're changed
11959 We have to watch out for the "australian" case (dst starts in
11960 october, ends in april)...flagged by "reverse" and checked by
11961 scanning through the months of the previous year.
11966 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11971 char *dstzone, *tz, *s_start, *s_end;
11972 int std_off, dst_off, isdst;
11973 int y, dststart, dstend;
11974 static char envtz[1025]; /* longer than any logical, symbol, ... */
11975 static char ucxtz[1025];
11976 static char reversed = 0;
11982 reversed = -1; /* flag need to check */
11983 envtz[0] = ucxtz[0] = '\0';
11984 tz = my_getenv("TZ",0);
11985 if (tz) strcpy(envtz, tz);
11986 tz = my_getenv("UCX$TZ",0);
11987 if (tz) strcpy(ucxtz, tz);
11988 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11991 if (!*tz) tz = ucxtz;
11994 while (isalpha(*s)) s++;
11995 s = tz_parse_offset(s, &std_off);
11997 if (!*s) { /* no DST, hurray we're done! */
12003 while (isalpha(*s)) s++;
12004 s2 = tz_parse_offset(s, &dst_off);
12008 dst_off = std_off - 3600;
12011 if (!*s) { /* default dst start/end?? */
12012 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
12013 s = strchr(ucxtz,',');
12015 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
12017 if (*s != ',') return 0;
12020 when = _toutc(when); /* convert to utc */
12021 when = when - std_off; /* convert to pseudolocal time*/
12023 w2 = localtime(&when);
12026 s = tz_parse_startend(s_start,w2,&dststart);
12028 if (*s != ',') return 0;
12031 when = _toutc(when); /* convert to utc */
12032 when = when - dst_off; /* convert to pseudolocal time*/
12033 w2 = localtime(&when);
12034 if (w2->tm_year != y) { /* spans a year, just check one time */
12035 when += dst_off - std_off;
12036 w2 = localtime(&when);
12039 s = tz_parse_startend(s_end,w2,&dstend);
12042 if (reversed == -1) { /* need to check if start later than end */
12046 if (when < 2*365*86400) {
12047 when += 2*365*86400;
12051 w2 =localtime(&when);
12052 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
12054 for (j = 0; j < 12; j++) {
12055 w2 =localtime(&when);
12056 tz_parse_startend(s_start,w2,&ds);
12057 tz_parse_startend(s_end,w2,&de);
12058 if (ds != de) break;
12062 if (de && !ds) reversed = 1;
12065 isdst = dststart && !dstend;
12066 if (reversed) isdst = dststart || !dstend;
12069 if (dst) *dst = isdst;
12070 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
12071 if (isdst) tz = dstzone;
12073 while(isalpha(*tz)) *zone++ = *tz++;
12079 #endif /* !RTL_USES_UTC */
12081 /* my_time(), my_localtime(), my_gmtime()
12082 * By default traffic in UTC time values, using CRTL gmtime() or
12083 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
12084 * Note: We need to use these functions even when the CRTL has working
12085 * UTC support, since they also handle C<use vmsish qw(times);>
12087 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
12088 * Modified by Charles Bailey <bailey@newman.upenn.edu>
12091 /*{{{time_t my_time(time_t *timep)*/
12092 time_t Perl_my_time(pTHX_ time_t *timep)
12097 if (gmtime_emulation_type == 0) {
12099 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
12100 /* results of calls to gmtime() and localtime() */
12101 /* for same &base */
12103 gmtime_emulation_type++;
12104 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
12105 char off[LNM$C_NAMLENGTH+1];;
12107 gmtime_emulation_type++;
12108 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
12109 gmtime_emulation_type++;
12110 utc_offset_secs = 0;
12111 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
12113 else { utc_offset_secs = atol(off); }
12115 else { /* We've got a working gmtime() */
12116 struct tm gmt, local;
12119 tm_p = localtime(&base);
12121 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
12122 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
12123 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
12124 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
12129 # ifdef VMSISH_TIME
12130 # ifdef RTL_USES_UTC
12131 if (VMSISH_TIME) when = _toloc(when);
12133 if (!VMSISH_TIME) when = _toutc(when);
12136 if (timep != NULL) *timep = when;
12139 } /* end of my_time() */
12143 /*{{{struct tm *my_gmtime(const time_t *timep)*/
12145 Perl_my_gmtime(pTHX_ const time_t *timep)
12151 if (timep == NULL) {
12152 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12155 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
12158 # ifdef VMSISH_TIME
12159 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
12161 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
12162 return gmtime(&when);
12164 /* CRTL localtime() wants local time as input, so does no tz correction */
12165 rsltmp = localtime(&when);
12166 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
12169 } /* end of my_gmtime() */
12173 /*{{{struct tm *my_localtime(const time_t *timep)*/
12175 Perl_my_localtime(pTHX_ const time_t *timep)
12177 time_t when, whenutc;
12181 if (timep == NULL) {
12182 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12185 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
12186 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
12189 # ifdef RTL_USES_UTC
12190 # ifdef VMSISH_TIME
12191 if (VMSISH_TIME) when = _toutc(when);
12193 /* CRTL localtime() wants UTC as input, does tz correction itself */
12194 return localtime(&when);
12196 # else /* !RTL_USES_UTC */
12198 # ifdef VMSISH_TIME
12199 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
12200 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
12203 #ifndef RTL_USES_UTC
12204 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
12205 when = whenutc - offset; /* pseudolocal time*/
12208 /* CRTL localtime() wants local time as input, so does no tz correction */
12209 rsltmp = localtime(&when);
12210 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12214 } /* end of my_localtime() */
12217 /* Reset definitions for later calls */
12218 #define gmtime(t) my_gmtime(t)
12219 #define localtime(t) my_localtime(t)
12220 #define time(t) my_time(t)
12223 /* my_utime - update modification/access time of a file
12225 * VMS 7.3 and later implementation
12226 * Only the UTC translation is home-grown. The rest is handled by the
12227 * CRTL utime(), which will take into account the relevant feature
12228 * logicals and ODS-5 volume characteristics for true access times.
12230 * pre VMS 7.3 implementation:
12231 * The calling sequence is identical to POSIX utime(), but under
12232 * VMS with ODS-2, only the modification time is changed; ODS-2 does
12233 * not maintain access times. Restrictions differ from the POSIX
12234 * definition in that the time can be changed as long as the
12235 * caller has permission to execute the necessary IO$_MODIFY $QIO;
12236 * no separate checks are made to insure that the caller is the
12237 * owner of the file or has special privs enabled.
12238 * Code here is based on Joe Meadows' FILE utility.
12242 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12243 * to VMS epoch (01-JAN-1858 00:00:00.00)
12244 * in 100 ns intervals.
12246 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12248 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12249 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12251 #if __CRTL_VER >= 70300000
12252 struct utimbuf utc_utimes, *utc_utimesp;
12254 if (utimes != NULL) {
12255 utc_utimes.actime = utimes->actime;
12256 utc_utimes.modtime = utimes->modtime;
12257 # ifdef VMSISH_TIME
12258 /* If input was local; convert to UTC for sys svc */
12260 utc_utimes.actime = _toutc(utimes->actime);
12261 utc_utimes.modtime = _toutc(utimes->modtime);
12264 utc_utimesp = &utc_utimes;
12267 utc_utimesp = NULL;
12270 return utime(file, utc_utimesp);
12272 #else /* __CRTL_VER < 70300000 */
12276 long int bintime[2], len = 2, lowbit, unixtime,
12277 secscale = 10000000; /* seconds --> 100 ns intervals */
12278 unsigned long int chan, iosb[2], retsts;
12279 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12280 struct FAB myfab = cc$rms_fab;
12281 struct NAM mynam = cc$rms_nam;
12282 #if defined (__DECC) && defined (__VAX)
12283 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12284 * at least through VMS V6.1, which causes a type-conversion warning.
12286 # pragma message save
12287 # pragma message disable cvtdiftypes
12289 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12290 struct fibdef myfib;
12291 #if defined (__DECC) && defined (__VAX)
12292 /* This should be right after the declaration of myatr, but due
12293 * to a bug in VAX DEC C, this takes effect a statement early.
12295 # pragma message restore
12297 /* cast ok for read only parameter */
12298 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12299 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12300 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12302 if (file == NULL || *file == '\0') {
12303 SETERRNO(ENOENT, LIB$_INVARG);
12307 /* Convert to VMS format ensuring that it will fit in 255 characters */
12308 if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12309 SETERRNO(ENOENT, LIB$_INVARG);
12312 if (utimes != NULL) {
12313 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
12314 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12315 * Since time_t is unsigned long int, and lib$emul takes a signed long int
12316 * as input, we force the sign bit to be clear by shifting unixtime right
12317 * one bit, then multiplying by an extra factor of 2 in lib$emul().
12319 lowbit = (utimes->modtime & 1) ? secscale : 0;
12320 unixtime = (long int) utimes->modtime;
12321 # ifdef VMSISH_TIME
12322 /* If input was UTC; convert to local for sys svc */
12323 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12325 unixtime >>= 1; secscale <<= 1;
12326 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12327 if (!(retsts & 1)) {
12328 SETERRNO(EVMSERR, retsts);
12331 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12332 if (!(retsts & 1)) {
12333 SETERRNO(EVMSERR, retsts);
12338 /* Just get the current time in VMS format directly */
12339 retsts = sys$gettim(bintime);
12340 if (!(retsts & 1)) {
12341 SETERRNO(EVMSERR, retsts);
12346 myfab.fab$l_fna = vmsspec;
12347 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12348 myfab.fab$l_nam = &mynam;
12349 mynam.nam$l_esa = esa;
12350 mynam.nam$b_ess = (unsigned char) sizeof esa;
12351 mynam.nam$l_rsa = rsa;
12352 mynam.nam$b_rss = (unsigned char) sizeof rsa;
12353 if (decc_efs_case_preserve)
12354 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12356 /* Look for the file to be affected, letting RMS parse the file
12357 * specification for us as well. I have set errno using only
12358 * values documented in the utime() man page for VMS POSIX.
12360 retsts = sys$parse(&myfab,0,0);
12361 if (!(retsts & 1)) {
12362 set_vaxc_errno(retsts);
12363 if (retsts == RMS$_PRV) set_errno(EACCES);
12364 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12365 else set_errno(EVMSERR);
12368 retsts = sys$search(&myfab,0,0);
12369 if (!(retsts & 1)) {
12370 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12371 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12372 set_vaxc_errno(retsts);
12373 if (retsts == RMS$_PRV) set_errno(EACCES);
12374 else if (retsts == RMS$_FNF) set_errno(ENOENT);
12375 else set_errno(EVMSERR);
12379 devdsc.dsc$w_length = mynam.nam$b_dev;
12380 /* cast ok for read only parameter */
12381 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12383 retsts = sys$assign(&devdsc,&chan,0,0);
12384 if (!(retsts & 1)) {
12385 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12386 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12387 set_vaxc_errno(retsts);
12388 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
12389 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
12390 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
12391 else set_errno(EVMSERR);
12395 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12396 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12398 memset((void *) &myfib, 0, sizeof myfib);
12399 #if defined(__DECC) || defined(__DECCXX)
12400 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12401 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12402 /* This prevents the revision time of the file being reset to the current
12403 * time as a result of our IO$_MODIFY $QIO. */
12404 myfib.fib$l_acctl = FIB$M_NORECORD;
12406 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12407 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12408 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12410 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12411 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12412 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12413 _ckvmssts(sys$dassgn(chan));
12414 if (retsts & 1) retsts = iosb[0];
12415 if (!(retsts & 1)) {
12416 set_vaxc_errno(retsts);
12417 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12418 else set_errno(EVMSERR);
12424 #endif /* #if __CRTL_VER >= 70300000 */
12426 } /* end of my_utime() */
12430 * flex_stat, flex_lstat, flex_fstat
12431 * basic stat, but gets it right when asked to stat
12432 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12435 #ifndef _USE_STD_STAT
12436 /* encode_dev packs a VMS device name string into an integer to allow
12437 * simple comparisons. This can be used, for example, to check whether two
12438 * files are located on the same device, by comparing their encoded device
12439 * names. Even a string comparison would not do, because stat() reuses the
12440 * device name buffer for each call; so without encode_dev, it would be
12441 * necessary to save the buffer and use strcmp (this would mean a number of
12442 * changes to the standard Perl code, to say nothing of what a Perl script
12443 * would have to do.
12445 * The device lock id, if it exists, should be unique (unless perhaps compared
12446 * with lock ids transferred from other nodes). We have a lock id if the disk is
12447 * mounted cluster-wide, which is when we tend to get long (host-qualified)
12448 * device names. Thus we use the lock id in preference, and only if that isn't
12449 * available, do we try to pack the device name into an integer (flagged by
12450 * the sign bit (LOCKID_MASK) being set).
12452 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12453 * name and its encoded form, but it seems very unlikely that we will find
12454 * two files on different disks that share the same encoded device names,
12455 * and even more remote that they will share the same file id (if the test
12456 * is to check for the same file).
12458 * A better method might be to use sys$device_scan on the first call, and to
12459 * search for the device, returning an index into the cached array.
12460 * The number returned would be more intelligible.
12461 * This is probably not worth it, and anyway would take quite a bit longer
12462 * on the first call.
12464 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
12465 static mydev_t encode_dev (pTHX_ const char *dev)
12468 unsigned long int f;
12473 if (!dev || !dev[0]) return 0;
12477 struct dsc$descriptor_s dev_desc;
12478 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12480 /* For cluster-mounted disks, the disk lock identifier is unique, so we
12481 can try that first. */
12482 dev_desc.dsc$w_length = strlen (dev);
12483 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
12484 dev_desc.dsc$b_class = DSC$K_CLASS_S;
12485 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
12486 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12487 if (!$VMS_STATUS_SUCCESS(status)) {
12489 case SS$_NOSUCHDEV:
12490 SETERRNO(ENODEV, status);
12496 if (lockid) return (lockid & ~LOCKID_MASK);
12500 /* Otherwise we try to encode the device name */
12504 for (q = dev + strlen(dev); q--; q >= dev) {
12509 else if (isalpha (toupper (*q)))
12510 c= toupper (*q) - 'A' + (char)10;
12512 continue; /* Skip '$'s */
12514 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
12516 enc += f * (unsigned long int) c;
12518 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
12520 } /* end of encode_dev() */
12521 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12522 device_no = encode_dev(aTHX_ devname)
12524 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12525 device_no = new_dev_no
12529 is_null_device(name)
12532 if (decc_bug_devnull != 0) {
12533 if (strncmp("/dev/null", name, 9) == 0)
12536 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12537 The underscore prefix, controller letter, and unit number are
12538 independently optional; for our purposes, the colon punctuation
12539 is not. The colon can be trailed by optional directory and/or
12540 filename, but two consecutive colons indicates a nodename rather
12541 than a device. [pr] */
12542 if (*name == '_') ++name;
12543 if (tolower(*name++) != 'n') return 0;
12544 if (tolower(*name++) != 'l') return 0;
12545 if (tolower(*name) == 'a') ++name;
12546 if (*name == '0') ++name;
12547 return (*name++ == ':') && (*name != ':');
12551 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag);
12553 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
12556 Perl_cando_by_name_int
12557 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12559 char usrname[L_cuserid];
12560 struct dsc$descriptor_s usrdsc =
12561 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12562 char *vmsname = NULL, *fileified = NULL;
12563 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12564 unsigned short int retlen, trnlnm_iter_count;
12565 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12566 union prvdef curprv;
12567 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12568 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12569 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12570 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12571 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12573 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12575 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12577 static int profile_context = -1;
12579 if (!fname || !*fname) return FALSE;
12581 /* Make sure we expand logical names, since sys$check_access doesn't */
12582 fileified = PerlMem_malloc(VMS_MAXRSS);
12583 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12584 if (!strpbrk(fname,"/]>:")) {
12585 strcpy(fileified,fname);
12586 trnlnm_iter_count = 0;
12587 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12588 trnlnm_iter_count++;
12589 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12594 vmsname = PerlMem_malloc(VMS_MAXRSS);
12595 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12596 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12597 /* Don't know if already in VMS format, so make sure */
12598 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12599 PerlMem_free(fileified);
12600 PerlMem_free(vmsname);
12605 strcpy(vmsname,fname);
12608 /* sys$check_access needs a file spec, not a directory spec.
12609 * flex_stat now will handle a null thread context during startup.
12612 retlen = namdsc.dsc$w_length = strlen(vmsname);
12613 if (vmsname[retlen-1] == ']'
12614 || vmsname[retlen-1] == '>'
12615 || vmsname[retlen-1] == ':'
12616 || (!flex_stat_int(vmsname, &st, 1) &&
12617 S_ISDIR(st.st_mode))) {
12619 if (!int_fileify_dirspec(vmsname, fileified, NULL)) {
12620 PerlMem_free(fileified);
12621 PerlMem_free(vmsname);
12630 retlen = namdsc.dsc$w_length = strlen(fname);
12631 namdsc.dsc$a_pointer = (char *)fname;
12634 case S_IXUSR: case S_IXGRP: case S_IXOTH:
12635 access = ARM$M_EXECUTE;
12636 flags = CHP$M_READ;
12638 case S_IRUSR: case S_IRGRP: case S_IROTH:
12639 access = ARM$M_READ;
12640 flags = CHP$M_READ | CHP$M_USEREADALL;
12642 case S_IWUSR: case S_IWGRP: case S_IWOTH:
12643 access = ARM$M_WRITE;
12644 flags = CHP$M_READ | CHP$M_WRITE;
12646 case S_IDUSR: case S_IDGRP: case S_IDOTH:
12647 access = ARM$M_DELETE;
12648 flags = CHP$M_READ | CHP$M_WRITE;
12651 if (fileified != NULL)
12652 PerlMem_free(fileified);
12653 if (vmsname != NULL)
12654 PerlMem_free(vmsname);
12658 /* Before we call $check_access, create a user profile with the current
12659 * process privs since otherwise it just uses the default privs from the
12660 * UAF and might give false positives or negatives. This only works on
12661 * VMS versions v6.0 and later since that's when sys$create_user_profile
12662 * became available.
12665 /* get current process privs and username */
12666 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12667 _ckvmssts_noperl(iosb[0]);
12669 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12671 /* find out the space required for the profile */
12672 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12673 &usrprodsc.dsc$w_length,&profile_context));
12675 /* allocate space for the profile and get it filled in */
12676 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12677 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12678 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12679 &usrprodsc.dsc$w_length,&profile_context));
12681 /* use the profile to check access to the file; free profile & analyze results */
12682 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12683 PerlMem_free(usrprodsc.dsc$a_pointer);
12684 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12688 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12692 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
12693 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12694 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12695 set_vaxc_errno(retsts);
12696 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12697 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12698 else set_errno(ENOENT);
12699 if (fileified != NULL)
12700 PerlMem_free(fileified);
12701 if (vmsname != NULL)
12702 PerlMem_free(vmsname);
12705 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12706 if (fileified != NULL)
12707 PerlMem_free(fileified);
12708 if (vmsname != NULL)
12709 PerlMem_free(vmsname);
12712 _ckvmssts_noperl(retsts);
12714 if (fileified != NULL)
12715 PerlMem_free(fileified);
12716 if (vmsname != NULL)
12717 PerlMem_free(vmsname);
12718 return FALSE; /* Should never get here */
12722 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
12723 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12724 * subset of the applicable information.
12727 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12729 return cando_by_name_int
12730 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12731 } /* end of cando() */
12735 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12737 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12739 return cando_by_name_int(bit, effective, fname, 0);
12741 } /* end of cando_by_name() */
12745 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12747 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12749 if (!fstat(fd, &statbufp->crtl_stat)) {
12751 char *vms_filename;
12752 vms_filename = PerlMem_malloc(VMS_MAXRSS);
12753 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12755 /* Save name for cando by name in VMS format */
12756 cptr = getname(fd, vms_filename, 1);
12758 /* This should not happen, but just in case */
12759 if (cptr == NULL) {
12760 statbufp->st_devnam[0] = 0;
12763 /* Make sure that the saved name fits in 255 characters */
12764 cptr = int_rmsexpand_vms
12766 statbufp->st_devnam,
12769 statbufp->st_devnam[0] = 0;
12771 PerlMem_free(vms_filename);
12773 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12775 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12777 # ifdef RTL_USES_UTC
12778 # ifdef VMSISH_TIME
12780 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12781 statbufp->st_atime = _toloc(statbufp->st_atime);
12782 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12786 # ifdef VMSISH_TIME
12787 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12791 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12792 statbufp->st_atime = _toutc(statbufp->st_atime);
12793 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12800 } /* end of flex_fstat() */
12804 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12808 const char *save_spec;
12819 if (decc_bug_devnull != 0) {
12820 if (is_null_device(fspec)) { /* Fake a stat() for the null device */
12821 memset(statbufp,0,sizeof *statbufp);
12822 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12823 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12824 statbufp->st_uid = 0x00010001;
12825 statbufp->st_gid = 0x0001;
12826 time((time_t *)&statbufp->st_mtime);
12827 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12832 /* Try for a directory name first. If fspec contains a filename without
12833 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12834 * and sea:[wine.dark]water. exist, we prefer the directory here.
12835 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12836 * not sea:[wine.dark]., if the latter exists. If the intended target is
12837 * the file with null type, specify this by calling flex_stat() with
12838 * a '.' at the end of fspec.
12840 * If we are in Posix filespec mode, accept the filename as is.
12844 fileified = PerlMem_malloc(VMS_MAXRSS);
12845 if (fileified == NULL)
12846 _ckvmssts_noperl(SS$_INSFMEM);
12848 temp_fspec = PerlMem_malloc(VMS_MAXRSS);
12849 if (temp_fspec == NULL)
12850 _ckvmssts_noperl(SS$_INSFMEM);
12852 strcpy(temp_fspec, fspec);
12856 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12857 if (decc_posix_compliant_pathnames == 0) {
12860 /* We may be able to optimize this, but in order for fileify_dirspec to
12861 * always return a usuable answer, we have to call vmspath first to
12862 * make sure that it is in VMS directory format, as stat/lstat on 8.3
12863 * can not handle directories in unix format that it does not have read
12864 * access to. Vmspath handles the case where a bare name which could be
12865 * a logical name gets passed.
12867 ret_spec = int_tovmspath(fspec, temp_fspec, NULL);
12868 if (ret_spec != NULL) {
12869 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
12870 if (ret_spec != NULL) {
12871 if (lstat_flag == 0)
12872 retval = stat(fileified, &statbufp->crtl_stat);
12874 retval = lstat(fileified, &statbufp->crtl_stat);
12875 save_spec = fileified;
12879 if (retval && vms_bug_stat_filename) {
12881 /* We should try again as a vmsified file specification */
12882 /* However Perl traditionally has not done this, which */
12883 /* causes problems with existing tests */
12885 ret_spec = int_tovmsspec(fspec, temp_fspec, 0, NULL);
12886 if (ret_spec != NULL) {
12887 if (lstat_flag == 0)
12888 retval = stat(temp_fspec, &statbufp->crtl_stat);
12890 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12891 save_spec = temp_fspec;
12896 /* Last chance - allow multiple dots with out EFS CHARSET */
12897 /* The CRTL stat() falls down hard on multi-dot filenames in unix
12898 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
12899 * enable it if it isn't already.
12901 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12902 if (!decc_efs_charset && (decc_efs_charset_index > 0))
12903 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12905 if (lstat_flag == 0)
12906 retval = stat(fspec, &statbufp->crtl_stat);
12908 retval = lstat(fspec, &statbufp->crtl_stat);
12910 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12911 if (!decc_efs_charset && (decc_efs_charset_index > 0)) {
12912 decc$feature_set_value(decc_efs_charset_index, 1, 0);
12918 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12920 if (lstat_flag == 0)
12921 retval = stat(temp_fspec, &statbufp->crtl_stat);
12923 retval = lstat(temp_fspec, &statbufp->crtl_stat);
12924 save_spec = temp_fspec;
12928 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12929 /* As you were... */
12930 if (!decc_efs_charset)
12931 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12936 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12938 /* If this is an lstat, do not follow the link */
12940 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12942 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12943 /* If we used the efs_hack above, we must also use it here for */
12944 /* perl_cando to work */
12945 if (efs_hack && (decc_efs_charset_index > 0)) {
12946 decc$feature_set_value(decc_efs_charset_index, 1, 1);
12949 cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12950 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12951 if (efs_hack && (decc_efs_charset_index > 0)) {
12952 decc$feature_set_value(decc_efs_charset, 1, 0);
12956 /* Fix me: If this is NULL then stat found a file, and we could */
12957 /* not convert the specification to VMS - Should never happen */
12959 statbufp->st_devnam[0] = 0;
12961 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12963 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12964 # ifdef RTL_USES_UTC
12965 # ifdef VMSISH_TIME
12967 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12968 statbufp->st_atime = _toloc(statbufp->st_atime);
12969 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12973 # ifdef VMSISH_TIME
12974 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12978 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12979 statbufp->st_atime = _toutc(statbufp->st_atime);
12980 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12984 /* If we were successful, leave errno where we found it */
12985 if (retval == 0) RESTORE_ERRNO;
12988 } /* end of flex_stat_int() */
12991 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12993 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12995 return flex_stat_int(fspec, statbufp, 0);
12999 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
13001 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
13003 return flex_stat_int(fspec, statbufp, 1);
13008 /*{{{char *my_getlogin()*/
13009 /* VMS cuserid == Unix getlogin, except calling sequence */
13013 static char user[L_cuserid];
13014 return cuserid(user);
13019 /* rmscopy - copy a file using VMS RMS routines
13021 * Copies contents and attributes of spec_in to spec_out, except owner
13022 * and protection information. Name and type of spec_in are used as
13023 * defaults for spec_out. The third parameter specifies whether rmscopy()
13024 * should try to propagate timestamps from the input file to the output file.
13025 * If it is less than 0, no timestamps are preserved. If it is 0, then
13026 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
13027 * propagated to the output file at creation iff the output file specification
13028 * did not contain an explicit name or type, and the revision date is always
13029 * updated at the end of the copy operation. If it is greater than 0, then
13030 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
13031 * other than the revision date should be propagated, and bit 1 indicates
13032 * that the revision date should be propagated.
13034 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
13036 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
13037 * Incorporates, with permission, some code from EZCOPY by Tim Adye
13038 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
13039 * as part of the Perl standard distribution under the terms of the
13040 * GNU General Public License or the Perl Artistic License. Copies
13041 * of each may be found in the Perl standard distribution.
13043 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
13045 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
13047 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
13048 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
13049 unsigned long int i, sts, sts2;
13051 struct FAB fab_in, fab_out;
13052 struct RAB rab_in, rab_out;
13053 rms_setup_nam(nam);
13054 rms_setup_nam(nam_out);
13055 struct XABDAT xabdat;
13056 struct XABFHC xabfhc;
13057 struct XABRDT xabrdt;
13058 struct XABSUM xabsum;
13060 vmsin = PerlMem_malloc(VMS_MAXRSS);
13061 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13062 vmsout = PerlMem_malloc(VMS_MAXRSS);
13063 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13064 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
13065 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
13066 PerlMem_free(vmsin);
13067 PerlMem_free(vmsout);
13068 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13072 esa = PerlMem_malloc(VMS_MAXRSS);
13073 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13075 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13076 esal = PerlMem_malloc(VMS_MAXRSS);
13077 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13079 fab_in = cc$rms_fab;
13080 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
13081 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
13082 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
13083 fab_in.fab$l_fop = FAB$M_SQO;
13084 rms_bind_fab_nam(fab_in, nam);
13085 fab_in.fab$l_xab = (void *) &xabdat;
13087 rsa = PerlMem_malloc(VMS_MAXRSS);
13088 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13090 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13091 rsal = PerlMem_malloc(VMS_MAXRSS);
13092 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13094 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
13095 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
13096 rms_nam_esl(nam) = 0;
13097 rms_nam_rsl(nam) = 0;
13098 rms_nam_esll(nam) = 0;
13099 rms_nam_rsll(nam) = 0;
13100 #ifdef NAM$M_NO_SHORT_UPCASE
13101 if (decc_efs_case_preserve)
13102 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
13105 xabdat = cc$rms_xabdat; /* To get creation date */
13106 xabdat.xab$l_nxt = (void *) &xabfhc;
13108 xabfhc = cc$rms_xabfhc; /* To get record length */
13109 xabfhc.xab$l_nxt = (void *) &xabsum;
13111 xabsum = cc$rms_xabsum; /* To get key and area information */
13113 if (!((sts = sys$open(&fab_in)) & 1)) {
13114 PerlMem_free(vmsin);
13115 PerlMem_free(vmsout);
13118 PerlMem_free(esal);
13121 PerlMem_free(rsal);
13122 set_vaxc_errno(sts);
13124 case RMS$_FNF: case RMS$_DNF:
13125 set_errno(ENOENT); break;
13127 set_errno(ENOTDIR); break;
13129 set_errno(ENODEV); break;
13131 set_errno(EINVAL); break;
13133 set_errno(EACCES); break;
13135 set_errno(EVMSERR);
13142 fab_out.fab$w_ifi = 0;
13143 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
13144 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
13145 fab_out.fab$l_fop = FAB$M_SQO;
13146 rms_bind_fab_nam(fab_out, nam_out);
13147 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
13148 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
13149 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
13150 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13151 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13152 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
13153 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13156 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
13157 esal_out = PerlMem_malloc(VMS_MAXRSS);
13158 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13159 rsal_out = PerlMem_malloc(VMS_MAXRSS);
13160 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13162 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
13163 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
13165 if (preserve_dates == 0) { /* Act like DCL COPY */
13166 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
13167 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
13168 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
13169 PerlMem_free(vmsin);
13170 PerlMem_free(vmsout);
13173 PerlMem_free(esal);
13176 PerlMem_free(rsal);
13177 PerlMem_free(esa_out);
13178 if (esal_out != NULL)
13179 PerlMem_free(esal_out);
13180 PerlMem_free(rsa_out);
13181 if (rsal_out != NULL)
13182 PerlMem_free(rsal_out);
13183 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
13184 set_vaxc_errno(sts);
13187 fab_out.fab$l_xab = (void *) &xabdat;
13188 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
13189 preserve_dates = 1;
13191 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
13192 preserve_dates =0; /* bitmask from this point forward */
13194 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
13195 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
13196 PerlMem_free(vmsin);
13197 PerlMem_free(vmsout);
13200 PerlMem_free(esal);
13203 PerlMem_free(rsal);
13204 PerlMem_free(esa_out);
13205 if (esal_out != NULL)
13206 PerlMem_free(esal_out);
13207 PerlMem_free(rsa_out);
13208 if (rsal_out != NULL)
13209 PerlMem_free(rsal_out);
13210 set_vaxc_errno(sts);
13213 set_errno(ENOENT); break;
13215 set_errno(ENOTDIR); break;
13217 set_errno(ENODEV); break;
13219 set_errno(EINVAL); break;
13221 set_errno(EACCES); break;
13223 set_errno(EVMSERR);
13227 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
13228 if (preserve_dates & 2) {
13229 /* sys$close() will process xabrdt, not xabdat */
13230 xabrdt = cc$rms_xabrdt;
13232 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
13234 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
13235 * is unsigned long[2], while DECC & VAXC use a struct */
13236 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
13238 fab_out.fab$l_xab = (void *) &xabrdt;
13241 ubf = PerlMem_malloc(32256);
13242 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
13243 rab_in = cc$rms_rab;
13244 rab_in.rab$l_fab = &fab_in;
13245 rab_in.rab$l_rop = RAB$M_BIO;
13246 rab_in.rab$l_ubf = ubf;
13247 rab_in.rab$w_usz = 32256;
13248 if (!((sts = sys$connect(&rab_in)) & 1)) {
13249 sys$close(&fab_in); sys$close(&fab_out);
13250 PerlMem_free(vmsin);
13251 PerlMem_free(vmsout);
13255 PerlMem_free(esal);
13258 PerlMem_free(rsal);
13259 PerlMem_free(esa_out);
13260 if (esal_out != NULL)
13261 PerlMem_free(esal_out);
13262 PerlMem_free(rsa_out);
13263 if (rsal_out != NULL)
13264 PerlMem_free(rsal_out);
13265 set_errno(EVMSERR); set_vaxc_errno(sts);
13269 rab_out = cc$rms_rab;
13270 rab_out.rab$l_fab = &fab_out;
13271 rab_out.rab$l_rbf = ubf;
13272 if (!((sts = sys$connect(&rab_out)) & 1)) {
13273 sys$close(&fab_in); sys$close(&fab_out);
13274 PerlMem_free(vmsin);
13275 PerlMem_free(vmsout);
13279 PerlMem_free(esal);
13282 PerlMem_free(rsal);
13283 PerlMem_free(esa_out);
13284 if (esal_out != NULL)
13285 PerlMem_free(esal_out);
13286 PerlMem_free(rsa_out);
13287 if (rsal_out != NULL)
13288 PerlMem_free(rsal_out);
13289 set_errno(EVMSERR); set_vaxc_errno(sts);
13293 while ((sts = sys$read(&rab_in))) { /* always true */
13294 if (sts == RMS$_EOF) break;
13295 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13296 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13297 sys$close(&fab_in); sys$close(&fab_out);
13298 PerlMem_free(vmsin);
13299 PerlMem_free(vmsout);
13303 PerlMem_free(esal);
13306 PerlMem_free(rsal);
13307 PerlMem_free(esa_out);
13308 if (esal_out != NULL)
13309 PerlMem_free(esal_out);
13310 PerlMem_free(rsa_out);
13311 if (rsal_out != NULL)
13312 PerlMem_free(rsal_out);
13313 set_errno(EVMSERR); set_vaxc_errno(sts);
13319 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
13320 sys$close(&fab_in); sys$close(&fab_out);
13321 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13323 PerlMem_free(vmsin);
13324 PerlMem_free(vmsout);
13328 PerlMem_free(esal);
13331 PerlMem_free(rsal);
13332 PerlMem_free(esa_out);
13333 if (esal_out != NULL)
13334 PerlMem_free(esal_out);
13335 PerlMem_free(rsa_out);
13336 if (rsal_out != NULL)
13337 PerlMem_free(rsal_out);
13340 set_errno(EVMSERR); set_vaxc_errno(sts);
13346 } /* end of rmscopy() */
13350 /*** The following glue provides 'hooks' to make some of the routines
13351 * from this file available from Perl. These routines are sufficiently
13352 * basic, and are required sufficiently early in the build process,
13353 * that's it's nice to have them available to miniperl as well as the
13354 * full Perl, so they're set up here instead of in an extension. The
13355 * Perl code which handles importation of these names into a given
13356 * package lives in [.VMS]Filespec.pm in @INC.
13360 rmsexpand_fromperl(pTHX_ CV *cv)
13363 char *fspec, *defspec = NULL, *rslt;
13365 int fs_utf8, dfs_utf8;
13369 if (!items || items > 2)
13370 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13371 fspec = SvPV(ST(0),n_a);
13372 fs_utf8 = SvUTF8(ST(0));
13373 if (!fspec || !*fspec) XSRETURN_UNDEF;
13375 defspec = SvPV(ST(1),n_a);
13376 dfs_utf8 = SvUTF8(ST(1));
13378 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13379 ST(0) = sv_newmortal();
13380 if (rslt != NULL) {
13381 sv_usepvn(ST(0),rslt,strlen(rslt));
13390 vmsify_fromperl(pTHX_ CV *cv)
13397 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13398 utf8_fl = SvUTF8(ST(0));
13399 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13400 ST(0) = sv_newmortal();
13401 if (vmsified != NULL) {
13402 sv_usepvn(ST(0),vmsified,strlen(vmsified));
13411 unixify_fromperl(pTHX_ CV *cv)
13418 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13419 utf8_fl = SvUTF8(ST(0));
13420 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13421 ST(0) = sv_newmortal();
13422 if (unixified != NULL) {
13423 sv_usepvn(ST(0),unixified,strlen(unixified));
13432 fileify_fromperl(pTHX_ CV *cv)
13439 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13440 utf8_fl = SvUTF8(ST(0));
13441 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13442 ST(0) = sv_newmortal();
13443 if (fileified != NULL) {
13444 sv_usepvn(ST(0),fileified,strlen(fileified));
13453 pathify_fromperl(pTHX_ CV *cv)
13460 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13461 utf8_fl = SvUTF8(ST(0));
13462 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13463 ST(0) = sv_newmortal();
13464 if (pathified != NULL) {
13465 sv_usepvn(ST(0),pathified,strlen(pathified));
13474 vmspath_fromperl(pTHX_ CV *cv)
13481 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13482 utf8_fl = SvUTF8(ST(0));
13483 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13484 ST(0) = sv_newmortal();
13485 if (vmspath != NULL) {
13486 sv_usepvn(ST(0),vmspath,strlen(vmspath));
13495 unixpath_fromperl(pTHX_ CV *cv)
13502 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13503 utf8_fl = SvUTF8(ST(0));
13504 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13505 ST(0) = sv_newmortal();
13506 if (unixpath != NULL) {
13507 sv_usepvn(ST(0),unixpath,strlen(unixpath));
13516 candelete_fromperl(pTHX_ CV *cv)
13524 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13526 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13527 Newx(fspec, VMS_MAXRSS, char);
13528 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13529 if (SvTYPE(mysv) == SVt_PVGV) {
13530 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13531 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13539 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13540 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13547 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13553 rmscopy_fromperl(pTHX_ CV *cv)
13556 char *inspec, *outspec, *inp, *outp;
13558 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13559 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13560 unsigned long int sts;
13565 if (items < 2 || items > 3)
13566 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13568 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13569 Newx(inspec, VMS_MAXRSS, char);
13570 if (SvTYPE(mysv) == SVt_PVGV) {
13571 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13572 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13580 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13581 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13587 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13588 Newx(outspec, VMS_MAXRSS, char);
13589 if (SvTYPE(mysv) == SVt_PVGV) {
13590 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13591 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13600 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13601 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13608 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13610 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13616 /* The mod2fname is limited to shorter filenames by design, so it should
13617 * not be modified to support longer EFS pathnames
13620 mod2fname(pTHX_ CV *cv)
13623 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13624 workbuff[NAM$C_MAXRSS*1 + 1];
13625 int total_namelen = 3, counter, num_entries;
13626 /* ODS-5 ups this, but we want to be consistent, so... */
13627 int max_name_len = 39;
13628 AV *in_array = (AV *)SvRV(ST(0));
13630 num_entries = av_len(in_array);
13632 /* All the names start with PL_. */
13633 strcpy(ultimate_name, "PL_");
13635 /* Clean up our working buffer */
13636 Zero(work_name, sizeof(work_name), char);
13638 /* Run through the entries and build up a working name */
13639 for(counter = 0; counter <= num_entries; counter++) {
13640 /* If it's not the first name then tack on a __ */
13642 strcat(work_name, "__");
13644 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13647 /* Check to see if we actually have to bother...*/
13648 if (strlen(work_name) + 3 <= max_name_len) {
13649 strcat(ultimate_name, work_name);
13651 /* It's too darned big, so we need to go strip. We use the same */
13652 /* algorithm as xsubpp does. First, strip out doubled __ */
13653 char *source, *dest, last;
13656 for (source = work_name; *source; source++) {
13657 if (last == *source && last == '_') {
13663 /* Go put it back */
13664 strcpy(work_name, workbuff);
13665 /* Is it still too big? */
13666 if (strlen(work_name) + 3 > max_name_len) {
13667 /* Strip duplicate letters */
13670 for (source = work_name; *source; source++) {
13671 if (last == toupper(*source)) {
13675 last = toupper(*source);
13677 strcpy(work_name, workbuff);
13680 /* Is it *still* too big? */
13681 if (strlen(work_name) + 3 > max_name_len) {
13682 /* Too bad, we truncate */
13683 work_name[max_name_len - 2] = 0;
13685 strcat(ultimate_name, work_name);
13688 /* Okay, return it */
13689 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13694 hushexit_fromperl(pTHX_ CV *cv)
13699 VMSISH_HUSHED = SvTRUE(ST(0));
13701 ST(0) = boolSV(VMSISH_HUSHED);
13707 Perl_vms_start_glob
13708 (pTHX_ SV *tmpglob,
13712 struct vs_str_st *rslt;
13716 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13719 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13720 struct dsc$descriptor_vs rsdsc;
13721 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13722 unsigned long hasver = 0, isunix = 0;
13723 unsigned long int lff_flags = 0;
13725 int vms_old_glob = 1;
13727 if (!SvOK(tmpglob)) {
13728 SETERRNO(ENOENT,RMS$_FNF);
13732 vms_old_glob = !decc_filename_unix_report;
13734 #ifdef VMS_LONGNAME_SUPPORT
13735 lff_flags = LIB$M_FIL_LONG_NAMES;
13737 /* The Newx macro will not allow me to assign a smaller array
13738 * to the rslt pointer, so we will assign it to the begin char pointer
13739 * and then copy the value into the rslt pointer.
13741 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13742 rslt = (struct vs_str_st *)begin;
13744 rstr = &rslt->str[0];
13745 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13746 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13747 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13748 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13750 Newx(vmsspec, VMS_MAXRSS, char);
13752 /* We could find out if there's an explicit dev/dir or version
13753 by peeking into lib$find_file's internal context at
13754 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13755 but that's unsupported, so I don't want to do it now and
13756 have it bite someone in the future. */
13757 /* Fix-me: vms_split_path() is the only way to do this, the
13758 existing method will fail with many legal EFS or UNIX specifications
13761 cp = SvPV(tmpglob,i);
13764 if (cp[i] == ';') hasver = 1;
13765 if (cp[i] == '.') {
13766 if (sts) hasver = 1;
13769 if (cp[i] == '/') {
13770 hasdir = isunix = 1;
13773 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13779 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13780 if ((hasdir == 0) && decc_filename_unix_report) {
13784 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13785 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13786 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13792 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13793 if (!stat_sts && S_ISDIR(st.st_mode)) {
13795 const char * fname;
13798 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13799 /* path delimiter of ':>]', if so, then the old behavior has */
13800 /* obviously been specificially requested */
13802 fname = SvPVX_const(tmpglob);
13803 fname_len = strlen(fname);
13804 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13805 if (vms_old_glob || (vms_dir != NULL)) {
13806 wilddsc.dsc$a_pointer = tovmspath_utf8(
13807 SvPVX(tmpglob),vmsspec,NULL);
13808 ok = (wilddsc.dsc$a_pointer != NULL);
13809 /* maybe passed 'foo' rather than '[.foo]', thus not
13813 /* Operate just on the directory, the special stat/fstat for */
13814 /* leaves the fileified specification in the st_devnam */
13816 wilddsc.dsc$a_pointer = st.st_devnam;
13821 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13822 ok = (wilddsc.dsc$a_pointer != NULL);
13825 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13827 /* If not extended character set, replace ? with % */
13828 /* With extended character set, ? is a wildcard single character */
13829 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13832 if (!decc_efs_case_preserve)
13834 } else if (*cp == '%') {
13836 } else if (*cp == '*') {
13842 wv_sts = vms_split_path(
13843 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13844 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13845 &wvs_spec, &wvs_len);
13854 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13855 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13856 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13860 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13861 &dfltdsc,NULL,&rms_sts,&lff_flags);
13862 if (!$VMS_STATUS_SUCCESS(sts))
13865 /* with varying string, 1st word of buffer contains result length */
13866 rstr[rslt->length] = '\0';
13868 /* Find where all the components are */
13869 v_sts = vms_split_path
13884 /* If no version on input, truncate the version on output */
13885 if (!hasver && (vs_len > 0)) {
13892 /* In Unix report mode, remove the ".dir;1" from the name */
13893 /* if it is a real directory */
13894 if (decc_filename_unix_report || decc_efs_charset) {
13895 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13899 ret_sts = flex_lstat(rstr, &statbuf);
13900 if ((ret_sts == 0) &&
13901 S_ISDIR(statbuf.st_mode)) {
13908 /* No version & a null extension on UNIX handling */
13909 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13915 if (!decc_efs_case_preserve) {
13916 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13919 /* Find File treats a Null extension as return all extensions */
13920 /* This is contrary to Perl expectations */
13922 if (wildstar || wildquery || vms_old_glob) {
13923 /* really need to see if the returned file name matched */
13924 /* but for now will assume that it matches */
13927 /* Exact Match requested */
13928 /* How are directories handled? - like a file */
13929 if ((e_len == we_len) && (n_len == wn_len)) {
13933 t1 = strncmp(e_spec, we_spec, e_len);
13937 t1 = strncmp(n_spec, we_spec, n_len);
13948 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13952 /* Start with the name */
13955 strcat(begin,"\n");
13956 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13959 if (cxt) (void)lib$find_file_end(&cxt);
13962 /* Be POSIXish: return the input pattern when no matches */
13963 strcpy(rstr,SvPVX(tmpglob));
13965 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13968 if (ok && sts != RMS$_NMF &&
13969 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13972 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13974 PerlIO_close(tmpfp);
13978 PerlIO_rewind(tmpfp);
13979 IoTYPE(io) = IoTYPE_RDONLY;
13980 IoIFP(io) = fp = tmpfp;
13981 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13991 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13995 unixrealpath_fromperl(pTHX_ CV *cv)
13998 char *fspec, *rslt_spec, *rslt;
14001 if (!items || items != 1)
14002 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
14004 fspec = SvPV(ST(0),n_a);
14005 if (!fspec || !*fspec) XSRETURN_UNDEF;
14007 Newx(rslt_spec, VMS_MAXRSS + 1, char);
14008 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
14010 ST(0) = sv_newmortal();
14012 sv_usepvn(ST(0),rslt,strlen(rslt));
14014 Safefree(rslt_spec);
14019 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
14023 vmsrealpath_fromperl(pTHX_ CV *cv)
14026 char *fspec, *rslt_spec, *rslt;
14029 if (!items || items != 1)
14030 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
14032 fspec = SvPV(ST(0),n_a);
14033 if (!fspec || !*fspec) XSRETURN_UNDEF;
14035 Newx(rslt_spec, VMS_MAXRSS + 1, char);
14036 rslt = do_vms_realname(fspec, rslt_spec, NULL);
14038 ST(0) = sv_newmortal();
14040 sv_usepvn(ST(0),rslt,strlen(rslt));
14042 Safefree(rslt_spec);
14048 * A thin wrapper around decc$symlink to make sure we follow the
14049 * standard and do not create a symlink with a zero-length name.
14051 * Also in ODS-2 mode, existing tests assume that the link target
14052 * will be converted to UNIX format.
14054 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
14055 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
14056 if (!link_name || !*link_name) {
14057 SETERRNO(ENOENT, SS$_NOSUCHFILE);
14061 if (decc_efs_charset) {
14062 return symlink(contents, link_name);
14067 /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
14068 /* because in order to work, the symlink target must be in UNIX format */
14070 /* As symbolic links can hold things other than files, we will only do */
14071 /* the conversion in in ODS-2 mode */
14073 utarget = PerlMem_malloc(VMS_MAXRSS + 1);
14074 if (int_tounixspec(contents, utarget, NULL) == NULL) {
14076 /* This should not fail, as an untranslatable filename */
14077 /* should be passed through */
14078 utarget = (char *)contents;
14080 sts = symlink(utarget, link_name);
14081 PerlMem_free(utarget);
14088 #endif /* HAS_SYMLINK */
14090 int do_vms_case_tolerant(void);
14093 case_tolerant_process_fromperl(pTHX_ CV *cv)
14096 ST(0) = boolSV(do_vms_case_tolerant());
14100 #ifdef USE_ITHREADS
14103 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
14104 struct interp_intern *dst)
14106 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
14108 memcpy(dst,src,sizeof(struct interp_intern));
14114 Perl_sys_intern_clear(pTHX)
14119 Perl_sys_intern_init(pTHX)
14121 unsigned int ix = RAND_MAX;
14126 MY_POSIX_EXIT = vms_posix_exit;
14129 MY_INV_RAND_MAX = 1./x;
14133 init_os_extras(void)
14136 char* file = __FILE__;
14137 if (decc_disable_to_vms_logname_translation) {
14138 no_translate_barewords = TRUE;
14140 no_translate_barewords = FALSE;
14143 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
14144 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
14145 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
14146 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
14147 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
14148 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
14149 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
14150 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
14151 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
14152 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
14153 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
14154 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
14155 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
14156 newXSproto("VMS::Filespec::case_tolerant_process",
14157 case_tolerant_process_fromperl,file,"");
14159 store_pipelocs(aTHX); /* will redo any earlier attempts */
14164 #if __CRTL_VER == 80200000
14165 /* This missed getting in to the DECC SDK for 8.2 */
14166 char *realpath(const char *file_name, char * resolved_name, ...);
14169 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
14170 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
14171 * The perl fallback routine to provide realpath() is not as efficient
14175 /* Hack, use old stat() as fastest way of getting ino_t and device */
14176 int decc$stat(const char *name, void * statbuf);
14177 #if !defined(__VAX) && __CRTL_VER >= 80200000
14178 int decc$lstat(const char *name, void * statbuf);
14180 #define decc$lstat decc$stat
14184 /* Realpath is fragile. In 8.3 it does not work if the feature
14185 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
14186 * links are implemented in RMS, not the CRTL. It also can fail if the
14187 * user does not have read/execute access to some of the directories.
14188 * So in order for Do What I Mean mode to work, if realpath() fails,
14189 * fall back to looking up the filename by the device name and FID.
14192 int vms_fid_to_name(char * outname, int outlen,
14193 const char * name, int lstat_flag, mode_t * mode)
14195 #pragma message save
14196 #pragma message disable MISALGNDSTRCT
14197 #pragma message disable MISALGNDMEM
14198 #pragma member_alignment save
14199 #pragma nomember_alignment
14202 unsigned short st_ino[3];
14203 unsigned short old_st_mode;
14204 unsigned long padl[30]; /* plenty of room */
14206 #pragma message restore
14207 #pragma member_alignment restore
14210 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14211 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
14216 /* Need to follow the mostly the same rules as flex_stat_int, or we may get
14217 * unexpected answers
14220 fileified = PerlMem_malloc(VMS_MAXRSS);
14221 if (fileified == NULL)
14222 _ckvmssts_noperl(SS$_INSFMEM);
14224 temp_fspec = PerlMem_malloc(VMS_MAXRSS);
14225 if (temp_fspec == NULL)
14226 _ckvmssts_noperl(SS$_INSFMEM);
14229 /* First need to try as a directory */
14230 ret_spec = int_tovmspath(name, temp_fspec, NULL);
14231 if (ret_spec != NULL) {
14232 ret_spec = int_fileify_dirspec(temp_fspec, fileified, NULL);
14233 if (ret_spec != NULL) {
14234 if (lstat_flag == 0)
14235 sts = decc$stat(fileified, &statbuf);
14237 sts = decc$lstat(fileified, &statbuf);
14241 /* Then as a VMS file spec */
14243 ret_spec = int_tovmsspec(name, temp_fspec, 0, NULL);
14244 if (ret_spec != NULL) {
14245 if (lstat_flag == 0) {
14246 sts = decc$stat(temp_fspec, &statbuf);
14248 sts = decc$lstat(temp_fspec, &statbuf);
14254 /* Next try - allow multiple dots with out EFS CHARSET */
14255 /* The CRTL stat() falls down hard on multi-dot filenames in unix
14256 * format unless * DECC$EFS_CHARSET is in effect, so temporarily
14257 * enable it if it isn't already.
14259 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14260 if (!decc_efs_charset && (decc_efs_charset_index > 0))
14261 decc$feature_set_value(decc_efs_charset_index, 1, 1);
14263 ret_spec = int_tovmspath(name, temp_fspec, NULL);
14264 if (lstat_flag == 0) {
14265 sts = decc$stat(name, &statbuf);
14267 sts = decc$lstat(name, &statbuf);
14269 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14270 if (!decc_efs_charset && (decc_efs_charset_index > 0))
14271 decc$feature_set_value(decc_efs_charset_index, 1, 0);
14276 /* and then because the Perl Unix to VMS conversion is not perfect */
14277 /* Specifically the CRTL removes spaces and possibly other illegal ODS-2 */
14278 /* characters from filenames so we need to try it as-is */
14280 if (lstat_flag == 0) {
14281 sts = decc$stat(name, &statbuf);
14283 sts = decc$lstat(name, &statbuf);
14290 dvidsc.dsc$a_pointer=statbuf.st_dev;
14291 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
14293 specdsc.dsc$a_pointer = outname;
14294 specdsc.dsc$w_length = outlen-1;
14296 vms_sts = lib$fid_to_name
14297 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
14298 if ($VMS_STATUS_SUCCESS(vms_sts)) {
14299 outname[specdsc.dsc$w_length] = 0;
14301 /* Return the mode */
14303 *mode = statbuf.old_st_mode;
14314 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
14317 char * rslt = NULL;
14320 if (decc_posix_compliant_pathnames > 0 ) {
14321 /* realpath currently only works if posix compliant pathnames are
14322 * enabled. It may start working when they are not, but in that
14323 * case we still want the fallback behavior for backwards compatibility
14325 rslt = realpath(filespec, outbuf);
14329 if (rslt == NULL) {
14331 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14332 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14336 /* Fall back to fid_to_name */
14338 Newx(vms_spec, VMS_MAXRSS + 1, char);
14340 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec, 0, &my_mode);
14344 /* Now need to trim the version off */
14345 sts = vms_split_path
14365 /* Trim off the version */
14366 int file_len = v_len + r_len + d_len + n_len + e_len;
14367 vms_spec[file_len] = 0;
14369 /* Trim off the .DIR if this is a directory */
14370 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
14371 if (S_ISDIR(my_mode)) {
14377 /* Drop NULL extensions on UNIX file specification */
14378 if ((e_len == 1) && decc_readdir_dropdotnotype) {
14383 /* The result is expected to be in UNIX format */
14384 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14386 /* Downcase if input had any lower case letters and
14387 * case preservation is not in effect.
14389 if (!decc_efs_case_preserve) {
14390 for (cp = filespec; *cp; cp++)
14391 if (islower(*cp)) { haslower = 1; break; }
14393 if (haslower) __mystrtolower(rslt);
14398 /* Now for some hacks to deal with backwards and forward */
14400 if (!decc_efs_charset) {
14402 /* 1. ODS-2 mode wants to do a syntax only translation */
14403 rslt = int_rmsexpand(filespec, outbuf,
14404 NULL, 0, NULL, utf8_fl);
14407 if (decc_filename_unix_report) {
14409 char * vms_dir_name;
14412 /* 2. ODS-5 / UNIX report mode should return a failure */
14413 /* if the parent directory also does not exist */
14414 /* Otherwise, get the real path for the parent */
14415 /* and add the child to it.
14417 /* basename / dirname only available for VMS 7.0+ */
14418 /* So we may need to implement them as common routines */
14420 Newx(dir_name, VMS_MAXRSS + 1, char);
14421 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14422 dir_name[0] = '\0';
14425 /* First try a VMS parse */
14426 sts = vms_split_path
14444 int dir_len = v_len + r_len + d_len + n_len;
14446 strncpy(dir_name, filespec, dir_len);
14447 dir_name[dir_len] = '\0';
14448 file_name = (char *)&filespec[dir_len + 1];
14451 /* This must be UNIX */
14454 tchar = strrchr(filespec, '/');
14456 if (tchar != NULL) {
14457 int dir_len = tchar - filespec;
14458 strncpy(dir_name, filespec, dir_len);
14459 dir_name[dir_len] = '\0';
14460 file_name = (char *) &filespec[dir_len + 1];
14464 /* Dir name is defaulted */
14465 if (dir_name[0] == 0) {
14467 dir_name[1] = '\0';
14470 /* Need realpath for the directory */
14471 sts = vms_fid_to_name(vms_dir_name,
14473 dir_name, 0, NULL);
14476 /* Now need to pathify it.
14477 char *tdir = int_pathify_dirspec(vms_dir_name,
14480 /* And now add the original filespec to it */
14481 if (file_name != NULL) {
14482 strcat(outbuf, file_name);
14486 Safefree(vms_dir_name);
14487 Safefree(dir_name);
14491 Safefree(vms_spec);
14497 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14500 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14501 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14504 /* Fall back to fid_to_name */
14506 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec, 0, NULL);
14513 /* Now need to trim the version off */
14514 sts = vms_split_path
14534 /* Trim off the version */
14535 int file_len = v_len + r_len + d_len + n_len + e_len;
14536 outbuf[file_len] = 0;
14538 /* Downcase if input had any lower case letters and
14539 * case preservation is not in effect.
14541 if (!decc_efs_case_preserve) {
14542 for (cp = filespec; *cp; cp++)
14543 if (islower(*cp)) { haslower = 1; break; }
14545 if (haslower) __mystrtolower(outbuf);
14554 /* External entry points */
14555 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14556 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14558 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14559 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14561 /* case_tolerant */
14563 /*{{{int do_vms_case_tolerant(void)*/
14564 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14565 * controlled by a process setting.
14567 int do_vms_case_tolerant(void)
14569 return vms_process_case_tolerant;
14572 /* External entry points */
14573 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14574 int Perl_vms_case_tolerant(void)
14575 { return do_vms_case_tolerant(); }
14577 int Perl_vms_case_tolerant(void)
14578 { return vms_process_case_tolerant; }
14582 /* Start of DECC RTL Feature handling */
14584 static int sys_trnlnm
14585 (const char * logname,
14589 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14590 const unsigned long attr = LNM$M_CASE_BLIND;
14591 struct dsc$descriptor_s name_dsc;
14593 unsigned short result;
14594 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14597 name_dsc.dsc$w_length = strlen(logname);
14598 name_dsc.dsc$a_pointer = (char *)logname;
14599 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14600 name_dsc.dsc$b_class = DSC$K_CLASS_S;
14602 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14604 if ($VMS_STATUS_SUCCESS(status)) {
14606 /* Null terminate and return the string */
14607 /*--------------------------------------*/
14614 static int sys_crelnm
14615 (const char * logname,
14616 const char * value)
14619 const char * proc_table = "LNM$PROCESS_TABLE";
14620 struct dsc$descriptor_s proc_table_dsc;
14621 struct dsc$descriptor_s logname_dsc;
14622 struct itmlst_3 item_list[2];
14624 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14625 proc_table_dsc.dsc$w_length = strlen(proc_table);
14626 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14627 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14629 logname_dsc.dsc$a_pointer = (char *) logname;
14630 logname_dsc.dsc$w_length = strlen(logname);
14631 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14632 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14634 item_list[0].buflen = strlen(value);
14635 item_list[0].itmcode = LNM$_STRING;
14636 item_list[0].bufadr = (char *)value;
14637 item_list[0].retlen = NULL;
14639 item_list[1].buflen = 0;
14640 item_list[1].itmcode = 0;
14642 ret_val = sys$crelnm
14644 (const struct dsc$descriptor_s *)&proc_table_dsc,
14645 (const struct dsc$descriptor_s *)&logname_dsc,
14647 (const struct item_list_3 *) item_list);
14652 /* C RTL Feature settings */
14654 static int set_features
14655 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
14656 int (* cli_routine)(void), /* Not documented */
14657 void *image_info) /* Not documented */
14663 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14664 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14665 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14666 unsigned long case_perm;
14667 unsigned long case_image;
14670 /* Allow an exception to bring Perl into the VMS debugger */
14671 vms_debug_on_exception = 0;
14672 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14673 if ($VMS_STATUS_SUCCESS(status)) {
14674 val_str[0] = _toupper(val_str[0]);
14675 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14676 vms_debug_on_exception = 1;
14678 vms_debug_on_exception = 0;
14681 /* Debug unix/vms file translation routines */
14682 vms_debug_fileify = 0;
14683 status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14684 if ($VMS_STATUS_SUCCESS(status)) {
14685 val_str[0] = _toupper(val_str[0]);
14686 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14687 vms_debug_fileify = 1;
14689 vms_debug_fileify = 0;
14693 /* Historically PERL has been doing vmsify / stat differently than */
14694 /* the CRTL. In particular, under some conditions the CRTL will */
14695 /* remove some illegal characters like spaces from filenames */
14696 /* resulting in some differences. The stat()/lstat() wrapper has */
14697 /* been reporting such file names as invalid and fails to stat them */
14698 /* fixing this bug so that stat()/lstat() accept these like the */
14699 /* CRTL does will result in several tests failing. */
14700 /* This should really be fixed, but for now, set up a feature to */
14701 /* enable it so that the impact can be studied. */
14702 vms_bug_stat_filename = 0;
14703 status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14704 if ($VMS_STATUS_SUCCESS(status)) {
14705 val_str[0] = _toupper(val_str[0]);
14706 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14707 vms_bug_stat_filename = 1;
14709 vms_bug_stat_filename = 0;
14713 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14714 vms_vtf7_filenames = 0;
14715 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14716 if ($VMS_STATUS_SUCCESS(status)) {
14717 val_str[0] = _toupper(val_str[0]);
14718 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14719 vms_vtf7_filenames = 1;
14721 vms_vtf7_filenames = 0;
14724 /* unlink all versions on unlink() or rename() */
14725 vms_unlink_all_versions = 0;
14726 status = sys_trnlnm
14727 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14728 if ($VMS_STATUS_SUCCESS(status)) {
14729 val_str[0] = _toupper(val_str[0]);
14730 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14731 vms_unlink_all_versions = 1;
14733 vms_unlink_all_versions = 0;
14736 /* Dectect running under GNV Bash or other UNIX like shell */
14737 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14738 gnv_unix_shell = 0;
14739 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14740 if ($VMS_STATUS_SUCCESS(status)) {
14741 gnv_unix_shell = 1;
14742 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14743 set_feature_default("DECC$EFS_CHARSET", 1);
14744 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14745 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14746 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14747 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14748 vms_unlink_all_versions = 1;
14749 vms_posix_exit = 1;
14753 /* hacks to see if known bugs are still present for testing */
14755 /* PCP mode requires creating /dev/null special device file */
14756 decc_bug_devnull = 0;
14757 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14758 if ($VMS_STATUS_SUCCESS(status)) {
14759 val_str[0] = _toupper(val_str[0]);
14760 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14761 decc_bug_devnull = 1;
14763 decc_bug_devnull = 0;
14766 /* UNIX directory names with no paths are broken in a lot of places */
14767 decc_dir_barename = 1;
14768 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14769 if ($VMS_STATUS_SUCCESS(status)) {
14770 val_str[0] = _toupper(val_str[0]);
14771 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14772 decc_dir_barename = 1;
14774 decc_dir_barename = 0;
14777 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14778 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14780 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14781 if (decc_disable_to_vms_logname_translation < 0)
14782 decc_disable_to_vms_logname_translation = 0;
14785 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14787 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14788 if (decc_efs_case_preserve < 0)
14789 decc_efs_case_preserve = 0;
14792 s = decc$feature_get_index("DECC$EFS_CHARSET");
14793 decc_efs_charset_index = s;
14795 decc_efs_charset = decc$feature_get_value(s, 1);
14796 if (decc_efs_charset < 0)
14797 decc_efs_charset = 0;
14800 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14802 decc_filename_unix_report = decc$feature_get_value(s, 1);
14803 if (decc_filename_unix_report > 0) {
14804 decc_filename_unix_report = 1;
14805 vms_posix_exit = 1;
14808 decc_filename_unix_report = 0;
14811 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14813 decc_filename_unix_only = decc$feature_get_value(s, 1);
14814 if (decc_filename_unix_only > 0) {
14815 decc_filename_unix_only = 1;
14818 decc_filename_unix_only = 0;
14822 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14824 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14825 if (decc_filename_unix_no_version < 0)
14826 decc_filename_unix_no_version = 0;
14829 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14831 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14832 if (decc_readdir_dropdotnotype < 0)
14833 decc_readdir_dropdotnotype = 0;
14836 #if __CRTL_VER >= 80200000
14837 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14839 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14840 if (decc_posix_compliant_pathnames < 0)
14841 decc_posix_compliant_pathnames = 0;
14842 if (decc_posix_compliant_pathnames > 4)
14843 decc_posix_compliant_pathnames = 0;
14848 status = sys_trnlnm
14849 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14850 if ($VMS_STATUS_SUCCESS(status)) {
14851 val_str[0] = _toupper(val_str[0]);
14852 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14853 decc_disable_to_vms_logname_translation = 1;
14858 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14859 if ($VMS_STATUS_SUCCESS(status)) {
14860 val_str[0] = _toupper(val_str[0]);
14861 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14862 decc_efs_case_preserve = 1;
14867 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14868 if ($VMS_STATUS_SUCCESS(status)) {
14869 val_str[0] = _toupper(val_str[0]);
14870 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14871 decc_filename_unix_report = 1;
14874 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14875 if ($VMS_STATUS_SUCCESS(status)) {
14876 val_str[0] = _toupper(val_str[0]);
14877 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14878 decc_filename_unix_only = 1;
14879 decc_filename_unix_report = 1;
14882 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14883 if ($VMS_STATUS_SUCCESS(status)) {
14884 val_str[0] = _toupper(val_str[0]);
14885 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14886 decc_filename_unix_no_version = 1;
14889 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14890 if ($VMS_STATUS_SUCCESS(status)) {
14891 val_str[0] = _toupper(val_str[0]);
14892 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14893 decc_readdir_dropdotnotype = 1;
14898 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14900 /* Report true case tolerance */
14901 /*----------------------------*/
14902 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14903 if (!$VMS_STATUS_SUCCESS(status))
14904 case_perm = PPROP$K_CASE_BLIND;
14905 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14906 if (!$VMS_STATUS_SUCCESS(status))
14907 case_image = PPROP$K_CASE_BLIND;
14908 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14909 (case_image == PPROP$K_CASE_SENSITIVE))
14910 vms_process_case_tolerant = 0;
14914 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14915 /* for strict backward compatibilty */
14916 status = sys_trnlnm
14917 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14918 if ($VMS_STATUS_SUCCESS(status)) {
14919 val_str[0] = _toupper(val_str[0]);
14920 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14921 vms_posix_exit = 1;
14923 vms_posix_exit = 0;
14927 /* CRTL can be initialized past this point, but not before. */
14928 /* DECC$CRTL_INIT(); */
14935 #pragma extern_model save
14936 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14937 const __align (LONGWORD) int spare[8] = {0};
14939 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14940 #if __DECC_VER >= 60560002
14941 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14943 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14945 #endif /* __DECC */
14947 const long vms_cc_features = (const long)set_features;
14950 ** Force a reference to LIB$INITIALIZE to ensure it
14951 ** exists in the image.
14953 int lib$initialize(void);
14955 #pragma extern_model strict_refdef
14957 int lib_init_ref = (int) lib$initialize;
14960 #pragma extern_model restore